Implement datum support and add make for ex-5.52

.gitignore

@@ -10,3 +10,7 @@ test.scm
 *.scm#*
 .#*.scm
 
+# ---> scm2c
+aout
+*.o
+

ex-5_50-52.scm

@@ -98,17 +98,21 @@
 
 (define c-preamble '(
   "#include <stdio.h>"
-  "#include \"scm_support.h\""
+  "#include <stdint.h>"
+  "#include <stdlib.h>"
+  ""
+  "#include \"datum.h\""
   ""
   "int main() {"
-  "    int val;"
-  "    int *argl;"
-  "    void *cont, *entry, *proc, *env;"
+  "    datum *val;"
+  "    datum *argl[10];"
+  "    datum *proc;"
+  "    void *cont, *entry, *env;"
   ""
   ))
 
 (define c-epilog '(
-  "    printf(\"%u\\n\", val);"
+  "    printf(\"%u\\n\", val->value);"
   "}"
   ))
 
@@ -133,7 +137,7 @@
      (display "]") (newline)
      (close-output-port port)))
 
-(compile-to-file "shared/scm2c/main.c" '(+ 1 1))
+(compile-to-file "shared/scm2c/main.c" '(+ 42 3))
 
 ; write assembly to file for debug purposes
 

shared/scm2c/datum.h

@@ -0,0 +1,60 @@
+enum datum_type {
+    datum_type_i32,
+    datum_type_bool,
+    datum_type_primitive_proc,
+    datum_type_compiled_proc,
+};
+
+typedef struct datum {
+    enum datum_type type;
+    int32_t value;
+    void* (*primitive_procedure) (void**);
+    void* compiled_pr;
+} datum;
+
+typedef struct procedure {
+} procedure;
+
+
+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/main.c

@@ -1,16 +1,21 @@
 #include <stdio.h>
-#include "scm_support.h"
+#include <stdint.h>
+#include <stdlib.h>
+
+#include "datum.h"
 
 int main() {
-    int val;
-    int *argl;
-    void *cont, *entry, *proc, *env;
+    datum *val;
+    datum *argl[10];
+    datum *proc;
+    void *cont, *entry, *env;
 
     proc = lookup_variable_value("+", env);
-    val = 1;
-    argl = list(val);
-    val = 1;
-    argl = cons(val, argl);
+    val = const_int(3);
+    argl[0] = val;
+    val = const_int(42);
+    argl[1] = val;
+    argl[2] = NULL;
     if (primitive_procedure(proc) == 1)
         goto primitivebranch3;
 compiledbranch2:
@@ -18,7 +23,7 @@ compiledbranch2:
     entry = compiled_procedure_entry(proc);
     goto *entry;
 primitivebranch3:
-    val = proc(argl);
+    val = (*proc->primitive_procedure)((void**) argl);
 aftercall1:
-    printf("%u\n", val);
+    printf("%u\n", val->value);
 }

shared/scm2c/makefile

@@ -0,0 +1,9 @@
+aout: main.o
+	cc -o aout main.o
+
+main.o : main.c datum.h
+	cc -c main.c
+
+clean :
+	rm aout main.o
+

shared/scm2c/scm2c.h

@@ -1,15 +0,0 @@
-void* lookup_variable_value(char* c, void* e) {
-    return NULL;
-}
-
-int* list(int n) {
-    return NULL;
-}
-
-int* cons(int n, int* argl) {
-    return NULL;
-}
-
-int primitive_procedure(void* p) {
-    return 1;
-}

shared/scm2c/translator.scm

@@ -74,9 +74,11 @@
 ;;;simple expressions
 
 (define (compile-self-evaluating exp target linkage)
-  (end-with-linkage linkage
-   (make-instruction-sequence '() (list target)
-    `(("    " ,target " " = " " ,exp ";")))))
+  (cond ((number? exp)
+          (end-with-linkage linkage
+           (make-instruction-sequence '() (list target)
+            `(("    " ,target " = const_int(" ,exp ");")))))
+        (else (error "SELF-EVAL -- unsupported type" exp))))
 
 (define (compile-quoted exp target linkage)
   (end-with-linkage linkage
@@ -222,25 +224,29 @@
                (append-instruction-sequences
                 (car operand-codes)
                 (make-instruction-sequence '(val) '(argl)
-                 '(("    " argl " = " list (val) ";"))))))
+                 '(("    argl[0] = val;"))))))
           (if (null? (cdr operand-codes))
               code-to-get-last-arg
               (preserving '(env)
                code-to-get-last-arg
                (code-to-get-rest-args
-                (cdr operand-codes))))))))
+                 1
+                 (cdr operand-codes))))))))
 
-(define (code-to-get-rest-args operand-codes)
+(define (code-to-get-rest-args index operand-codes)
   (let ((code-for-next-arg
          (preserving '(argl)
           (car operand-codes)
           (make-instruction-sequence '(val argl) '(argl)
-           '(("    " argl " " = " " cons "(" val ", " argl ");"))))))
+           `(("    argl[" ,index "] = val;"))))))
     (if (null? (cdr operand-codes))
-        code-for-next-arg
+        (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 (cdr operand-codes))))))
+         (code-to-get-rest-args (+ index 1) (cdr operand-codes))))))
 
 ;;;applying procedures
 
@@ -263,7 +269,7 @@
          (end-with-linkage linkage
           (make-instruction-sequence '(proc argl)
                                      (list target)
-           `(("    val = proc(argl);"))))))
+           `(("    val = (*proc->primitive_procedure)((void**) argl);"))))))
        (make-instruction-sequence '() '() `((,after-call ":")))))))
 
 ;;;applying compiled procedures