| 1 | (ql:quickload "lisp-unit") |
| 2 | |
| 3 | (defpackage :compiler |
| 4 | (:use :common-lisp :lisp-unit)) |
| 5 | (in-package :compiler) |
| 6 | |
| 7 | (setq *print-failures* t) |
| 8 | |
| 9 | (defvar *primops*) |
| 10 | (setq *primops* '(car cdr cons atom progn reverse-list)) |
| 11 | |
| 12 | (defun process-quoted (exp) |
| 13 | (if (atom exp) |
| 14 | (if exp (if (numberp exp) (list 'number exp) (list 'symbol exp)) '(list 0)) |
| 15 | (list 'list (process-quoted (cdr exp)) (process-quoted (car exp))))) |
| 16 | |
| 17 | (define-test process-quoted |
| 18 | (assert-equal '(number 5) (process-quoted '5)) |
| 19 | (assert-equal '(list 0) (process-quoted '())) |
| 20 | (assert-equal '(symbol foo) (process-quoted 'foo)) |
| 21 | (assert-equal |
| 22 | '(list (list (list 0) (symbol foo)) (number 5)) |
| 23 | (process-quoted '(5 foo))) |
| 24 | (assert-equal |
| 25 | '(list (list 0) (list (list 0) (list (list 0) (number 5)))) |
| 26 | (process-quoted '(((5)))))) |
| 27 | |
| 28 | (defun process-proc (func-name func-args func-body env) |
| 29 | (process-toplevel func-body (append (cons func-name (reverse func-args)) env))) |
| 30 | |
| 31 | (defun rest-of-funcall (func args) |
| 32 | (if (atom args) func (list 'more (rest-of-funcall func (cdr args)) (car args)))) |
| 33 | |
| 34 | (defun process-funcall (func-name func-args env) |
| 35 | (let* ((prim-idx (position func-name *primops*)) |
| 36 | (processed-args (mapcar #'(lambda (exp) (process-toplevel exp env)) func-args))) |
| 37 | (if (numberp prim-idx) |
| 38 | (list 'call (rest-of-funcall (list func-name nil) (cdr processed-args)) (car processed-args)) |
| 39 | (let ((final-args (append processed-args (list (process-toplevel func-name env))))) |
| 40 | (list 'call (rest-of-funcall '(funcall nil) (cdr final-args)) (car final-args)))))) |
| 41 | |
| 42 | (defun process-toplevel (exp env) |
| 43 | (if (atom exp) |
| 44 | (if (numberp exp) |
| 45 | (list 'number exp) |
| 46 | (cond |
| 47 | ((equal exp 't) '(symbol t)) |
| 48 | ((equal exp 'nil) '(list 0)) |
| 49 | (t (let ((idx (position exp env))) |
| 50 | (if (numberp idx) |
| 51 | (list 'var (- -1 idx)) |
| 52 | (error "Variable ~a not in environment" exp)))))) |
| 53 | (let ((func (car exp))) |
| 54 | (cond |
| 55 | ((equal func 'quote) (process-quoted (cadr exp))) |
| 56 | ((equal func 'lambda) (destructuring-bind (func-name func-args func-body) (cdr exp) |
| 57 | (list 'proc (process-proc func-name func-args func-body env)))) |
| 58 | ((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))) |
| 59 | (t (process-funcall func (cdr exp) env)) |
| 60 | )))) |
| 61 | |
| 62 | (define-test process-toplevel-quote |
| 63 | (assert-equal '(number 5) (process-toplevel '(quote 5) ()))) |
| 64 | |
| 65 | (define-test process-toplevel-if |
| 66 | (assert-equal |
| 67 | '(if (list (symbol x) (list (list (list 0) (number 3)) (number 2))) (symbol t)) |
| 68 | (process-toplevel '(if t '(2 3) 'x) ()))) |
| 69 | |
| 70 | (define-test process-toplevel-cdr |
| 71 | (assert-equal |
| 72 | '(call (car nil) (list (list (list 0) (number 2)) (number 1))) |
| 73 | (process-toplevel '(car '(1 2)) ()))) |
| 74 | |
| 75 | (define-test process-toplevel-lambda |
| 76 | (assert-equal |
| 77 | '(proc (var -2)) |
| 78 | (process-toplevel '(lambda id (x) x) ()))) |
| 79 | |
| 80 | (define-test process-toplevel-funcall |
| 81 | (assert-equal |
| 82 | '(call (more (funcall nil) (proc (var -2))) (number 5)) |
| 83 | (process-toplevel '((lambda id (x) x) 5) ()))) |
| 84 | |
| 85 | (define-test process-toplevel-append |
| 86 | (assert-equal |
| 87 | '(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)))) |
| 88 | (process-toplevel '(lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y)))) ()) |
| 89 | )) |
| 90 | |
| 91 | (define-test process-toplevel-append-call |
| 92 | (assert-equal |
| 93 | '(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))) |
| 94 | (process-toplevel '((lambda append (x y) (if (atom x) y (cons (car x) (append (cdr x) y)))) '(a b c) '(d e f)) ()))) |
| 95 | |
| 96 | ; (run-tests) |
| 97 | |
| 98 | ; read a sexp, process it, print the result |
| 99 | (prin1 (process-toplevel (read) ())) |