(pushnew (symbol-name-to-js-string name) *ps-reserved-symbol-names* :test #'equalp))
(defun ps-reserved-symbol-p (symbol)
- (find (symbol-name-to-js-string symbol) *ps-reserved-symbol-names* :test #'equalp))
+ (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 (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)))))
+ `(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*))
;;; 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 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)
(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 compile-parenscript-form
+: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)
(defpsmacro ,name ,args ,@body)))
(defun ps-macroexpand (form)
- (aif (or (lookup-macro-def form *ps-symbol-macro-env*)
+ (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))
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."))
-
(defun adjust-ps-compilation-level (form level)
- (cond ((or (and (consp form) (eq 'progn (car form)))
- (and (symbolp form) (eq :toplevel level)))
- level)
- ((eq :toplevel level) :inside-toplevel-form)))
-
-(defmethod compile-parenscript-form :around (form &key expecting)
- (assert (if expecting (member expecting '(:expression :statement :symbol)) t))
- (if (eq expecting :symbol)
- (compile-to-symbol form)
- (let ((*ps-compilation-level* (adjust-ps-compilation-level form *ps-compilation-level*)))
- (call-next-method))))
-
-(defun compile-to-symbol (form)
+ "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 :expecting :expression)))
+ (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)
- (when (eq *ps-compilation-level* :toplevel)
- (multiple-value-bind (expansion expanded-p)
- (ps-macroexpand symbol)
- (when expanded-p
- (return-from compile-parenscript-form (compile-parenscript-form expansion :expecting expecting)))))
- (cond ((keywordp symbol) symbol)
- ((ps-special-form-p (list symbol))
- (if (ps-reserved-symbol-p symbol)
- (funcall (get-ps-special-form symbol) :symbol)
- (error "Attempting to use Parenscript special form ~a as variable" symbol)))
- (t `(js:variable ,symbol))))
+(defmethod ps-compile ((form character))
+ (ps-compile (string form)))
+
+(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 `(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 op
(not '!)
(eql '\=\=)
(= '\=\=)
- (t op)))
-
-(defmethod compile-parenscript-form ((form cons) &key (expecting :statement))
+ (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 compile-funcall-form (form)
+ `(js:funcall
+ ,(if (symbolp (car form))
+ `(js:variable ,(maybe-rename-local-function (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)
- (cond (expanded-p (compile-parenscript-form form :expecting expecting))
- ((ps-special-form-p form) (apply (get-ps-special-form (car form)) (cons expecting (cdr form))))
- ((op-form-p form)
- `(js:operator ,(ps-convert-op-name (compile-parenscript-form (car form) :expecting :symbol))
- ,@(mapcar (lambda (form)
- (compile-parenscript-form (ps-macroexpand form) :expecting :expression))
- (cdr form))))
- ((funcall-form-p form)
- `(js:funcall ,(compile-parenscript-form (if (symbolp (car form))
- (maybe-rename-local-function (car form))
- (ps-macroexpand (car form)))
- :expecting :expression)
- ,@(mapcar (lambda (arg)
- (compile-parenscript-form (ps-macroexpand arg) :expecting :expression))
- (cdr form))))
- (t (error "Cannot compile ~S to a ParenScript form." 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)
HCoop / clinton / parenscript.git / blobdiff