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 ;;; Concatenate a list of strings, with a separator
  20 (defun join (list separator)
  21   (cond
  22     ((null list)
  23      "")
  24     ((null (cdr list))
  25      (car list))
  26     (t
  27      (concat (car list)
  28              separator
  29              (join (cdr list) separator)))))
  30
  31
  32 ;;; Compiler
  33
  34 (defvar *compilations* nil)
  35
  36 (defun extend-env (args env)
  37   (append (mapcar #'make-binding args) env))
  38
  39 (defun ls-lookup (symbol env)
  40   (let ((binding (assoc symbol env)))
  41     (if binding
  42         (format nil "~a" (cdr binding))
  43         (error "Undefined variable `~a'"  symbol))))
  44
  45 (defmacro define-compilation (name args &body body)
  46   "creates a new primitive `name' with parameters args and @body. The
  47 body can access to the local environment through the variable env"
  48   `(push (list ',name (lambda (env ,@args) ,@body))
  49          *compilations*))
  50
  51 (define-compilation if (condition true false)
  52   (format nil "((~a)? (~a) : (~a))"
  53           (ls-compile condition env)
  54           (ls-compile true env)
  55           (ls-compile false env)))
  56
  57 (define-compilation lambda (args &rest body)
  58   (let ((new-env (extend-env args env)))
  59     (concat "(function ("
  60             (join (mapcar (lambda (x) (ls-lookup x new-env))
  61                           args)
  62                   ",")
  63             "){
  64 "
  65             (ls-compile-block body new-env)
  66             "
  67 })")))
  68
  69 (define-compilation setq (var val)
  70   (format nil "~a = ~a" (ls-lookup var env) (ls-compile val env)))
  71
  72 (defun lisp->js (sexp)
  73   (cond
  74     ((integerp sexp) (format nil "~a" sexp))
  75     ((stringp sexp) (format nil "\"~a\"" sexp))
  76     ((listp sexp)   (concat "[" (join (mapcar 'lisp->js sexp) ",") "]"))))
  77
  78 (define-compilation quote (sexp)
  79   (lisp->js sexp))
  80
  81 (defparameter *env* '())
  82 (defparameter *env-fun* '())
  83
  84 (defun ls-compile (sexp &optional env)
  85   (cond
  86     ((symbolp sexp) (ls-lookup sexp env))
  87     ((integerp sexp) (format nil "~a" sexp))
  88     ((stringp sexp) (format nil " \"~a\" " sexp))
  89                                         ; list
  90     ((listp sexp)
  91      (let ((compiler-func (second (assoc (car sexp) *compilations*))))
  92        (if compiler-func
  93            (apply compiler-func env (cdr sexp))
  94            ;; funcall
  95            )))))
  96
  97 (defun ls-compile-block (sexps env)
  98   (concat (join (mapcar (lambda (x)
  99                           (ls-compile x env))
 100                         (butlast sexps))
 101                 ";
 102 ")
 103           ";
 104 return " (ls-compile (car (last sexps)) env) ";"))