ehaliewicz · August 29, 2015 14:00 · Apr 22, 2014 · Apr 22, 2014
diff --git a/lc->c.lisp b/lc->c.lisp
@@ -1,3 +1,10 @@
+;; compiles untyped lambda calculus to portable C
+;; syntax
+;; (lambda x x) - lambda abstraction
+;; (x y)        - lambda combination (assuming x and y are bound)
+
+
+
 ;; map of function names to declarations
 ;; kept separate from the rest of the C code because they need to be forward-declared
 (defvar *lambda-map* nil)

diff --git a/lc->c.lisp b/lc->c.lisp
@@ -0,0 +1,249 @@
+;; map of function names to declarations
+;; kept separate from the rest of the C code because they need to be forward-declared
+(defvar *lambda-map* nil)
+
+
+(defun c-compile-lambda (expression outfile)
+  (with-open-file (out outfile :direction :output
+                       :if-does-not-exist :create :if-exists :supersede)
+    (format out "~a" (lambda->c expression))))
+
+
+;; c type definitions, includes, etc.
+(defun prelude ()
+  (cat-new
+   (emit "#include \"stdlib.h\"")
+   (emit "#include \"stdio.h\"")
+   (emit "#include \"string.h\"")
+   (emit "#define MULTI_LINE_STRING(a) #a")
+   (emit "typedef struct closure * (*lambda_func)();")
+   (emit "typedef struct closure { char* str; lambda_func func; struct env* environment;} closure;")
+   (emit "typedef struct env { struct env* next; closure* dat;} env;~%")
+   (emit "env** stack;")
+   (emit "int sp = 0;")
+   (emit "env* environment = NULL;")
+
+
+   (emit "char* gc_pool;")
+   (emit "int gc_ptr = 0;")
+   (emit "int gc_pool_size;")
+   (emit "int num_allocs = 0;")
+   (emit "int num_bytes_allocd = 0;")
+
+   (emit "void* gc_alloc(int size_in_bytes) {")
+   (emit "int res = gc_ptr;")
+   (emit "gc_ptr+=size_in_bytes;")
+   (emit "num_bytes_allocd+=size_in_bytes;")
+   (emit "num_allocs++;")
+   ;; no gc yet, just keep allocating memory until we run out ;)
+   (emit "if (gc_ptr > gc_pool_size) {")
+   (emit "void* res = realloc(gc_pool, gc_pool_size*2);")
+   (emit "if(res) {")
+   (emit "gc_pool = res;")
+   (emit "} else {")
+   (emit "printf(\"Out of memory, gc not implemented\\n\");")
+   (emit "exit(0);")
+   (emit "}")
+   (emit "}")
+   (emit "return &(gc_pool[res]);")
+   (emit "}")
+
+   ;; environment extension
+   (emit "env* push(closure* obj, env* old_env) {")
+   (emit "env* link = gc_alloc(sizeof(closure));")
+   (emit "link->next = old_env;")
+   (emit "link->dat = obj;")
+   (emit "return link;")
+   (emit "}")
+
+   ;; environment lookup
+   (emit "closure* env_ref(env* environment, int idx) {")
+   (emit "env* tmp_env = environment;")
+   (emit "if(tmp_env == NULL) { goto error; }")
+   (emit "while(idx > 0 && tmp_env->next) {")
+   (emit "tmp_env = tmp_env->next;")
+   (emit "idx--;")
+   (emit "}")
+
+   (emit "if (tmp_env == NULL || idx > 0) { goto error; }")
+
+   (emit "return tmp_env->dat;")
+
+   (emit "error:")
+   (emit "printf(\"Error retrieving environment value: idx %i\\n\", idx);")
+   (emit  "exit(0);")
+
+   (emit "}")
+
+   (emit "closure* make_closure(lambda_func func, char* str, env* environment) {")
+   (emit "closure *clos = gc_alloc(sizeof(closure));")
+   (emit "clos->func = func;")
+   (emit "clos->str = str;")
+   (emit "clos->environment = environment;")
+   (emit "return clos;")
+   (emit "}")))
+
+
+
+;; wrapper func
+;; emits a main function
+(defun lambda->c (expression)
+  (let ((*lambda-map* (make-hash-table :test 'eq)))
+
+    (declare (special *lambda-map*))
+
+    (multiple-value-bind (decl value)
+        (compile-lambda expression nil)
+
+      (cat-new
+       (prelude)       
+       (apply #'cat-new
+              (loop for v being the hash-value of *lambda-map* collecting
+                   (emit v)))
+
+
+
+       (emit "int main(int argc, char** argv) {")
+
+       (emit "if (argc < 2) { gc_pool_size = 128; }")
+       (emit "else { gc_pool_size = strtoul(argv[1], NULL, 10); }")
+       ;; allocate memory
+       (emit "gc_pool = malloc(sizeof(char*) * gc_pool_size);")
+
+       ;; calculate result
+       decl
+
+
+       (emit "printf(\"result: %s\\n\", (~a->func)(environment)->str);" value)
+
+       ;; free memory and output allocation statistics
+       (emit "free(gc_pool);")
+       (emit "printf(\"Number of bytes allocated: %i\\n\", num_bytes_allocd);")
+       (emit "printf(\"Number of objects allocated: %i\\n\", num_allocs);")
+       (emit "return 0;")
+       (emit "}")))))
+
+
+(defun emit (string &rest args)
+  (apply #'format nil string args))
+
+
+;; concatenate strings with newlines in between
+(defun cat-new (&rest strings)
+  (apply
+   #'concatenate 'string
+   (reduce (lambda (x y) (cons x (cons (format nil "~%") y)))
+           strings
+           :from-end :left
+           :initial-value nil)))
+
+
+;; compile a lambda expression into a closure
+(defun compile-closure (expr env)
+  (destructuring-bind (lambda arg body) expr
+                 (let ((clos-name (gensym "closure"))
+                       (func-name (gensym "lambda"))
+                       (returnp (symbolp body)))
+                   (let ((func-decl
+
+                          (cat-new
+                           (emit "closure* ~a(env* environment) {" func-name)
+
+                           (multiple-value-bind (decl value)
+                               (compile-lambda body (cons arg env))
+                             (cat-new
+                              decl                              
+                              (emit "return ~a;" value)))
+
+                               (emit "}")))
+                         (clos-decl
+                          (emit "closure* ~a = make_closure(&~a, MULTI_LINE_STRING(~a), environment);~%"
+                                clos-name func-name expr))
+                         (clos-value (emit "~a" clos-name)))
+
+                     (setf (gethash func-name *lambda-map*) func-decl)
+                     (values
+                      clos-decl
+                      clos-value)))))
+
+
+(defun compile-print (expr env)
+  (let ((null-closure (emit "make_closure(NULL, NULL, NULL)")))
+    (values
+     (if (stringp expr)
+         (emit "printf(\"%s\\n\", ~s);" expr)
+         (multiple-value-bind (decl value) (compile-lambda expr env)
+           (cat-new
+            decl
+            (emit "printf(\"%s\\n\", (~a)->str);" value))))
+     ;; null closure, because all values on the C side are closures
+     null-closure
+
+     )))
+
+
+;; returns two values: (C declaration, C value) 
+(defun compile-lambda (expr &optional env)
+  (etypecase expr
+    (symbol (let ((pos (position expr env)))
+
+              ;; symbol reference: only a value, no declaration needed
+              (values nil
+                      (if pos
+                          (emit "(env_ref(environment, ~a))" pos)
+                          (if (null expr)
+                              "NULL"
+                              (error "Unbound symbol ~a." expr))))))
+    (list (case (car expr)
+
+            (lambda  (compile-closure expr env))
+
+            (print (compile-print (cadr expr) env))
+
+            (otherwise ;; application
+             (destructuring-bind (operator operand) expr
+
+               (multiple-value-bind (operand-decl operand-value)
+                   (compile-lambda operand env)
+                 (multiple-value-bind (operator-decl operator-value)
+                     (compile-lambda operator env)
+
+                   (values
+
+                    ;; declaration
+                    (cat-new
+                     operand-decl
+                     operator-decl)
+
+                    ;; value
+                    (emit "~a->func(push(~a, ~a->environment))" operator-value operand-value operator-value))))))))))
+
+
+
+
+
+
+
+;; doesn't work
+(defun cps-transform (expr)
+  (labels ((recur (expr)
+             (etypecase expr
+               (symbol `(lambda k (k ,expr)))
+               (string `(lambda k (k ,expr)))
+               (list
+                (case (car expr)
+
+                  (call/cc
+                   `(,(recur (cadr expr)) k))
+
+                  (lambda (destructuring-bind (lambda arg body) expr
+                       `(lambda k
+                          (lambda ,arg
+                            (k ,(if (symbolp body) body body))))))
+                  (otherwise
+                   (destructuring-bind (operator operand) expr
+                     `((,(recur operator)
+                         (lambda val (k val)))
+                       ,(recur operand)))))))))
+    `((lambda k ,(recur expr))
+      (lambda x x))))
No results found