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 ;;; Return the required args of a lambda list
  81 (defun lambda-list-required-argument (lambda-list)
  82   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
  83       nil
  84       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
  85
  86 (defun lambda-list-rest-argument (lambda-list)
  87   (second (member '&rest lambda-list)))
  88
  89 (define-compilation lambda (lambda-list &rest body)
  90   (let ((required-arguments (lambda-list-required-argument lambda-list))
  91         (rest-argument (lambda-list-rest-argument lambda-list)))
  92     (let ((new-env (extend-env (cons rest-argument required-arguments) env)))
  93       (concat "(function ("
  94               (join (mapcar (lambda (x) (lookup-variable x new-env))
  95                             required-arguments)
  96                     ",")
  97               "){
  98 "
  99               (if rest-argument
 100                   (concat "var " (lookup-variable rest-argument new-env)
 101                           " = arguments.slice("
 102                           (prin1-to-string (length required-arguments)) ");
 103 ")
 104                   "")
 105
 106               (concat (ls-compile-block (butlast body) new-env fenv)
 107                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 108               "
 109 })"))))
 110
 111 (define-compilation fsetq (var val)
 112   (format nil "~a = ~a" (lookup-function var fenv) (ls-compile val env fenv)))
 113
 114 (define-compilation setq (var val)
 115   (format nil "~a = ~a" (lookup-variable var env) (ls-compile val env fenv)))
 116
 117 (defun lisp->js (sexp)
 118   (cond
 119     ((integerp sexp) (format nil "~a" sexp))
 120     ((stringp sexp) (format nil "\"~a\"" sexp))
 121     ((listp sexp)   (concat "[" (join (mapcar 'lisp->js sexp) ",") "]"))))
 122
 123 (define-compilation quote (sexp)
 124   (lisp->js sexp))
 125
 126 (define-compilation debug (form)
 127   (format nil "console.log(~a)" (ls-compile form env fenv)))
 128
 129 (define-compilation while (pred &rest body)
 130   (format nil "(function(){while(~a){~a}})() "
 131           (ls-compile pred env fenv)
 132           (ls-compile-block body env fenv)))
 133
 134 (defmacro eval-when-compile (&body body)
 135   `(eval-when (:compile-toplevel :execute)
 136      ,@body))
 137
 138 (defvar *eval-when-compilations*)
 139 (define-compilation eval-when-compile (&rest body)
 140   (setq *eval-when-compilations* "")
 141   (eval (cons 'progn body))
 142   (if (string= *eval-when-compilations* "")
 143       nil
 144       *eval-when-compilations*))
 145
 146 ;;; aritmetic primitives
 147 (define-compilation + (x y)
 148   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 149
 150 (define-compilation - (x y)
 151   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 152
 153 (define-compilation * (x y)
 154   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 155
 156 (define-compilation / (x y)
 157   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 158
 159 (define-compilation = (x y)
 160   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 161
 162
 163 (defmacro with-eval-when-compilation (&body body)
 164   `(setq *eval-when-compilations*
 165          (concat *eval-when-compilations* (progn ,@body))))
 166
 167 (defun %compile-defvar (name)
 168   (push (make-var-binding name) *env*)
 169   (with-eval-when-compilation
 170     (format nil "var ~a" (lookup-variable name *env*))))
 171
 172 (defun %compile-defun (name)
 173   (push (make-func-binding name) *fenv*)
 174   (with-eval-when-compilation
 175     (format nil "var ~a" (lookup-variable name *fenv*))))
 176
 177 (defun %compile-defmacro (name lambda)
 178   (push (cons name (cons 'macro lambda)) *fenv*))
 179
 180 (defun compile-funcall (name args env fenv)
 181   (format nil "~a(~{~a~^, ~})"
 182           (lookup-function name fenv)
 183           (mapcar (lambda (x) (ls-compile x env fenv)) args)))
 184
 185 (defun ls-macroexpand-1 (form &optional env fenv)
 186   (let ((function (cdr (assoc (car form) *fenv*))))
 187     (if (and (listp function) (eq (car function) 'macro))
 188         (apply (eval (cdr function)) (cdr form))
 189         form)))
 190
 191 (defun ls-compile (sexp &optional env fenv)
 192   (cond
 193     ((symbolp sexp) (lookup-variable sexp env))
 194     ((integerp sexp) (format nil "~a" sexp))
 195     ((stringp sexp) (format nil "\"~a\"" sexp))
 196     ((listp sexp)
 197      (let ((sexp (ls-macroexpand-1 sexp env fenv)))
 198        (let ((compiler-func (second (assoc (car sexp) *compilations*))))
 199          (if compiler-func
 200              (apply compiler-func env fenv (cdr sexp))
 201              (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
 202
 203
 204 (defun ls-compile-file (filename output)
 205   (with-open-file (in filename)
 206     (with-open-file (out output :direction :output :if-exists :supersede)
 207       (loop
 208          for x = (read in nil) while x
 209          for compilation = (ls-compile x)
 210          when compilation do (write-line (concat compilation "; ") out)))))
 211
 212
 213 ;;; Testing
 214
 215 (defun compile-test ()
 216   (ls-compile-file "test.lisp" "test.js"))