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-binding (symbol)
  17     (cons symbol (format nil "V_~d" (incf counter)))))
  18
  19 ;;; Concatenate a list of strings, with a separator
  20 (defun join (list separator)
  21   (cond
  22     ((null list)
  23      "")
  24     ((null (cdr list))
  25      (car list))
  26     (t
  27      (concat (car list)
  28              separator
  29              (join (cdr list) separator)))))
  30
  31 ;;; Compiler
  32
  33 (defvar *compilations* nil)
  34
  35 (defun ls-compile-sexps (sexps env)
  36   (concat (join (mapcar (lambda (x)
  37                           (concat (ls-compile x env) ";"))
  38                         sexps)
  39                 ";
  40 ")))
  41
  42 (defun ls-compile-block (sexps env)
  43   (concat (ls-compile-sexps (butlast sexps) env)
  44           "return " (ls-compile (car (last sexps)) env) ";"))
  45
  46
  47 (defun extend-env (args env)
  48   (append (mapcar #'make-binding args) env))
  49
  50 (defun ls-lookup (symbol env)
  51   (let ((binding (assoc symbol env)))
  52     (if binding
  53         (format nil "~a" (cdr binding))
  54         (error "Undefined variable `~a'"  symbol))))
  55
  56 (defmacro define-compilation (name args &body body)
  57   ;; Creates a new primitive `name' with parameters args and
  58   ;; @body. The body can access to the local environment through the
  59   ;; variable ENV.
  60   `(push (list ',name (lambda (env ,@args) ,@body))
  61          *compilations*))
  62
  63 (define-compilation if (condition true false)
  64   (format nil "((~a)? (~a) : (~a))"
  65           (ls-compile condition env)
  66           (ls-compile true env)
  67           (ls-compile false env)))
  68
  69 (define-compilation lambda (args &rest body)
  70   (let ((new-env (extend-env args env)))
  71     (concat "(function ("
  72             (join (mapcar (lambda (x) (ls-lookup x new-env))
  73                           args)
  74                   ",")
  75             "){
  76 "
  77             (ls-compile-block body new-env)
  78             "
  79 })")))
  80
  81 (define-compilation setq (var val)
  82   (format nil "~a = ~a" (ls-lookup var env) (ls-compile val env)))
  83
  84 (defun lisp->js (sexp)
  85   (cond
  86     ((integerp sexp) (format nil "~a" sexp))
  87     ((stringp sexp) (format nil "\"~a\"" sexp))
  88     ((listp sexp)   (concat "[" (join (mapcar 'lisp->js sexp) ",") "]"))))
  89
  90 (define-compilation quote (sexp)
  91   (lisp->js sexp))
  92
  93 (define-compilation debug (form)
  94   (format nil "console.log(~a)" (ls-compile form env)))
  95
  96 (define-compilation while (pred &rest body)
  97   (format nil "(function(){while(~a){~a}})() "
  98           (ls-compile pred env)
  99           (ls-compile-sexps body env)))
 100
 101 (defmacro eval-when-compile (&body body)
 102   `(eval-when (:compile-toplevel :execute)
 103      ,@body))
 104
 105 (define-compilation eval-when-compile (when &rest body)
 106   (eval body))
 107
 108 ;;; aritmetic primitives
 109 (define-compilation + (x y)
 110   (concat "((" (ls-compile x env) ") + (" (ls-compile y env) "))"))
 111
 112 (define-compilation - (x y)
 113   (concat "((" (ls-compile x env) ") - (" (ls-compile y env) "))"))
 114
 115 (define-compilation * (x y)
 116   (concat "((" (ls-compile x env) ") * (" (ls-compile y env) "))"))
 117
 118 (define-compilation / (x y)
 119   (concat "((" (ls-compile x env) ") / (" (ls-compile y env) "))"))
 120
 121 (define-compilation = (x y)
 122   (concat "((" (ls-compile x env) ") == (" (ls-compile y env) "))"))
 123
 124
 125 (defparameter *env* '())
 126 (defparameter *env-fun* '())
 127
 128 (defun ls-compile (sexp &optional env)
 129   (cond
 130     ((symbolp sexp) (ls-lookup sexp env))
 131     ((integerp sexp) (format nil "~a" sexp))
 132     ((stringp sexp) (format nil " \"~a\" " sexp))
 133     ((listp sexp)
 134      (let ((compiler-func (second (assoc (car sexp) *compilations*))))
 135        (if compiler-func
 136            (apply compiler-func env (cdr sexp))
 137            (funcall (ls-compile (car sexp) env)  )
 138            ;; funcall
 139            )))))
 140
 141
 142 ;;; Testing
 143
 144 (defun compile-test ()
 145   (with-open-file (in "test.lisp")
 146     (with-open-file (out "test.js" :direction :output :if-exists :supersede)
 147       (loop
 148          for x = (read in nil) while x
 149          do (write-string (concat (ls-compile x) "; ") out)))))