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 ;;; Compiler
  32
  33 (defvar *compilations* nil)
  34
  35 (defun ls-compile-sexps (sexps env)
  36   (concat (join (mapcar (lambda (x)
  37                           (concat (ls-compile x env) ";"))
  38                         sexps)
  39                 ";
  40 ")))
  41
  42 (defun ls-compile-block (sexps env)
  43   (concat (ls-compile-sexps (butlast sexps) env)
  44           "return " (ls-compile (car (last sexps)) env) ";"))
  45
  46
  47 (defun extend-env (args env)
  48   (append (mapcar #'make-binding args) env))
  49
  50 (defparameter *env* '())
  51 (defparameter *fenv* '())
  52
  53 (defun ls-lookup (symbol env)
  54   (let ((binding (assoc symbol env)))
  55     (and binding (format nil "~a" (cdr binding)))))
  56
  57 (defun lookup-variable (symbol env)
  58   (or (ls-lookup symbol env)
  59       (ls-lookup symbol *env*)
  60       (error "Undefined variable `~a'"  symbol)))
  61
  62 (defun lookup-function (symbol env)
  63   (or (ls-lookup symbol env)
  64       (ls-lookup symbol *fenv*)
  65       (error "Undefined function `~a'"  symbol)))
  66
  67 (defmacro define-compilation (name args &body body)
  68   ;; Creates a new primitive `name' with parameters args and
  69   ;; @body. The body can access to the local environment through the
  70   ;; variable ENV.
  71   `(push (list ',name (lambda (env ,@args) ,@body))
  72          *compilations*))
  73
  74 (define-compilation if (condition true false)
  75   (format nil "((~a)? (~a) : (~a))"
  76           (ls-compile condition env)
  77           (ls-compile true env)
  78           (ls-compile false env)))
  79
  80 (define-compilation lambda (args &rest body)
  81   (let ((new-env (extend-env args env)))
  82     (concat "(function ("
  83             (join (mapcar (lambda (x) (lookup-variable x new-env))
  84                           args)
  85                   ",")
  86             "){
  87 "
  88             (ls-compile-block body new-env)
  89             "
  90 })")))
  91
  92 (define-compilation setq (var val)
  93   (format nil "~a = ~a" (lookup-variable var env) (ls-compile val env)))
  94
  95 (defun lisp->js (sexp)
  96   (cond
  97     ((integerp sexp) (format nil "~a" sexp))
  98     ((stringp sexp) (format nil "\"~a\"" sexp))
  99     ((listp sexp)   (concat "[" (join (mapcar 'lisp->js sexp) ",") "]"))))
 100
 101 (define-compilation quote (sexp)
 102   (lisp->js sexp))
 103
 104 (define-compilation debug (form)
 105   (format nil "console.log(~a)" (ls-compile form env)))
 106
 107 (define-compilation while (pred &rest body)
 108   (format nil "(function(){while(~a){~a}})() "
 109           (ls-compile pred env)
 110           (ls-compile-sexps body env)))
 111
 112 (defmacro eval-when-compile (&body body)
 113   `(eval-when (:compile-toplevel :execute)
 114      ,@body))
 115
 116 (define-compilation eval-when-compile (&rest body)
 117   (eval (cons 'progn body)))
 118
 119 ;;; aritmetic primitives
 120 (define-compilation + (x y)
 121   (concat "((" (ls-compile x env) ") + (" (ls-compile y env) "))"))
 122
 123 (define-compilation - (x y)
 124   (concat "((" (ls-compile x env) ") - (" (ls-compile y env) "))"))
 125
 126 (define-compilation * (x y)
 127   (concat "((" (ls-compile x env) ") * (" (ls-compile y env) "))"))
 128
 129 (define-compilation / (x y)
 130   (concat "((" (ls-compile x env) ") / (" (ls-compile y env) "))"))
 131
 132 (define-compilation = (x y)
 133   (concat "((" (ls-compile x env) ") == (" (ls-compile y env) "))"))
 134
 135
 136 (defun %compile-defvar (name)
 137   (push (make-binding name) *env*)
 138   (format nil "var ~a" (lookup-variable name *env*)))
 139
 140 (defun ls-compile (sexp &optional env)
 141   (cond
 142     ((symbolp sexp) (lookup-variable sexp env))
 143     ((integerp sexp) (format nil "~a" sexp))
 144     ((stringp sexp) (format nil "\"~a\"" sexp))
 145     ((listp sexp)
 146      (let ((compiler-func (second (assoc (car sexp) *compilations*))))
 147        (if compiler-func
 148            (apply compiler-func env (cdr sexp))
 149            (funcall (ls-compile (car sexp) env)  )
 150            ;; funcall
 151            )))))
 152
 153
 154 ;;; Testing
 155
 156 (defun compile-test ()
 157   (with-open-file (in "test.lisp")
 158     (with-open-file (out "test.js" :direction :output :if-exists :supersede)
 159       (loop
 160          for x = (read in nil) while x
 161          do (write-line (concat (ls-compile x) "; ") out)))))