Add compiler

The compiler is currently written in Lisp. It should be rewritten in Perl.

diff --git a/compiler.l b/compiler.l
new file mode 100644 (file)
index 0000000..c999904
--- /dev/null
+++ b/compiler.l
@@ -0,0 +1,99 @@
+(ql:quickload "lisp-unit")
+
+(defpackage :compiler
+  (:use :common-lisp :lisp-unit))
+(in-package :compiler)
+
+(setq *print-failures* t)
+
+(defvar *primops*)
+(setq *primops* '(car cdr cons atom progn reverse-list))
+
+(defun process-quoted (exp)
+  (if (atom exp)
+         (if exp (if (numberp exp) (list 'number exp) (list 'symbol exp)) '(list 0))
+         (list 'list (process-quoted (cdr exp)) (process-quoted (car exp)))))
+
+(define-test process-quoted
+       (assert-equal '(number 5) (process-quoted '5))
+  (assert-equal '(list 0) (process-quoted '()))
+  (assert-equal '(symbol foo) (process-quoted 'foo))
+  (assert-equal
+   '(list (list (list 0) (symbol foo)) (number 5))
+   (process-quoted '(5 foo)))
+  (assert-equal
+   '(list (list 0) (list (list 0) (list (list 0) (number 5))))
+   (process-quoted '(((5))))))
+
+(defun process-proc (func-name func-args func-body env)
+  (process-toplevel func-body (append (cons func-name (reverse func-args)) env)))
+
+(defun rest-of-funcall (func args)
+  (if (atom args) func (list 'more (rest-of-funcall func (cdr args)) (car args))))
+
+(defun process-funcall (func-name func-args env)
+  (let* ((prim-idx (position func-name *primops*))
+                (processed-args (mapcar #'(lambda (exp) (process-toplevel exp env)) func-args)))
+       (if (numberp prim-idx)
+               (list 'call (rest-of-funcall (list func-name nil) (cdr processed-args)) (car processed-args))
+               (let ((final-args (append processed-args (list (process-toplevel func-name env)))))
+                 (list 'call (rest-of-funcall '(funcall nil) (cdr final-args)) (car final-args))))))
+
+(defun process-toplevel (exp env)
+  (if (atom exp)
+         (if (numberp exp)
+                 (list 'number exp)
+                 (cond
+                       ((equal exp 't)   '(symbol t))
+                       ((equal exp 'nil) '(list 0))
+                       (t (let ((idx (position exp env)))
+                                (if (numberp idx)
+                                        (list 'var (- -1 idx))
+                                        (error "Variable ~a not in environment" exp))))))
+         (let ((func (car exp)))
+                       (cond
+                         ((equal func 'quote) (process-quoted (cadr exp)))
+                         ((equal func 'lambda) (destructuring-bind (func-name func-args func-body) (cdr exp)
+                                                                         (list 'proc (process-proc func-name func-args func-body env))))
+                         ((equal func 'if) (destructuring-bind (if-cond if-then if-else) (mapcar #'(lambda (exp) (process-toplevel exp env)) (cdr exp)) (list 'if (list 'list if-else if-then) if-cond)))
+                         (t (process-funcall func (cdr exp) env))
+                         ))))
+
+(define-test process-toplevel-quote
+  (assert-equal '(number 5) (process-toplevel '(quote 5) ())))
+
+(define-test process-toplevel-if
+  (assert-equal
+   '(if (list (symbol x) (list (list (list 0) (number 3)) (number 2))) (symbol t))
+   (process-toplevel '(if t '(2 3) 'x) ())))
+
+(define-test process-toplevel-cdr
+  (assert-equal
+   '(call (car nil) (list (list (list 0) (number 2)) (number 1)))
+   (process-toplevel '(car '(1 2)) ())))
+
+(define-test process-toplevel-lambda
+  (assert-equal
+   '(proc (var -2))
+   (process-toplevel '(lambda id (x) x) ())))
+
+(define-test process-toplevel-funcall
+  (assert-equal
+   '(call (more (funcall nil) (proc (var -2))) (number 5))
+   (process-toplevel '((lambda id (x) x) 5) ())))
+
+(define-test process-toplevel-append
+  (assert-equal
+   '(proc (if (list (call (more (cons nil) (call (more (more (funcall nil) (var -1)) (var -2)) (call (cdr nil) (var -3)))) (call (car nil) (var -3))) (var -2)) (call (atom nil) (var -3))))
+   (process-toplevel '(lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y)))) ())
+   ))
+
+(define-test process-toplevel-append-call
+  (assert-equal
+   '(call (more (more (funcall nil) (proc (if (list (call (more (cons nil) (call (more (more (funcall nil) (var -1)) (var -2)) (call (cdr nil) (var -3)))) (call (car nil) (var -3))) (var -2)) (call (atom nil) (var -3))))) (list (list (list (list 0) (symbol f)) (symbol e)) (symbol d))) (list (list (list (list 0) (symbol c)) (symbol b)) (symbol a)))
+   (process-toplevel '((lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y)))) '(a b c) '(d e f)) ())))
+
+; (run-tests)
+
+; read a sexp, process it, print the result
+(prin1 (process-toplevel (read) ()))