diff --git a/eval.c b/eval.c index 4414274b..142ffe1a 100644 --- a/eval.c +++ b/eval.c @@ -137,14 +137,48 @@ static sexp sexp_make_procedure(char flags, unsigned short num_args, return (sexp) proc; } +static sexp sexp_make_macro (procedure p, env e) { + macro mac = SEXP_ALLOC(sizeof(struct macro)); + mac->tag = SEXP_MACRO; + mac->e = e; + mac->proc = p; + return (sexp) mac; +} + /************************* the compiler ***************************/ +sexp sexp_expand_macro (macro mac, sexp form, env e) { + sexp res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); + bytecode bc; + unsigned int i; + fprintf(stderr, "expanding: "); + sexp_write(form, cur_error_port); + fprintf(stderr, "\n => "); + bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+32); + bc->tag = SEXP_BYTECODE; + bc->len = 32; + emit_push(&bc, &i, mac->e); + emit_push(&bc, &i, e); + emit_push(&bc, &i, form); + emit_push(&bc, &i, mac->proc); + emit(&bc, &i, OP_CALL); + emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); + emit(&bc, &i, OP_DONE); + res = vm(bc, e, stack, 0); + sexp_write(res, cur_error_port); + fprintf(stderr, "\n"); + SEXP_FREE(bc); + SEXP_FREE(stack); + return res; +} + void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, sexp params, sexp fv, sexp sv, unsigned int *d, int tailp) { int tmp1, tmp2, tmp3; env e2; sexp o1, o2, cell; + loop: if (SEXP_PAIRP(obj)) { if (SEXP_SYMBOLP(SEXP_CAR(obj))) { o1 = env_cell(e, SEXP_CAR(obj)); @@ -159,6 +193,10 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, analyze_lambda(SEXP_FALSE, SEXP_CADR(obj), SEXP_CDDR(obj), bc, i, e, params, fv, sv, d, tailp); break; + case CORE_DEFINE_SYNTAX: + env_define(e, SEXP_CADR(obj), + sexp_make_macro((procedure) eval(SEXP_CADDR(obj), e), e)); + break; case CORE_DEFINE: if ((((core_form)o1)->code == CORE_DEFINE) && SEXP_PAIRP(SEXP_CADR(obj))) { @@ -293,6 +331,9 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e, default: errx(1, "unknown opcode class: %d", ((opcode)o1)->op_class); } + } else if (SEXP_MACROP(o1)) { + obj = sexp_expand_macro((macro) o1, obj, e); + goto loop; } else { /* general procedure call */ analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); @@ -575,7 +616,7 @@ unsigned int sexp_restore_stack(sexp saved, sexp *current) { return len; } -#define sexp_raise(exn) {stack[top-1]=(exn); goto call_error_handler;} +#define sexp_raise(exn) {stack[top++]=(exn); goto call_error_handler;} sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { unsigned char *ip=bc->data; @@ -590,6 +631,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { break; case OP_GLOBAL_REF: tmp1 = env_cell(e, ((sexp*)ip)[0]); + if (! tmp1) + sexp_raise(sexp_intern("undefined-variable")); stack[top++]=SEXP_CDR(tmp1); ip += sizeof(sexp); break; @@ -893,6 +936,7 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { break; case OP_ERROR: call_error_handler: + fprintf(stderr, "in error handler\n"); sexp_write_string("ERROR: ", cur_error_port); sexp_write(stack[top-1], cur_error_port); sexp_write_string("\n", cur_error_port); @@ -970,6 +1014,8 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) { /* sexp_write(stack[top-1], cur_error_port); */ /* fprintf(stderr, "...\n"); */ /* print_stack(stack, top); */ + if (top<4) + goto end_loop; cp = stack[top-2]; ip = (unsigned char*) sexp_unbox_integer(stack[top-3]); i = sexp_unbox_integer(stack[top-4]); diff --git a/eval.h b/eval.h index 658ceecf..a32aa26e 100644 --- a/eval.h +++ b/eval.h @@ -43,6 +43,12 @@ typedef struct env { sexp bindings; } *env; +typedef struct macro { + char tag; + procedure proc; + env e; +} *macro; + typedef struct opcode { char tag; char op_class; diff --git a/sexp.c b/sexp.c index ebf3d620..f20d4607 100644 --- a/sexp.c +++ b/sexp.c @@ -411,10 +411,16 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#", out); break; case SEXP_OPORT: sexp_write_string("#", out); break; + case SEXP_CORE: + sexp_write_string("#", out); break; + case SEXP_OPCODE: + sexp_write_string("#", out); break; case SEXP_BYTECODE: sexp_write_string("#", out); break; case SEXP_ENV: sexp_write_string("#", out); break; + case SEXP_MACRO: + sexp_write_string("#", out); break; case SEXP_STRING: sexp_write_char('"', out); i = sexp_string_length(obj); diff --git a/sexp.h b/sexp.h index e889b98b..199be5c8 100644 --- a/sexp.h +++ b/sexp.h @@ -80,6 +80,7 @@ enum sexp_types { /* the following are used only by the evaluator */ SEXP_EXCEPTION, SEXP_PROCEDURE, + SEXP_MACRO, SEXP_ENV, SEXP_BYTECODE, SEXP_CORE, @@ -124,6 +125,7 @@ typedef long sexp_sint_t; #define SEXP_BYTECODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag ==SEXP_BYTECODE) #define SEXP_COREP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_CORE) #define SEXP_OPCODEP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_OPCODE) +#define SEXP_MACROP(x) (SEXP_POINTERP(x) && ((sexp)(x))->tag == SEXP_MACRO) #define SEXP_SYMBOLP(x) (SEXP_ISYMBOLP(x) || SEXP_LSYMBOLP(x))