-(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
(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*))
(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)))
(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
(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.
HCoop / clinton / parenscript.git / blobdiff