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);
}
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);
}
}
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;
}
}
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);
}
}
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);
}