예제 #1
0
int main(int argc, char *argv[]) {
    secd_t secd;
    cell_t *heap = (cell_t *)malloc(sizeof(cell_t) * N_CELLS);

    init_secd(&secd, heap, N_CELLS);
#if ((CTRLDEBUG) || (MEMDEBUG))
    secd_setport(&secd, SECD_STDDBG, secd_fopen(&secd, "secd.log", "w"));
#endif

    cell_t *cmdport = SECD_NIL;
    if (argc == 2)
        cmdport = secd_fopen(&secd, argv[1], "r");

    cell_t *inp = sexp_parse(&secd, cmdport); // cmdport is dropped after
    if (is_nil(inp) || !is_cons(inp)) {
        secd_errorf(&secd, "list of commands expected\n");
        dbg_printc(&secd, inp);
        return 1;
    }

    cell_t *ret;
    ret = run_secd(&secd, inp);

    return (is_error(ret) ? EXIT_FAILURE : EXIT_SUCCESS);
}
예제 #2
0
파일: env.c 프로젝트: EarlGray/SECD
void secd_print_env(secd_t *secd) {
    cell_t *env = secd->env;
    int i = 0;
    secd_printf(secd, ";;Environment:\n");
    while (not_nil(env)) {
        secd_printf(secd, ";;  Frame #%d:\n", i++);
        cell_t *frame = get_car(env);
        cell_t *symlist = get_car(frame);
        cell_t *vallist = get_cdr(frame);

        while (not_nil(symlist)) {
            if (is_symbol(symlist)) {
                secd_printf(secd, ";;  . %s\t=>\t", symname(symlist));
                dbg_print_cell(secd, vallist);
                break;
            }
            cell_t *sym = get_car(symlist);
            cell_t *val = get_car(vallist);
            if (!is_symbol(sym)) {
                errorf("print_env: not a symbol at *%p in symlist\n", sym);
                dbg_printc(secd, sym);
            }
            secd_printf(secd, ";;    %s\t=>\t", symname(sym));
            dbg_print_cell(secd, val);

            symlist = list_next(secd, symlist);
            vallist = list_next(secd, vallist);
        }

        env = list_next(secd, env);
    }
}
예제 #3
0
파일: machine.c 프로젝트: EarlGray/SECD
cell_t * run_secd(secd_t *secd, cell_t *ctrl) {
    cell_t *op, *ret;
    TIMING_DECLARATIONS(ts_then, ts_now);

    share_cell(secd, ctrl);
    set_control(secd, &ctrl);

    while (true)  {
        TIMING_START_OPERATION(ts_then);

        op = pop_control(secd);
        assert_cell(op, "run: no command");
        if (cell_type(op) != CELL_OP) {
            errorf("run: not an opcode at [%ld]\n", cell_index(secd, op));
            dbg_printc(secd, op);
            continue;
        }

        int opind = op->as.op;
        if (about_to_halt(secd, opind, &ret))
            return ret;

        secd_opfunc_t callee = (secd_opfunc_t) opcode_table[ opind ].fun;

        ret = callee(secd);
        if (is_error(ret))
            if (!handle_exception(secd, ret))
                return fatal_exception(secd, ret, opind);

        drop_cell(secd, op);

        TIMING_END_OPERATION(ts_then, ts_now)

        run_postop(secd);

        ++secd->tick;
    }
}
예제 #4
0
BOOL skip_sgml_special(HSCPRC * hp, EXPSTR * content)
{
    INFILE *inpf = hp->inpf;
    int ch = infgetc(inpf);     /* read next char */
    int ch_prev = EOF;
    BOOL end = FALSE;           /* flag: end of comment reached? */

    if (ch == '>')
    {
        hsc_message(hp, MSG_ZERO_COMMENT, "empty sgml comment");
        end = TRUE;
    }
    else if (ch == '-')
    {
        ch_prev = ch;
        ch = infgetc(inpf);
        if (ch == '-')
        {
            BOOL inside_comment = TRUE;
            BOOL warned_text = FALSE;

            DS(fprintf(stderr, DHLS "skip sgml comment\n"));
            APP_CONTENT_CH(ch_prev);
            APP_CONTENT_CH(ch);

            ch_prev = EOF;
            ch = infgetc(inpf);

            while (!end && (ch != EOF))
            {
                /* append current char to content */
                APP_CONTENT_CH(ch);

                if ((ch == '-') && (ch_prev == '-'))
                {
                    inside_comment = !inside_comment;
                    warned_text = FALSE;
                    ch_prev = EOF;
                }
                else if (ch == '-')
                {
                    ch_prev = '-';
                }
                else if (ch == '\r')
                {
                    ch_prev = '\r';
                    msg_lf_in_comment(hp);
                }
                else
                {
                    if (ch == '\n')
                    {
                        if (ch_prev != '\r')
                        {
                            msg_lf_in_comment(hp);
                        }
                    }

                    ch_prev = EOF;
                    if (ch == '>')
                    {
                        if (inside_comment)
                        {
                            hsc_message(hp, MSG_GT_IN_COMMENT,
                                        "%q inside sgml-comment", ">");
                        }
                        else
                        {
                            end = TRUE;
                        }
                    }
                    else
                    {
                        if (!inside_comment && !warned_text)
                        {
                            hsc_message(hp, MSG_TEXT_IN_COMMENT,
                                        "text outside sgml-comment context");
                        }
                        warned_text = TRUE;
                    }
                }

                if (!end)
                {
                    /* read next char */
                    ch = infgetc(inpf);
                }
            }

            /* push back last char */
            if (!end && (ch != EOF))
            {
                inungetc(ch, inpf);
            }
        }
        else
        {
            /* push back chars read until yet */
            inungetc(ch, inpf);
            inungetc(ch_prev, inpf);

            ch_prev = EOF;
        }
    }

    /* skip other "!"-tags (SSI and that bullshit) */
    if (!end)
    {
        DS(fprintf(stderr, DHLS "skip sgml special\n"));

        APP_CONTENT_CH(ch);

        do
        {
            ch = infgetc(inpf);
            if (ch != EOF)
            {
                APP_CONTENT_CH(ch);
                DS(
                      {
                      fprintf(stderr, DHLS "  word starting with: ");
                      dbg_printc(ch);
                      fprintf(stderr, "\n");
                      }
                );

                if (ch == '>')
                {
                    end = TRUE;
                }
                else
                {
                    skip_expression(hp, content, ch);
                }
            }
예제 #5
0
BOOL skip_sgml_special(HSCPRC * hp, EXPSTR * content, BOOL *stripped)
{
    INFILE *inpf = hp->inpf;
    int ch = infgetc(inpf);     /* read next char */
    int ch_prev = EOF;
    BOOL end = FALSE;           /* flag: end of comment reached? */

    if (ch == '>') {
        hsc_message(hp, MSG_ZERO_COMMENT, "empty sgml comment");
        end = TRUE;
    } else if (ch == '-') {
        ch_prev = ch;
        ch = infgetc(inpf);
        if (ch == '-') {
            BOOL inside_comment = TRUE;
            BOOL warned_text = FALSE;
            
            /* don't keep contents if STRIPCOMMENT was set (but do keep stuff
             * starting in "<!" but not "<!--") */
            if(hp->strip_cmt) {
               HSCTAG dummytag;
               dummytag.name = "!-- ... --";
               content = NULL;
               *stripped = TRUE;
               hsc_msg_stripped_tag(hp, &dummytag, "sgml-comment");
            }

            DS(fprintf(stderr, DHLS "skip sgml comment\n"));
            APP_CONTENT_CH(ch_prev);
            APP_CONTENT_CH(ch);

            ch_prev = EOF;
            ch = infgetc(inpf);

            while (!end && (ch != EOF)) {
                /* append current char to content */
                APP_CONTENT_CH(ch);

                if ((ch == '-') && (ch_prev == '-')) {
                    inside_comment = !inside_comment;
                    warned_text = FALSE;
                    ch_prev = EOF;
                } else if (ch == '-') {
                    ch_prev = '-';
                } else if (ch == '\r') {
                    ch_prev = '\r';
                    msg_lf_in_comment(hp);
                } else {
                    if (ch == '\n') {
                        if (ch_prev != '\r')
                            msg_lf_in_comment(hp);
                    }

                    ch_prev = EOF;
                    if (ch == '>') {
                        if (inside_comment)
                            hsc_message(hp, MSG_GT_IN_COMMENT,
                                        "%q inside sgml-comment", ">");
                        else
                            end = TRUE;
                    } else {
                        if (!inside_comment && !warned_text)
                            hsc_message(hp, MSG_TEXT_IN_COMMENT,
                                        "text outside sgml-comment context");
                        warned_text = TRUE;
                    }
                }

                if (!end) {
                    /* read next char */
                    ch = infgetc(inpf);
                }
            }

            /* push back last char */
            if (!end && (ch != EOF))
                inungetc(ch, inpf);
        } else {
            /* push back chars read until yet */
            inungetc(ch, inpf);
            inungetc(ch_prev, inpf);

            ch_prev = EOF;
        }
    }

    /* skip other "!"-tags (SSI and that bullshit) */
    if (!end) {
        DS(fprintf(stderr, DHLS "skip sgml special\n"));

        APP_CONTENT_CH(ch);
        do {
            ch = infgetc(inpf);
            if (ch != EOF) {
                APP_CONTENT_CH(ch);
                DS(
                      {
                      fprintf(stderr, DHLS "  word starting with: ");
                      dbg_printc(ch);
                      fprintf(stderr, "\n");
                      }
                );

                if (ch == '>')
                    end = TRUE;
                else
                    skip_expression(hp, content, ch);
            }