X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lispstrack.lisp;h=4baeb39e79a2f20564431ff16b8cff19d983d3df;hb=6f8be0359a98a4bb35423dfd88330bb7a6161103;hp=dcd0a6d14e1785877b5b786fab731a01aeb5e43c;hpb=25dc92889efe9b8300193371a8fb3a506510488a;p=jscl.git diff --git a/lispstrack.lisp b/lispstrack.lisp index dcd0a6d..4baeb39 100644 --- a/lispstrack.lisp +++ b/lispstrack.lisp @@ -1,12 +1,104 @@ -(defun ls-compile (sexp) +;;; Utils + +(defmacro while (condition &body body) + `(do () + ((not ,condition)) + ,@body)) + +;;; simplify me, please +(defun concat (&rest strs) + (reduce (lambda (s1 s2) (concatenate 'string s1 s2)) + strs + :initial-value "")) + + +(let ((counter 0)) + (defun make-binding (symbol) + (cons symbol (format nil "V_~d" (incf counter))))) + +;;; Concatenate a list of strings, with a separator +(defun join (list separator) + (cond + ((null list) + "") + ((null (cdr list)) + (car list)) + (t + (concat (car list) + separator + (join (cdr list) separator))))) + + +;;; Compiler + +(defvar *compilations* nil) + +(defun extend-env (args env) + (append (mapcar #'make-binding args) env)) + +(defun ls-lookup (symbol env) + (let ((binding (assoc symbol env))) + (if binding + (format nil "~a" (cdr binding)) + (error "Undefined variable `~a'" symbol)))) + +(defmacro define-compilation (name args &body body) + "creates a new primitive `name' with parameters args and @body. The +body can access to the local environment through the variable env" + `(push (list ',name (lambda (env ,@args) ,@body)) + *compilations*)) + +(define-compilation if (condition true false) + (format nil "((~a)? (~a) : (~a))" + (ls-compile condition env) + (ls-compile true env) + (ls-compile false env))) + +(define-compilation lambda (args &rest body) + (let ((new-env (extend-env args env))) + (concat "(function (" + (join (mapcar (lambda (x) (ls-lookup x new-env)) + args) + ",") + "){ +" + (ls-compile-block body new-env) + " +})"))) + +(define-compilation setq (var val) + (format nil "~a = ~a" (ls-lookup var env) (ls-compile val env))) + +(defun lisp->js (sexp) (cond - ((symbolp sexp) nil) ((integerp sexp) (format nil "~a" sexp)) - ; list - ((case (first sexp) - (if nil) - (lambda nil) - (t nil))))) + ((stringp sexp) (format nil "\"~a\"" sexp)) + ((listp sexp) (concat "[" (join (mapcar 'lisp->js sexp) ",") "]")))) -(defparameter *env-var* '()) +(define-compilation quote (sexp) + (lisp->js sexp)) + +(defparameter *env* '()) (defparameter *env-fun* '()) + +(defun ls-compile (sexp &optional env) + (cond + ((symbolp sexp) (ls-lookup sexp env)) + ((integerp sexp) (format nil "~a" sexp)) + ((stringp sexp) (format nil " \"~a\" " sexp)) + ; list + ((listp sexp) + (let ((compiler-func (second (assoc (car sexp) *compilations*)))) + (if compiler-func + (apply compiler-func env (cdr sexp)) + ;; funcall + ))))) + +(defun ls-compile-block (sexps env) + (concat (join (mapcar (lambda (x) + (ls-compile x env)) + (butlast sexps)) + "; +") + "; +return " (ls-compile (car (last sexps)) env) ";"))