X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=866cea2f1bf4305a8911f792a41e7a20b0fbd9bd;hb=18c8e6a2d7bdc53f5a95c1a29b8913ee66a415d6;hp=08291449c373d4284148b225ec295da612c06fe8;hpb=008edd3627c0cc149280b9143a18bb7cea3c0918;p=jscl.git

diff --git a/src/compiler.lisp b/src/compiler.lisp
index 0829144..866cea2 100644
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -228,7 +228,7 @@
   (flet ((canonicalize (keyarg)
 	   ;; Build a canonical keyword argument descriptor, filling
 	   ;; the optional fields. The result is a list of the form
-	   ;; ((keyword-name var) init-form).
+	   ;; ((keyword-name var) init-form svar).
            (let ((arg (ensure-list keyarg)))
              (cons (if (listp (car arg))
                        (car arg)
@@ -280,13 +280,14 @@
                ,@(with-collect
                   (dotimes (idx n-optional-arguments)
                     (let ((arg (nth idx optional-arguments)))
-                      (collect `(,(+ idx n-required-arguments)
-                                  (= ,(make-symbol (translate-variable (car arg)))
-                                     ,(ls-compile (cadr arg)))
-                                  ,(when (third arg)
-                                         `(= ,(make-symbol (translate-variable (third arg)))
-                                             ,(ls-compile nil)))))))
-                  (collect `(default (break))))))))
+                      (collect `(case ,(+ idx n-required-arguments)))
+                      (collect `(= ,(make-symbol (translate-variable (car arg)))
+                                   ,(ls-compile (cadr arg))))
+                      (collect (when (third arg)
+                                 `(= ,(make-symbol (translate-variable (third arg)))
+                                     ,(ls-compile nil))))))
+                  (collect 'default)
+                  (collect '(break)))))))
 
 (defun compile-lambda-rest (ll)
   (let ((n-required-arguments (length (ll-required-arguments ll)))
@@ -310,55 +311,62 @@
 	 (length (ll-optional-arguments ll)))
 	(keyword-arguments
 	 (ll-keyword-arguments-canonical ll)))
-    `(code
-      ;; Declare variables
-      ,@(mapcar (lambda (arg)
-                  (let ((var (second (car arg))))
-                    `(code "var " ,(translate-variable var) "; "
-                           ,(when (third arg)
-                              `(code "var " ,(translate-variable (third arg))
-                                     " = " ,(ls-compile nil)
-                                     ";" )))))
-                keyword-arguments)
-      ;; Parse keywords
-      ,(flet ((parse-keyword (keyarg)
-               ;; ((keyword-name var) init-form)
-               `(code "for (i=" ,(+ n-required-arguments n-optional-arguments)
-                      "; i<nargs; i+=2){"
-                      "if (arguments[i+2] === " ,(ls-compile (caar keyarg)) "){"
-                      ,(translate-variable (cadr (car keyarg)))
-                      " = arguments[i+3];"
-                      ,(let ((svar (third keyarg)))
-                            (when svar
-                              `(code ,(translate-variable svar) " = " ,(ls-compile t) ";" )))
-                      "break;"
-                      "}"
-                      "}"
-                      ;; Default value
-                      "if (i == nargs){"
-                      ,(translate-variable (cadr (car keyarg)))
-                      " = "
-                      ,(ls-compile (cadr keyarg))
-                      ";"
-                      "}")))
-        (when keyword-arguments
-          `(code "var i;"
-                 ,@(mapcar #'parse-keyword keyword-arguments))))
-      ;; Check for unknown keywords
-      ,(when keyword-arguments
-        `(code "var start = " ,(+ n-required-arguments n-optional-arguments) ";"
-               "if ((nargs - start) % 2 == 1){"
-               "throw 'Odd number of keyword arguments';" 
-               "}"
-               "for (i = start; i<nargs; i+=2){"
-               "if ("
-               ,@(interleave (mapcar (lambda (x)
-                                       `(code "arguments[i+2] !== " ,(ls-compile (caar x))))
-                                     keyword-arguments)
-                            " && ")
-               ")"
-               "throw 'Unknown keyword argument ' + xstring(arguments[i+2].name);" 
-               "}" )))))
+    `(progn
+       ;; Declare variables
+       ,@(with-collect
+          (dolist (keyword-argument keyword-arguments)
+            (destructuring-bind ((keyword-name var) &optional initform svar)
+                keyword-argument
+              (declare (ignore keyword-name initform))
+              (collect `(var ,(make-symbol (translate-variable var))))
+              (when svar
+                (collect
+                    `(var (,(make-symbol (translate-variable svar))
+                            ,(ls-compile nil))))))))
+       
+       ;; Parse keywords
+       ,(flet ((parse-keyword (keyarg)
+                (destructuring-bind ((keyword-name var) &optional initform svar) keyarg
+                  ;; ((keyword-name var) init-form svar)
+                  `(progn
+                     (for ((= i ,(+ n-required-arguments n-optional-arguments))
+                           (< i |nargs|)
+                           (+= i 2))
+                          ;; ....
+                          (if (=== (property |arguments| (+ i 2))
+                                   ,(ls-compile keyword-name))
+                              (progn
+                                (= ,(make-symbol (translate-variable var))
+                                   (property |arguments| (+ i 3)))
+                                ,(when svar `(= ,(make-symbol (translate-variable svar))
+                                                ,(ls-compile t)))
+                                (break))))
+                     (if (== i |nargs|)
+                         (= ,(make-symbol (translate-variable var))
+                            ,(ls-compile initform)))))))
+         (when keyword-arguments
+           `(progn
+              (var i)
+              ,@(mapcar #'parse-keyword keyword-arguments))))
+       
+       ;; Check for unknown keywords
+       ,(when keyword-arguments
+         `(progn
+            (var (start ,(+ n-required-arguments n-optional-arguments)))
+            (if (== (% (- |nargs| start) 2) 1)
+                (throw "Odd number of keyword arguments."))
+            (for ((= i start) (< i |nargs|) (+= i 2))
+                 (if (and ,@(mapcar (lambda (keyword-argument)
+                                 (destructuring-bind ((keyword-name var) &optional initform svar)
+                                     keyword-argument
+                                   (declare (ignore var initform svar))
+                                   `(!== (property |arguments| (+ i 2)) ,(ls-compile keyword-name))))
+                               keyword-arguments))
+                     (throw (+ "Unknown keyword argument "
+                               (call |xstring|
+                                     (property
+                                      (property |arguments| (+ i 2))
+                                      "name")))))))))))
 
 (defun parse-lambda-list (ll)
   (values (ll-required-arguments ll)
@@ -419,8 +427,7 @@
                                                   (or rest-argument keyword-arguments))
                     ,(compile-lambda-optional ll)
                     ,(compile-lambda-rest ll)
-                    (code
-                     ,(compile-lambda-parse-keywords ll))
+                    ,(compile-lambda-parse-keywords ll)
 
                     ,(let ((*multiple-value-p* t))
                           (if block
@@ -777,14 +784,15 @@
     ;; unique identifier of the block as exception. We can't use the
     ;; variable name itself, because it could not to be unique, so we
     ;; capture it in a closure.
-    (js!selfcall
-      (when multiple-value-p `(code "var values = mv;" ))
-      "throw ({"
-      "type: 'block', "
-      "id: " (binding-value b) ", "
-      "values: " (ls-compile value multiple-value-p) ", "
-      "message: 'Return from unknown block " (symbol-name name) ".'"
-      "})")))
+    (js!selfcall*
+      (when multiple-value-p
+        `(var (|values| |mv|)))
+      `(throw
+           (object
+            "type" "block"
+            "id" ,(make-symbol (binding-value b))
+            "values" ,(ls-compile value multiple-value-p)
+            "message" ,(concat "Return from unknown block '" (symbol-name name) "'."))))))
 
 (define-compilation catch (id &rest body)
   (js!selfcall*
@@ -819,7 +827,7 @@
   (let* ((go-tag-counter 0)
          (bindings
           (mapcar (lambda (label)
-                    (let ((tagidx (integer-to-string (incf go-tag-counter))))
+                    (let ((tagidx (incf go-tag-counter)))
                       (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
                   (remove-if-not #'go-tag-p body))))
     (extend-lexenv bindings *environment* 'gotag)))
@@ -840,34 +848,28 @@
           initag)
       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
         (setq initag (second (binding-value b))))
-      (js!selfcall
+      (js!selfcall*
         ;; TAGBODY branch to take
-        "var " branch " = " initag ";"
-        "var " tbidx " = [];"
-        "tbloop:"
-        "while (true) {"
-        `(code "try {"
-               ,(let ((content nil))
-                  `(code "switch(" ,branch "){"
-                        "case " ,initag ":"
-                        ,@(dolist (form (cdr body) (reverse content))
-                          (push (if (not (go-tag-p form))
-                                    `(code ,(ls-compile form) ";" )
+        `(var (,(make-symbol branch) ,initag))
+        `(var (,(make-symbol tbidx) #()))
+        `(label tbloop
+                (while true
+                  (try
+                   (switch ,(make-symbol branch)
+                           ,@(with-collect
+                              (dolist (form (cdr body))
+                                (if (go-tag-p form)
                                     (let ((b (lookup-in-lexenv form *environment* 'gotag)))
-                                      `(code "case " ,(second (binding-value b)) ":" )))
-                                content))
-                           "default:"
-                           "    break tbloop;"
-                           "}" ))
-               "}"
-               "catch (jump) {"
-               "    if (jump.type == 'tagbody' && jump.id == " ,tbidx ")"
-               "        " ,branch " = jump.label;"
-               "    else"
-               "        throw(jump);"
-               "}" )
-        "}"
-        "return " (ls-compile nil) ";" ))))
+                                      (collect `(case ,(second (binding-value b)))))
+                                    (collect (ls-compile form)))))
+                           default
+                           (break tbloop)))
+                  (catch (jump)
+                    (if (and (== (get jump "type") "tagbody")
+                             (== (get jump "id") ,(make-symbol tbidx)))
+                        (= ,(make-symbol branch) (get jump "label"))
+                        (throw jump)))))
+        `(return ,(ls-compile nil))))))
 
 (define-compilation go (label)
   (let ((b (lookup-in-lexenv label *environment* 'gotag))
@@ -876,13 +878,13 @@
              ((integerp label) (integer-to-string label)))))
     (when (null b)
       (error "Unknown tag `~S'" label))
-    (js!selfcall
-      "throw ({"
-      "type: 'tagbody', "
-      "id: " (first (binding-value b)) ", "
-      "label: " (second (binding-value b)) ", "
-      "message: 'Attempt to GO to non-existing tag " n "'"
-      "})" )))
+    (js!selfcall*
+      `(throw
+           (object
+            "type" "tagbody"
+            "id" ,(make-symbol (first (binding-value b)))
+            "label" ,(second (binding-value b))
+            "message" ,(concat "Attempt to GO to non-existing tag " n))))))
 
 (define-compilation unwind-protect (form &rest clean-up)
   (js!selfcall*