(in-package :parenscript)
-(defvar *ps-literals* ())
-(defvar *ps-special-forms* ())
+;;; reserved symbols/literals
-(defun get-ps-special-form (name)
- "Returns the special form function corresponding to the given name."
- (lisp-symbol-to-ps-identifier name :special-form))
+(defvar *ps-reserved-symbol-names* ()) ;; symbol names reserved for PS/JS literals
-(defun add-ps-literal (symbol)
- (pushnew (get-ps-special-form symbol) *ps-literals*))
+(defun add-ps-literal (name)
+ (push (symbol-name name) *ps-reserved-symbol-names*))
-(defun undefine-ps-special-form (name)
- "Undefines the special form with the given name (name is a symbol)."
- (setq name (get-ps-special-form name))
- (setf *ps-special-forms* (delete name *ps-special-forms*)
- *ps-literals* (delete name *ps-literals*))
- (unintern name :parenscript-special-forms))
+(defun ps-literal-p (symbol)
+ (find (symbol-name symbol) *ps-reserved-symbol-names* :test #'equalp))
+
+;;; special forms
+
+(defvar *ps-special-forms* (make-hash-table :test 'eq))
+
+(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."
- (setq name (get-ps-special-form name))
(let ((arglist (gensym "ps-arglist-")))
- `(progn (pushnew ',name *ps-special-forms*)
- (defun ,name (&rest ,arglist)
- (destructuring-bind ,lambda-list
- ,arglist
- ,@body)))))
+ `(setf (gethash ',name *ps-special-forms*)
+ (lambda (&rest ,arglist)
+ (destructuring-bind ,lambda-list
+ ,arglist
+ ,@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
(defvar *ps-special-variables* ())
-;;; ParenScript form predicates
-(defun ps-special-form-p (form)
- (and (consp form)
- (symbolp (car form))
- (member (get-ps-special-form (car form)) *ps-special-forms*)))
-
-(defun ps-literal-p (symbol)
- (member (get-ps-special-form symbol) *ps-literals*))
+;;; form predicates
(defun op-form-p (form)
(and (listp form)
(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.")
(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 name env-dict))
(defsetf get-macro-spec (name env-dict)
(spec)
- `(setf (gethash (lisp-symbol-to-ps-identifier ,name :macro) ,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
(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)
+ `(progn (undefine-ps-special-form ',symbol)
+ (setf (get-macro-spec ',symbol *ps-macro-toplevel*) (cons t (lambda () ',expansion)))
+ ',symbol))
(defun import-macros-from-lisp (&rest names)
"Import the named Lisp macros into the ParenScript macro
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)))
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))
+ (cond ((ps-symbol-macro-p form) (values (ps-macroexpand (funcall (lookup-macro-expansion-function form))) t))
(t (values form nil)))))
;;;; compiler interface
(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)))))))))
+(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)))))))
+
+(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))
(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))))
((funcall-form-p form)
(list 'js-funcall
(compile-parenscript-form name :expecting :expression)
(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))
HCoop / clinton / parenscript.git / blobdiff