diff --git a/ex-5_50-52.scm b/ex-5_50-52.scm index 6982130..936fa8c 100644 --- a/ex-5_50-52.scm +++ b/ex-5_50-52.scm @@ -1,71 +1,71 @@ (load "shared/util") -;(load "shared/ch5-regsim") -;(load "shared/ch5-compiler") -;(load "shared/ch5-eceval-support") -; -;(display "\nex-5.50 - compile-metacircular-evaluator\n") -; -;(define mceval-code -; (let ((port (open-input-file "shared/ch4-mceval.scm"))) -; (read port))) -; -;(define mceval-compiled -; (append -; (list '(assign env (op get-global-environment))) -; (statements (compile mceval-code 'val 'next)))) -; -;;; write assembly to file for debug purposes -;; (let ((port (open-output-file "f-mceval-compiled.scm"))) -;; (define (write-list-to-port xs port) -;; (if (null? xs) '() -;; (begin (display (car xs) port) (display "\n" port) -;; (write-list-to-port (cdr xs) port)))) -;; (write-list-to-port mceval-compiled port) -;; (close-output-port port)) -; -;(define eceval-operations (list -; (list 'list list) -; (list 'cons cons) -; -; (list 'true? true?) -; (list 'false? false?) ;for compiled code -; (list 'make-procedure make-procedure) -; (list 'compound-procedure? compound-procedure?) -; (list 'procedure-parameters procedure-parameters) -; (list 'procedure-body procedure-body) -; (list 'procedure-environment procedure-environment) -; (list 'extend-environment extend-environment) -; (list 'lookup-variable-value lookup-variable-value) -; (list 'set-variable-value! set-variable-value!) -; (list 'define-variable! define-variable!) -; (list 'primitive-procedure? primitive-procedure?) -; (list 'apply-primitive-procedure apply-primitive-procedure) -; (list 'prompt-for-input prompt-for-input) -; (list 'announce-output announce-output) -; (list 'user-print user-print) -; (list 'empty-arglist empty-arglist) -; (list 'adjoin-arg adjoin-arg) -; (list 'last-operand? last-operand?) -; (list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine -; (list 'get-global-environment get-global-environment) -; -; ;;for compiled code (also in eceval-support.scm) -; (list 'make-compiled-procedure make-compiled-procedure) -; (list 'compiled-procedure? compiled-procedure?) -; (list 'compiled-procedure-entry compiled-procedure-entry) -; (list 'compiled-procedure-env compiled-procedure-env) -; )) -; -;(define the-global-environment (setup-environment)) -;(define mceval-machine -; (make-machine -; '(exp env val proc argl continue unev) -; eceval-operations -; mceval-compiled)) -; -;(start mceval-machine) -;;; (factorial 5) computed by compiled mceval executed by register simulator -;(assert (get-register-contents mceval-machine 'val) 120) +(load "shared/ch5-regsim") +(load "shared/ch5-compiler") +(load "shared/ch5-eceval-support") + +(display "\nex-5.50 - compile-metacircular-evaluator\n") + +(define mceval-code + (let ((port (open-input-file "shared/ch4-mceval.scm"))) + (read port))) + +(define mceval-compiled + (append + (list '(assign env (op get-global-environment))) + (statements (compile mceval-code 'val 'next)))) + +;; write assembly to file for debug purposes +; (let ((port (open-output-file "f-mceval-compiled.scm"))) +; (define (write-list-to-port xs port) +; (if (null? xs) '() +; (begin (display (car xs) port) (display "\n" port) +; (write-list-to-port (cdr xs) port)))) +; (write-list-to-port mceval-compiled port) +; (close-output-port port)) + +(define eceval-operations (list + (list 'list list) + (list 'cons cons) + + (list 'true? true?) + (list 'false? false?) ;for compiled code + (list 'make-procedure make-procedure) + (list 'compound-procedure? compound-procedure?) + (list 'procedure-parameters procedure-parameters) + (list 'procedure-body procedure-body) + (list 'procedure-environment procedure-environment) + (list 'extend-environment extend-environment) + (list 'lookup-variable-value lookup-variable-value) + (list 'set-variable-value! set-variable-value!) + (list 'define-variable! define-variable!) + (list 'primitive-procedure? primitive-procedure?) + (list 'apply-primitive-procedure apply-primitive-procedure) + (list 'prompt-for-input prompt-for-input) + (list 'announce-output announce-output) + (list 'user-print user-print) + (list 'empty-arglist empty-arglist) + (list 'adjoin-arg adjoin-arg) + (list 'last-operand? last-operand?) + (list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine + (list 'get-global-environment get-global-environment) + + ;;for compiled code (also in eceval-support.scm) + (list 'make-compiled-procedure make-compiled-procedure) + (list 'compiled-procedure? compiled-procedure?) + (list 'compiled-procedure-entry compiled-procedure-entry) + (list 'compiled-procedure-env compiled-procedure-env) + )) + +(define the-global-environment (setup-environment)) +(define mceval-machine + (make-machine + '(exp env val proc argl continue unev) + eceval-operations + mceval-compiled)) + +(start mceval-machine) +;; (factorial 5) computed by compiled mceval executed by register simulator +(assert (get-register-contents mceval-machine 'val) 120) ;; Uncomment driver loop within shared/ch4-mceval.scm and load in mit-scheme ;; for REPL: @@ -93,27 +93,31 @@ (load "shared/scm2c/translator") -; My goal is to create proof of concept. Not to compile the metacircular -; evaluator. - (define c-preamble '( "#include " "#include " "#include " "" "#include \"datum.h\"" + "#include \"env.h\"" + "#include \"stack.h\"" "" "int main() {" - " datum *val;" - " datum *argl[10];" - " datum *proc;" - " void *cont, *entry, *env;" + " datum *val, *argl, *proc;" + " void *continu, *entry;" + " environment *env = get_global_environment();" + " stack *proc_stack = create_stack();" + " stack *env_stack = create_stack();" + " stack *argl_stack = create_stack();" + " stack *continu_stack = create_stack();" "" )) (define c-epilog '( - " printf(\"%u\\n\", val->value);" + " print_datum(val);" + " printf(\"\\n\");" "}" + "" )) (define (compile-to-file file-name code) @@ -137,7 +141,28 @@ (display "]") (newline) (close-output-port port))) -(compile-to-file "shared/scm2c/main.c" '(+ 42 3)) +(compile-to-file + "shared/scm2c/main.c" + '(begin + (define (fac n) (if (= n 1) 1 (* n (fac (- n 1))))) + (define (fib n) (if (< n 2) 1 (+ (fib (- n 2)) (fib (- n 1))))) + (fac 10))) -; write assembly to file for debug purposes +; I haven't implemented all expressions and data types, so I cannot + +; λ → cd shared/scm2c/ +; λ → make +; λ → ./aout +; 3628800 + +; I haven't implemented all expressions and datatypes, so I cannot compile the +; metacircular evaluator. Nevertheless, I have implemented procedure +; definitions and environment support, and I can compute factorials and +; Fibonacci numbers. That's all that ever counts. The whole C program is a +; massive memory leak that I could resolve by using reference-counting +; pointers. I am happy, grateful, and proud that I have finished working +; through this book. All that remains are the summaries for Chapters 4 and 5, +; and then I will move on to even more ambitious goals. LFG! + +(display "[FIN :]\n") diff --git a/shared/scm2c/datum.c b/shared/scm2c/datum.c new file mode 100644 index 0000000..7dc7de0 --- /dev/null +++ b/shared/scm2c/datum.c @@ -0,0 +1,87 @@ +#include +#include + +#include "datum.h" + +datum* cons(datum *e, datum *xs) { + e->next = xs; + return e; +} + +datum* const_i32(int32_t value) { + datum* r = malloc(sizeof(datum)); + if (!r) exit(-1); + r->type = datum_type_i32; + r->value = value; + return r; +} + +datum* const_bool(int32_t value) { + datum* r = malloc(sizeof(datum)); + if (!r) exit(-1); + r->type = datum_type_bool; + r->value = value; + return r; +} + +datum* const_primitive_proc(datum* (*primitive_procedure) (datum*)) { + datum* r = malloc(sizeof(datum)); + if (!r) exit(-1); + r->type = datum_type_primitive_proc; + r->primitive_procedure = primitive_procedure; + return r; +} + +int primitive_procedure(datum* d) { + if (d->type == datum_type_primitive_proc) { + return 1; + } + return 0; +} + +int is_false(datum *d) { + if (d->type == datum_type_i32) { + return 0; + } else if (d->type == datum_type_bool) { + return !d->value; + } else if (d->next) { + return 0; + } else { + return 1; + } +} + +int datum_eq(datum *a, datum *b) { + if ((a->type == datum_type_i32) && (b->type == datum_type_i32)) { + return a->value == b->value; + } + return 0; +} + +int datum_lt(datum *a, datum *b) { + if ((a->type == datum_type_i32) && (b->type == datum_type_i32)) { + return a->value < b->value; + } + return 0; +} + +void print_datum(datum* d) { + if (!d) { + printf("ERROR - DATUM is null"); + exit(-1); + } + + switch (d->type) { + case datum_type_i32: + printf("%i", d->value); + break; + default: + printf("Cannot print type %u", d->type); + break; + } +} + +void* compiled_procedure_entry(datum* d) { + return d->compiled_procedure_entry; +} + diff --git a/shared/scm2c/datum.h b/shared/scm2c/datum.h index db2b707..9625b10 100644 --- a/shared/scm2c/datum.h +++ b/shared/scm2c/datum.h @@ -1,3 +1,8 @@ +#ifndef DATUM_H +#define DATUM_H + +#include + enum datum_type { datum_type_i32, datum_type_bool, @@ -8,53 +13,22 @@ enum datum_type { typedef struct datum { enum datum_type type; int32_t value; - void* (*primitive_procedure) (void**); - void* compiled_pr; + struct datum* (*primitive_procedure) (struct datum*); + void* compiled_procedure_entry; + void* env; + struct datum *next; } datum; -typedef struct procedure { -} procedure; +datum* cons(datum *e, datum *xs); +datum* const_i32(int32_t value); +datum* const_bool(int32_t value); +datum* const_primitive_proc(datum* (*primitive_procedure) (datum*)); +int primitive_procedure(datum* d); +int is_false(datum *d); +int datum_eq(datum *a, datum *b); +int datum_lt(datum *a, datum *b); +void print_datum(datum* d); +void* compiled_procedure_entry(datum* d); - -datum* const_int(int32_t value) { - datum* r = malloc(sizeof(datum)); - if (!r) exit(-1); - r->type = datum_type_i32; - r->value = value; -} - -int primitive_procedure(datum* d) { - if (d->type == datum_type_primitive_proc) { - return 1; - } - return 0; -} - -datum* add(datum** args) { - size_t i = 0; - int32_t result = 0; - - while (args[i] != NULL) { - if (args[i]->type != datum_type_i32) { - printf("ADD - invalid type\n"); - exit(-1); - } - result += args[i]->value; - i += 1; - } - - return const_int(result); -} - -void* compiled_procedure_entry(void* p) { - return compiled_procedure_entry; -} - -datum* lookup_variable_value(char* c, void* e) { - datum* r = malloc(sizeof(datum)); - if (!r) exit(-1); - r->type = datum_type_primitive_proc; - r->primitive_procedure = (void*) &add; - return r; -} +#endif diff --git a/shared/scm2c/env.c b/shared/scm2c/env.c new file mode 100644 index 0000000..0653ef8 --- /dev/null +++ b/shared/scm2c/env.c @@ -0,0 +1,97 @@ +#include +#include +#include + +#include "env.h" +#include "primitives.h" + +datum* define_variable(const char *var, datum *value, environment *env) { + if (env->first_mapping == NULL) { + env->first_mapping = new_mapping(var, value); + return NULL; + } + + mapping* m = env->first_mapping; + while (1) { + if (strcmp(var, m->variable) == 0) { + m->value = value; + } + if (m->next) { + m = m->next; + } else { + break; + } + } + + m->next = new_mapping(var, value); + return NULL; +} + +datum* lookup_variable_value(char* var, environment* env) { + environment* e = env; + mapping* m; + + while (e) { + m = e->first_mapping; + while (m) { + if (strcmp(var, m->variable) == 0) { + return m->value; + } + m = m->next; + } + e = e->outer_env; + } + + printf("UNDEFINED VARIABLE %s", var); + exit(-1); +} + +datum* make_compiled_proc(void* entry, environment* e) { + datum* r = malloc(sizeof(datum)); + if (!r) exit(-1); + r->type = datum_type_compiled_proc; + r->compiled_procedure_entry = entry; + r->env = e; + return r; +} + +environment* extend_environment(const char **args, datum *argl, environment* outer_env) { + environment* env = malloc(sizeof(environment)); + if (!env) exit(-1); + env->first_mapping = NULL; + env->outer_env = outer_env; + + size_t i = 0; + while (argl && args[i]) { + define_variable(args[i], argl, env); + i += 1; + argl = argl->next; + } + + return env; +} + +environment* get_global_environment(void) { + environment* env = malloc(sizeof(environment)); + if (!env) exit(-1); + env->first_mapping = NULL; + env->outer_env = NULL; + define_variable("+", const_primitive_proc(&add), env); + define_variable("-", const_primitive_proc(&sub), env); + define_variable("*", const_primitive_proc(&mul), env); + define_variable("=", const_primitive_proc(&eq), env); + define_variable("<", const_primitive_proc(<), env); + define_variable("display", const_primitive_proc(&display), env); + define_variable("newline", const_primitive_proc(&newline), env); + return env; +} + +mapping* new_mapping(const char* var, datum* value) { + mapping* m = malloc(sizeof(mapping)); + if (!m) exit(-1); + m->variable = var; + m->value = value; + m->next = NULL; + return m; +} + diff --git a/shared/scm2c/env.h b/shared/scm2c/env.h new file mode 100644 index 0000000..270727b --- /dev/null +++ b/shared/scm2c/env.h @@ -0,0 +1,25 @@ +#ifndef ENV_H +#define ENV_H + +#include "datum.h" + +typedef struct mapping { + const char *variable; + datum *value; + struct mapping *next; +} mapping; + +typedef struct environment { + struct mapping *first_mapping; + struct environment *outer_env; +} environment; + +datum* define_variable(const char *var, datum *value, environment *env); +datum* lookup_variable_value(char* c, environment* e); +datum* make_compiled_proc(void* entry, environment* e); +environment* extend_environment(const char **args, datum *argl, environment* env); +environment* get_global_environment(void); +mapping* new_mapping(const char* var, datum* value); + +#endif + diff --git a/shared/scm2c/main.c b/shared/scm2c/main.c index 01628aa..09c0935 100644 --- a/shared/scm2c/main.c +++ b/shared/scm2c/main.c @@ -3,27 +3,230 @@ #include #include "datum.h" +#include "env.h" +#include "stack.h" int main() { - datum *val; - datum *argl[10]; - datum *proc; - void *cont, *entry, *env; + datum *val, *argl, *proc; + void *continu, *entry; + environment *env = get_global_environment(); + stack *proc_stack = create_stack(); + stack *env_stack = create_stack(); + stack *argl_stack = create_stack(); + stack *continu_stack = create_stack(); + val = make_compiled_proc(&&entry29, env); + goto afterlambda28; +entry29: + env = proc->env; + const char *argv30[] = {"n", }; + env = extend_environment(argv30, argl, env); + save(continu, continu_stack); + save(env, env_stack); + proc = lookup_variable_value("=", env); + val = const_i32(1); + argl = cons(val, NULL); + val = lookup_variable_value("n", env); + argl = cons(val, argl); + if (primitive_procedure(proc) == 1) + goto primitivebranch45; + goto compiledbranch44; +compiledbranch44: + continu = &&aftercall43; + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch45: + val = (*proc->primitive_procedure)(argl); +aftercall43: + env = restore(env_stack); + continu = restore(continu_stack); + if(is_false(val)) + goto falsebranch32; + goto truebranch33; +truebranch33: + val = const_i32(1); + goto *continu; +falsebranch32: + proc = lookup_variable_value("*", env); + save(continu, continu_stack); + save(proc, proc_stack); + save(env, env_stack); + proc = lookup_variable_value("fac", env); + save(proc, proc_stack); + proc = lookup_variable_value("-", env); + val = const_i32(1); + argl = cons(val, NULL); + val = lookup_variable_value("n", env); + argl = cons(val, argl); + if (primitive_procedure(proc) == 1) + goto primitivebranch36; + goto compiledbranch35; +compiledbranch35: + continu = &&aftercall34; + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch36: + val = (*proc->primitive_procedure)(argl); +aftercall34: + argl = cons(val, NULL); + proc = restore(proc_stack); + if (primitive_procedure(proc) == 1) + goto primitivebranch39; + goto compiledbranch38; +compiledbranch38: + continu = &&aftercall37; + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch39: + val = (*proc->primitive_procedure)(argl); +aftercall37: + argl = cons(val, NULL); + env = restore(env_stack); + val = lookup_variable_value("n", env); + argl = cons(val, argl); + proc = restore(proc_stack); + continu = restore(continu_stack); + if (primitive_procedure(proc) == 1) + goto primitivebranch42; + goto compiledbranch41; +compiledbranch41: + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch42: + val = (*proc->primitive_procedure)(argl); + goto *continu; +aftercall40: +afterif31: +afterlambda28: + val = define_variable("fac", val, env); + val = make_compiled_proc(&&entry5, env); + goto afterlambda4; +entry5: + env = proc->env; + const char *argv6[] = {"n", }; + env = extend_environment(argv6, argl, env); + save(continu, continu_stack); + save(env, env_stack); + proc = lookup_variable_value("<", env); + val = const_i32(2); + argl = cons(val, NULL); + val = lookup_variable_value("n", env); + argl = cons(val, argl); + if (primitive_procedure(proc) == 1) + goto primitivebranch27; + goto compiledbranch26; +compiledbranch26: + continu = &&aftercall25; + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch27: + val = (*proc->primitive_procedure)(argl); +aftercall25: + env = restore(env_stack); + continu = restore(continu_stack); + if(is_false(val)) + goto falsebranch8; + goto truebranch9; +truebranch9: + val = const_i32(1); + goto *continu; +falsebranch8: proc = lookup_variable_value("+", env); - val = const_int(3); - argl[0] = val; - val = const_int(42); - argl[1] = val; - argl[2] = NULL; + save(continu, continu_stack); + save(proc, proc_stack); + save(env, env_stack); + proc = lookup_variable_value("fib", env); + save(proc, proc_stack); + proc = lookup_variable_value("-", env); + val = const_i32(1); + argl = cons(val, NULL); + val = lookup_variable_value("n", env); + argl = cons(val, argl); + if (primitive_procedure(proc) == 1) + goto primitivebranch18; + goto compiledbranch17; +compiledbranch17: + continu = &&aftercall16; + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch18: + val = (*proc->primitive_procedure)(argl); +aftercall16: + argl = cons(val, NULL); + proc = restore(proc_stack); + if (primitive_procedure(proc) == 1) + goto primitivebranch21; + goto compiledbranch20; +compiledbranch20: + continu = &&aftercall19; + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch21: + val = (*proc->primitive_procedure)(argl); +aftercall19: + argl = cons(val, NULL); + env = restore(env_stack); + save(argl, argl_stack); + proc = lookup_variable_value("fib", env); + save(proc, proc_stack); + proc = lookup_variable_value("-", env); + val = const_i32(2); + argl = cons(val, NULL); + val = lookup_variable_value("n", env); + argl = cons(val, argl); + if (primitive_procedure(proc) == 1) + goto primitivebranch12; + goto compiledbranch11; +compiledbranch11: + continu = &&aftercall10; + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch12: + val = (*proc->primitive_procedure)(argl); +aftercall10: + argl = cons(val, NULL); + proc = restore(proc_stack); + if (primitive_procedure(proc) == 1) + goto primitivebranch15; + goto compiledbranch14; +compiledbranch14: + continu = &&aftercall13; + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch15: + val = (*proc->primitive_procedure)(argl); +aftercall13: + argl = restore(argl_stack); + argl = cons(val, argl); + proc = restore(proc_stack); + continu = restore(continu_stack); + if (primitive_procedure(proc) == 1) + goto primitivebranch24; + goto compiledbranch23; +compiledbranch23: + entry = compiled_procedure_entry(proc); + goto *entry; +primitivebranch24: + val = (*proc->primitive_procedure)(argl); + goto *continu; +aftercall22: +afterif7: +afterlambda4: + val = define_variable("fib", val, env); + proc = lookup_variable_value("fac", env); + val = const_i32(10); + argl = cons(val, NULL); if (primitive_procedure(proc) == 1) goto primitivebranch3; + goto compiledbranch2; compiledbranch2: - cont = &&aftercall1; + continu = &&aftercall1; entry = compiled_procedure_entry(proc); goto *entry; primitivebranch3: - val = (*proc->primitive_procedure)((void**) argl); + val = (*proc->primitive_procedure)(argl); aftercall1: - printf("%u\n", val->value); + print_datum(val); + printf("\n"); } + diff --git a/shared/scm2c/makefile b/shared/scm2c/makefile index 06b3015..3fbab50 100644 --- a/shared/scm2c/makefile +++ b/shared/scm2c/makefile @@ -1,9 +1,26 @@ -aout: main.o - cc -o aout main.o +CC=gcc -Wall -main.o : main.c datum.h - cc -c main.c +aout: main.o datum.o env.o primitives.o stack.o + $(CC) -o aout main.o datum.o env.o primitives.o stack.o + +main.c: ../../ex-5_50-52.scm translator.scm + cd ../../ && ./run ex-5_50-52.scm + +main.o: main.c datum.h env.h + $(CC) -c main.c + +datum.o: datum.c datum.h + $(CC) -c datum.c + +env.o: env.c env.h datum.h + $(CC) -c env.c + +primitives.o: primitives.c primitives.h datum.h + $(CC) -c primitives.c + +stack.o: stack.c stack.h datum.h + $(CC) -c stack.c clean : - rm aout main.o + rm aout main.o datum.o env.o primitives.o stack.o diff --git a/shared/scm2c/primitives.c b/shared/scm2c/primitives.c new file mode 100644 index 0000000..e8f7c86 --- /dev/null +++ b/shared/scm2c/primitives.c @@ -0,0 +1,99 @@ +#include +#include + +#include "primitives.h" + +datum* add(datum* args) { + int32_t result = 0; + while (args) { + if (args->type != datum_type_i32) { + printf("ADD - invalid type\n"); + exit(-1); + } + result += args->value; + args = args->next; + } + return const_i32(result); +} + +datum* sub(datum* args) { + int32_t result; + + if (args) { + result = args->value; + } else { + exit(-1); + } + + if (!args->next) { + result = -result; + } else { + args = args->next; + while (args) { + if (args->type != datum_type_i32) { + printf("SUB - invalid type\n"); + exit(-1); + } + result -= args->value; + args = args->next; + } + } + + return const_i32(result); +} + +datum* mul(datum* args) { + int32_t result = 1; + + while (args) { + if (args->type != datum_type_i32) { + printf("MUL - invalid type\n"); + exit(-1); + } + result *= args->value; + args = args->next; + } + + return const_i32(result); +} + +datum* eq(datum* args) { + if (!args->next) { + return const_bool(1); + } + + datum *first = args; + while (first->next) { + if (!datum_eq(first, first->next)) + return const_bool(0); + first = first->next; + } + + return const_bool(1); +} + +datum* lt(datum* args) { + if (!args->next) { + return const_bool(1); + } + + datum *first = args; + while (first->next) { + if (!datum_lt(first, first->next)) + return const_bool(0); + first = first->next; + } + + return const_bool(1); +} + +datum* display(datum* args) { + print_datum(args); + return NULL; +} + +datum* newline(datum* args) { + printf("\n"); + return NULL; +} + diff --git a/shared/scm2c/primitives.h b/shared/scm2c/primitives.h new file mode 100644 index 0000000..73abb43 --- /dev/null +++ b/shared/scm2c/primitives.h @@ -0,0 +1,14 @@ +#ifndef PRIMITIVES_H +#define PRIMITIVES_H + +#include "datum.h" + +datum* add(datum* args); +datum* sub(datum* args); +datum* mul(datum* args); +datum* eq(datum* args); +datum* lt(datum* args); +datum* display(datum* args); +datum* newline(datum* args); + +#endif diff --git a/shared/scm2c/stack.c b/shared/scm2c/stack.c new file mode 100644 index 0000000..56a258d --- /dev/null +++ b/shared/scm2c/stack.c @@ -0,0 +1,41 @@ +#include +#include + +#include "stack.h" + +struct stack proc_stack; + +stack* create_stack(void) { + stack* s = malloc(sizeof(stack)); + if (!s) exit(-1); + s->first = NULL; + return s; +} + +void save(void *d, stack *s) { + stack_elem* elem = malloc(sizeof(stack_elem)); + elem->value = d; + + if (!s->first) { + elem->next = NULL; + } else { + elem->next = s->first; + } + s->first = elem; +} + +void* restore(stack *s) { + void *r; + stack_elem *se; + + if (!s->first) { + printf("stack empty!\n"); + exit(-1); + } + + se = s->first; + r = s->first->value; + s->first = se->next; + free(se); + return r; +} diff --git a/shared/scm2c/stack.h b/shared/scm2c/stack.h new file mode 100644 index 0000000..ecddbfb --- /dev/null +++ b/shared/scm2c/stack.h @@ -0,0 +1,18 @@ +#ifndef STACK_H +#define STACK_H + +typedef struct stack_elem { + void *value; + struct stack_elem *next; +} stack_elem; + +typedef struct stack { + struct stack_elem *first; +} stack; + +stack* create_stack(void); +void save(void *d, stack *s); +void* restore(stack *s); + +#endif + diff --git a/shared/scm2c/translator.scm b/shared/scm2c/translator.scm index b7ce6b5..6c9b980 100644 --- a/shared/scm2c/translator.scm +++ b/shared/scm2c/translator.scm @@ -57,16 +57,16 @@ (define (compile-linkage linkage) (cond ((eq? linkage 'return) - (make-instruction-sequence '(continue) '() - '((goto (reg continue))))) + (make-instruction-sequence '(continu) '() + '((" goto *continu;")))) ((eq? linkage 'next) (empty-instruction-sequence)) (else (make-instruction-sequence '() '() - `((goto (label ,linkage))))))) + `((" goto " ,linkage ";")))))) (define (end-with-linkage linkage instruction-sequence) - (preserving '(continue) + (preserving '(continu) instruction-sequence (compile-linkage linkage))) @@ -77,7 +77,7 @@ (cond ((number? exp) (end-with-linkage linkage (make-instruction-sequence '() (list target) - `((" " ,target " = const_int(" ,exp ");"))))) + `((" " ,target " = const_i32(" ,exp ");"))))) (else (error "SELF-EVAL -- unsupported type" exp)))) (define (compile-quoted exp target linkage) @@ -114,11 +114,8 @@ (preserving '(env) get-value-code (make-instruction-sequence '(env val) (list target) - `((perform (op define-variable!) - (const ,var) - (reg val) - (reg env)) - (assign ,target (const ok)))))))) + `((" " ,target " = define_variable(\"" ,var "\", val, env);") + )))))) ;;;conditional expressions @@ -137,9 +134,9 @@ ;; end of footnote (define (compile-if exp target linkage) - (let ((t-branch (make-label 'true-branch)) - (f-branch (make-label 'false-branch)) - (after-if (make-label 'after-if))) + (let ((t-branch (make-label 'truebranch)) + (f-branch (make-label 'falsebranch)) + (after-if (make-label 'afterif))) (let ((consequent-linkage (if (eq? linkage 'next) after-if linkage))) (let ((p-code (compile (if-predicate exp) 'val 'next)) @@ -148,23 +145,30 @@ (if-consequent exp) target consequent-linkage)) (a-code (compile (if-alternative exp) target linkage))) - (preserving '(env continue) + (preserving '(env continu) p-code (append-instruction-sequences (make-instruction-sequence '(val) '() - `((test (op false?) (reg val)) - (branch (label ,f-branch)))) + `((" if(is_false(val))") + (" goto " ,f-branch ";") + (" goto " ,t-branch ";") + )) (parallel-instruction-sequences - (append-instruction-sequences t-branch c-code) - (append-instruction-sequences f-branch a-code)) - after-if)))))) + (append-instruction-sequences + (make-instruction-sequence '() '() `((,t-branch ":"))) + c-code) + (append-instruction-sequences + (make-instruction-sequence '() '() `((,f-branch ":"))) + a-code)) + (make-instruction-sequence '() '() `((,after-if ":"))) + )))))) ;;; sequences (define (compile-sequence seq target linkage) (if (last-exp? seq) (compile (first-exp seq) target linkage) - (preserving '(env continue) + (preserving '(env continu) (compile (first-exp seq) target 'next) (compile-sequence (rest-exps seq) target linkage)))) @@ -172,31 +176,39 @@ (define (compile-lambda exp target linkage) (let ((proc-entry (make-label 'entry)) - (after-lambda (make-label 'after-lambda))) + (after-lambda (make-label 'afterlambda))) (let ((lambda-linkage (if (eq? linkage 'next) after-lambda linkage))) (append-instruction-sequences (tack-on-instruction-sequence (end-with-linkage lambda-linkage (make-instruction-sequence '(env) (list target) - `((assign ,target - (op make-compiled-procedure) - (label ,proc-entry) - (reg env))))) + `((" " ,target " = make_compiled_proc(&&" ,proc-entry ", env);")))) (compile-lambda-body exp proc-entry)) - after-lambda)))) + (make-instruction-sequence '() '() `((,after-lambda ":"))))))) (define (compile-lambda-body exp proc-entry) - (let ((formals (lambda-parameters exp))) + (define (formals-to-string formals) + (if (null? formals) + "" + (string-append + "\"" + (string-append + (symbol->string (car formals)) + (string-append + "\", " + (formals-to-string (cdr formals))))))) + (let ((formals (lambda-parameters exp)) + (argv (make-label 'argv))) (append-instruction-sequences (make-instruction-sequence '(env proc argl) '(env) - `(,proc-entry - (assign env (op compiled-procedure-env) (reg proc)) - (assign env - (op extend-environment) - (const ,formals) - (reg argl) - (reg env)))) + `( + (,proc-entry ":") + (" env = proc->env;") + (" const char *" ,argv "[] = {" ,(formals-to-string formals) "};") + (" env = extend_environment(" ,argv ", argl, env);") + )) + ;(" env = extend_environment(" (const ,formals) ", argl, env);"))) (compile-sequence (lambda-body exp) 'val 'return)))) @@ -209,9 +221,9 @@ (operand-codes (map (lambda (operand) (compile operand 'val 'next)) (operands exp)))) - (preserving '(env continue) + (preserving '(env continu) proc-code - (preserving '(proc continue) + (preserving '(proc continu) (construct-arglist operand-codes) (compile-procedure-call target linkage))))) @@ -219,34 +231,30 @@ (let ((operand-codes (reverse operand-codes))) (if (null? operand-codes) (make-instruction-sequence '() '(argl) - '((assign argl (const ())))) + '((" argl = NULL;"))) (let ((code-to-get-last-arg (append-instruction-sequences (car operand-codes) (make-instruction-sequence '(val) '(argl) - '((" argl[0] = val;")))))) + '((" argl = cons(val, NULL);")))))) (if (null? (cdr operand-codes)) code-to-get-last-arg (preserving '(env) code-to-get-last-arg (code-to-get-rest-args - 1 (cdr operand-codes)))))))) -(define (code-to-get-rest-args index operand-codes) +(define (code-to-get-rest-args operand-codes) (let ((code-for-next-arg (preserving '(argl) (car operand-codes) (make-instruction-sequence '(val argl) '(argl) - `((" argl[" ,index "] = val;")))))) + `((" argl = cons(val, argl);")))))) (if (null? (cdr operand-codes)) - (append-instruction-sequences - code-for-next-arg - (make-instruction-sequence - '() '() `((" argl[" ,(+ index 1) "] = NULL;")))) + code-for-next-arg (preserving '(env) code-for-next-arg - (code-to-get-rest-args (+ index 1) (cdr operand-codes)))))) + (code-to-get-rest-args (cdr operand-codes)))))) ;;;applying procedures @@ -259,7 +267,8 @@ (append-instruction-sequences (make-instruction-sequence '(proc) '() `((" if (" primitive_procedure "(proc) == 1)") - (" goto " ,primitive-branch ";"))) + (" goto " ,primitive-branch ";") + (" goto " ,compiled-branch ";"))) (parallel-instruction-sequences (append-instruction-sequences (make-instruction-sequence '() '() `((,compiled-branch ":"))) @@ -269,7 +278,7 @@ (end-with-linkage linkage (make-instruction-sequence '(proc argl) (list target) - `((" val = (*proc->primitive_procedure)((void**) argl);")))))) + `((" val = (*proc->primitive_procedure)(argl);")))))) (make-instruction-sequence '() '() `((,after-call ":"))))))) ;;;applying compiled procedures @@ -277,31 +286,31 @@ (define (compile-proc-appl target linkage) (cond ((and (eq? target 'val) (not (eq? linkage 'return))) (make-instruction-sequence '(proc) all-regs - `((" " cont " = &&" ,linkage ";") + `((" continu = &&" ,linkage ";") (" " entry " = " compiled_procedure_entry "(proc);") (" goto *entry;")))) ((and (not (eq? target 'val)) (not (eq? linkage 'return))) (let ((proc-return (make-label 'proc-return))) (make-instruction-sequence '(proc) all-regs - `((assign continue (label ,proc-return)) + `((assign continu (label ,proc-return)) (assign val (op compiled_procedure_entry) (reg proc)) - (goto (reg val)) + (" goto " (reg val) "// FOO2") ,proc-return (assign ,target (reg val)) - (goto (label ,linkage)))))) + (" goto " (label ,linkage) "; // FOO1"))))) ((and (eq? target 'val) (eq? linkage 'return)) - (make-instruction-sequence '(proc continue) all-regs - '((assign val (op compiled-procedure-entry) - (reg proc)) - (goto (reg val))))) + (make-instruction-sequence '(proc continu) all-regs + '((" entry = compiled_procedure_entry(proc);") + (" goto *entry;") + ))) ((and (not (eq? target 'val)) (eq? linkage 'return)) (error "return linkage, target not val -- COMPILE" target)))) ;; footnote -(define all-regs '(env proc val argl continue)) +(define all-regs '(env proc val argl continu)) ;;;SECTION 5.5.4 @@ -361,9 +370,9 @@ (registers-needed seq1)) (list-difference (registers-modified seq1) (list first-reg)) - (append `((save ,first-reg)) + (append `((" save(",first-reg ", " ,first-reg "_stack);")) (statements seq1) - `((restore ,first-reg)))) + `((" " ,first-reg " = restore(" ,first-reg "_stack);")))) seq2) (preserving (cdr regs) seq1 seq2)))))