1 (ql:quickload "lisp-unit")
4 (:use :common-lisp :lisp-unit))
7 (setq *print-failures* t)
10 (setq *primops* '(car cdr cons atom progn reverse-list))
12 (defun process-quoted (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)))))
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))
22 '(list (list (list 0) (symbol foo)) (number 5))
23 (process-quoted '(5 foo)))
25 '(list (list 0) (list (list 0) (list (list 0) (number 5))))
26 (process-quoted '(((5))))))
28 (defun process-proc (func-name func-args func-body env)
29 (process-toplevel func-body (append (cons func-name (reverse func-args)) env)))
31 (defun rest-of-funcall (func args)
32 (if (atom args) func (list 'more (rest-of-funcall func (cdr args)) (car args))))
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))))))
42 (defun process-toplevel (exp env)
47 ((equal exp 't) '(symbol t))
48 ((equal exp 'nil) '(list 0))
49 (t (let ((idx (position exp env)))
51 (list 'var (- -1 idx))
52 (error "Variable ~a not in environment" exp))))))
53 (let ((func (car exp)))
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))
62 (define-test process-toplevel-quote
63 (assert-equal '(number 5) (process-toplevel '(quote 5) ())))
65 (define-test process-toplevel-if
67 '(if (list (symbol x) (list (list (list 0) (number 3)) (number 2))) (symbol t))
68 (process-toplevel '(if t '(2 3) 'x) ())))
70 (define-test process-toplevel-cdr
72 '(call (car nil) (list (list (list 0) (number 2)) (number 1)))
73 (process-toplevel '(car '(1 2)) ())))
75 (define-test process-toplevel-lambda
78 (process-toplevel '(lambda id (x) x) ())))
80 (define-test process-toplevel-funcall
82 '(call (more (funcall nil) (proc (var -2))) (number 5))
83 (process-toplevel '((lambda id (x) x) 5) ())))
85 (define-test process-toplevel-append
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)))) ())
91 (define-test process-toplevel-append-call
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)) ())))
98 ; read a sexp, process it, print the result
99 (prin1 (process-toplevel (read) ()))