X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=lispstrack.lisp;h=7848b81bc0d7d5fdf1b13f05bf477f90c2953cc6;hb=ee2e4ec32c9961958bd3c1c8dda6a98e78ea61c8;hp=0019b5c3417a042f896f0a4c080838b19784822b;hpb=7d2b066997fe16aa9b87ccf08d3678dc55f023e9;p=jscl.git

diff --git a/lispstrack.lisp b/lispstrack.lisp
index 0019b5c..7848b81 100644
--- a/lispstrack.lisp
+++ b/lispstrack.lisp
@@ -132,6 +132,17 @@
       (t
        (cons (ls-read stream) (%read-list stream))))))
 
+(defun read-string (stream)
+  (let ((string "")
+        (ch nil))
+    (setq ch (%read-char stream))
+    (while (not (char= ch #\"))
+      (when (char= ch #\\)
+        (setq ch (%read-char stream)))
+      (setq string (concat string (string ch)))
+      (setq ch (%read-char stream)))
+    string))
+
 (defvar *eof* (make-symbol "EOF"))
 (defun ls-read (stream)
   (skip-whitespaces-and-comments stream)
@@ -150,8 +161,7 @@
        (list 'backquote (ls-read stream)))
       ((char= ch #\")
        (%read-char stream)
-       (prog1 (read-until stream (lambda (ch) (char= ch #\")))
-         (%read-char stream)))
+       (read-string stream))
       ((char= ch #\,)
        (%read-char stream)
        (if (eql (%peek-char stream) #\@)
@@ -254,7 +264,7 @@
     (binding-translation (lookup-function symbol env))))
 
 
-(defvar *toplevel-compilations*)
+(defvar *toplevel-compilations* nil)
 
 (defun %compile-defvar (name)
   (let ((b (lookup-variable name *env*)))
@@ -279,7 +289,7 @@
                        sexps))
                  ";
 "))
-(defmacro define-compilation (name args &body body)
+(defmacro define-compilation (name args &rest body)
   ;; Creates a new primitive `name' with parameters args and
   ;; @body. The body can access to the local environment through the
   ;; variable ENV.
@@ -308,7 +318,7 @@
   (let ((required-arguments (lambda-list-required-argument lambda-list))
         (rest-argument (lambda-list-rest-argument lambda-list)))
     (let ((new-env (extend-local-env
-                    (append (if rest-argument (list rest-argument))
+                    (append (and rest-argument (list rest-argument))
                             required-arguments)
                     env)))
       (concat "(function ("
@@ -320,7 +330,7 @@
               *newline*
               (if rest-argument
                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
-                    (concat "var " js!rest ";" *newline*
+                    (concat "var " js!rest "= false;" *newline*
                             "for (var i = arguments.length-1; i>="
                             (integer-to-string (length required-arguments))
                             "; i--)" *newline*
@@ -345,12 +355,27 @@
 
 ;;; Literals
 
+(defun escape-string (string)
+  (let ((output "")
+        (index 0)
+        (size (length string)))
+    (while (< index size)
+      (let ((ch (char string index)))
+        (when (or (char= ch #\") (char= ch #\\))
+          (setq output (concat output "\\")))
+        (when (or (char= ch #\newline))
+          (setq output (concat output "\\"))
+          (setq ch #\n))
+        (setq output (concat output (string ch))))
+      (incf index))
+    output))
+
 (defun literal->js (sexp)
   (cond
     ((null sexp) "false")
     ((integerp sexp) (integer-to-string sexp))
-    ((stringp sexp) (concat "\"" sexp "\""))
-    ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
+    ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
+    ((symbolp sexp) (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}"))
     ((consp sexp) (concat "{car: "
                           (literal->js (car sexp))
                           ", cdr: "
@@ -460,6 +485,10 @@
 (define-compilation = (x y)
   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 
+(define-compilation numberp (x)
+  (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")"))
+
+
 (define-compilation mod (x y)
   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 
@@ -472,6 +501,10 @@
 (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) ")"))
+
+
 (define-compilation car (x)
   (concat "(" (ls-compile x env fenv) ").car"))
 
@@ -484,6 +517,9 @@
 (define-compilation setcdr (x new)
   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 
+(define-compilation symbolp (x)
+  (concat "('name' in " (ls-compile x env fenv) ")"))
+
 (define-compilation make-symbol (name)
   (concat "{name: " (ls-compile name env fenv) "}"))
 
@@ -499,6 +535,9 @@
 (define-compilation string (x)
   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 
+(define-compilation stringp (x)
+  (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")"))
+
 (define-compilation string-upcase (x)
   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 
@@ -529,6 +568,30 @@
                 ", ")
           ")"))
 
+(define-compilation apply (func &rest args)
+  (if (null args)
+      (concat "(" (ls-compile func env fenv) ")()")
+      (let ((args (butlast args))
+            (last (car (last args))))
+        (concat "function(){" *newline*
+                "var f = " (ls-compile func env fenv) ";" *newline*
+                "var args = [" (join (mapcar (lambda (x)
+                                               (ls-compile x env fenv))
+                                             args)
+                                     ", ")
+                "];" *newline*
+                "var tail = (" (ls-compile last env fenv) ");" *newline*
+                "while (tail != false){" *newline*
+                "    args.push(tail[0]);" *newline*
+                "    args = args.slice(1);" *newline*
+                "}" *newline*
+                "return f.apply(this, args);" *newline*
+                "}" *newline*))))
+
+(define-compilation js-eval (string)
+  (concat "eval(" (ls-compile string env fenv)  ")"))
+
+
 (define-compilation error (string)
   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
 
@@ -569,13 +632,13 @@
                    ", ")
              ")"))
     (t
-     (error "Invalid function designator ~a." function))))
+     (error (concat "Invalid function designator " (symbol-name function))))))
 
 (defun ls-compile (sexp &optional env fenv)
   (cond
     ((symbolp sexp) (lookup-variable-translation sexp env))
     ((integerp sexp) (integer-to-string sexp))
-    ((stringp sexp) (concat "\"" sexp "\""))
+    ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
     ((listp sexp)
      (if (assoc (car sexp) *compilations*)
          (let ((comp (second (assoc (car sexp) *compilations*))))
@@ -588,9 +651,10 @@
   (setq *toplevel-compilations* nil)
   (let ((code (ls-compile sexp)))
     (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))))