]>
Commit | Line | Data |
---|---|---|
c6418cc5 MG |
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) ())) |