X-Git-Url: http://git.hcoop.net/clinton/parenscript.git/blobdiff_plain/837bcc37c5a8727b89a99523d215f6769ff38389..11cba1a7a2b323b69750823dfa079dc9990dba20:/src/compiler.lisp

diff --git a/src/compiler.lisp b/src/compiler.lisp
index d793725..8a98dda 100644
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -16,7 +16,8 @@
   (pushnew (symbol-name-to-js-string name) *ps-reserved-symbol-names* :test #'equalp))
 
 (defun ps-reserved-symbol-p (symbol)
-  (find (symbol-name-to-js-string symbol) *ps-reserved-symbol-names* :test #'equalp))
+  (when (symbolp symbol)
+    (find (symbol-name-to-js-string symbol) *ps-reserved-symbol-names* :test #'equalp)))
 
 ;;; special forms
 
@@ -26,17 +27,11 @@
   (gethash name *ps-special-forms*))
 
 (defmacro define-ps-special-form (name lambda-list &rest body)
-  "Define a special form NAME. The first argument (an anaphor called
-'expecting' automatically added to the arglist) to the special form is
-a keyword indicating whether the form is expected to produce
-an :expression or a :statement."
-  (let ((args (gensym "ps-arglist-")))
-    `(setf (gethash ',name *ps-special-forms*)
-           (lambda (&rest ,args)
-             (destructuring-bind ,(cons 'expecting lambda-list)
-                 ,args
-               (declare (ignorable expecting))
-               ,@body)))))
+  `(setf (gethash ',name *ps-special-forms*)
+         (lambda (&rest whole)
+           (destructuring-bind ,lambda-list
+               whole
+             ,@body))))
 
 (defun undefine-ps-special-form (name)
   (remhash name *ps-special-forms*))
@@ -65,11 +60,19 @@ lexical block.")
 
 ;;; form predicates
 
+(defun comparison-form-p (form)
+  (member (car form) '(< > <= >= == != === !==)))
+
 (defun op-form-p (form)
   (and (listp form)
        (not (ps-special-form-p form))
        (not (null (op-precedence (first form))))))
 
+(defun method-call-form-p (form)
+  (and (listp form)
+       (symbolp (car form))
+       (char= #\. (char (symbol-name (car form)) 0))))
+
 (defun funcall-form-p (form)
   (and form
        (listp form)
@@ -102,7 +105,7 @@ stored as the second value.")
   (defparameter *ps-compilation-level* :toplevel
     "This value takes on the following values:
 :toplevel indicates that we are traversing toplevel forms.
-:inside-toplevel-form indicates that we are inside a call to compile-parenscript-form
+:inside-toplevel-form indicates that we are inside a call to ps-compile-*
 nil indicates we are no longer toplevel-related."))
 
 (defun lookup-macro-def (name env)
@@ -152,7 +155,7 @@ CL environment)."
           (defpsmacro ,name ,args ,@body)))
 
 (defun ps-macroexpand (form)
-  (aif (or (lookup-macro-def form *ps-symbol-macro-env*)
+  (aif (or (and (symbolp form) (lookup-macro-def form *ps-symbol-macro-env*))
            (and (consp form) (lookup-macro-def (car form) *ps-macro-env*)))
        (values (ps-macroexpand (funcall it form)) t)
        form))
@@ -163,64 +166,76 @@ CL environment)."
        fun-name))
 
 ;;;; compiler interface
-(defgeneric compile-parenscript-form (form &key expecting)
-  (:documentation "Compiles a ParenScript form to the intermediate
-ParenScript representation. :expecting determines whether the form is
-compiled to an :expression (the default), a :statement, or a
-:symbol."))
-
 (defun adjust-ps-compilation-level (form level)
-  (cond ((or (and (consp form) (eq 'progn (car form)))
-             (and (symbolp form) (eq :toplevel level)))
-         level)
-        ((eq :toplevel level) :inside-toplevel-form)))
-
-(defmethod compile-parenscript-form :around (form &key expecting)
-  (assert (if expecting (member expecting '(:expression :statement :symbol)) t))
-  (if (eq expecting :symbol)
-      (compile-to-symbol form)
-      (let ((*ps-compilation-level* (adjust-ps-compilation-level form *ps-compilation-level*)))
-        (call-next-method))))
-
-(defun compile-to-symbol (form)
+  "Given the current *ps-compilation-level*, LEVEL, and the fully macroexpanded
+form, FORM, returns the new value for *ps-compilation-level*."
+  (cond ((or (and (consp form) (member (car form)
+                       '(progn locally macrolet symbol-macrolet compile-file)))
+         (and (symbolp form) (eq :toplevel level)))
+     level)
+    ((eq :toplevel level) :inside-toplevel-form)))
+
+
+(defun ps-compile-symbol (form)
   "Compiles the given Parenscript form and guarantees that the
 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 :expecting :expression)))
+  (let ((exp (ps-compile-expression form)))
     (when (eq (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)
     exp))
 
-(defmethod compile-parenscript-form (form &key expecting)
-  (declare (ignore expecting))
+(defmethod ps-compile (form)
   (error "The object ~S cannot be compiled by ParenScript." form))
 
-(defmethod compile-parenscript-form ((form number) &key expecting)
-  (declare (ignore expecting))
+(defmethod ps-compile ((form number))
   form)
 
-(defmethod compile-parenscript-form ((form string) &key expecting)
-  (declare (ignore expecting))
+(defmethod ps-compile ((form string))
   form)
 
-(defmethod compile-parenscript-form ((form character) &key expecting)
-  (declare (ignore expecting))
-  (compile-parenscript-form (string form)))
-
-(defmethod compile-parenscript-form ((symbol symbol) &key expecting)
-  (when (eq *ps-compilation-level* :toplevel)
-    (multiple-value-bind (expansion expanded-p)
-        (ps-macroexpand symbol)
-      (when expanded-p 
-        (return-from compile-parenscript-form (compile-parenscript-form expansion :expecting expecting)))))
-  (cond ((keywordp symbol) symbol)
-        ((ps-special-form-p (list symbol))
-         (if (ps-reserved-symbol-p symbol)
-             (funcall (get-ps-special-form symbol) :symbol)
-             (error "Attempting to use Parenscript special form ~a as variable" symbol)))
-        (t `(js:variable ,symbol))))
+(defmethod ps-compile ((form character))
+  (ps-compile (string form)))
+
+(defmethod ps-compile ((symbol symbol))
+  (multiple-value-bind (expansion expanded?)
+      (ps-macroexpand symbol)
+    (if expanded?
+        (ps-compile expansion)
+        (cond ((keywordp symbol) symbol)
+              ((ps-special-form-p (list symbol))
+               (if (ps-reserved-symbol-p symbol)
+                   (funcall (get-ps-special-form symbol))
+                   (error "Attempting to use Parenscript special form ~a as variable" symbol)))
+              (t `(js:variable ,symbol))))))
+
+;;; operators
+
+(let ((precedence-table (make-hash-table :test 'eq)))
+  (loop for level in '((js:new js:slot-value js:aref)
+                       (postfix++ postfix--)
+                       (delete void typeof ++ -- unary+ unary- ~ !)
+                       (* / %)
+                       (+ -)
+                       (<< >> >>>)
+                       (< > <= >= js:instanceof js:in)
+                       (== != === !==)
+                       (&)
+                       (^)
+                       (\|)
+                       (\&\& and)
+                       (\|\| or)
+                       (js:?)
+                       (= *= /= %= += -= <<= >>= >>>= \&\= ^= \|=)
+                       (comma))
+     for i from 0
+     do (mapcar (lambda (symbol)
+                  (setf (gethash symbol precedence-table) i))
+                level))
+  (defun op-precedence (op)
+    (gethash op precedence-table)))
 
 (defun ps-convert-op-name (op)
   (case op
@@ -229,27 +244,78 @@ the form cannot be compiled to a symbol."
     (not '!)
     (eql '\=\=)
     (=   '\=\=)
-    (t op)))
-
-(defmethod compile-parenscript-form ((form cons) &key (expecting :statement))
+   (t op)))
+
+(defun maybe-fix-nary-comparison-form (form)
+  (if (< 2 (length (cdr form)))
+      (values
+       (let* ((operator (car form))
+              (tmp-var-forms (butlast (cddr form)))
+              (tmp-vars (loop repeat (length tmp-var-forms)
+                           collect (ps-gensym "_cmp")))
+              (all-comparisons (append (list (cadr form))
+                                       tmp-vars
+                                       (last form))))
+         `(let ,(mapcar #'list tmp-vars tmp-var-forms)
+            (and ,@(loop for x1 in all-comparisons
+                      for x2 in (cdr all-comparisons)
+                      collect (list operator x1 x2)))))
+       t)
+      form))
+
+(defun compile-op-form (form)
+  `(js:operator ,(ps-convert-op-name (ps-compile-symbol (car form)))
+                ,@(mapcar (lambda (form)
+                            (ps-compile-expression (ps-macroexpand form)))
+                          (cdr form))))
+
+(defun compile-method-call-form (form)
+  (compile-funcall-form
+   `((js:slot-value ,(second form)
+                    ',(make-symbol (subseq (symbol-name (first form)) 1)))
+     ,@(cddr form))))
+
+(defun compile-funcall-form (form)
+  `(js:funcall
+    ,(if (symbolp (car form))
+         `(js:variable ,(maybe-rename-local-function (car form)))
+         (ps-compile-expression (ps-macroexpand (car form))))
+    ,@(mapcar #'ps-compile-expression (cdr form))))
+
+(defvar compile-expression?)
+
+(defmethod ps-compile ((form cons))
   (multiple-value-bind (form expanded-p)
       (ps-macroexpand form)
-    (cond (expanded-p (compile-parenscript-form form :expecting expecting))
-          ((ps-special-form-p form) (apply (get-ps-special-form (car form)) (cons expecting (cdr form))))
-          ((op-form-p form)
-           `(js:operator ,(ps-convert-op-name (compile-parenscript-form (car form) :expecting :symbol))
-                         ,@(mapcar (lambda (form)
-                                     (compile-parenscript-form (ps-macroexpand form) :expecting :expression))
-                                   (cdr form))))
-          ((funcall-form-p form)
-           `(js:funcall ,(compile-parenscript-form (if (symbolp (car form))
-                                                       (maybe-rename-local-function (car form))
-                                                       (ps-macroexpand (car form)))
-                                                   :expecting :expression)
-                        ,@(mapcar (lambda (arg)
-                                    (compile-parenscript-form (ps-macroexpand arg) :expecting :expression))
-                                  (cdr form))))
-          (t (error "Cannot compile ~S to a ParenScript form." form)))))
+    (let ((*ps-compilation-level*
+           (if expanded-p
+               *ps-compilation-level*
+               (adjust-ps-compilation-level form *ps-compilation-level*))))
+      (cond (expanded-p
+             (ps-compile form))
+            ((ps-special-form-p form)
+             (apply (get-ps-special-form (car form)) (cdr form)))
+            ((comparison-form-p form)
+             (multiple-value-bind (form fixed?)
+                 (maybe-fix-nary-comparison-form form)
+               (if fixed?
+                   (ps-compile form)
+                   (compile-op-form form))))
+            ((op-form-p form)
+             (compile-op-form form))
+            ((method-call-form-p form)
+	     (compile-method-call-form form))
+            ((funcall-form-p form)
+             (compile-funcall-form form))
+	    (t (error "Cannot compile ~S to a ParenScript form." form))))))
+
+(defun ps-compile-statement (form)
+  (let ((compile-expression? nil))
+    (ps-compile form)))
+
+(defun ps-compile-expression (form)
+  (let ((compile-expression? t))
+    (ps-compile form)))
 
 (defvar *ps-gensym-counter* 0)