X-Git-Url: http://git.hcoop.net/clinton/parenscript.git/blobdiff_plain/3b16a7f3d31bbf3360c4a44f487e9a501c0aa235..5ffb1ebaaff5e8f899fd4b1bd91b015f2c52d656:/src/compiler.lisp

diff --git a/src/compiler.lisp b/src/compiler.lisp
index e4b0301..0cc8dc7 100644
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -1,48 +1,45 @@
-(in-package :parenscript)
+(in-package "PARENSCRIPT")
 
-(defvar *ps-symbols* (make-hash-table :test 'equal))
-(defvar *ps-literals* (make-hash-table :test 'eq))
-(defvar *ps-special-forms* (make-hash-table :test 'eq))
+;;; reserved symbols/literals
 
-(defclass parenscript-symbol ()
-  ((name :initarg :name :accessor name-of)))
+(defvar *ps-reserved-symbol-names* ()) ;; symbol names reserved for PS/JS literals
 
-(defmethod print-object ((obj parenscript-symbol) stream)
-  (format stream "~a" (name-of obj)))
+(defun add-ps-literal (name)
+  (push (symbol-name name) *ps-reserved-symbol-names*))
 
-(defun ps-intern (thing)
-  (if (typep thing 'parenscript-symbol) thing
-      (let ((str (string thing)))
-        (multiple-value-bind (sym hit?) (gethash str *ps-symbols*)
-          (if hit? sym
-              (setf (gethash str *ps-symbols*)
-                    (make-instance 'parenscript-symbol :name str)))))))
+(defun ps-literal-p (symbol)
+  (find (symbol-name symbol) *ps-reserved-symbol-names* :test #'equalp))
 
-(defun get-ps-special-form (name)
-  "Returns the special form function corresponding to the given name."
-  (gethash (ps-intern name) *ps-special-forms*))
+;;; special forms
 
-(defun add-ps-literal (name &aux (sym (ps-intern name)))
-  (setf (gethash sym *ps-literals*) sym))
+(defvar *ps-special-forms* (make-hash-table :test 'eq))
 
-(defun undefine-ps-special-form (name &aux (sym (ps-intern name)))
-  "Undefines the special form with the given name (name is a symbol)."
-  (remhash sym *ps-special-forms*)
-  (remhash sym *ps-literals*)
-  t)
+(defun get-ps-special-form (name)
+  (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 (ps-intern ',name) *ps-special-forms*)
-           (lambda (&rest ,arglist)
-             (destructuring-bind ,lambda-list
-                 ,arglist
+  "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)))))
 
+(defun undefine-ps-special-form (name)
+  (remhash name *ps-special-forms*))
+
+(defun ps-special-form-p (form)
+  (and (consp form)
+       (symbolp (car form))
+       (gethash (car form) *ps-special-forms*)))
+
+;;; scoping
+
 (defvar *enclosing-lexical-block-declarations* ()
   "This special variable is expected to be bound to a fresh list by
 special forms that introduce a new JavaScript lexical block (currently
@@ -55,14 +52,10 @@ lexical block.")
 
 (defvar *ps-special-variables* ())
 
-;;; ParenScript form predicates
-(defun ps-special-form-p (form)
-  (and (consp form)
-       (symbolp (car form))
-       (gethash (ps-intern (car form)) *ps-special-forms*)))
+(defun ps-special-variable-p (sym)
+  (member sym *ps-special-variables*))
 
-(defun ps-literal-p (symbol)
-  (gethash (ps-intern symbol) *ps-literals*))
+;;; form predicates
 
 (defun op-form-p (form)
   (and (listp form)
@@ -74,19 +67,14 @@ lexical block.")
        (not (op-form-p form))
        (not (ps-special-form-p form))))
 
-(defun method-call-p (form)
-  (and (funcall-form-p form)
-       (symbolp (first form))
-       (eql (char (symbol-name (first form)) 0) #\.)))
-
 ;;; macro expansion
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun make-macro-env-dictionary ()
-    "Creates a standard macro dictionary."
-    (make-hash-table :test #'equal))
+    (make-hash-table :test 'eq))
   (defvar *ps-macro-toplevel* (make-macro-env-dictionary)
-    "Toplevel macro environment dictionary. Key is the symbol of the
-macro, value is (symbol-macro-p . expansion-function).")
+    "Toplevel macro environment dictionary. Key is the symbol name of
+    the macro, value is (symbol-macro-p . expansion-function).")
+
   (defvar *ps-macro-env* (list *ps-macro-toplevel*)
     "Current macro environment.")
 
@@ -95,14 +83,20 @@ macro, value is (symbol-macro-p . expansion-function).")
 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.")
+
+  (defparameter *toplevel-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
+nil indicates we are no longer toplevel-related.")
   
   (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 (ps-intern name) env-dict))
+    (gethash name env-dict))
   (defsetf get-macro-spec (name env-dict)
       (spec)
-    `(setf (gethash (ps-intern ,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
@@ -137,32 +131,26 @@ function and the parent macro environment of the macro."
       (lookup-macro-spec name environment)
     (values (cdr macro-spec) parent-env)))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defun make-ps-macro-function (args body)
-    (let* ((whole-var (when (eql '&whole (first args)) (second args)))
-           (effective-lambda-list (if whole-var (cddr args) args))
-           (form-arg (or whole-var (gensym "ps-macro-form-arg-")))
-           (body (if (and (cdr body) (stringp (first body))) (rest body) body))) ;; drop docstring
-      (compile nil `(lambda (,form-arg)
-                     (destructuring-bind ,effective-lambda-list
-                         (cdr ,form-arg)
-                       ,@body)))))
-      
-  (defun define-ps-macro% (name args body &key symbol-macro-p)
-    (undefine-ps-special-form name)
-    (setf (get-macro-spec name *ps-macro-toplevel*)
-          (cons symbol-macro-p (make-ps-macro-function args body)))
-    nil))
+(defun make-ps-macro-function (args body)
+  (let* ((whole-var (when (eql '&whole (first args)) (second args)))
+         (effective-lambda-list (if whole-var (cddr args) args))
+         (whole-arg (or whole-var (gensym "ps-macro-form-arg-"))))
+    `(lambda (,whole-arg)
+       (destructuring-bind ,effective-lambda-list
+           (cdr ,whole-arg)
+         ,@body))))
 
 (defmacro defpsmacro (name args &body body)
-  "Define a ParenScript macro, and store it in the toplevel ParenScript
-macro environment."
-  `(define-ps-macro% ',name ',args ',body :symbol-macro-p nil))
+  `(progn (undefine-ps-special-form ',name)
+          (setf (get-macro-spec ',name *ps-macro-toplevel*)
+                (cons nil ,(make-ps-macro-function args body)))
+          ',name))
 
-(defmacro define-ps-symbol-macro (name &body body)
-  "Define a ParenScript symbol macro, and store it in the toplevel ParenScript
-macro environment.  BODY is a Lisp form that should return a ParenScript form."
-  `(define-ps-macro% ',name () ',body :symbol-macro-p t))
+(defmacro define-ps-symbol-macro (symbol expansion)
+  (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
@@ -170,21 +158,20 @@ environment. When the imported macro is macroexpanded by ParenScript,
 it is first fully macroexpanded in the Lisp macro environment, and
 then that expansion is further expanded by ParenScript."
   (dolist (name names)
-    (define-ps-macro% name '(&rest args)
-      (list `(common-lisp:macroexpand `(,',name ,@args)))
-      :symbol-macro-p nil)))
+    (eval `(defpsmacro ,name (&rest args)
+             (macroexpand `(,',name ,@args))))))
 
 (defmacro defmacro/ps (name args &body body)
   "Define a Lisp macro and import it into the ParenScript macro environment."
   `(progn (defmacro ,name ,args ,@body)
-          (ps:import-macros-from-lisp ',name)))
+          (import-macros-from-lisp ',name)))
 
 (defmacro defmacro+ps (name args &body body)
-  "Define a Lisp macro and a ParenScript macro in their respective
-macro environments. This function should be used when you want to use
-the same macro in both Lisp and ParenScript, but the 'macroexpand' of
-that macro in Lisp makes the Lisp macro unsuitable to be imported into
-the ParenScript macro environment."
+  "Define a Lisp macro and a ParenScript macro with the same macro
+function (ie - the same result from macroexpand-1), for cases when the
+two have different full macroexpansions (for example if the CL macro
+contains implementation-specific code when macroexpanded fully in the
+CL environment)."
   `(progn (defmacro ,name ,args ,@body)
           (defpsmacro ,name ,args ,@body)))
 
@@ -192,15 +179,11 @@ the ParenScript macro 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) (list 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)
@@ -209,6 +192,16 @@ ParenScript representation. :expecting determines whether the form is
 compiled to an :expression (the default), a :statement, or a
 :symbol."))
 
+(defun adjust-toplevel-compilation-level (form level)
+  (let ((default-level (if (eql :toplevel level)
+			   :inside-toplevel-form
+			   nil)))
+    (if (consp form)
+	(case (car form)
+	  ('progn level)
+	  (t default-level))
+	default-level)))
+
 (defmethod compile-parenscript-form :around (form &key expecting)
   (assert (if expecting (member expecting '(:expression :statement :symbol)) t))
   (if (eql expecting :symbol)
@@ -217,15 +210,17 @@ compiled to an :expression (the default), a :statement, or a
           (ps-macroexpand form)
         (if expanded-p
             (compile-parenscript-form expanded-form :expecting expecting)
-            (call-next-method)))))
+	    (let ((*toplevel-compilation-level*
+		   (progn
+		     (adjust-toplevel-compilation-level form *toplevel-compilation-level*))))
+	      (call-next-method))))))
 
 (defun compile-to-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))
+    (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)
@@ -249,38 +244,15 @@ the form cannot be compiled to a symbol."
 
 (defmethod compile-parenscript-form ((symbol symbol) &key expecting)
   (declare (ignore expecting))
-  (cond ((ps-special-form-p (list symbol))
+  (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 (arg-forms)
-  "Compiles a bunch of Parenscript forms from a funcall form to an effective set of
-Javascript arguments.  The only extra processing this does is makes :keyword arguments
-into a single options argument via CREATE."
-  (flet ((keyword-arg (arg)
-           "If the given compiled expression is supposed to be a keyword argument, returns
-the keyword for it."
-           (when (and (listp arg) (eql (first arg) 'ps-quote)) (second arg))))
-    (let ((compiled-args (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression))
-                                 arg-forms)))
-      (do ((effective-expressions nil)
-           (expressions-subl compiled-args))
-          ((not expressions-subl) (reverse effective-expressions))
-        (let ((arg-expr (first expressions-subl)))
-          (if (keyword-arg arg-expr)
-              (progn (when (oddp (length expressions-subl))
-                       (error "Odd number of keyword arguments: ~A." arg-forms))
-                     (push (list 'js-object (loop for (name val) on expressions-subl by #'cddr
-                                                  collect (list name val)))
-                           effective-expressions)
-                     (setf expressions-subl nil))
-              (progn (push arg-expr effective-expressions)
-                     (setf expressions-subl (rest expressions-subl)))))))))
+        (t `(js:variable ,symbol))))
 
 (defun ps-convert-op-name (op)
-  (case (ensure-ps-symbol op)
+  (case op
     (and '\&\&)
     (or '\|\|)
     (not '!)
@@ -291,29 +263,23 @@ the keyword for it."
 (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))
-                 (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form))))
-          ((method-call-p form)
-           (list 'js-method-call
-                 (compile-parenscript-form name :expecting :symbol)
-                 (compile-parenscript-form (first args) :expecting :expression)
-                 (compile-function-argument-forms (rest args))))
+           `(js: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)))
+           `(js:funcall ,(compile-parenscript-form name :expecting :expression)
+             ,@(mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression)) args)))
           (t (error "Cannot compile ~S to a ParenScript form." 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.
@@ -327,7 +293,7 @@ gensym-prefix-string)."
                             (list symbol))
                       (if prefix
                           `(,symbol (ps-gensym ,prefix))
-                          `(,symbol (ps-gensym ,(symbol-to-js symbol))))))
+                          `(,symbol (ps-gensym ,(symbol-to-js-string symbol))))))
                   symbols)
      ,@body))
 
@@ -343,3 +309,34 @@ gensym-prefix-string)."
        `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars))
           ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars)
              ,@body)))))
+
+(defvar *read-function* #'read
+  "This should be a function that takes the same inputs and returns the same
+outputs as the common lisp read function.  We declare it as a variable to allow
+a user-supplied reader instead of the default lisp reader.")
+
+(defun ps-compile-stream (stream)
+  "Compiles a source stream as if it were a file.  Outputs a Javascript string."
+
+  (let ((*toplevel-compilation-level* :toplevel)
+	(*package* *package*)
+	(end-read-form '#:unique))
+    (flet ((read-form () (funcall *read-function* stream nil end-read-form)))
+      (let* ((js-string
+	      ;; cons up the forms, compiling as we go, and print the result
+	      (do ((form (read-form) (read-form))
+		   (compiled-forms nil))
+		  ((eql form end-read-form)
+		     (format nil "~{~A~^;~%~}"
+			     (remove-if
+			      #'(lambda (x) (or (null x) (= 0 (length x))))
+			      (mapcar 'compiled-form-to-string (nreverse compiled-forms)))))
+		(push (compile-parenscript-form form :expecting :statement) compiled-forms))))
+	js-string))))
+
+
+(defun ps-compile-file (source-file)
+  "Compiles the given Parenscript source file and returns a Javascript string."
+  (with-open-file (stream source-file :direction :input)
+    (ps-compile-stream stream)))
+