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