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
 118 ;;; Literals
 119
 120 (defvar *literals* '())
 121
 122 (defun literal->js (sexp)
 123   (cond
 124     ((null sexp) "undefined")
 125     ((integerp sexp) (format nil "~a" sexp))
 126     ((stringp sexp) (format nil "\"~a\"" sexp))
 127     ((symbolp sexp) (format nil "{name: \"~a\"}" (symbol-name sexp)))
 128     ((consp sexp) (concat "{car: "
 129                           (literal->js (car sexp))
 130                           ", cdr: "
 131                           (literal->js (cdr sexp)) "}"))))
 132
 133 (let ((counter 0))
 134   (defun literal (form)
 135     (let ((var (format nil "l~d" (incf counter))))
 136       (push (cons var (literal->js form)) *literals*)
 137       var)))
 138
 139 (define-compilation quote (sexp)
 140   (literal sexp))
 141
 142 (define-compilation debug (form)
 143   (format nil "console.log(~a)" (ls-compile form env fenv)))
 144
 145 (define-compilation while (pred &rest body)
 146   (format nil "(function(){while(~a){~a}})() "
 147           (ls-compile pred env fenv)
 148           (ls-compile-block body env fenv)))
 149
 150 (defmacro eval-when-compile (&body body)
 151   `(eval-when (:compile-toplevel :execute)
 152      ,@body))
 153
 154 (defvar *eval-when-compilations*)
 155 (define-compilation eval-when-compile (&rest body)
 156   (setq *eval-when-compilations* "")
 157   (eval (cons 'progn body))
 158   (if (string= *eval-when-compilations* "")
 159       nil
 160       *eval-when-compilations*))
 161
 162
 163 (defmacro define-transformation (name args form)
 164   `(define-compilation ,name ,args
 165      (ls-compile ,form env fenv)))
 166
 167 (define-transformation progn (&rest body)
 168   `((lambda () ,@body)))
 169
 170 (define-transformation let (bindings &rest body)
 171   `((lambda ,(mapcar 'car bindings) ,@body)
 172     ,@(mapcar 'cadr bindings)))
 173
 174 ;;; aritmetic primitives
 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 * (x y)
 182   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 183
 184 (define-compilation / (x y)
 185   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 186
 187 (define-compilation = (x y)
 188   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 189
 190 (define-compilation cons (x y)
 191   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
 192
 193 (define-compilation car (x)
 194   (concat "(" (ls-compile x env fenv) ").car"))
 195
 196 (define-compilation cdr (x)
 197   (concat "(" (ls-compile x env fenv) ").cdr"))
 198
 199 (define-compilation symbol-name (x)
 200   (concat "(" (ls-compile x env fenv) ").name"))
 201
 202 (define-compilation eq (x y)
 203   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
 204
 205
 206
 207 (defmacro with-eval-when-compilation (&body body)
 208   `(setq *eval-when-compilations*
 209          (concat *eval-when-compilations* (progn ,@body))))
 210
 211 (defun %compile-defvar (name)
 212   (push (make-var-binding name) *env*)
 213   (with-eval-when-compilation
 214     (format nil "var ~a" (lookup-variable name *env*))))
 215
 216 (defun %compile-defun (name)
 217   (push (make-func-binding name) *fenv*)
 218   (with-eval-when-compilation
 219     (format nil "var ~a" (lookup-variable name *fenv*))))
 220
 221 (defun %compile-defmacro (name lambda)
 222   (push (cons name (cons 'macro lambda)) *fenv*))
 223
 224 (defun ls-macroexpand-1 (form &optional env fenv)
 225   (let ((function (cdr (assoc (car form) *fenv*))))
 226     (if (and (listp function) (eq (car function) 'macro))
 227         (apply (eval (cdr function)) (cdr form))
 228         form)))
 229
 230 (defun compile-funcall (function args env fenv)
 231   (cond
 232     ((symbolp function)
 233      (format nil "~a(~{~a~^, ~})"
 234              (lookup-function function fenv)
 235              (mapcar (lambda (x) (ls-compile x env fenv)) args)))
 236     ((and (listp function) (eq (car function) 'lambda))
 237      (format nil "(~a)(~{~a~^, ~})"
 238              (ls-compile function env fenv)
 239              (mapcar (lambda (x) (ls-compile x env fenv)) args)))
 240     (t
 241      (error "Invalid function designator ~a." function))))
 242
 243 (defun ls-compile (sexp &optional env fenv)
 244   (cond
 245     ((symbolp sexp) (lookup-variable sexp env))
 246     ((integerp sexp) (format nil "~a" sexp))
 247     ((stringp sexp) (format nil "\"~a\"" sexp))
 248     ((listp sexp)
 249      (let ((sexp (ls-macroexpand-1 sexp env fenv)))
 250        (let ((compiler-func (second (assoc (car sexp) *compilations*))))
 251          (if compiler-func
 252              (apply compiler-func env fenv (cdr sexp))
 253              (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
 254
 255 (defun ls-compile-toplevel (sexp)
 256   (setq *literals* nil)
 257   (let ((code (ls-compile sexp)))
 258     (prog1
 259         (concat (join (mapcar (lambda (lit)
 260                                 (concat "var " (car lit) " = " (cdr lit) ";
 261 "))
 262                               *literals*)
 263                       "")
 264                 code)
 265       (setq *literals* nil))))
 266
 267
 268 (defun ls-compile-file (filename output)
 269   (with-open-file (in filename)
 270     (with-open-file (out output :direction :output :if-exists :supersede)
 271       (loop
 272          for x = (read in nil) while x
 273          for compilation = (ls-compile-toplevel x)
 274          when compilation do (write-line (concat compilation "; ") out)))))
 275
 276
 277 ;;; Testing
 278
 279 (defun compile-test ()
 280   (ls-compile-file "test.lisp" "test.js"))