Changed the implementation of quote from being special cased in several Parenscript...

diff --git a/src/compiler.lisp b/src/compiler.lisp
index c663635..d9db1e4 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -136,9 +136,10 @@ function and the parent macro environment of the macro."
           ',name))
 
 (defmacro define-ps-symbol-macro (symbol expansion)
-  `(progn (undefine-ps-special-form ',symbol)
-          (setf (get-macro-spec ',symbol *ps-macro-toplevel*) (cons t (lambda () ',expansion)))
-          ',symbol))
+  (let ((x (gensym)))
+    `(progn (undefine-ps-special-form ',symbol)
+            (setf (get-macro-spec ',symbol *ps-macro-toplevel*) (cons t (lambda (,x) (declare (ignore ,x)) ',expansion)))
+            ',symbol)))
 
 (defun import-macros-from-lisp (&rest names)
   "Import the named Lisp macros into the ParenScript macro
@@ -167,15 +168,11 @@ CL environment)."
   "Recursively macroexpands ParenScript macros and symbol-macros in
 the given ParenScript form. Returns two values: the expanded form, and
 whether any expansion was performed on the form or not."
-  (if (consp form)
-      (let ((op (car form))
-            (args (cdr form)))
-        (cond ((equal op 'quote) (values (if (equalp '(nil) args) nil form) ; leave quotes alone, unless it's a quoted nil
-                                         nil))
-              ((ps-macro-p op) (values (ps-macroexpand (funcall (lookup-macro-expansion-function op) form)) t))
-              (t (values form nil))))
-      (cond ((ps-symbol-macro-p form) (values (ps-macroexpand (funcall (lookup-macro-expansion-function form))) t))
-            (t (values form nil)))))
+  (let ((macro-function (cond ((ps-symbol-macro-p form) form)
+                              ((and (consp form) (ps-macro-p (car form))) (car form)))))
+    (if macro-function
+        (values (ps-macroexpand (funcall (lookup-macro-expansion-function macro-function) form)) t)
+        (values form nil))))
 
 ;;;; compiler interface
 (defgeneric compile-parenscript-form (form &key expecting)
@@ -199,8 +196,7 @@ compiled to an :expression (the default), a :statement, or a
 resultant symbol has an associated script-package. Raises an error if
 the form cannot be compiled to a symbol."
   (let ((exp (compile-parenscript-form form)))
-    (when (or (eql (first exp) 'js-variable)
-              (eql (first exp) 'ps-quote))
+    (when (eql (first exp) 'js-variable)
       (setf exp (second exp)))
     (assert (symbolp exp) ()
             "~a is expected to be a symbol, but compiles to ~a (the ParenScript output for ~a alone is \"~a\"). This could be due to ~a being a special form." form exp form (ps* form) form)
@@ -254,10 +250,7 @@ the form cannot be compiled to a symbol."
 (defmethod compile-parenscript-form ((form cons) &key (expecting :statement))
   (let* ((name (car form))
          (args (cdr form)))
-    (cond ((eql name 'quote)
-           (assert (= 1 (length args)) () "Wrong number of arguments to quote: ~s" args)
-           (list 'ps-quote (first args)))
-          ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args)))
+    (cond ((ps-special-form-p form) (apply (get-ps-special-form name) (cons expecting args)))
           ((op-form-p form)
            (list 'operator
                  (ps-convert-op-name (compile-parenscript-form (first form) :expecting :symbol))

diff --git a/src/printer.lisp b/src/printer.lisp
index 981786d..71f8d51 100644 (file)
--- a/src/printer.lisp
+++ b/src/printer.lisp
@@ -125,11 +125,6 @@ arguments, defines a printer for that form using the given body."
   (defun op-precedence (op)
     (gethash op *op-precedence-hash*)))
 
-(defprinter ps-quote (val)
-  (if (null val)
-      (psw "null")
-      (error "Cannot translate quoted value ~S to javascript" val)))
-
 (defprinter js-literal (str)
   (psw str))
 
@@ -212,7 +207,7 @@ arguments, defines a printer for that form using the given body."
 (defprinter js-object (slot-defs)
   (psw "{ ")
   (loop for ((slot-name . slot-value) . remaining) on slot-defs do
-        (if (and (listp slot-name) (eql 'ps-quote (car slot-name)) (symbolp (second slot-name)))
+        (if (and (listp slot-name) (eq 'quote (car slot-name)) (symbolp (second slot-name)))
             (psw (js-translate-symbol (second slot-name)))
             (ps-print slot-name))
         (psw " : ")
@@ -226,11 +221,8 @@ arguments, defines a printer for that form using the given body."
           (and (listp obj) (member (car obj) '(js-lambda js-object))))
       (parenthesize-print obj)
       (ps-print obj))
-  (if (and (listp slot) (eql 'ps-quote (car slot)))
-      (progn (psw #\.)
-             (if (symbolp (second slot))
-                 (psw (js-translate-symbol (second slot)))
-                 (ps-print slot)))
+  (if (symbolp slot)
+      (progn (psw #\.) (psw (js-translate-symbol slot)))
       (progn (psw #\[) (ps-print slot) (psw #\]))))
 
 (defprinter js-cond-statement (clauses)

diff --git a/src/special-forms.lisp b/src/special-forms.lisp
index f9b259a..003c069 100644 (file)
--- a/src/special-forms.lisp
+++ b/src/special-forms.lisp
@@ -26,6 +26,14 @@
   (def-for-literal break js-break)
   (def-for-literal continue js-continue))
 
+(defpsmacro quote (x)
+  (typecase x
+    (cons (cons 'array (mapcar (lambda (x) `',x) x)))
+    (null '(make-array))
+    (symbol (symbol-to-js-string x))
+    (number x)
+    (string x)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; unary operators
 (macrolet ((def-unary-ops (&rest ops)
@@ -447,7 +455,7 @@ lambda-list::=
       (destructuring-bind (name expansion)
           macro
         (setf (get-macro-spec name macro-env-dict)
-              (cons t (lambda () expansion)))))
+              (cons t (lambda (x) (declare (ignore x)) expansion)))))
     (compile-parenscript-form `(progn ,@body))))
 
 (define-ps-special-form defmacro (expecting name args &body body)
@@ -475,16 +483,17 @@ lambda-list::=
                                        (numberp key)
                                        (and (listp key)
                                             (or (eq 'js-variable (car key))
-                                                (eq 'ps-quote (car key)))))
+                                                (eq 'quote (car key)))))
                                    ()
                                    "Slot key ~s is not one of js-variable, keyword, string or number." key)
                            (cons key (compile-parenscript-form val-expr :expecting :expression))))))
 
 (define-ps-special-form %js-slot-value (expecting obj slot)
   (declare (ignore expecting))
-  (if (ps::ps-macroexpand slot)
-      (list 'js-slot-value (compile-parenscript-form obj :expecting :expression) (compile-parenscript-form slot))
-      (compile-parenscript-form obj :expecting :expression)))
+  (list 'js-slot-value (compile-parenscript-form obj :expecting :expression)
+        (if (and (listp slot) (eq 'quote (car slot)))
+            (second slot) ;; assume we're quoting a symbol
+            (compile-parenscript-form slot))))
 
 (define-ps-special-form instanceof (expecting value type)
   (declare (ignore expecting))

diff --git a/t/ps-tests.lisp b/t/ps-tests.lisp
index bdd9426..b493903 100644 (file)
--- a/t/ps-tests.lisp
+++ b/t/ps-tests.lisp
@@ -211,25 +211,17 @@ x = 2 + sideEffect() + x + 5;")
 (test script-star-eval2
   (is (string= "x = 1;" (normalize-js-code (ps* '(setf x 1))))))
 
-(test-ps-js slot-value-null1
-  (slot-value foo nil)
-  "foo")
-
-(test-ps-js slot-value-null2
-  (slot-value foo 'nil)
-  "foo")
-
 (test-ps-js unquoted-nil
   nil
   "null")
 
 (test-ps-js list-with-single-nil
-  (array 'nil)
+  (array nil)
   "[null]")
 
-(test-ps-js quoted-nil
+(test-ps-js quoted-nil-is-array
   'nil
-  "null")
+  "new Array()")
 
 (test-ps-js defsetf1
   (progn (defsetf baz (x y) (newval) `(set-baz ,x ,y ,newval))
@@ -744,3 +736,11 @@ try {
 (test-ps-js math-pi
   pi
   "Math.PI")
+
+(test-ps-js literal-array
+  '(1 2 3)
+  "[1, 2, 3]")
+
+(test-ps-js literal-array-1
+  '(1 foo 3)
+  "[1, 'foo', 3]")