Implement 5.52 translate Scheme to C

ex-5_50-52.scm

@@ -1,71 +1,71 @@
 (load "shared/util")
-;(load "shared/ch5-regsim")
+(load "shared/ch5-regsim")
-;(load "shared/ch5-compiler")
+(load "shared/ch5-compiler")
-;(load "shared/ch5-eceval-support")
+(load "shared/ch5-eceval-support")
-;
+
-;(display "\nex-5.50 - compile-metacircular-evaluator\n")
+(display "\nex-5.50 - compile-metacircular-evaluator\n")
-;
+
-;(define mceval-code
+(define mceval-code
-;  (let ((port (open-input-file "shared/ch4-mceval.scm")))
+  (let ((port (open-input-file "shared/ch4-mceval.scm")))
-;    (read port)))
+    (read port)))
-;
+
-;(define mceval-compiled
+(define mceval-compiled
-;  (append
+  (append
-;    (list '(assign env (op get-global-environment)))
+    (list '(assign env (op get-global-environment)))
-;    (statements (compile mceval-code 'val 'next))))
+    (statements (compile mceval-code 'val 'next))))
-;
+
-;;; write assembly to file for debug purposes
+;; write assembly to file for debug purposes
-;; (let ((port (open-output-file "f-mceval-compiled.scm")))
+; (let ((port (open-output-file "f-mceval-compiled.scm")))
-;;   (define (write-list-to-port xs port)
+;   (define (write-list-to-port xs port)
-;;     (if (null? xs) '()
+;     (if (null? xs) '()
-;;       (begin (display (car xs) port) (display "\n" port)
+;       (begin (display (car xs) port) (display "\n" port)
-;;              (write-list-to-port (cdr xs) port))))
+;              (write-list-to-port (cdr xs) port))))
-;;   (write-list-to-port mceval-compiled port)
+;   (write-list-to-port mceval-compiled port)
-;;   (close-output-port port))
+;   (close-output-port port))
-;
+
-;(define eceval-operations (list
+(define eceval-operations (list
-;   (list 'list list)
+   (list 'list list)
-;   (list 'cons cons)
+   (list 'cons cons)
-;
+
-;   (list 'true? true?)
+   (list 'true? true?)
-;   (list 'false? false?)    ;for compiled code
+   (list 'false? false?)    ;for compiled code
-;   (list 'make-procedure make-procedure)
+   (list 'make-procedure make-procedure)
-;   (list 'compound-procedure? compound-procedure?)
+   (list 'compound-procedure? compound-procedure?)
-;   (list 'procedure-parameters procedure-parameters)
+   (list 'procedure-parameters procedure-parameters)
-;   (list 'procedure-body procedure-body)
+   (list 'procedure-body procedure-body)
-;   (list 'procedure-environment procedure-environment)
+   (list 'procedure-environment procedure-environment)
-;   (list 'extend-environment extend-environment)
+   (list 'extend-environment extend-environment)
-;   (list 'lookup-variable-value lookup-variable-value)
+   (list 'lookup-variable-value lookup-variable-value)
-;   (list 'set-variable-value! set-variable-value!)
+   (list 'set-variable-value! set-variable-value!)
-;   (list 'define-variable! define-variable!)
+   (list 'define-variable! define-variable!)
-;   (list 'primitive-procedure? primitive-procedure?)
+   (list 'primitive-procedure? primitive-procedure?)
-;   (list 'apply-primitive-procedure apply-primitive-procedure)
+   (list 'apply-primitive-procedure apply-primitive-procedure)
-;   (list 'prompt-for-input prompt-for-input)
+   (list 'prompt-for-input prompt-for-input)
-;   (list 'announce-output announce-output)
+   (list 'announce-output announce-output)
-;   (list 'user-print user-print)
+   (list 'user-print user-print)
-;   (list 'empty-arglist empty-arglist)
+   (list 'empty-arglist empty-arglist)
-;   (list 'adjoin-arg adjoin-arg)
+   (list 'adjoin-arg adjoin-arg)
-;   (list 'last-operand? last-operand?)
+   (list 'last-operand? last-operand?)
-;   (list 'no-more-exps? no-more-exps?)  ;for non-tail-recursive machine
+   (list 'no-more-exps? no-more-exps?)  ;for non-tail-recursive machine
-;   (list 'get-global-environment get-global-environment)
+   (list 'get-global-environment get-global-environment)
-;
+
-;   ;;for compiled code (also in eceval-support.scm)
+   ;;for compiled code (also in eceval-support.scm)
-;   (list 'make-compiled-procedure make-compiled-procedure)
+   (list 'make-compiled-procedure make-compiled-procedure)
-;   (list 'compiled-procedure? compiled-procedure?)
+   (list 'compiled-procedure? compiled-procedure?)
-;   (list 'compiled-procedure-entry compiled-procedure-entry)
+   (list 'compiled-procedure-entry compiled-procedure-entry)
-;   (list 'compiled-procedure-env compiled-procedure-env)
+   (list 'compiled-procedure-env compiled-procedure-env)
-;  ))
+  ))
-;
+
-;(define the-global-environment (setup-environment))
+(define the-global-environment (setup-environment))
-;(define mceval-machine
+(define mceval-machine
-;  (make-machine
+  (make-machine
-;    '(exp env val proc argl continue unev)
+    '(exp env val proc argl continue unev)
-;    eceval-operations
+    eceval-operations
-;    mceval-compiled))
+    mceval-compiled))
-;
+
-;(start mceval-machine)
+(start mceval-machine)
-;;; (factorial 5) computed by compiled mceval executed by register simulator
+;; (factorial 5) computed by compiled mceval executed by register simulator
-;(assert (get-register-contents mceval-machine 'val) 120)
+(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 <stdio.h>"
   "#include <stdint.h>"
   "#include <stdlib.h>"
   ""
   "#include \"datum.h\""
+  "#include \"env.h\""
+  "#include \"stack.h\""
   ""
   "int main() {"
-  "    datum *val;"
+  "    datum *val, *argl, *proc;"
-  "    datum *argl[10];"
+  "    void *continu, *entry;"
-  "    datum *proc;"
+  "    environment *env = get_global_environment();"
-  "    void *cont, *entry, *env;"
+  "    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")
 

shared/scm2c/datum.c

@@ -0,0 +1,87 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#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;
+}
+

shared/scm2c/datum.h

@@ -1,3 +1,8 @@
+#ifndef DATUM_H
+#define DATUM_H
+
+#include <stdint.h>
+
 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**);
+    struct datum* (*primitive_procedure) (struct datum*);
-    void* compiled_pr;
+    void* compiled_procedure_entry;
+    void* env;
+    struct datum *next;
 } datum;
 
-typedef struct procedure {
+datum* cons(datum *e, datum *xs);
-} procedure;
+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);
 
-
+#endif
-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;
-}
 

shared/scm2c/env.c

@@ -0,0 +1,97 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#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(&lt), 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;
+}
+

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
+

shared/scm2c/main.c

@@ -3,27 +3,230 @@
 #include <stdlib.h>
 
 #include "datum.h"
+#include "env.h"
+#include "stack.h"
 
 int main() {
-    datum *val;
+    datum *val, *argl, *proc;
-    datum *argl[10];
+    void *continu, *entry;
-    datum *proc;
+    environment *env = get_global_environment();
-    void *cont, *entry, *env;
+    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);
+    save(continu, continu_stack);
-    argl[0] = val;
+    save(proc, proc_stack);
-    val = const_int(42);
+    save(env, env_stack);
-    argl[1] = val;
+    proc = lookup_variable_value("fib", env);
-    argl[2] = NULL;
+    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");
 }
+

shared/scm2c/makefile

@@ -1,9 +1,26 @@
-aout: main.o
+CC=gcc -Wall
-	cc -o aout main.o
 
-main.o : main.c datum.h
+aout: main.o datum.o env.o primitives.o stack.o
-	cc -c main.c
+	$(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
 

shared/scm2c/primitives.c

@@ -0,0 +1,99 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+#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;
+}
+

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

shared/scm2c/stack.c

@@ -0,0 +1,41 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+#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;
+}

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
+

shared/scm2c/translator.scm

@@ -57,16 +57,16 @@
 
 (define (compile-linkage linkage)
   (cond ((eq? linkage 'return)
-         (make-instruction-sequence '(continue) '()
+         (make-instruction-sequence '(continu) '()
-          '((goto (reg continue)))))
+          '(("    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!)
+       `(("    " ,target " = define_variable(\"" ,var "\", val, env);")
-                  (const ,var)
+         ))))))
-                  (reg val)
-                  (reg env))
-         (assign ,target (const ok))))))))
 
 
 ;;;conditional expressions
@@ -137,9 +134,9 @@
 ;; end of footnote
 
 (define (compile-if exp target linkage)
-  (let ((t-branch (make-label 'true-branch))
+  (let ((t-branch (make-label 'truebranch))
-        (f-branch (make-label 'false-branch))
+        (f-branch (make-label 'falsebranch))
-        (after-if (make-label 'after-if)))
+        (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))
+           `(("    if(is_false(val))")
-             (branch (label ,f-branch))))
+             ("        goto " ,f-branch ";")
+             ("    goto " ,t-branch ";")
+             ))
           (parallel-instruction-sequences
-           (append-instruction-sequences t-branch c-code)
+           (append-instruction-sequences
-           (append-instruction-sequences f-branch a-code))
+             (make-instruction-sequence '() '() `((,t-branch ":")))
-          after-if))))))
+             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
+          `(("    " ,target " = make_compiled_proc(&&" ,proc-entry ", env);"))))
-                    (op make-compiled-procedure)
-                    (label ,proc-entry)
-                    (reg 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))
+        (,proc-entry ":")
-        (assign env
+        ("    env = proc->env;")
-                (op extend-environment)
+        ("    const char *" ,argv "[] = {" ,(formals-to-string formals) "};")
-                (const ,formals)
+        ("    env = extend_environment(" ,argv ", argl, env);")
-                (reg argl)
+        ))
-                (reg 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;"))))
         (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
+         (make-instruction-sequence '(proc continu) all-regs
-          '((assign val (op compiled-procedure-entry)
+          '(("    entry = compiled_procedure_entry(proc);")
-                        (reg proc))
+            ("    goto *entry;")
-            (goto (reg val)))))
+            )))
         ((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)))))