Corrected reference doc to explain 'var' special form as 'global variable' instead...

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

diff --git a/src/compiler.lisp b/src/compiler.lisp
index bdbe625..2284970 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -1,13 +1,39 @@
 (in-package :parenscript)
 
 (in-package :parenscript)
 

-(defvar *ps-literals* ())
-(defvar *ps-special-forms* ())
+(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))

 
 

-(defun undefine-ps-special-form (name)
+(defclass parenscript-symbol ()
+  ((name :initarg :name :accessor name-of)))
+
+(defmethod print-object ((obj parenscript-symbol) stream)
+  (format stream "~a" (name-of obj)))
+
+(defun find-ps-symbol (symbol)
+  (multiple-value-bind (sym hit?) (gethash (string symbol) *ps-symbols*)
+    (when hit? sym)))
+
+(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 get-ps-special-form (name)
+  "Returns the special form function corresponding to the given name."
+  (gethash (find-ps-symbol name) *ps-special-forms*))
+
+(defun add-ps-literal (name &aux (sym (ps-intern name)))
+  (setf (gethash sym *ps-literals*) sym))
+
+(defun undefine-ps-special-form (name &aux (sym (ps-intern name)))

   "Undefines the special form with the given name (name is a symbol)."
   "Undefines the special form with the given name (name is a symbol)."

-  (setf *ps-special-forms* (delete name *ps-special-forms*)
-        *ps-literals* (delete name *ps-literals*))
-  (unintern (lisp-symbol-to-ps-identifier name :special-form) :parenscript-special-forms))
+  (remhash sym *ps-special-forms*)
+  (remhash sym *ps-literals*)
+  t)

 
 (defmacro define-ps-special-form (name lambda-list &rest body)
   "Define a special form NAME. The first argument given to the special
 
 (defmacro define-ps-special-form (name lambda-list &rest body)
   "Define a special form NAME. The first argument given to the special


@@ -15,23 +41,19 @@ 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-")))
 an :expression or a :statement. The resulting Parenscript language
 types are appended to the ongoing javascript compilation."
   (let ((arglist (gensym "ps-arglist-")))

-    `(progn (pushnew ',name *ps-special-forms*)
-      (defun ,(lisp-symbol-to-ps-identifier name :special-form) (&rest ,arglist)
-        (destructuring-bind ,lambda-list
-            ,arglist
-          ,@body)))))
-
-(defun get-ps-special-form (name)
-  "Returns the special form function corresponding to the given name."
-  (lisp-symbol-to-ps-identifier name :special-form))
+    `(setf (gethash (ps-intern ',name) *ps-special-forms*)
+           (lambda (&rest ,arglist)
+             (destructuring-bind ,lambda-list
+                 ,arglist
+               ,@body)))))

 
 (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
 function definitions and lambdas). Enclosed special forms are expected
 to push variable declarations onto the list when the variables
 
 (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
 function definitions and lambdas). Enclosed special forms are expected
 to push variable declarations onto the list when the variables

-declaration cannot be made by the enclosed form (for example, a
-(x,y,z) expression progn). It is then the responsibility of the
+declaration cannot be made by the enclosed form \(for example, a
+\(x,y,z\) expression progn\). It is then the responsibility of the

 enclosing special form to introduce the variable bindings in its
 lexical block.")
 
 enclosing special form to introduce the variable bindings in its
 lexical block.")
 


@@ -41,10 +63,10 @@ lexical block.")
 (defun ps-special-form-p (form)
   (and (consp form)
        (symbolp (car form))
 (defun ps-special-form-p (form)
   (and (consp form)
        (symbolp (car form))

-       (member (car form) *ps-special-forms*)))
+       (gethash (find-ps-symbol (car form)) *ps-special-forms*)))

 
 (defun ps-literal-p (symbol)
 
 (defun ps-literal-p (symbol)

-  (member symbol *ps-literals*))
+  (gethash (find-ps-symbol symbol) *ps-literals*))

 
 (defun op-form-p (form)
   (and (listp form)
 
 (defun op-form-p (form)
   (and (listp form)


@@ -66,13 +88,13 @@ lexical block.")
   (defun make-macro-env-dictionary ()
     "Creates a standard macro dictionary."
     (make-hash-table :test #'equal))
   (defun make-macro-env-dictionary ()
     "Creates a standard macro dictionary."
     (make-hash-table :test #'equal))

-  (defvar *script-macro-toplevel* (make-macro-env-dictionary)
+  (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 of the
 macro, value is (symbol-macro-p . expansion-function).")

-  (defvar *script-macro-env* (list *script-macro-toplevel*)
+  (defvar *ps-macro-env* (list *ps-macro-toplevel*)

     "Current macro environment.")
 
     "Current macro environment.")
 

-  (defvar *script-setf-expanders* (make-macro-env-dictionary)
+  (defvar *ps-setf-expanders* (make-macro-env-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
     "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


@@ -81,12 +103,12 @@ 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)."
   (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 (lisp-symbol-to-ps-identifier name :macro) env-dict))
+    (gethash (find-ps-symbol name) env-dict))

   (defsetf get-macro-spec (name env-dict)
       (spec)
   (defsetf get-macro-spec (name env-dict)
       (spec)

-    `(setf (gethash (lisp-symbol-to-ps-identifier ,name :macro) ,env-dict) ,spec)))
+    `(setf (gethash (ps-intern ,name) ,env-dict) ,spec)))

 
 

-(defun lookup-macro-spec (name &optional (environment *script-macro-env*))
+(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.
   "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.


@@ -99,19 +121,19 @@ NAME must be a symbol."
         (when val
           (return-from lookup-macro-spec
             (values val (or (cdr env)
         (when val
           (return-from lookup-macro-spec
             (values val (or (cdr env)

-                            (list *script-macro-toplevel*)))))))))
+                            (list *ps-macro-toplevel*)))))))))

 
 

-(defun script-symbol-macro-p (name &optional (environment *script-macro-env*))
+(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))))
 
   "True if there is a Parenscript symbol macro named by the symbol NAME."
   (and (symbolp name) (car (lookup-macro-spec name environment))))
 

-(defun script-macro-p (name &optional (environment *script-macro-env*))
+(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))))))
 
   "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 *script-macro-env*))
+(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."
   "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."


@@ -130,21 +152,21 @@ function and the parent macro environment of the macro."
                          (cdr ,form-arg)
                        ,@body)))))
       
                          (cdr ,form-arg)
                        ,@body)))))
       

-  (defun define-script-macro% (name args body &key symbol-macro-p)
+  (defun define-ps-macro% (name args body &key symbol-macro-p)

     (undefine-ps-special-form name)
     (undefine-ps-special-form name)

-    (setf (get-macro-spec name *script-macro-toplevel*)
+    (setf (get-macro-spec name *ps-macro-toplevel*)

           (cons symbol-macro-p (make-ps-macro-function args body)))
     nil))
 
 (defmacro defpsmacro (name args &body body)
   "Define a ParenScript macro, and store it in the toplevel ParenScript
 macro environment."
           (cons symbol-macro-p (make-ps-macro-function args body)))
     nil))
 
 (defmacro defpsmacro (name args &body body)
   "Define a ParenScript macro, and store it in the toplevel ParenScript
 macro environment."

-  `(define-script-macro% ',name ',args ',body :symbol-macro-p nil))
+  `(define-ps-macro% ',name ',args ',body :symbol-macro-p nil))

 
 

-(defmacro define-script-symbol-macro (name &body body)
+(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 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-script-macro% ',name () ',body :symbol-macro-p t))
+  `(define-ps-macro% ',name () ',body :symbol-macro-p t))

 
 (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


@@ -152,7 +174,7 @@ 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)
 it is first fully macroexpanded in the Lisp macro environment, and
 then that expansion is further expanded by ParenScript."
   (dolist (name names)

-    (define-script-macro% name '(&rest args) 
+    (define-ps-macro% name '(&rest args)

       (list `(common-lisp:macroexpand `(,',name ,@args)))
       :symbol-macro-p nil)))
 
       (list `(common-lisp:macroexpand `(,',name ,@args)))
       :symbol-macro-p nil)))
 


@@ -177,11 +199,11 @@ whether any expansion was performed on the form or not."
   (if (consp form)
       (let ((op (car form))
             (args (cdr form)))
   (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
+        (cond ((equal op 'quote) (values (if (equalp '(nil) args) nil form) ; leave quotes alone, unless it's a quoted nil

                                          nil))
                                          nil))

-              ((script-macro-p op) (values (ps-macroexpand (funcall (lookup-macro-expansion-function op) form)) t))
+              ((ps-macro-p op) (values (ps-macroexpand (funcall (lookup-macro-expansion-function op) form)) t))

               (t (values form nil))))
               (t (values form nil))))

-      (cond ((script-symbol-macro-p form) (values (ps-macroexpand (funcall (lookup-macro-expansion-function form) (list form))) t))
+      (cond ((ps-symbol-macro-p form) (values (ps-macroexpand (funcall (lookup-macro-expansion-function form) (list form))) t))

             (t (values form nil)))))
 
 ;;;; compiler interface
             (t (values form nil)))))
 
 ;;;; compiler interface


@@ -207,7 +229,7 @@ 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)
 the form cannot be compiled to a symbol."
   (let ((exp (compile-parenscript-form form)))
     (when (or (eql (first exp) 'js-variable)

-              (eql (first exp) 'script-quote))
+              (eql (first exp) 'ps-quote))

       (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)
       (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)


@@ -244,7 +266,7 @@ 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."
   (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) 'script-quote)) (second arg))))
+           (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)
     (let ((compiled-args (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :expression))
                                  arg-forms)))
       (do ((effective-expressions nil)


@@ -261,16 +283,25 @@ the keyword for it."
               (progn (push arg-expr effective-expressions)
                      (setf expressions-subl (rest expressions-subl)))))))))
 
               (progn (push arg-expr effective-expressions)
                      (setf expressions-subl (rest expressions-subl)))))))))
 

+(defun ps-convert-op-name (op)
+  (case (ensure-ps-symbol 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)
 (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 'script-quote (first 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-special-form-p form) (apply (get-ps-special-form name) (cons expecting args)))
           ((op-form-p form)
            (list 'operator

-                 (script-convert-op-name (compile-parenscript-form (first form) :expecting :symbol))
+                 (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
                  (mapcar (lambda (form) (compile-parenscript-form form :expecting :expression)) (rest form))))
           ((method-call-p form)
            (list 'js-method-call


@@ -303,3 +334,16 @@ gensym-prefix-string)."
                           `(,symbol (ps-gensym ,(symbol-to-js symbol))))))
                   symbols)
      ,@body))
                           `(,symbol (ps-gensym ,(symbol-to-js symbol))))))
                   symbols)
      ,@body))

+
+(defun %check-once-only-vars (vars)
+  (let ((bad-var (find-if (lambda (x) (or (not (symbolp x)) (keywordp x))) vars)))
+    (when bad-var
+      (error "PS-ONLY-ONCE expected a non-keyword symbol but got ~s" bad-var))))
+
+(defmacro ps-once-only ((&rest vars) &body body)
+  (%check-once-only-vars vars)
+  (let ((gensyms (mapcar (lambda (x) (ps-gensym (string x))) vars)))
+    `(let ,(mapcar (lambda (g v) `(,g (ps-gensym ,(string v)))) gensyms vars)
+       `(let* (,,@(mapcar (lambda (g v) ``(,,g ,,v)) gensyms vars))
+          ,(let ,(mapcar (lambda (g v) `(,v ,g)) gensyms vars)
+             ,@body)))))