lispstrack.lisp

   1 ;;; Utils
   2
   3 (defmacro while (condition &body body)
   4   `(do ()
   5        ((not ,condition))
   6      ,@body))
   7
   8 ;;; simplify me, please
   9 (defun concat (&rest strs)
  10   (reduce (lambda (s1 s2) (concatenate 'string s1 s2))
  11           strs
  12           :initial-value ""))
  13
  14
  15 (let ((counter 0))
  16   (defun make-binding (symbol)
  17     (cons symbol (format nil "V_~d" (incf counter)))))
  18
  19 ;;; Compiler
  20
  21 (defvar *compilations* nil)
  22
  23 (defun extend-env (args env)
  24   (append (mapcar #'make-binding args) env))
  25
  26 (defun ls-lookup (symbol env)
  27   (let ((binding (assoc symbol env)))
  28     (if binding
  29         (format nil "~a" (cdr binding))
  30         (error "Undefined variable `~a'"  symbol))))
  31
  32 (defmacro define-compilation (name args &body body)
  33   "creates a new primitive `name' with parameters args and @body. The
  34 body can access to the local environment through the variable env"
  35   `(push (list ',name (lambda (env ,@args) ,@body))
  36          *compilations*))
  37
  38 (define-compilation if (condition true false)
  39   (format nil "((~a)? (~a) : (~a))"
  40           (ls-compile condition env)
  41           (ls-compile true env)
  42           (ls-compile false env)))
  43
  44 (define-compilation lambda (args &rest body)
  45   (let ((new-env (extend-env args env)))
  46     (concat "(function ("
  47             (format nil "~{~a~^, ~}" (mapcar
  48                                       (lambda (x) (ls-lookup x new-env))
  49                                       args))
  50             "){ "
  51             (ls-compile-block body new-env)
  52             "})
  53 ")))
  54
  55 (define-compilation setq (var val)
  56   (format nil "~a = ~a" (ls-lookup var env) (ls-compile val env)))
  57
  58 (define-compilation quote (sexp)
  59   (cond
  60     ((integerp sexp) (format nil "~a" sexp))
  61     ((stringp sexp) (format nil "\"~a\"" sexp))
  62     ((listp sexp)   (format nil "[~{~a~^, ~}]" sexp))))
  63
  64 (defparameter *env* '())
  65 (defparameter *env-fun* '())
  66
  67 (defun ls-compile (sexp &optional env)
  68   (cond
  69     ((symbolp sexp) (ls-lookup sexp env))
  70     ((integerp sexp) (format nil "~a" sexp))
  71     ((stringp sexp) (format nil " \"~a\" " sexp))
  72                                         ; list
  73     ((listp sexp)
  74      (let ((compiler-func (second (assoc (car sexp) *compilations*))))
  75        (if compiler-func
  76            (apply compiler-func env (cdr sexp))
  77            ;; funcall
  78            )))))
  79
  80 (defun ls-compile-block (sexps env)
  81   (format nil
  82     "~{~#[~; return ~a;~:;~a;~%~]~}"
  83     (mapcar #'(lambda (x)
  84                       (ls-compile x env))
  85                   sexps)))