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-var-binding (symbol)
  17     (cons symbol (format nil "v~d" (incf counter)))))
  18
  19 (let ((counter 0))
  20   (defun make-func-binding (symbol)
  21     (cons symbol (format nil "f~d" (incf counter)))))
  22
  23
  24 ;;; Concatenate a list of strings, with a separator
  25 (defun join (list separator)
  26   (cond
  27     ((null list)
  28      "")
  29     ((null (cdr list))
  30      (car list))
  31     (t
  32      (concat (car list)
  33              separator
  34              (join (cdr list) separator)))))
  35
  36 ;;; Compiler
  37
  38 (defvar *compilations* nil)
  39
  40 (defun ls-compile-block (sexps env fenv)
  41   (concat (join (mapcar (lambda (x)
  42                           (concat (ls-compile x env fenv) ";"))
  43                         sexps)
  44                 ";
  45 ")))
  46
  47 (defun extend-env (args env)
  48   (append (mapcar #'make-var-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 fenv ,@args) ,@body))
  72          *compilations*))
  73
  74 (define-compilation if (condition true false)
  75   (format nil "((~a)? (~a) : (~a))"
  76           (ls-compile condition env fenv)
  77           (ls-compile true env fenv)
  78           (ls-compile false env fenv)))
  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             (concat (ls-compile-block (butlast body) new-env fenv)
  89                     "return " (ls-compile (car (last body)) new-env fenv) ";")
  90             "
  91 })")))
  92
  93 (define-compilation fsetq (var val)
  94   (format nil "~a = ~a" (lookup-function var fenv) (ls-compile val env fenv)))
  95
  96 (define-compilation setq (var val)
  97   (format nil "~a = ~a" (lookup-variable var env) (ls-compile val env fenv)))
  98
  99 (defun lisp->js (sexp)
 100   (cond
 101     ((integerp sexp) (format nil "~a" sexp))
 102     ((stringp sexp) (format nil "\"~a\"" sexp))
 103     ((listp sexp)   (concat "[" (join (mapcar 'lisp->js sexp) ",") "]"))))
 104
 105 (define-compilation quote (sexp)
 106   (lisp->js sexp))
 107
 108 (define-compilation debug (form)
 109   (format nil "console.log(~a)" (ls-compile form env fenv)))
 110
 111 (define-compilation while (pred &rest body)
 112   (format nil "(function(){while(~a){~a}})() "
 113           (ls-compile pred env fenv)
 114           (ls-compile-block body env fenv)))
 115
 116 (defmacro eval-when-compile (&body body)
 117   `(eval-when (:compile-toplevel :execute)
 118      ,@body))
 119
 120 (defvar *eval-when-compilations*)
 121 (define-compilation eval-when-compile (&rest body)
 122   (setq *eval-when-compilations* "")
 123   (eval (cons 'progn body))
 124   (if (string= *eval-when-compilations* "")
 125       nil
 126       *eval-when-compilations*))
 127
 128 ;;; aritmetic primitives
 129 (define-compilation + (x y)
 130   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 131
 132 (define-compilation - (x y)
 133   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 134
 135 (define-compilation * (x y)
 136   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 137
 138 (define-compilation / (x y)
 139   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 140
 141 (define-compilation = (x y)
 142   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 143
 144
 145 (defmacro with-eval-when-compilation (&body body)
 146   `(setq *eval-when-compilations*
 147          (concat *eval-when-compilations* (progn ,@body))))
 148
 149 (defun %compile-defvar (name)
 150   (push (make-var-binding name) *env*)
 151   (with-eval-when-compilation
 152     (format nil "var ~a" (lookup-variable name *env*))))
 153
 154 (defun %compile-defun (name)
 155   (push (make-func-binding name) *fenv*)
 156   (with-eval-when-compilation
 157     (format nil "var ~a" (lookup-variable name *fenv*))))
 158
 159 (defun %compile-defmacro (name lambda)
 160   (push (cons name (cons 'macro lambda)) *fenv*))
 161
 162 (defun compile-funcall (name args env fenv)
 163   (format nil "~a(~{~a~^, ~})"
 164           (lookup-function name fenv)
 165           (mapcar (lambda (x) (ls-compile x env fenv)) args)))
 166
 167 (defun ls-macroexpand-1 (form &optional env fenv)
 168   (let ((function (cdr (assoc (car form) *fenv*))))
 169     (if (and (listp function) (eq (car function) 'macro))
 170         (apply (eval (cdr function)) (cdr form))
 171         form)))
 172
 173 (defun ls-compile (sexp &optional env fenv)
 174   (cond
 175     ((symbolp sexp) (lookup-variable sexp env))
 176     ((integerp sexp) (format nil "~a" sexp))
 177     ((stringp sexp) (format nil "\"~a\"" sexp))
 178     ((listp sexp)
 179      (let ((sexp (ls-macroexpand-1 sexp env fenv)))
 180        (let ((compiler-func (second (assoc (car sexp) *compilations*))))
 181          (if compiler-func
 182              (apply compiler-func env fenv (cdr sexp))
 183              (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
 184
 185
 186 (defun ls-compile-file (filename output)
 187   (with-open-file (in filename)
 188     (with-open-file (out output :direction :output :if-exists :supersede)
 189       (loop
 190          for x = (read in nil) while x
 191          for compilation = (ls-compile x)
 192          when compilation do (write-line (concat compilation "; ") out)))))
 193
 194
 195 ;;; Testing
 196
 197 (defun compile-test ()
 198   (ls-compile-file "test.lisp" "test.js"))