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 (defvar *literal-ns* '())
  58
  59 (let ((counter 0))
  60   (defun make-literal (literal)
  61     (cons (format nil "l~d" (incf counter))
  62           (literal-lisp->js literal))))
  63
  64 (defvar *modified-literals* "")
  65 (defun ls-compile-toplevel (sexp &optional env fenv)
  66   (setq *modified-literals* nil)
  67   (let ((code (ls-compile sexp env fenv)))
  68     (format nil "~a" *modified-literals*)
  69     (format nil "~a" code))
  70   (setq *modified-literals* ""))
  71
  72 (defun lookup-variable (symbol env)
  73   (or (ls-lookup symbol env)
  74       (ls-lookup symbol *env*)
  75       (error "Undefined variable `~a'"  symbol)))
  76
  77 (defun lookup-function (symbol env)
  78   (or (ls-lookup symbol env)
  79       (ls-lookup symbol *fenv*)
  80       (error "Undefined function `~a'"  symbol)))
  81
  82 (defmacro define-compilation (name args &body body)
  83   ;; Creates a new primitive `name' with parameters args and
  84   ;; @body. The body can access to the local environment through the
  85   ;; variable ENV.
  86   `(push (list ',name (lambda (env fenv ,@args) ,@body))
  87          *compilations*))
  88
  89 (define-compilation if (condition true false)
  90   (format nil "((~a)? (~a) : (~a))"
  91           (ls-compile condition env fenv)
  92           (ls-compile true env fenv)
  93           (ls-compile false env fenv)))
  94
  95 ;;; Return the required args of a lambda list
  96 (defun lambda-list-required-argument (lambda-list)
  97   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
  98       nil
  99       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
 100
 101 (defun lambda-list-rest-argument (lambda-list)
 102   (second (member '&rest lambda-list)))
 103
 104 (define-compilation lambda (lambda-list &rest body)
 105   (let ((required-arguments (lambda-list-required-argument lambda-list))
 106         (rest-argument (lambda-list-rest-argument lambda-list)))
 107     (let ((new-env (extend-env (cons rest-argument required-arguments) env)))
 108       (concat "(function ("
 109               (join (mapcar (lambda (x) (lookup-variable x new-env))
 110                             required-arguments)
 111                     ",")
 112               "){
 113 "
 114               (if rest-argument
 115                   (concat "var " (lookup-variable rest-argument new-env)
 116                           " = arguments.slice("
 117                           (prin1-to-string (length required-arguments)) ");
 118 ")
 119                   "")
 120
 121               (concat (ls-compile-block (butlast body) new-env fenv)
 122                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 123               "
 124 })"))))
 125
 126 (define-compilation fsetq (var val)
 127   (format nil "~a = ~a" (lookup-function var fenv) (ls-compile val env fenv)))
 128
 129 (define-compilation setq (var val)
 130   (format nil "~a = ~a" (lookup-variable var env) (ls-compile val env fenv)))
 131
 132 (defun literal-lisp->js (sexp)
 133   (cond
 134     ((null sexp) "undefined")
 135     ((integerp sexp) (format nil "~a" sexp))
 136     ((stringp sexp) (format nil "\"~a\"" sexp))
 137     ((listp sexp) (concat "{car: " (literal-lisp->js (car sexp)) ", cdr: "
 138                           (literal-lisp->js (cdr sexp)) "}"))))
 139
 140 (define-compilation quote (sexp)
 141   (let ((literal (make-literal sexp)))
 142     (setq *modified-literals* (cdr sexp))
 143     (format nil "~a" (car literal))))
 144
 145 (define-compilation debug (form)
 146   (format nil "console.log(~a)" (ls-compile form env fenv)))
 147
 148 (define-compilation while (pred &rest body)
 149   (format nil "(function(){while(~a){~a}})() "
 150           (ls-compile pred env fenv)
 151           (ls-compile-block body env fenv)))
 152
 153 (defmacro eval-when-compile (&body body)
 154   `(eval-when (:compile-toplevel :execute)
 155      ,@body))
 156
 157 (defvar *eval-when-compilations*)
 158 (define-compilation eval-when-compile (&rest body)
 159   (setq *eval-when-compilations* "")
 160   (eval (cons 'progn body))
 161   (if (string= *eval-when-compilations* "")
 162       nil
 163       *eval-when-compilations*))
 164
 165 ;;; aritmetic primitives
 166 (define-compilation + (x y)
 167   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 168
 169 (define-compilation - (x y)
 170   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 171
 172 (define-compilation * (x y)
 173   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 174
 175 (define-compilation / (x y)
 176   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 177
 178 (define-compilation = (x y)
 179   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 180
 181 (define-compilation cons (x y)
 182   (concat "(new Cons("y", " x "))"))
 183
 184 (define-compilation car (x)
 185   (concat "(x.car)"))
 186
 187 (define-compilation cdr (x)
 188   (concat "(x.cdr)"))
 189
 190 (defmacro with-eval-when-compilation (&body body)
 191   `(setq *eval-when-compilations*
 192          (concat *eval-when-compilations* (progn ,@body))))
 193
 194 (defun %compile-defvar (name)
 195   (push (make-var-binding name) *env*)
 196   (with-eval-when-compilation
 197     (format nil "var ~a" (lookup-variable name *env*))))
 198
 199 (defun %compile-defun (name)
 200   (push (make-func-binding name) *fenv*)
 201   (with-eval-when-compilation
 202     (format nil "var ~a" (lookup-variable name *fenv*))))
 203
 204 (defun %compile-defmacro (name lambda)
 205   (push (cons name (cons 'macro lambda)) *fenv*))
 206
 207 (defun compile-funcall (name args env fenv)
 208   (format nil "~a(~{~a~^, ~})"
 209           (lookup-function name fenv)
 210           (mapcar (lambda (x) (ls-compile x env fenv)) args)))
 211
 212 (defun ls-macroexpand-1 (form &optional env fenv)
 213   (let ((function (cdr (assoc (car form) *fenv*))))
 214     (if (and (listp function) (eq (car function) 'macro))
 215         (apply (eval (cdr function)) (cdr form))
 216         form)))
 217
 218 (defun ls-compile (sexp &optional env fenv)
 219   (cond
 220     ((symbolp sexp) (lookup-variable sexp env))
 221     ((integerp sexp) (format nil "~a" sexp))
 222     ((stringp sexp) (format nil "\"~a\"" sexp))
 223     ((listp sexp)
 224      (let ((sexp (ls-macroexpand-1 sexp env fenv)))
 225        (let ((compiler-func (second (assoc (car sexp) *compilations*))))
 226          (if compiler-func
 227              (apply compiler-func env fenv (cdr sexp))
 228              (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
 229
 230
 231 (defun ls-compile-file (filename output)
 232   (with-open-file (in filename)
 233     (with-open-file (out output :direction :output :if-exists :supersede)
 234       (loop
 235          for x = (read in nil) while x
 236          for compilation = (ls-compile x)
 237          when compilation do (write-line (concat compilation "; ") out)))))
 238
 239
 240 ;;; Testing
 241
 242 (defun compile-test ()
 243   (ls-compile-file "test.lisp" "test.js"))