Expand compound symbol (warning: very lightly tested)

[clinton/parenscript.git] / src / compiler.lisp

diff --git a/src/compiler.lisp b/src/compiler.lisp
index c663635..a55fe46 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -1,14 +1,23 @@
-(in-package :parenscript)
+(in-package "PARENSCRIPT")

 
 ;;; reserved symbols/literals
 
 
 ;;; reserved symbols/literals
 

-(defvar *ps-reserved-symbol-names* ()) ;; symbol names reserved for PS/JS literals
+(defvar *ps-reserved-symbol-names*
+  (list "break" "case" "catch" "continue" "default" "delete" "do" "else"
+        "finally" "for" "function" "if" "in" "instanceof" "new" "return"
+        "switch" "this" "throw" "try" "typeof" "var" "void" "while" "with"
+        "abstract" "boolean" "byte" "char" "class" "const" "debugger" "double"
+        "enum" "export" "extends" "final" "float" "goto" "implements" "import"
+        "int" "interface" "long" "native" "package" "private" "protected"
+        "public" "short" "static" "super" "synchronized" "throws" "transient"
+        "volatile"))

 
 

-(defun add-ps-literal (name)
-  (push (symbol-name name) *ps-reserved-symbol-names*))
+(defun add-ps-reserved-symbol (name)
+  (pushnew (symbol-name-to-js-string name) *ps-reserved-symbol-names* :test #'equalp))

 
 

-(defun ps-literal-p (symbol)
-  (find (symbol-name symbol) *ps-reserved-symbol-names* :test #'equalp))
+(defun ps-reserved-symbol-p (symbol)
+  (when (symbolp symbol)
+    (find (symbol-name-to-js-string symbol) *ps-reserved-symbol-names* :test #'equalp)))

 
 ;;; special forms
 
 
 ;;; special forms
 


@@ -18,16 +27,11 @@
   (gethash name *ps-special-forms*))
 
 (defmacro define-ps-special-form (name lambda-list &rest body)
   (gethash name *ps-special-forms*))
 
 (defmacro define-ps-special-form (name lambda-list &rest body)

-  "Define a special form NAME. The first argument given to the special
-form is a keyword indicating whether the form is expected to produce
-an :expression or a :statement. The resulting Parenscript language
-types are appended to the ongoing javascript compilation."
-  (let ((arglist (gensym "ps-arglist-")))
-    `(setf (gethash ',name *ps-special-forms*)
-           (lambda (&rest ,arglist)
-             (destructuring-bind ,lambda-list
-                 ,arglist
-               ,@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*))
 
 (defun undefine-ps-special-form (name)
   (remhash name *ps-special-forms*))


@@ -51,74 +55,61 @@ lexical block.")
 
 (defvar *ps-special-variables* ())
 
 
 (defvar *ps-special-variables* ())
 

+(defun ps-special-variable-p (sym)
+  (member sym *ps-special-variables*))
+

 ;;; form predicates
 
 ;;; 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 op-form-p (form)
   (and (listp form)
        (not (ps-special-form-p form))
        (not (null (op-precedence (first form))))))
 

-(defun funcall-form-p (form)
+(defun method-call-form-p (form)

   (and (listp form)
   (and (listp form)

+       (symbolp (car form))
+       (char= #\. (char (symbol-name (car form)) 0))))
+
+(defun funcall-form-p (form)
+  (and form
+       (listp form)

        (not (op-form-p form))
        (not (ps-special-form-p form))))
 
 ;;; macro expansion
 (eval-when (:compile-toplevel :load-toplevel :execute)
        (not (op-form-p form))
        (not (ps-special-form-p form))))
 
 ;;; macro expansion
 (eval-when (:compile-toplevel :load-toplevel :execute)

-  (defun make-macro-env-dictionary ()
+  (defun make-macro-dictionary ()

     (make-hash-table :test 'eq))
     (make-hash-table :test 'eq))

-  (defvar *ps-macro-toplevel* (make-macro-env-dictionary)
-    "Toplevel macro environment dictionary. Key is the symbol name of
-    the macro, value is (symbol-macro-p . expansion-function).")
+  
+  (defvar *ps-macro-toplevel* (make-macro-dictionary)
+    "Toplevel macro environment dictionary.")
+

   (defvar *ps-macro-env* (list *ps-macro-toplevel*)
     "Current macro environment.")
 
   (defvar *ps-macro-env* (list *ps-macro-toplevel*)
     "Current macro environment.")
 

-  (defvar *ps-setf-expanders* (make-macro-env-dictionary)
+  (defvar *ps-symbol-macro-toplevel* (make-macro-dictionary))
+
+  (defvar *ps-symbol-macro-env* (list *ps-symbol-macro-toplevel*))
+
+  (defvar *ps-local-function-names* ())
+
+  (defvar *ps-setf-expanders* (make-macro-dictionary)

     "Setf expander dictionary. Key is the symbol of the access
 function of the place, value is an expansion function that takes the
 arguments of the access functions as a first value and the form to be
 stored as the second value.")
     "Setf expander dictionary. Key is the symbol of the access
 function of the place, value is an expansion function that takes the
 arguments of the access functions as a first value and the form to be
 stored as the second value.")

-  
-  (defun get-macro-spec (name env-dict)
-    "Retrieves the macro spec of the given name with the given environment dictionary.
-SPEC is of the form (symbol-macro-p . expansion-function)."
-    (gethash name env-dict))
-  (defsetf get-macro-spec (name env-dict)
-      (spec)
-    `(setf (gethash ,name ,env-dict) ,spec)))
-
-(defun lookup-macro-spec (name &optional (environment *ps-macro-env*))
-  "Looks up the macro spec associated with NAME in the given environment.  A
-macro spec is of the form (symbol-macro-p . function). Returns two values:
-the SPEC and the parent macro environment.
-
-NAME must be a symbol."
-  (when (symbolp name)
-    (do ((env environment (cdr env)))
-        ((null env) nil)
-      (let ((val (get-macro-spec name (car env))))
-        (when val
-          (return-from lookup-macro-spec
-            (values val (or (cdr env)
-                            (list *ps-macro-toplevel*)))))))))
-
-(defun ps-symbol-macro-p (name &optional (environment *ps-macro-env*))
-  "True if there is a Parenscript symbol macro named by the symbol NAME."
-  (and (symbolp name) (car (lookup-macro-spec name environment))))
-
-(defun ps-macro-p (name &optional (environment *ps-macro-env*))
-  "True if there is a Parenscript macro named by the symbol NAME."
-  (and (symbolp name)
-       (let ((macro-spec (lookup-macro-spec name environment)))
-         (and macro-spec (not (car macro-spec))))))
-
-(defun lookup-macro-expansion-function (name &optional (environment *ps-macro-env*))
-  "Lookup NAME in the given macro expansion environment (which
-defaults to the current macro environment). Returns the expansion
-function and the parent macro environment of the macro."
-  (multiple-value-bind (macro-spec parent-env)
-      (lookup-macro-spec name environment)
-    (values (cdr macro-spec) parent-env)))
+
+  (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 ps-compile-*
+nil indicates we are no longer toplevel-related."))
+
+(defun lookup-macro-def (name env)
+  (loop for e in env thereis (gethash name e)))

 
 (defun make-ps-macro-function (args body)
   (let* ((whole-var (when (eql '&whole (first args)) (second args)))
 
 (defun make-ps-macro-function (args body)
   (let* ((whole-var (when (eql '&whole (first args)) (second args)))


@@ -131,14 +122,14 @@ function and the parent macro environment of the macro."
 
 (defmacro defpsmacro (name args &body body)
   `(progn (undefine-ps-special-form ',name)
 
 (defmacro defpsmacro (name args &body body)
   `(progn (undefine-ps-special-form ',name)

-          (setf (get-macro-spec ',name *ps-macro-toplevel*)
-                (cons nil ,(make-ps-macro-function args body)))
+          (setf (gethash ',name *ps-macro-toplevel*) ,(make-ps-macro-function args body))

           ',name))
 
 (defmacro define-ps-symbol-macro (symbol expansion)
           ',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 (gethash ',symbol *ps-symbol-macro-toplevel*) (lambda (,x) (declare (ignore ,x)) ',expansion))
+            ',symbol)))

 
 (defun import-macros-from-lisp (&rest names)
   "Import the named Lisp macros into the ParenScript macro
 
 (defun import-macros-from-lisp (&rest names)
   "Import the named Lisp macros into the ParenScript macro


@@ -164,114 +155,198 @@ CL environment)."
           (defpsmacro ,name ,args ,@body)))
 
 (defun ps-macroexpand (form)
           (defpsmacro ,name ,args ,@body)))
 
 (defun ps-macroexpand (form)

-  "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)))))
+  (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))
+
+(defun maybe-rename-local-function (fun-name)
+  (aif (lookup-macro-def fun-name *ps-local-function-names*)
+       it
+       fun-name))

 
 ;;;; compiler interface
 
 ;;;; 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."))
-
-(defmethod compile-parenscript-form :around (form &key expecting)
-  (assert (if expecting (member expecting '(:expression :statement :symbol)) t))
-  (if (eql expecting :symbol)
-      (compile-to-symbol form)
-      (multiple-value-bind (expanded-form expanded-p)
-          (ps-macroexpand form)
-        (if expanded-p
-            (compile-parenscript-form expanded-form :expecting expecting)
-            (call-next-method)))))
-
-(defun compile-to-symbol (form)
+(defun adjust-ps-compilation-level (form level)
+  "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."
   "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)))
-    (when (or (eql (first exp) 'js-variable)
-              (eql (first exp) 'ps-quote))
+  (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))
 
       (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))
 
   (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)
 
   form)
 

-(defmethod compile-parenscript-form ((form string) &key expecting)
-  (declare (ignore expecting))
+(defmethod ps-compile ((form string))

   form)
 
   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)
-  (declare (ignore expecting))
-  (cond ((keywordp symbol) symbol)
-        ((ps-special-form-p (list symbol))
-         (if (ps-literal-p symbol)
-             (funcall (get-ps-special-form symbol) :symbol)
-             (error "Attempting to use Parenscript special form ~a as variable" symbol)))
-        (t (list 'js-variable symbol))))
-
-(defun compile-function-argument-forms (args)
-  (let ((remaining-args args))
-    (loop while remaining-args collecting
-         (if (keywordp (first remaining-args))
-             (prog2 (when (oddp (length remaining-args))
-                      (error "Odd number of keyword arguments: ~A." args))
-                 (compile-parenscript-form (cons 'create remaining-args) :expecting :expression)
-               (setf remaining-args nil))
-             (prog1 (compile-parenscript-form (first remaining-args) :expecting :expression)
-               (setf remaining-args (cdr remaining-args)))))))
+(defmethod ps-compile ((form character))
+  (ps-compile (string form)))
+
+(defun compound-symbol-p (symbol)
+  (let ((split (split-sequence:split-sequence #\. (symbol-name symbol))))
+    (break "~A = ~A" symbol split)
+    (if (cdr split)
+       (reduce
+        (lambda (&optional slot-name object-exp)
+          `(js:slot-value ,object-exp ,(make-symbol slot-name)))
+        (reverse (cddr split))
+        :initial-value `(slot-value
+                         (js:variable ,(ps-macroexpand
+                                        (intern (car split)
+                                                (symbol-package symbol))))
+                         ,(make-symbol (cadr split)))
+        :from-end t)
+       nil)))
+
+(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 (aif (compound-symbol-p symbol)
+                     it
+                     `(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)
 
 (defun ps-convert-op-name (op)

-  (case (ensure-ps-symbol op)
+  (case op

     (and '\&\&)
     (or '\|\|)
     (not '!)
     (eql '\=\=)
     (=   '\=\=)
     (and '\&\&)
     (or '\|\|)
     (not '!)
     (eql '\=\=)
     (=   '\=\=)

-    (t op)))
-
-(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)))
-          ((op-form-p form)
-           (list 'operator
-                 (ps-convert-op-name (compile-parenscript-form (first form) :expecting :symbol))
-                 (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form))))
-          ((funcall-form-p form)
-           (list 'js-funcall
-                 (compile-parenscript-form name :expecting :expression)
-                 (compile-function-argument-forms args)))
-          (t (error "Cannot compile ~S to a ParenScript form." form)))))
+   (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 function-name->js-expression (name)
+  (aif (compound-symbol-p name)
+       it
+       `(js:variable ,(maybe-rename-local-function name))))
+
+(defun compile-funcall-form (form)
+  `(js:funcall
+    ,(if (symbolp (car form))
+         (function-name->js-expression (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)
+    (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)
 
 (defun ps-gensym (&optional (prefix "_js"))
 
 (defvar *ps-gensym-counter* 0)
 
 (defun ps-gensym (&optional (prefix "_js"))

-  (make-symbol (format nil "~A~A" prefix (incf *ps-gensym-counter*))))
+  (let ((prefix (if (stringp prefix) prefix (symbol-to-js-string prefix nil))))
+    (make-symbol (format nil "~A~:[~;_~]~A" prefix
+                         (digit-char-p (char prefix (1- (length prefix))))
+                         (incf *ps-gensym-counter*)))))

 
 (defmacro with-ps-gensyms (symbols &body body)
   "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
 
 (defmacro with-ps-gensyms (symbols &body body)
   "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.