Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

initial macro support

Browse source
This commit is contained in:
Alex Shinn 2009-03-11 15:48:18 +09:00
parent c2103148cb
commit dfc38557b9
4 changed files with 61 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
eval.c
View file

@ -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]);

6
eval.h
View file

@ -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;

6
sexp.c
View file

@ -411,10 +411,16 @@ void sexp_write (sexp obj, sexp out) {
sexp_write_string("#<input-port>", out); break;
case SEXP_OPORT:
sexp_write_string("#<output-port>", out); break;
case SEXP_CORE:
sexp_write_string("#<core-form>", out); break;
case SEXP_OPCODE:
sexp_write_string("#<opcode>", out); break;
case SEXP_BYTECODE:
sexp_write_string("#<bytecode>", out); break;
case SEXP_ENV:
sexp_write_string("#<env>", out); break;
case SEXP_MACRO:
sexp_write_string("#<macro>", out); break;
case SEXP_STRING:
sexp_write_char('"', out);
i = sexp_string_length(obj);

2
sexp.h
View file

@ -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))