(in-package "PARENSCRIPT")
+(defmacro with-local-macro-environment ((var env) &body body)
+ `(let* ((,var (make-macro-dictionary))
+ (,env (cons ,var ,env)))
+ ,@body))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; literals
(defmacro defpsliteral (name string)
`(progn
- (add-ps-literal ',name)
+ (add-ps-reserved-symbol ',name)
(define-ps-special-form ,name ()
(list 'js:literal ,string))))
(macrolet ((def-for-literal (name printer)
`(progn
- (add-ps-literal ',name)
+ (add-ps-reserved-symbol ',name)
(define-ps-special-form ,name (&optional label)
(list ',printer label)))))
(def-for-literal break js:break)
(def-for-literal continue js:continue))
-(defpsmacro quote (x)
- (typecase x
- (cons (cons 'array (mapcar (lambda (x) (when x `',x)) x)))
- (null '(array))
- (keyword x)
- (symbol (symbol-to-js-string x))
- (number x)
- (string x)))
+(define-ps-special-form quote (x)
+ (ps-compile-expression
+ (typecase x
+ (cons `(array ,@(mapcar (lambda (x) (when x `',x)) x)))
+ (null '(array))
+ (keyword x)
+ (symbol (symbol-to-js-string x))
+ (number x)
+ (string x))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; unary operators
(spacep (if (listp op) (second op) nil)))
`(define-ps-special-form ,op (x)
(list 'js:unary-operator ',op
- (compile-parenscript-form x :expecting :expression)
+ (ps-compile-expression (ps-macroexpand x))
:prefix t :space ,spacep))))
ops))))
(def-unary-ops ~ ! (new t) (delete t) (void t) (typeof t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; statements
(define-ps-special-form return (&optional value)
- `(js:return ,(compile-parenscript-form value :expecting :expression)))
+ `(js:return ,(ps-compile-expression (ps-macroexpand value))))
(define-ps-special-form throw (value)
- `(js:throw ,(compile-parenscript-form value :expecting :expression)))
+ `(js:throw ,(ps-compile-expression (ps-macroexpand value))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; arrays
(define-ps-special-form array (&rest values)
- `(js:array ,@(mapcar (lambda (form) (compile-parenscript-form form :expecting :expression))
- values)))
+ `(js:array ,@(mapcar (lambda (form) (ps-compile-expression (ps-macroexpand form)))
+ values)))
(define-ps-special-form aref (array &rest coords)
- `(js:aref ,(compile-parenscript-form array :expecting :expression)
+ `(js:aref ,(ps-compile-expression (ps-macroexpand array))
,(mapcar (lambda (form)
- (compile-parenscript-form form :expecting :expression))
+ (ps-compile-expression (ps-macroexpand form)))
coords)))
(defpsmacro list (&rest values)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operators
(define-ps-special-form incf (x &optional (delta 1))
- (if (eql delta 1)
- `(js:unary-operator js:++ ,(compile-parenscript-form x :expecting :expression) :prefix t)
- `(js:operator js:+= ,(compile-parenscript-form x :expecting :expression)
- ,(compile-parenscript-form delta :expecting :expression))))
+ (let ((x (ps-macroexpand x))
+ (delta (ps-macroexpand delta)))
+ (if (eql delta 1)
+ `(js:unary-operator js:++ ,(ps-compile-expression x) :prefix t)
+ `(js:operator js:+= ,(ps-compile-expression x)
+ ,(ps-compile-expression delta)))))
(define-ps-special-form decf (x &optional (delta 1))
- (if (eql delta 1)
- `(js:unary-operator js:-- ,(compile-parenscript-form x :expecting :expression) :prefix t)
- `(js:operator js:-= ,(compile-parenscript-form x :expecting :expression)
- ,(compile-parenscript-form delta :expecting :expression))))
+ (let ((x (ps-macroexpand x))
+ (delta (ps-macroexpand delta)))
+ (if (eql delta 1)
+ `(js:unary-operator js:-- ,(ps-compile-expression x) :prefix t)
+ `(js:operator js:-= ,(ps-compile-expression x)
+ ,(ps-compile-expression delta)))))
(define-ps-special-form - (first &rest rest)
- (if rest
- `(js:operator js:- ,@(mapcar (lambda (val) (compile-parenscript-form val :expecting :expression))
- (cons first rest)))
- `(js:unary-operator js:- ,(compile-parenscript-form first :expecting :expression) :prefix t)))
+ (let ((first (ps-macroexpand first))
+ (rest (mapcar #'ps-macroexpand rest)))
+ (if rest
+ `(js:operator js:- ,@(mapcar (lambda (val) (ps-compile-expression val))
+ (cons first rest)))
+ `(js:unary-operator js:- ,(ps-compile-expression first) :prefix t))))
(define-ps-special-form not (x)
- (let ((form (compile-parenscript-form x :expecting :expression))
+ (let ((form (ps-compile-expression (ps-macroexpand x)))
inverse-op)
(if (and (eq (car form) 'js:operator)
(= (length (cddr form)) 2)
(eq 'js:literal (car form)))))
(define-ps-special-form progn (&rest body)
- (if (and (eq expecting :expression) (= 1 (length body)))
- (compile-parenscript-form (car body) :expecting :expression)
- `(,(if (eq expecting :expression) 'js:|,| 'js:block)
- ,@(let* ((block (flatten-blocks (remove nil (mapcar (lambda (form)
- (compile-parenscript-form form :expecting expecting))
- body)))))
- (append (remove-if #'constant-literal-form-p (butlast block)) (last block))))))
+ (let ((body (mapcar #'ps-macroexpand body)))
+ (if (and compile-expression? (= 1 (length body)))
+ (ps-compile-expression (car body))
+ `(,(if compile-expression? 'js:|,| 'js:block)
+ ,@(let* ((block (flatten-blocks (remove nil (mapcar #'ps-compile body)))))
+ (append (remove-if #'constant-literal-form-p (butlast block)) (last block)))))))
(define-ps-special-form cond (&rest clauses)
- (ecase expecting
- (:statement `(js:if ,(compile-parenscript-form (caar clauses) :expecting :expression)
- ,(compile-parenscript-form `(progn ,@(cdar clauses)))
- ,@(loop for (test . body) in (cdr clauses) appending
- (if (eq t test)
- `(:else ,(compile-parenscript-form `(progn ,@body) :expecting :statement))
- `(:else-if ,(compile-parenscript-form test :expecting :expression)
- ,(compile-parenscript-form `(progn ,@body) :expecting :statement))))))
- (:expression (make-cond-clauses-into-nested-ifs clauses))))
+ (if compile-expression?
+ (make-cond-clauses-into-nested-ifs clauses)
+ `(js:if ,(ps-compile-expression (caar clauses))
+ ,(ps-compile-statement `(progn ,@(cdar clauses)))
+ ,@(loop for (test . body) in (cdr clauses) appending
+ (if (eq t test)
+ `(:else ,(ps-compile-statement `(progn ,@body)))
+ `(:else-if ,(ps-compile-expression test)
+ ,(ps-compile-statement `(progn ,@body))))))))
(defun make-cond-clauses-into-nested-ifs (clauses)
(if clauses
(destructuring-bind (test &rest body)
(car clauses)
(if (eq t test)
- (compile-parenscript-form `(progn ,@body) :expecting :expression)
- `(js:? ,(compile-parenscript-form test :expecting :expression)
- ,(compile-parenscript-form `(progn ,@body) :expecting :expression)
+ (ps-compile-expression `(progn ,@body))
+ `(js:? ,(ps-compile-expression test)
+ ,(ps-compile-expression `(progn ,@body))
,(make-cond-clauses-into-nested-ifs (cdr clauses)))))
- (compile-parenscript-form nil :expecting :expression))) ;; js:null
+ (ps-compile-expression nil)))
(define-ps-special-form if (test then &optional else)
- (ecase expecting
- (:statement `(js:if ,(compile-parenscript-form test :expecting :expression)
- ,(compile-parenscript-form `(progn ,then))
- ,@(when else `(:else ,(compile-parenscript-form `(progn ,else))))))
- (:expression `(js:? ,(compile-parenscript-form test :expecting :expression)
- ,(compile-parenscript-form then :expecting :expression)
- ,(compile-parenscript-form else :expecting :expression)))))
+ (if compile-expression?
+ `(js:? ,(ps-compile-expression (ps-macroexpand test))
+ ,(ps-compile-expression (ps-macroexpand then))
+ ,(ps-compile-expression (ps-macroexpand else)))
+ `(js:if ,(ps-compile-expression (ps-macroexpand test))
+ ,(ps-compile-statement `(progn ,then))
+ ,@(when else `(:else ,(ps-compile-statement `(progn ,else)))))))
(define-ps-special-form switch (test-expr &rest clauses)
- `(js:switch ,(compile-parenscript-form test-expr :expecting :expression)
+ `(js:switch ,(ps-compile-expression test-expr)
,(loop for (val . body) in clauses collect
(cons (if (eq val 'default)
'default
- (compile-parenscript-form val :expecting :expression))
- (mapcar (lambda (x) (compile-parenscript-form x :expecting :statement))
+ (ps-compile-expression val))
+ (mapcar (lambda (x) (ps-compile-statement x))
body)))))
(defpsmacro case (value &rest clauses)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; function definition
+
+(defvar *vars-bound-in-enclosing-lexical-scopes* ())
+
(defun compile-function-definition (args body)
- (list (mapcar (lambda (arg) (compile-parenscript-form arg :expecting :symbol)) args)
- (let* ((*enclosing-lexical-block-declarations* ())
- (body (compile-parenscript-form `(progn ,@body)))
- (var-decls (compile-parenscript-form
- `(progn ,@(mapcar (lambda (var) `(var ,var)) *enclosing-lexical-block-declarations*)))))
- `(js:block ,@(cdr var-decls) ,@(cdr body)))))
+ (let ((args (mapcar #'ps-compile-symbol args)))
+ (list args
+ (let* ((*enclosing-lexical-block-declarations* ())
+ (*vars-bound-in-enclosing-lexical-scopes* (append args
+ *vars-bound-in-enclosing-lexical-scopes*))
+ (body (ps-compile-statement `(progn ,@body)))
+ (var-decls (ps-compile-statement
+ `(progn ,@(mapcar (lambda (var) `(var ,var)) *enclosing-lexical-block-declarations*)))))
+ `(js:block ,@(cdr var-decls) ,@(cdr body))))))
(define-ps-special-form %js-lambda (args &rest body)
`(js:lambda ,@(compile-function-definition args body)))
(init-form (if (listp spec) (second spec)))
(supplied-p-var (if (listp spec) (third spec))))
(values var init-form supplied-p-var)))
-
+
(defun parse-aux-spec (spec)
"Returns two values: variable and init-form"
;; [&aux {var | (var [init-form])}*])
(values (if (symbolp spec) spec (first spec))
(when (listp spec) (second spec))))
-(defpsmacro defaultf (place value)
- `(when (=== ,place undefined)
- (setf ,place ,value)))
+(defpsmacro defaultf (name value suppl)
+ `(progn
+ ,@(when suppl `((var ,suppl t)))
+ (when (=== ,name undefined)
+ (setf ,name ,value ,@(when suppl (list suppl nil))))))
(defun parse-extended-function (lambda-list body &optional name)
"Returns two values: the effective arguments and body for a function with
the given lambda-list and body."
- ;; The lambda list is transformed as follows, since a javascript lambda list is just a
+ ;; The lambda list is transformed as follows, since a javascript lambda list is just a
;; list of variable names, and you have access to the arguments variable inside the function:
;; * standard variables are the mapped directly into the js-lambda list
;; * optional variables' variable names are mapped directly into the lambda list,
- ;; and for each optional variable with name v and default value d, a form is produced
- ;; (defaultf v d)
+ ;; and for each optional variable with name v, default value d, and
+ ;; supplied-p parameter s, a form is produced (defaultf v d s)
;; * keyword variables are not included in the js-lambda list, but instead are
;; obtained from the magic js ARGUMENTS pseudo-array. Code assigning values to
- ;; keyword vars is prepended to the body of the function.
+ ;; keyword vars is prepended to the body of the function. Defaults and supplied-p
+ ;; are handled using the same mechanism as with optional vars.
(declare (ignore name))
(multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
more? more-context more-count key-object)
(mapcar #'parse-optional-spec optionals))))
(opt-forms
(mapcar #'(lambda (opt-spec)
- (multiple-value-bind (var val) (parse-optional-spec opt-spec)
- `(defaultf ,var ,val)))
+ (multiple-value-bind (var val suppl)
+ (parse-optional-spec opt-spec)
+ `(defaultf ,var ,val ,suppl)))
optionals))
(key-forms
(when keys?
(with-ps-gensyms (n)
(let ((decls nil) (assigns nil) (defaults nil))
(mapc (lambda (k)
- (multiple-value-bind (var init-form keyword-str)
+ (multiple-value-bind (var init-form keyword-str suppl)
(parse-key-spec k)
(push `(var ,var) decls)
(push `(,keyword-str (setf ,var (aref arguments (1+ ,n)))) assigns)
- (push (list 'defaultf var init-form) defaults)))
+ (push (list 'defaultf var init-form suppl) defaults)))
(reverse keys))
`(,@decls
(loop :for ,n :from ,(length requireds)
(defpsmacro defun (name lambda-list &body body)
"An extended defun macro that allows cool things like keyword arguments.
lambda-list::=
- (var*
- [&optional {var | (var [init-form [supplied-p-parameter]])}*]
- [&rest var]
- [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
+ (var*
+ [&optional {var | (var [init-form [supplied-p-parameter]])}*]
+ [&rest var]
+ [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
[&aux {var | (var [init-form])}*])"
(if (symbolp name)
`(defun-function ,name ,lambda-list ,@body)
`(%js-defun ,name ,effective-args
,@effective-body)))
-(defvar *defun-setf-name-prefix* "__setf_")
-
-(defpsmacro defun-setf (setf-name lambda-list &body body)
- (let ((mangled-function-name (intern (concatenate 'string *defun-setf-name-prefix* (symbol-name (second setf-name)))
- (symbol-package (second setf-name))))
- (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords))))
- `(progn (defsetf ,(second setf-name) ,(cdr lambda-list) (store-var)
- `(,',mangled-function-name ,store-var ,@(list ,@function-args)))
- (defun ,mangled-function-name ,lambda-list ,@body))))
-
(defpsmacro lambda (lambda-list &body body)
"An extended defun macro that allows cool things like keyword arguments.
lambda-list::=
- (var*
- [&optional {var | (var [init-form [supplied-p-parameter]])}*]
- [&rest var]
- [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
+ (var*
+ [&optional {var | (var [init-form [supplied-p-parameter]])}*]
+ [&rest var]
+ [&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
[&aux {var | (var [init-form])}*])"
(multiple-value-bind (effective-args effective-body)
(parse-extended-function lambda-list body)
`(%js-lambda ,effective-args
,@effective-body)))
-(defpsmacro flet (fn-defs &rest body)
- (flet ((process-fn-def (def)
- `(var ,(car def) (lambda ,@(cdr def)))))
- `(progn ,@(mapcar #'process-fn-def fn-defs) ,@body)))
+(define-ps-special-form labels (fn-defs &rest body)
+ (with-local-macro-environment (local-fn-renames *ps-local-function-names*)
+ (loop for (fn-name) in fn-defs do
+ (setf (gethash fn-name local-fn-renames) (ps-gensym fn-name)))
+ (ps-compile
+ `(progn ,@(loop for (fn-name . def) in fn-defs collect
+ `(var ,(gethash fn-name local-fn-renames) (lambda ,@def)))
+ ,@body))))
-(defpsmacro labels (fn-defs &rest body)
- (flet ((process-fn-def (def)
- `(var ,(car def) (defun ,(car def) ,@(cdr def)))))
- `(progn ,@(mapcar #'process-fn-def fn-defs) ,@body)))
+(defvar *defun-setf-name-prefix* "__setf_")
+
+(defpsmacro defun-setf (setf-name lambda-list &body body)
+ (let ((mangled-function-name (intern (concatenate 'string *defun-setf-name-prefix* (symbol-name (second setf-name)))
+ (symbol-package (second setf-name))))
+ (function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords))))
+ (ps* `(defsetf ,(second setf-name) ,(cdr lambda-list) (store-var)
+ `(,',mangled-function-name ,store-var ,@(list ,@function-args))))
+ `(defun ,mangled-function-name ,lambda-list ,@body)))
(defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
- (setf (get-macro-spec access-fn *ps-setf-expanders*)
+ (setf (gethash access-fn *ps-setf-expanders*)
(compile nil
(let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
`(lambda (access-fn-args store-form)
(defpsmacro defsetf-short (access-fn update-fn &optional docstring)
(declare (ignore docstring))
- (setf (get-macro-spec access-fn *ps-setf-expanders*)
+ (setf (gethash access-fn *ps-setf-expanders*)
(lambda (access-fn-args store-form)
`(,update-fn ,@access-fn-args ,store-form)))
nil)
(defpsmacro defsetf (access-fn &rest args)
`(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
-(defpsmacro funcall (&rest arg-form)
- arg-form)
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; macros
-(defmacro with-temp-macro-environment ((var) &body body)
- `(let* ((,var (make-macro-env-dictionary))
- (*ps-macro-env* (cons ,var *ps-macro-env*)))
- ,@body))
-
(define-ps-special-form macrolet (macros &body body)
- (with-temp-macro-environment (macro-env-dict)
+ (with-local-macro-environment (local-macro-dict *ps-macro-env*)
(dolist (macro macros)
(destructuring-bind (name arglist &body body)
macro
- (setf (get-macro-spec name macro-env-dict)
- (cons nil (eval (make-ps-macro-function arglist body))))))
- (compile-parenscript-form `(progn ,@body))))
+ (setf (gethash name local-macro-dict) (eval (make-ps-macro-function arglist body)))))
+ (ps-compile `(progn ,@body))))
(define-ps-special-form symbol-macrolet (symbol-macros &body body)
- (with-temp-macro-environment (macro-env-dict)
- (dolist (macro symbol-macros)
- (destructuring-bind (name expansion)
- macro
- (setf (get-macro-spec name macro-env-dict)
- (cons t (lambda (x) (declare (ignore x)) expansion)))))
- (compile-parenscript-form `(progn ,@body))))
+ (with-local-macro-environment (local-macro-dict *ps-symbol-macro-env*)
+ (let (local-var-bindings)
+ (dolist (macro symbol-macros)
+ (destructuring-bind (name expansion)
+ macro
+ (setf (gethash name local-macro-dict) (lambda (x) (declare (ignore x)) expansion))
+ (push name local-var-bindings)))
+ (let ((*vars-bound-in-enclosing-lexical-scopes* (append local-var-bindings
+ *vars-bound-in-enclosing-lexical-scopes*)))
+ (ps-compile `(progn ,@body))))))
(define-ps-special-form defmacro (name args &body body) ;; should this be a macro?
(eval `(defpsmacro ,name ,args ,@body))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; objects
-(add-ps-literal '{})
+(add-ps-reserved-symbol '{})
(define-ps-symbol-macro {} (create))
(define-ps-special-form create (&rest arrows)
- `(js:object ,@(loop for (key-expr val-expr) on arrows by #'cddr collecting
- (let ((key (compile-parenscript-form key-expr :expecting :expression)))
- (when (keywordp key)
- (setf key `(js:variable ,key)))
- (assert (or (stringp key)
- (numberp key)
- (and (listp key)
- (or (eq 'js:variable (car key))
- (eq 'quote (car key)))))
- ()
- "Slot key ~s is not one of js-variable, keyword, string or number." key)
- (cons key (compile-parenscript-form val-expr :expecting :expression))))))
-
-(define-ps-special-form %js-slot-value (obj slot)
- `(js:slot-value ,(compile-parenscript-form obj :expecting :expression)
- ,(if (and (listp slot) (eq 'quote (car slot)))
- (second slot) ;; assume we're quoting a symbol
- (compile-parenscript-form slot))))
+ `(js:object
+ ,@(loop for (key-expr val-expr) on arrows by #'cddr collecting
+ (let ((compiled-key (ps-compile-expression (ps-macroexpand key-expr))))
+ (assert (or (stringp compiled-key)
+ (numberp compiled-key)
+ (keywordp compiled-key)
+ (and (listp compiled-key)
+ (eq 'js:variable (car compiled-key))))
+ ()
+ "Slot key ~s is not one of js-variable, keyword, string or number."
+ compiled-key)
+ (let ((key (aif (ps-reserved-symbol-p (if (listp compiled-key)
+ (second compiled-key)
+ compiled-key))
+ it
+ compiled-key)))
+ (cons key (ps-compile-expression (ps-macroexpand val-expr))))))))
(define-ps-special-form instanceof (value type)
- `(js:instanceof ,(compile-parenscript-form value :expecting :expression)
- ,(compile-parenscript-form type :expecting :expression)))
+ `(js:instanceof ,(ps-compile-expression value)
+ ,(ps-compile-expression type)))
+
+(define-ps-special-form %js-slot-value (obj slot)
+ (let ((slot (ps-macroexpand slot)))
+ `(js:slot-value ,(ps-compile-expression (ps-macroexpand obj))
+ ,(let ((slot (if (and (listp slot) (eq 'quote (car slot)))
+ (second slot) ;; assume we're quoting a symbol
+ (ps-compile-expression slot))))
+ (if (and (symbolp slot)
+ (ps-reserved-symbol-p slot))
+ (symbol-name-to-js-string slot)
+ slot)))))
(defpsmacro slot-value (obj &rest slots)
(if (null (rest slots))
(t nil)))
(define-ps-special-form setf1% (lhs rhs)
- (let ((lhs (compile-parenscript-form lhs :expecting :expression))
- (rhs (compile-parenscript-form rhs :expecting :expression)))
+ (let ((lhs (ps-compile-expression (ps-macroexpand lhs)))
+ (rhs (ps-compile-expression (ps-macroexpand rhs))))
(if (and (listp rhs)
(eq 'js:operator (car rhs))
(member (cadr rhs) '(+ *))
`(js:= ,lhs ,rhs))))
(defpsmacro setf (&rest args)
- (flet ((process-setf-clause (place value-form)
- (if (and (listp place) (get-macro-spec (car place) *ps-setf-expanders*))
- (funcall (get-macro-spec (car place) *ps-setf-expanders*) (cdr place) value-form)
- (let ((exp-place (ps-macroexpand place)))
- (if (and (listp exp-place) (get-macro-spec (car exp-place) *ps-setf-expanders*))
- (funcall (get-macro-spec (car exp-place) *ps-setf-expanders*) (cdr exp-place) value-form)
- `(setf1% ,exp-place ,value-form))))))
- (assert (evenp (length args)) ()
- "~s does not have an even number of arguments." (cons 'setf args))
- `(progn ,@(loop for (place value) on args by #'cddr collect (process-setf-clause place value)))))
+ (assert (evenp (length args)) ()
+ "~s does not have an even number of arguments." `(setf ,args))
+ `(progn ,@(loop for (place value) on args by #'cddr collect
+ (let ((place (ps-macroexpand place)))
+ (aif (and (listp place) (gethash (car place) *ps-setf-expanders*))
+ (funcall it (cdr place) value)
+ `(setf1% ,place ,value))))))
(defpsmacro psetf (&rest args)
(let ((places (loop for x in args by #'cddr collect x))
(define-ps-special-form var (name &optional (value (values) value-provided?) documentation)
(declare (ignore documentation))
- (ecase expecting
- (:statement
- `(js:var ,name ,@(when value-provided?
- (list (compile-parenscript-form value :expecting :expression)))))
- (:expression
- (push name *enclosing-lexical-block-declarations*)
- (when value-provided?
- (compile-parenscript-form `(setf ,name ,value) :expecting :expression)))))
+ (let ((name (ps-macroexpand name)))
+ (if compile-expression?
+ (progn (push name *enclosing-lexical-block-declarations*)
+ (when value-provided?
+ (ps-compile-expression `(setf ,name ,value))))
+ `(js:var (js:variable ,name) ,@(when value-provided?
+ (list (ps-compile-expression (ps-macroexpand value))))))))
(defpsmacro defvar (name &optional (value (values) value-provided?) documentation)
;; this must be used as a top-level form, otherwise the resulting behavior will be undefined.
(pushnew name *ps-special-variables*)
`(var ,name ,@(when value-provided? (list value))))
-(defpsmacro let (bindings &body body)
- (flet ((add-renamed-vars (bindings predicate)
- (mapcar (lambda (x) (append x (list (ps-gensym (car x)))))
- (remove-if predicate bindings :key #'car)))
- (var (x) (first x))
- (val (x) (second x))
- (renamed (x) (third x)))
- (let* ((normalized-bindings (mapcar (lambda (x) (if (symbolp x) `(,x nil) x)) bindings))
- (lexical-bindings (add-renamed-vars normalized-bindings #'ps-special-variable-p))
- (dynamic-bindings (add-renamed-vars normalized-bindings (complement #'ps-special-variable-p)))
- (renamed-body `(symbol-macrolet ,(mapcar (lambda (x) (list (var x) (renamed x)))
- lexical-bindings)
- ,@body)))
- `(progn
- ,@(mapcar (lambda (x) `(var ,(renamed x) ,(val x))) lexical-bindings)
- ,(if dynamic-bindings
- `(progn ,@(mapcar (lambda (x) `(var ,(renamed x))) dynamic-bindings)
- (try (progn (setf ,@(loop for x in dynamic-bindings append
- `(,(renamed x) ,(var x)
- ,(var x) ,(val x))))
- ,renamed-body)
- (:finally
- (setf ,@(mapcan (lambda (x) `(,(var x) ,(renamed x))) dynamic-bindings)))))
- renamed-body)))))
+(define-ps-special-form let (bindings &body body)
+ `(js:let ,(mapcar #'car bindings)
+ ,@(let ((body-forms (if compile-expression?
+ `((progn
+ ,@(mapcar (lambda (bind)
+ `(var ,(car bind) ,(cadr bind)))
+ bindings)
+ ,@body))
+ `(,@(mapcar (lambda (bind)
+ `(var ,(car bind) ,(cadr bind)))
+ bindings)
+ ,@body))))
+ (mapcar #'ps-compile body-forms))))
(defpsmacro let* (bindings &body body)
(if bindings
,@body))
`(progn ,@body)))
+(defpsmacro letrec (bindings &body body)
+ `(let ,(mapcar (lambda (bind)
+ (list (car bind) 'null))
+ bindings)
+ ,@(mapcar (lambda (bind) `(var ,(car bind) ,(cadr bind)))
+ bindings)
+ ,@body))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; iteration
(defun make-for-vars/inits (init-forms)
(mapcar (lambda (x)
- (cons (compile-parenscript-form (if (atom x) x (first x)) :expecting :symbol)
- (compile-parenscript-form (if (atom x) nil (second x)) :expecting :expression)))
+ (cons (ps-compile-symbol (ps-macroexpand (if (atom x) x (first x))))
+ (ps-compile-expression (ps-macroexpand (if (atom x) nil (second x))))))
init-forms))
(define-ps-special-form labeled-for (label init-forms cond-forms step-forms &rest body)
`(js:for ,label
,(make-for-vars/inits init-forms)
- ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) cond-forms)
- ,(mapcar (lambda (x) (compile-parenscript-form x :expecting :expression)) step-forms)
- ,(compile-parenscript-form `(progn ,@body))))
+ ,(mapcar (lambda (x) (ps-compile-expression (ps-macroexpand x))) cond-forms)
+ ,(mapcar (lambda (x) (ps-compile-expression (ps-macroexpand x))) step-forms)
+ ,(ps-compile-statement `(progn ,@body))))
(defpsmacro for (init-forms cond-forms step-forms &body body)
`(labeled-for nil ,init-forms ,cond-forms ,step-forms ,@body))
,(do-make-iter-psteps decls)))))
(define-ps-special-form for-in ((var object) &rest body)
- `(js:for-in ,(compile-parenscript-form var :expecting :expression)
- ,(compile-parenscript-form object :expecting :expression)
- ,(compile-parenscript-form `(progn ,@body))))
+ `(js:for-in ,(ps-compile-expression var)
+ ,(ps-compile-expression (ps-macroexpand object))
+ ,(ps-compile-statement `(progn ,@body))))
(define-ps-special-form while (test &rest body)
- `(js:while ,(compile-parenscript-form test :expecting :expression)
- ,(compile-parenscript-form `(progn ,@body))))
+ `(js:while ,(ps-compile-expression test)
+ ,(ps-compile-statement `(progn ,@body))))
(defpsmacro dotimes ((var count &optional (result nil result?)) &rest body)
`(do* ((,var 0 (1+ ,var)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; misc
(define-ps-special-form with (expression &rest body)
- `(js:with ,(compile-parenscript-form expression :expecting :expression)
- ,(compile-parenscript-form `(progn ,@body))))
+ `(js:with ,(ps-compile-expression expression)
+ ,(ps-compile-statement `(progn ,@body))))
(define-ps-special-form try (form &rest clauses)
(let ((catch (cdr (assoc :catch clauses)))
(assert (not (cdar catch)) nil "Sorry, currently only simple catch forms are supported.")
(assert (or catch finally) ()
"Try form should have either a catch or a finally clause or both.")
- `(js:try ,(compile-parenscript-form `(progn ,form))
- :catch ,(when catch (list (compile-parenscript-form (caar catch) :expecting :symbol)
- (compile-parenscript-form `(progn ,@(cdr catch)))))
- :finally ,(when finally (compile-parenscript-form `(progn ,@finally))))))
+ `(js:try ,(ps-compile-statement `(progn ,form))
+ :catch ,(when catch (list (ps-compile-symbol (caar catch))
+ (ps-compile-statement `(progn ,@(cdr catch)))))
+ :finally ,(when finally (ps-compile-statement `(progn ,@finally))))))
(define-ps-special-form cc-if (test &rest body)
- `(js:cc-if ,test ,@(mapcar #'compile-parenscript-form body)))
+ `(js:cc-if ,test ,@(mapcar #'ps-compile-statement body)))
(define-ps-special-form regex (regex)
`(js:regex ,(string regex)))
(define-ps-special-form lisp (lisp-form)
;; (ps (foo (lisp bar))) is in effect equivalent to (ps* `(foo ,bar))
;; when called from inside of ps*, lisp-form has access only to the dynamic environment (like for eval)
- `(js:escape (ps1* ,lisp-form)))
+ `(js:escape (compiled-form-to-string (let ((compile-expression? ,compile-expression?))
+ (ps-compile ,lisp-form)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; eval-when
COMMON-LISP code in :compile-toplevel and :load-toplevel sitations, and parenscript code in
:execute. "
(when (and (member :compile-toplevel situation-list)
- (member *toplevel-compilation-level* '(:toplevel :inside-toplevel-form)))
+ (member *ps-compilation-level* '(:toplevel :inside-toplevel-form)))
(eval `(progn ,@body)))
(if (member :execute situation-list)
- (compile-parenscript-form `(progn ,@body) :expecting expecting)
- (compile-parenscript-form `(progn) :expecting expecting)))
\ No newline at end of file
+ (ps-compile `(progn ,@body))
+ (ps-compile `(progn))))
HCoop / clinton / parenscript.git / blobdiff