X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=lispstrack.lisp;h=3da80587bd0e71a304c864618654b768362f13e9;hb=cb758983d9f583b913a6cf925a036f1f0e22c902;hp=387f38809eae4a876872a8f8adac1aee80a2cd9b;hpb=8bce67f493249b5dbcb314fba9b41801d061203a;p=jscl.git diff --git a/lispstrack.lisp b/lispstrack.lisp index 387f388..3da8058 100644 --- a/lispstrack.lisp +++ b/lispstrack.lisp @@ -178,6 +178,7 @@ (read-until stream #'terminalp)))) (cond ((string= cname "space") (char-code #\space)) + ((string= cname "tab") (char-code #\tab)) ((string= cname "newline") (char-code #\newline)) (t (char-code (char cname 0)))))) (#\+ @@ -298,7 +299,7 @@ (define-compilation if (condition true false) (concat "(" - (ls-compile condition env fenv) + (ls-compile condition env fenv) " !== " (ls-compile nil nil nil) " ? " (ls-compile true env fenv) " : " @@ -330,7 +331,7 @@ *newline* (if rest-argument (let ((js!rest (lookup-variable-translation rest-argument new-env))) - (concat "var " js!rest ";" *newline* + (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline* "for (var i = arguments.length-1; i>=" (integer-to-string (length required-arguments)) "; i--)" *newline* @@ -372,10 +373,9 @@ (defun literal->js (sexp) (cond - ((null sexp) "false") ((integerp sexp) (integer-to-string sexp)) ((stringp sexp) (concat "\"" (escape-string sexp) "\"")) - ((symbolp sexp) (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")) + ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*)) ((consp sexp) (concat "{car: " (literal->js (car sexp)) ", cdr: " @@ -383,11 +383,9 @@ (let ((counter 0)) (defun literal (form) - (if (null form) - (literal->js form) - (let ((var (concat "l" (integer-to-string (incf counter))))) - (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*) - var)))) + (let ((var (concat "l" (integer-to-string (incf counter))))) + (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*) + var))) (define-compilation quote (sexp) (literal sexp)) @@ -397,7 +395,7 @@ (define-compilation while (pred &rest body) (concat "(function(){ while(" - (ls-compile pred env fenv) + (ls-compile pred env fenv) " !== " (ls-compile nil nil nil) "){" (ls-compile-block body env fenv) "}})()")) @@ -410,7 +408,7 @@ (lookup-function-translation x fenv)))) #+common-lisp -(defmacro eval-when-compile (&body body) +c(defmacro eval-when-compile (&body body) `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)) @@ -467,6 +465,9 @@ ;;; Primitives +(defun compile-bool (x) + (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")")) + (define-compilation + (x y) (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))")) @@ -480,13 +481,13 @@ (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))")) (define-compilation < (x y) - (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))")) + (compile-bool (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))"))) (define-compilation = (x y) - (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))")) + (compile-bool (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))) (define-compilation numberp (x) - (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")) + (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")"))) (define-compilation mod (x y) @@ -496,14 +497,16 @@ (concat "(Math.floor(" (ls-compile x env fenv) "))")) (define-compilation null (x) - (concat "(" (ls-compile x env fenv) "== false)")) + (compile-bool (concat "(" (ls-compile x env fenv) "===" (ls-compile nil env fenv) ")"))) (define-compilation cons (x y) (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}")) (define-compilation consp (x) - (concat "('car' in " (ls-compile x env fenv) ")")) - + (compile-bool + (concat "(function(){ var tmp = " + (ls-compile x env fenv) + "; return (typeof tmp == 'object' && 'car' in tmp);})()"))) (define-compilation car (x) (concat "(" (ls-compile x env fenv) ").car")) @@ -518,7 +521,10 @@ (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")")) (define-compilation symbolp (x) - (concat "('name' in " (ls-compile x env fenv) ")")) + (compile-bool + (concat "(function(){ var tmp = " + (ls-compile x env fenv) + "; return (typeof tmp == 'object' && 'name' in tmp); })()"))) (define-compilation make-symbol (name) (concat "{name: " (ls-compile name env fenv) "}")) @@ -527,16 +533,19 @@ (concat "(" (ls-compile x env fenv) ").name")) (define-compilation eq (x y) - (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")")) + (compile-bool + (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))) (define-compilation equal (x y) - (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")")) + (compile-bool + (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")"))) (define-compilation string (x) (concat "String.fromCharCode(" (ls-compile x env fenv) ")")) (define-compilation stringp (x) - (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")) + (compile-bool + (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")"))) (define-compilation string-upcase (x) (concat "(" (ls-compile x env fenv) ").toUpperCase()")) @@ -573,7 +582,7 @@ (concat "(" (ls-compile func env fenv) ")()") (let ((args (butlast args)) (last (car (last args)))) - (concat "function(){" *newline* + (concat "(function(){" *newline* "var f = " (ls-compile func env fenv) ";" *newline* "var args = [" (join (mapcar (lambda (x) (ls-compile x env fenv)) @@ -581,12 +590,12 @@ ", ") "];" *newline* "var tail = (" (ls-compile last env fenv) ");" *newline* - "while (tail != false){" *newline* - " args.push(tail[0]);" *newline* - " args = args.slice(1);" *newline* + "while (tail != " (ls-compile nil env fenv) "){" *newline* + " args.push(tail.car);" *newline* + " tail = tail.cdr;" *newline* "}" *newline* "return f.apply(this, args);" *newline* - "}" *newline*)))) + "})()" *newline*)))) (define-compilation js-eval (string) (concat "eval(" (ls-compile string env fenv) ")")) @@ -599,7 +608,11 @@ "{}") (define-compilation get (object key) - (concat "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]")) + (concat "(function(){ var tmp = " + "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]" + ";" + "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;" + "})()")) (define-compilation set (object key value) (concat "((" @@ -608,10 +621,15 @@ (ls-compile key env fenv) "]" " = " (ls-compile value env fenv) ")")) +(define-compilation in (key object) + (compile-bool + (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")"))) + + (defun macrop (x) (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro))) -(defun ls-macroexpand-1 (form &optional env fenv) +(defun ls-macroexpand-1 (form env fenv) (when (macrop (car form)) (let ((binding (lookup-function (car form) *env*))) (if (eq (binding-type binding) 'macro) @@ -634,7 +652,7 @@ (t (error (concat "Invalid function designator " (symbol-name function)))))) -(defun ls-compile (sexp &optional env fenv) +(defun ls-compile (sexp env fenv) (cond ((symbolp sexp) (lookup-variable-translation sexp env)) ((integerp sexp) (integer-to-string sexp)) @@ -649,11 +667,12 @@ (defun ls-compile-toplevel (sexp) (setq *toplevel-compilations* nil) - (let ((code (ls-compile sexp))) + (let ((code (ls-compile sexp nil nil))) (prog1 - (concat (join (mapcar (lambda (x) (concat x ";" *newline*)) + (concat "/* " (princ-to-string sexp) " */" + (join (mapcar (lambda (x) (concat x ";" *newline*)) *toplevel-compilations*) - "") + "") code) (setq *toplevel-compilations* nil))))