static bool contains_untrusted_macro(unsigned trust_lvl, expr const & e) {
if (trust_lvl > LEAN_BELIEVER_TRUST_LEVEL)
return false;
return static_cast<bool>(find(e, [&](expr const & e, unsigned) {
return is_macro(e) && macro_def(e).trust_level() >= trust_lvl;
}));
}
static void gc_traverse(pobject env)
{
pobject object;
while (is_cons(env)) {
gc_flag_set(env, GC_FLAG_ON);
object = cons_car(env);
if (object && (gc_flag_get(object) == 0)) {
/*
printf("%p\n", object);
*/
gc_flag_set(object, GC_FLAG_ON);
/* XXX: dotted list support??? */
if (is_cons(object)) {
gc_traverse(object);
} else if (is_closure(object)) {
gc_traverse(object->data.closure.env);
gc_traverse(object->data.closure.code);
} else if (is_macro(object)) {
gc_traverse(object->data.macro.env);
gc_traverse(object->data.macro.code);
}
}
env = cons_cdr(env);
}
}
expr replace_visitor::visit_macro(expr const & e) {
lean_assert(is_macro(e));
buffer<expr> new_args;
for (unsigned i = 0; i < macro_num_args(e); i++)
new_args.push_back(visit(macro_arg(e, i)));
return update_macro(e, new_args.size(), new_args.data());
}
static bool contains_untrusted_macro(unsigned trust_lvl, expr const & e) {
#if defined(LEAN_ALL_MACROS_HAVE_SMALL_TRUST_LVL)
if (trust_lvl > LEAN_BELIEVER_TRUST_LEVEL) return false;
#endif
return static_cast<bool>(find(e, [&](expr const & e, unsigned) {
return is_macro(e) && macro_def(e).trust_level() >= trust_lvl;
}));
}
static pobject builtin_macro_expand(pobject env, pobject params)
{
pobject p = cons_car(params);
if (is_cons(p)) {
pobject macro = eval(env, cons_car(p));
if (is_macro(macro))
return macro_expand(env, macro, cons_cdr(p));
}
return NIL;
}
static void mcpp_main( void)
/*
* Main process for mcpp -- copies tokens from the current input stream
* (main file or included file) to the output file.
*/
{
int c; /* Current character */
char * wp; /* Temporary pointer */
DEFBUF * defp; /* Macro definition */
int line_top; /* Is in the line top, possibly spaces */
LINE_COL line_col; /* Location of macro call in source */
keep_comments = option_flags.c && !no_output;
keep_spaces = option_flags.k; /* Will be turned off if !compiling */
line_col.col = line_col.line = 0L;
/*
* This loop is started "from the top" at the beginning of each line.
* 'wrong_line' is set TRUE in many places if it is necessary to write
* a #line record. (But we don't write them when expanding macros.)
*
* 'newlines' variable counts the number of blank lines that have been
* skipped over. These are then either output via #line records or
* by outputting explicit blank lines.
* 'newlines' will be cleared on end of an included file by get_ch().
*/
while (1) { /* For the whole input */
newlines = 0; /* Count empty lines */
while (1) { /* For each line, ... */
out_ptr = output; /* Top of the line buf */
c = get_ch();
if (src_col)
break; /* There is a residual tokens on the line */
while (char_type[ c] & HSP) { /* ' ' or '\t' */
if (c != COM_SEP)
*out_ptr++ = c; /* Retain line top white spaces */
/* Else skip 0-length comment */
c = get_ch();
}
if (c == '#') { /* Is 1st non-space '#' */
directive(); /* Do a #directive */
} else if (mcpp_mode == STD && option_flags.dig && c == '%') {
/* In POST_STD digraphs are already converted */
if (get_ch() == ':') { /* '%:' i.e. '#' */
directive(); /* Do a #directive */
} else {
unget_ch();
if (! compiling) {
skip_nl();
newlines++;
} else {
break;
}
}
} else if (c == CHAR_EOF) { /* End of input */
break;
} else if (! compiling) { /* #ifdef false? */
skip_nl(); /* Skip to newline */
newlines++; /* Count it, too. */
} else if (in_asm && ! no_output) { /* In #asm block */
put_asm(); /* Put out as it is */
} else if (c == '\n') { /* Blank line */
if (keep_comments)
mcpp_fputc( '\n', OUT); /* May flush comments */
else
newlines++; /* Wait for a token */
} else {
break; /* Actual token */
}
}
if (c == CHAR_EOF) /* Exit process at */
break; /* end of input */
/*
* If the loop didn't terminate because of end of file, we
* know there is a token to compile. First, clean up after
* absorbing newlines. newlines has the number we skipped.
*/
if (no_output) {
wrong_line = FALSE;
} else {
if (wrong_line || newlines > 10) {
sharp( NULL, 0); /* Output # line number */
if (keep_spaces && src_col) {
while (src_col--) /* Adjust columns */
mcpp_fputc( ' ', OUT);
src_col = 0;
}
} else { /* If just a few, stuff */
while (newlines-- > 0) /* them out ourselves */
mcpp_fputc('\n', OUT);
}
}
/*
* Process each token on this line.
*/
line_top = TRUE;
while (c != '\n' && c != CHAR_EOF) { /* For the whole line */
/*
* has_pragma is set to TRUE so as to execute _Pragma() operator
* when the psuedo macro _Pragma() is found.
*/
int has_pragma;
if ((mcpp_debug & MACRO_CALL) && ! in_directive) {
line_col.line = src_line; /* Location in source */
line_col.col = infile->bptr - infile->buffer - 1;
}
if (scan_token( c, (wp = out_ptr, &wp), out_wend) == NAM
&& (defp = is_macro( &wp)) != NULL) { /* A macro */
wp = expand_macro( defp, out_ptr, out_wend, line_col
, & has_pragma); /* Expand it completely */
if (line_top) { /* The first token is a macro */
char * tp = out_ptr;
while (char_type[ *tp & UCHARMAX] & HSP)
tp++; /* Remove excessive spaces */
memmove( out_ptr, tp, strlen( tp) + 1);
wp -= (tp - out_ptr);
}
if (has_pragma) { /* Found _Pramga() */
do_pragma_op(); /* Do _Pragma() operator*/
out_ptr = output; /* Do the rest of line */
wrong_line = TRUE; /* Line-num out of sync */
} else {
out_ptr = wp;
}
if (keep_spaces && wrong_line && infile
&& *(infile->bptr) != '\n' && *(infile->bptr) != EOS) {
src_col = infile->bptr - infile->buffer;
/* Remember the current colums */
break; /* Do sharp() now */
}
} else { /* Not a macro call */
out_ptr = wp; /* Advance the place */
if (wrong_line) /* is_macro() swallowed */
break; /* the newline */
}
while (char_type[ c = get_ch()] & HSP) { /* Horizontal space */
if (c != COM_SEP) /* Skip 0-length comment*/
*out_ptr++ = c;
}
line_top = FALSE; /* Read over some token */
} /* Loop for line */
putout( output); /* Output the line */
} /* Continue until EOF */
}
bool is_nested_declaration(expr const & e) {
return is_macro(e) && macro_def(e).get_name() == get_nested_decl_name();
}
/* An explicit control evaluator, taken almost directly from SICP, section
* 5.2. list is a flat list of expressions to evaluate. where is a label to
* begin at. Return value depends on where.
*/
NODE *evaluator(NODE *list, enum labels where) {
/* registers */
NODE *exp = NIL, /* the current expression */
*val = NIL, /* the value of the last expression */
*proc = NIL, /* the procedure definition */
*argl = NIL, /* evaluated argument list */
*unev = NIL, /* list of unevaluated expressions */
*stack = NIL, /* register stack */
*parm = NIL, /* the current formal */
*catch_tag = NIL,
*arg = NIL; /* the current actual */
/* registers that don't get reference counted, so we pretend they're ints */
FIXNUM vsp = 0, /* temp ptr into var_stack */
cont = 0, /* where to go next */
formals = (FIXNUM)NIL; /* list of formal parameters */
int i, nargs;
BOOLEAN tracing; /* are we tracing the current procedure? */
FIXNUM oldtailcall; /* in case of reentrant use of evaluator */
FIXNUM repcount; /* count for repeat */
FIXNUM old_ift_iff;
oldtailcall = tailcall;
old_ift_iff = ift_iff_flag;
save2(var,this_line);
assign(var, var_stack);
save2(fun,ufun);
cont = (FIXNUM)all_done;
numsave((FIXNUM)cont);
newcont(where);
goto fetch_cont;
begin_line:
ref(list);
assign(this_line, list);
newcont(end_line);
begin_seq:
make_tree(list);
if (!is_tree(list)) {
assign(val, UNBOUND);
goto fetch_cont;
}
assign(unev, tree__tree(list));
assign(val, UNBOUND);
goto eval_sequence;
end_line:
if (val != UNBOUND) {
if (NOT_THROWING) err_logo(DK_WHAT, val);
deref(val);
}
val = NIL;
deref(list);
goto fetch_cont;
/* ----------------- EVAL ---------------------------------- */
tail_eval_dispatch:
tailcall = 1;
eval_dispatch:
switch (nodetype(exp)) {
case QUOTE: /* quoted literal */
assign(val, node__quote(exp));
goto fetch_cont;
case COLON: /* variable */
assign(val, valnode__colon(exp));
while (val == UNBOUND && NOT_THROWING)
assign(val, err_logo(NO_VALUE, node__colon(exp)));
goto fetch_cont;
case CONS: /* procedure application */
if (tailcall == 1 && is_macro(car(exp)) &&
is_list(procnode__caseobj(car(exp)))) {
/* tail call to user-defined macro must be treated as non-tail
* because the expression returned by the macro
* remains to be evaluated in the caller's context */
assign(unev, NIL);
goto non_tail_eval;
}
assign(fun, car(exp));
if (cdr(exp) != NIL)
goto ev_application;
else
goto ev_no_args;
default:
assign(val, exp); /* self-evaluating */
goto fetch_cont;
}
ev_no_args:
/* Evaluate an application of a procedure with no arguments. */
assign(argl, NIL);
goto apply_dispatch; /* apply the procedure */
ev_application:
/* Evaluate an application of a procedure with arguments. */
assign(unev, cdr(exp));
assign(argl, NIL);
mixsave(tailcall,var);
num2save(val_status,ift_iff_flag);
save2(didnt_get_output,didnt_output_name);
eval_arg_loop:
if (unev == NIL) goto eval_args_done;
assign(exp, car(unev));
if (exp == Not_Enough_Node) {
if (NOT_THROWING)
err_logo(NOT_ENOUGH, NIL);
goto eval_args_done;
}
save(argl);
save2(unev,fun);
save2(ufun,last_ufun);
save2(this_line,last_line);
assign(var, var_stack);
tailcall = -1;
val_status = 1;
assign(didnt_get_output,
cons_list(0,fun,ufun,this_line,END_OF_LIST));
assign(didnt_output_name, NIL);
newcont(accumulate_arg);
goto eval_dispatch; /* evaluate the current argument */
accumulate_arg:
/* Put the evaluated argument into the argl list. */
reset_args(var);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
assign(last_call, fun);
restore2(unev,fun);
restore(argl);
while (NOT_THROWING && val == UNBOUND) {
assign(val, err_logo(DIDNT_OUTPUT, NIL));
}
push(val, argl);
pop(unev);
goto eval_arg_loop;
eval_args_done:
restore2(didnt_get_output,didnt_output_name);
num2restore(val_status,ift_iff_flag);
mixrestore(tailcall,var);
if (stopping_flag == THROWING) {
assign(val, UNBOUND);
goto fetch_cont;
}
assign(argl, reverse(argl));
/* --------------------- APPLY ---------------------------- */
apply_dispatch:
/* Load in the procedure's definition and decide whether it's a compound
* procedure or a primitive procedure.
*/
proc = procnode__caseobj(fun);
if (is_macro(fun)) {
num2save(val_status,tailcall);
val_status = 1;
newcont(macro_return);
}
if (proc == UNDEFINED) {
if (ufun != NIL) {
untreeify_proc(ufun);
}
if (NOT_THROWING)
assign(val, err_logo(DK_HOW, fun));
else
assign(val, UNBOUND);
goto fetch_cont;
}
if (is_list(proc)) goto compound_apply;
/* primitive_apply */
if (NOT_THROWING)
assign(val, (*getprimfun(proc))(argl));
else
assign(val, UNBOUND);
#define do_case(x) case x: goto x;
fetch_cont:
{
enum labels x = (enum labels)cont;
cont = (FIXNUM)car(stack);
numpop(&stack);
switch (x) {
do_list(do_case)
default: abort();
}
}
compound_apply:
#ifdef mac
check_mac_stop();
#endif
#ifdef ibm
check_ibm_stop();
#endif
if (tracing = flag__caseobj(fun, PROC_TRACED)) {
for (i = 0; i < trace_level; i++) print_space(writestream);
trace_level++;
ndprintf(writestream, "( %s ", fun);
}
/* Bind the actuals to the formals */
vsp = (FIXNUM)var_stack; /* remember where we came in */
for (formals = (FIXNUM)formals__procnode(proc);
formals != (FIXNUM)NIL;
formals = (FIXNUM)cdr((NODE *)formals)) {
parm = car((NODE *)formals);
if (nodetype(parm) == INT) break; /* default # args */
if (argl != NIL) {
arg = car(argl);
if (tracing) {
print_node(writestream, maybe_quote(arg));
print_space(writestream);
}
} else
arg = UNBOUND;
if (nodetype(parm) == CASEOBJ) {
if (not_local(parm,(NODE *)vsp)) {
push(parm, var_stack);
setobject(var_stack, valnode__caseobj(parm));
}
tell_shadow(parm);
setvalnode__caseobj(parm, arg);
} else if (nodetype(parm) == CONS) {
/* parm is optional or rest */
if (not_local(car(parm),(NODE *)vsp)) {
push(car(parm), var_stack);
setobject(var_stack, valnode__caseobj(car(parm)));
}
tell_shadow(car(parm));
if (cdr(parm) == NIL) { /* parm is rest */
setvalnode__caseobj(car(parm), argl);
break;
}
if (arg == UNBOUND) { /* use default */
save2(fun,var);
save2(ufun,last_ufun);
save2(this_line,last_line);
save2(didnt_output_name,didnt_get_output);
num2save(ift_iff_flag,val_status);
assign(var, var_stack);
tailcall = -1;
val_status = 1;
mixsave(formals,argl);
numsave(vsp);
assign(list, cdr(parm));
if (NOT_THROWING)
make_tree(list);
else
assign(list, NIL);
if (!is_tree(list)) {
assign(val, UNBOUND);
goto set_args_continue;
}
assign(unev, tree__tree(list));
assign(val, UNBOUND);
newcont(set_args_continue);
goto eval_sequence;
set_args_continue:
numrestore(vsp);
mixrestore(formals,argl);
parm = car((NODE *)formals);
reset_args(var);
num2restore(ift_iff_flag,val_status);
restore2(didnt_output_name,didnt_get_output);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
restore2(fun,var);
arg = val;
}
setvalnode__caseobj(car(parm), arg);
}
if (argl != NIL) pop(argl);
}
if (check_throwing) {
assign(val, UNBOUND);
goto fetch_cont;
}
vsp = 0;
if (tracing = flag__caseobj(fun, PROC_TRACED)) {
if (NOT_THROWING) print_char(writestream, ')');
new_line(writestream);
save(fun);
newcont(compound_apply_continue);
}
assign(val, UNBOUND);
assign(last_ufun, ufun);
assign(ufun, fun);
assign(last_line, this_line);
assign(this_line, NIL);
proc = procnode__caseobj(fun);
assign(list, bodylist__procnode(proc)); /* get the body ... */
make_tree_from_body(list);
if (!is_tree(list)) {
goto fetch_cont;
}
assign(unev, tree__tree(list));
if (NOT_THROWING) stopping_flag = RUN;
assign(output_node, UNBOUND);
if (val_status == 1) val_status = 2;
else if (val_status == 5) val_status = 3;
else val_status = 0;
eval_sequence:
/* Evaluate each expression in the sequence. Stop as soon as
* val != UNBOUND.
*/
if (!RUNNING || val != UNBOUND) {
goto fetch_cont;
}
if (nodetype(unev) == LINE) {
assign(this_line, unparsed__line(unev));
if (flag__caseobj(ufun, PROC_STEPPED)) {
char junk[20];
if (tracing) {
int i = 1;
while (i++ < trace_level) print_space(stdout);
}
print_node(stdout, this_line);
ndprintf(stdout, " >>> ");
input_blocking++;
#ifndef TIOCSTI
if (!setjmp(iblk_buf))
#endif
#ifdef __ZTC__
ztc_getcr();
#else
fgets(junk, 19, stdin);
#endif
input_blocking = 0;
update_coords('\n');
}
}
assign(exp, car(unev));
pop(unev);
if (is_list(exp) && (is_tailform(procnode__caseobj(car(exp))))) {
if (nameis(car(exp),Output) || nameis(car(exp),Op)) {
assign(didnt_get_output,
cons_list(0,car(exp),ufun,this_line,END_OF_LIST));
assign(didnt_output_name, NIL);
if (val_status == 2 || val_status == 3) {
val_status = 1;
assign(exp, cadr(exp));
goto tail_eval_dispatch;
} else if (ufun == NIL) {
err_logo(AT_TOPLEVEL,car(exp));
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status < 4) {
val_status = 1;
assign(exp, cadr(exp));
assign(unev, NIL);
goto non_tail_eval; /* compute value then give error */
}
} else if (nameis(car(exp),Stop)) {
if (ufun == NIL) {
err_logo(AT_TOPLEVEL,car(exp));
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status == 0 || val_status == 3) {
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status < 4) {
assign(didnt_output_name, fun);
assign(val, UNBOUND);
goto fetch_cont;
}
} else { /* maybeoutput */
assign(exp, cadr(exp));
val_status = 5;
goto tail_eval_dispatch;
}
}
if (unev == NIL) {
if (val_status == 2 || val_status == 4) {
assign(didnt_output_name, fun);
assign(unev, UNBOUND);
goto non_tail_eval;
} else {
goto tail_eval_dispatch;
}
}
if (is_list(car(unev)) && nameis(car(car(unev)),Stop)) {
if ((val_status == 0 || val_status == 3) && ufun != NIL) {
goto tail_eval_dispatch;
} else if (val_status < 4) {
assign(didnt_output_name, fun);
goto tail_eval_dispatch;
}
}
non_tail_eval:
save2(unev,fun);
num2save(ift_iff_flag,val_status);
save2(ufun,last_ufun);
save2(this_line,last_line);
save(var);
assign(var, var_stack);
tailcall = 0;
newcont(eval_sequence_continue);
goto eval_dispatch;
eval_sequence_continue:
reset_args(var);
restore(var);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
if (dont_fix_ift) {
num2restore(dont_fix_ift,val_status);
dont_fix_ift = 0;
} else
num2restore(ift_iff_flag,val_status);
restore2(unev,fun);
if (stopping_flag == MACRO_RETURN) {
if (unev == UNBOUND) assign(unev, NIL);
assign(unev, append(val, unev));
assign(val, UNBOUND);
stopping_flag = RUN;
if (unev == NIL) goto fetch_cont;
} else if (val_status < 4) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2 && NOT_THROWING) {
assign(didnt_output_name,Output);
err_logo(DIDNT_OUTPUT,Output);
}
if (val == UNBOUND && val_status == 1 && NOT_THROWING) {
assign(didnt_output_name,Stop);
err_logo(DIDNT_OUTPUT,Output);
}
goto fetch_cont;
}
}
if (val != UNBOUND) {
err_logo((unev == NIL ? DK_WHAT_UP : DK_WHAT), val);
assign(val, UNBOUND);
}
if (NOT_THROWING && (unev == NIL || unev == UNBOUND)) {
if (val_status != 4) err_logo(DIDNT_OUTPUT,NIL);
goto fetch_cont;
}
goto eval_sequence;
compound_apply_continue:
/* Only get here if tracing */
restore(fun);
--trace_level;
if (NOT_THROWING) {
for (i = 0; i < trace_level; i++) print_space(writestream);
print_node(writestream, fun);
if (val == UNBOUND)
ndprintf(writestream, " stops\n");
else {
ref(val);
ndprintf(writestream, " outputs %s\n", maybe_quote(val));
deref(val);
}
}
goto fetch_cont;
/* --------------------- MACROS ---------------------------- */
macro_return:
num2restore(val_status,tailcall);
while (!is_list(val) && NOT_THROWING) {
assign(val,err_logo(ERR_MACRO,val));
}
if (NOT_THROWING) {
if (is_cont(val)) {
newcont(cont__cont(val));
val->n_car = NIL;
assign(val, val__cont(val));
goto fetch_cont;
}
macro_reval:
if (tailcall == 0) {
make_tree(val);
stopping_flag = MACRO_RETURN;
if (!is_tree(val)) assign(val, NIL);
else assign(val, tree__tree(val));
goto fetch_cont;
}
assign(list,val);
goto begin_seq;
}
assign(val, UNBOUND);
goto fetch_cont;
runresult_continuation:
assign(list, val);
newcont(runresult_followup);
val_status = 5;
goto begin_seq;
runresult_followup:
if (val == UNBOUND) {
assign(val, NIL);
} else {
assign(val, cons(val, NIL));
}
goto fetch_cont;
repeat_continuation:
assign(list, cdr(val));
repcount = getint(car(val));
repeat_again:
assign(val, UNBOUND);
if (repcount == 0) goto fetch_cont;
mixsave(repcount,list);
num2save(val_status,tailcall);
val_status = 4;
newcont(repeat_followup);
goto begin_seq;
repeat_followup:
if (val != UNBOUND && NOT_THROWING) {
ref(val);
err_logo(DK_WHAT, val);
unref(val);
}
num2restore(val_status,tailcall);
mixrestore(repcount,list);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
goto fetch_cont;
}
}
if (repcount > 0) /* negative means forever */
--repcount;
#ifdef mac
check_mac_stop();
#endif
#ifdef ibm
check_ibm_stop();
#endif
if (RUNNING) goto repeat_again;
assign(val, UNBOUND);
goto fetch_cont;
catch_continuation:
assign(list, cdr(val));
assign(catch_tag, car(val));
if (compare_node(catch_tag,Error,TRUE) == 0) {
push(Erract, var_stack);
setobject(var_stack, valnode__caseobj(Erract));
setvalnode__caseobj(Erract, UNBOUND);
}
save(catch_tag);
save2(didnt_output_name,didnt_get_output);
num2save(val_status,tailcall);
newcont(catch_followup);
val_status = 5;
goto begin_seq;
catch_followup:
num2restore(val_status,tailcall);
restore2(didnt_output_name,didnt_get_output);
restore(catch_tag);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
}
}
if (stopping_flag == THROWING &&
compare_node(throw_node, catch_tag, TRUE) == 0) {
throw_node = reref(throw_node, UNBOUND);
stopping_flag = RUN;
assign(val, output_node);
}
goto fetch_cont;
begin_apply:
/* This is for lapply. */
assign(fun, car(val));
while (nodetype(fun) == ARRAY && NOT_THROWING)
assign(fun, err_logo(APPLY_BAD_DATA, fun));
assign(argl, cadr(val));
assign(val, UNBOUND);
while (!is_list(argl) && NOT_THROWING)
assign(argl, err_logo(APPLY_BAD_DATA, argl));
if (NOT_THROWING && fun != NIL) {
if (is_list(fun)) { /* template */
if (is_list(car(fun)) && cdr(fun) != NIL) {
/* lambda form */
formals = (FIXNUM)car(fun);
numsave(tailcall);
tailcall = 0;
llocal((NODE *)formals); /* bind the formals locally */
numrestore(tailcall);
for ( ;
formals && argl && NOT_THROWING;
formals = (FIXNUM)cdr((NODE *)formals),
assign(argl, cdr(argl)))
setvalnode__caseobj(car((NODE *)formals), car(argl));
assign(val, cdr(fun));
goto macro_reval;
} else { /* question-mark form */
save(qm_list);
assign(qm_list, argl);
assign(list, fun);
make_tree(list);
if (list == NIL || !is_tree(list)) {
goto qm_failed;
}
assign(unev, tree__tree(list));
save2(didnt_output_name,didnt_get_output);
num2save(val_status,tailcall);
newcont(qm_continue);
val_status = 5;
goto eval_sequence;
qm_continue:
num2restore(val_status,tailcall);
restore2(didnt_output_name,didnt_get_output);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
}
}
qm_failed:
restore(qm_list);
goto fetch_cont;
}
} else { /* name of procedure to apply */
int min, max, n;
NODE *arg;
assign(fun, intern(fun));
if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
fun != Null_Word)
silent_load(fun, NULL); /* try ./<fun>.lg */
if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
fun != Null_Word)
silent_load(fun, logolib); /* try <logolib>/<fun> */
proc = procnode__caseobj(fun);
while (proc == UNDEFINED && NOT_THROWING) {
assign(val, err_logo(DK_HOW_UNREC, fun));
}
if (NOT_THROWING) {
if (nodetype(proc) == CONS) {
min = getint(minargs__procnode(proc));
max = getint(maxargs__procnode(proc));
} else {
if (getprimdflt(proc) < 0) { /* special form */
err_logo(DK_HOW_UNREC, fun); /* can't apply */
goto fetch_cont;
} else {
min = getprimmin(proc);
max = getprimmax(proc);
}
}
for (n = 0, arg = argl; arg != NIL; n++, arg = cdr(arg));
if (n < min) {
err_logo(NOT_ENOUGH, NIL);
} else if (n > max && max >= 0) {
err_logo(TOO_MUCH, NIL);
} else {
goto apply_dispatch;
}
}
}
}
goto fetch_cont;
all_done:
tailcall = oldtailcall;
ift_iff_flag = old_ift_iff;
restore2(fun,ufun);
reset_args(var);
restore2(var,this_line);
deref(argl);deref(unev);deref(stack);deref(catch_tag);deref(exp);
return(val);
}
void check_macro(expr const & m) const {
if (!is_macro(m) || macro_num_args(m) != 2)
throw exception("invalid typed-expr, incorrect number of arguments");
}
bool is_prenum(expr const & e) {
return is_macro(e) && dynamic_cast<prenum_macro_definition_cell const*>(macro_def(e).raw()) != nullptr;
}
bool is_choice(expr const & e) {
return is_macro(e) && macro_def(e) == *g_choice;
}
bool is_typed_expr(expr const & e) {
return is_macro(e) && macro_def(e) == *g_typed_expr;
}
static void do_pragma_op( void)
/*
* Execute the _Pragma() operator contained in an expanded macro.
* Note: _Pragma() operator is also implemented as a special macro. Therefore
* it is always searched as a macro.
* There might be more than one _Pragma() in a expanded macro and those may be
* surrounded by other token sequences.
* Since all the macros have been expanded completely, any name identical to
* macro should not be re-expanded.
* However, a macro in the string argument of _Pragma() may be expanded by
* do_pragma() after de_stringize(), if EXPAND_PRAGMA == TRUE.
*/
{
FILEINFO * file;
DEFBUF * defp;
int prev = output < out_ptr; /* There is a previous sequence */
int token_type;
char * cp1, * cp2;
int c;
file = unget_string( out_ptr, NULL);
while (c = get_ch(), file == infile) {
if (char_type[ c] & HSP) {
*out_ptr++ = c;
continue;
}
if (scan_token( c, (cp1 = out_ptr, &cp1), out_wend)
== NAM && (defp = is_macro( &cp1)) != NULL
&& defp->nargs == DEF_PRAGMA) { /* _Pragma() operator */
if (prev) {
putout( output); /* Putout the previous sequence */
cp1 = stpcpy( output, "pragma "); /* From top of buffer */
}
/* is_macro() already read over possible spaces after _Pragma */
*cp1++ = get_ch(); /* '(' */
while (char_type[ c = get_ch()] & HSP)
*cp1++ = c;
if (((token_type = scan_token( c, (cp2 = cp1, &cp1), out_wend))
!= STR && token_type != WSTR)) {
/* Not a string literal */
put_seq( output, cp1);
return;
}
workp = de_stringize( cp2, work_buf);
while (char_type[ c = get_ch()] & HSP)
*cp1++ = c;
if (c != ')') { /* More than a string literal */
unget_ch();
put_seq( output, cp1);
return;
}
strcpy( workp, "\n"); /* Terminate with <newline> */
unget_string( work_buf, NULL);
do_pragma(); /* Do the #pragma "line" */
infile->bptr += strlen( infile->bptr); /* Clear sequence */
cp1 = out_ptr = output; /* From the top of buffer */
prev = FALSE;
} else { /* Not pragma sequence */
out_ptr = cp1;
prev = TRUE;
}
}
unget_ch();
if (prev)
putout( output);
}
bool is_structure_instance(expr const & e) {
return is_macro(e) && macro_def(e).get_name() == *g_structure_instance_name;
}
void check_macro(expr const & m) const {
if (!is_macro(m) || macro_num_args(m) != 1)
throw exception(sstream() << "invalid '" << m_proj_name
<< "' projection macro, incorrect number of arguments");
}
static void check_num_args(environment const & env, expr const & m) {
lean_assert(is_macro(m));
if (macro_num_args(m) != 3)
throw_kernel_exception(env, "invalid number of arguments for resolve macro", m);
}
bool is_options_expr(expr const & e) {
return is_macro(e) && macro_def(e).get_name() == *g_options_name;
}
bool is_string_macro(expr const & e) {
return is_macro(e) && dynamic_cast<string_macro const *>(macro_def(e).raw()) != nullptr;
}
bool is_let_value(expr const & e) {
return is_macro(e) && dynamic_cast<let_value_definition_cell const *>(macro_def(e).raw());
}
void parseline(list *instructions, list *labels) {
start:
;;
dcpu16token tok = nexttoken();
if (tok == T_COLON) {
/* Label definition */
if ((tok = nexttoken()) == T_IDENTIFIER) {
dcpu16label *l = getnewlabel(labels, cur_tok.string);
if (l->defined)
error("Redefinition of label '%s' (%04X -> %04X) forbidden",
l->label, l->pc, pc);
l->pc = pc;
l->defined = 1;
goto start;
} else {
error("Expected label, got %s", toktostr(tok));
}
} else if (is_instruction(tok)) {
dcpu16instruction instr, *newinstr;
instr.opcode = tok;
instr.a = parseoperand(labels);
if (!is_nonbasic_instruction(tok)) {
if ((tok = nexttoken()) == T_COMMA) {
instr.b = parseoperand(labels);
} else {
error("Expected ',', got %s", toktostr(tok));
}
}
if ((tok = nexttoken()) != T_NEWLINE)
error("Expected EOL, got %s", toktostr(tok));
/*
* All tokens valid, store instructions, advance PC
*/
newinstr = malloc(sizeof(dcpu16instruction));
memcpy(newinstr, &instr, sizeof(dcpu16instruction));
newinstr->pc = pc;
newinstr->line = curline;
list_push_back(instructions, newinstr);
pc += instruction_length(newinstr);
} else if (is_macro(tok)) {
if (tok == T_ORG) {
if ((tok = nexttoken()) == T_NUMBER) {
if (flag_paranoid && (cur_tok.number < pc)) {
warning("new origin precedes old origin! "
"This could cause already written code to be "
"overriden.");
}
pc = cur_tok.number;
} else {
error("Expected numeric, got %s", toktostr(tok));
}
} else if (tok == T_DAT) {
/* All of the stuff we are about to read, neatly packed
* into words */
list_node *p = NULL;
list *data = list_create();
do {
if ((tok = nexttoken()) == T_STRING) {
char *ptr = cur_tok.string;
while (*ptr != '\0') {
uint16_t *dat = malloc(sizeof(uint16_t));
*dat = *ptr++;
list_push_back(data, dat);
}
} else if (tok == T_NUMBER) {
uint16_t *dat = malloc(sizeof(uint16_t));
*dat = cur_tok.number;
list_push_back(data, dat);
} else {
error("Expected string or numeric, got %s", toktostr(tok));
}
if ((tok = nexttoken()) == T_COMMA)
continue;
else if (tok == T_NEWLINE)
break;
else
error("Expected ',' or EOL, got %s", toktostr(tok));
} while (1);
/*
ram[pc++] = cur_tok.number;
*/
for (p = list_get_root(data); p != NULL; p = p->next) {
ram[pc++] = *((uint16_t*)p->data);
}
list_dispose(&data, &free);
}
} else if (tok == T_NEWLINE) {
return;
} else {
error("Expected label-definition or opcode, got %s", toktostr(tok));
}
}
void check_macro(expr const & m) const {
if (!is_macro(m) || macro_num_args(m) != 2)
throw exception("invalid let expression");
}
bool contains_untrusted_macro(unsigned trust_lvl, expr const & e) {
return static_cast<bool>(find(e, [&](expr const & e, unsigned) {
return is_macro(e) && macro_def(e).trust_level() >= trust_lvl;
}));
}
sexp eval_object(sexp object, sexp environment) {
tail_loop:
if (is_quote_form(object)) return quotation_text(object);
if (is_variable_form(object))
return get_variable_value(object, environment);
if (is_define_form(object)) {
/* sexp value = eval_object(definition_value(object), environment); */
/* add_binding(definition_variable(object), value, environment); */
/* return value; */
return eval_object(define2set(object), environment);
}
if (is_assignment_form(object)) {
sexp value = eval_object(assignment_value(object), environment);
set_binding(assignment_variable(object), value, environment);
return value;
}
if (is_if_form(object)) {
sexp test_part = if_test_part(object);
sexp then_part = if_then_part(object);
sexp else_part = if_else_part(object);
if (!is_false(eval_object(test_part, environment))) {
object = then_part;
} else {
object = else_part;
}
goto tail_loop;
}
if (is_lambda_form(object)) {
sexp parameters = lambda_parameters(object);
sexp body = lambda_body(object);
return make_lambda_procedure(parameters, body, environment);
}
if (is_begin_form(object)) {
return eval_begin(object, environment);
}
if (is_cond_form(object)) {
object = cond2if(object);
goto tail_loop;
}
if (is_let_form(object)) {
object = let2lambda(object);
goto tail_loop;
}
if (is_and_form(object)) {
sexp tests = and_tests(object);
if (is_null(tests))
return make_true();
while (is_pair(pair_cdr(tests))) {
sexp result = eval_object(pair_car(tests), environment);
if (is_false(result))
return make_false();
tests = pair_cdr(tests);
}
return eval_object(pair_car(tests), environment);
}
if (is_or_form(object)) {
sexp tests = or_tests(object);
if (is_null(tests))
return make_false();
while (is_pair(pair_cdr(tests))) {
sexp result = eval_object(pair_car(tests), environment);
if (!is_false(result))
return result;
tests = pair_cdr(tests);
}
return eval_object(pair_car(tests), environment);
}
if (is_macro_form(object)) {
sexp pars = macro_parameters(object);
sexp body = macro_body(object);
return make_macro_procedure(pars, body, environment);
}
if (is_application_form(object)) {
sexp operator = application_operator(object);
sexp operands = application_operands(object);
operator = eval_object(operator, environment);
if (!is_function(operator) && !is_macro(operator)) {
fprintf(stderr, "Illegal functional object ");
write_object(operator, make_file_out_port(stderr));
fprintf(stderr, " from ");
write_object(pair_car(object), make_file_out_port(stderr));
fputc('\n', stderr);
exit(1);
}
/* Expand the macro before evaluating arguments */
if (is_macro(operator)) {
sexp body = macro_proc_body(operator);
sexp vars = macro_proc_pars(operator);
sexp def_env = macro_proc_env(operator);
sexp object = make_pair(S("begin"), body);
sexp env = extend_environment(vars, operands, def_env);
sexp exp = eval_object(object, env);
return eval_object(exp, environment);
}
operands = eval_arguments(operands, environment);
/* if (is_apply(operator)) { */
/* operator = pair_car(operands); */
/* operands = apply_operands_conc(pair_cdr(operands)); */
/* } */
if (is_eval(operator)) {
environment = pair_cadr(operands);
object = pair_car(operands);
goto tail_loop;
}
return eval_application(operator, operands);
} else return object;
}
