compiler.l

   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) ()))