X-Git-Url: https://git.hcoop.net/clinton/parenscript.git/blobdiff_plain/79630c82ac03066ceb1dac50015eb6b7a2151bbe..c2c51a3db0b1bff4be5cf2afc8166f8220edfade:/src/compiler.lisp

diff --git a/src/compiler.lisp b/src/compiler.lisp
index c663635..a55fe46 100644
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -1,14 +1,23 @@
-(in-package :parenscript)
+(in-package "PARENSCRIPT")
 
 ;;; 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
 
@@ -18,16 +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 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*))
@@ -51,74 +55,61 @@ lexical block.")
 
 (defvar *ps-special-variables* ())
 
+(defun ps-special-variable-p (sym)
+  (member sym *ps-special-variables*))
+
 ;;; 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 funcall-form-p (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)
        (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))
-  (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-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.")
-  
-  (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)))
@@ -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)
-          (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)
-  `(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
@@ -164,114 +155,198 @@ CL environment)."
           (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
-(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."
-  (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))
 
-(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)
-  (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)
-  (case (ensure-ps-symbol op)
+  (case op
     (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"))
-  (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.