;;;; The macrology of the Parenscript language. Special forms and macros.
;;; parenscript gensyms
-(defvar *gen-script-name-counter* 0)
+(defvar *ps-gensym-counter* 0)
-(defun gen-script-name-string (&key (prefix "_js_"))
- "Generates a unique valid javascript identifier ()"
- (concatenate 'string
- prefix (princ-to-string (incf *gen-script-name-counter*))))
+(defun ps-gensym (&optional (prefix "_js"))
+ (make-symbol (format nil "~A-~A" prefix (incf *ps-gensym-counter*))))
-(defun gen-script-name (&key (prefix ""))
- "Generate a new javascript identifier."
- (intern (gen-script-name-string :prefix prefix)
- (find-package :parenscript.ps-gensyms)))
-
-(defmacro gen-ps-name (&rest args)
- `(gen-script-name ,@args))
-
-(defmacro with-unique-ps-names (symbols &body body)
- "Evaluate BODY with the variables on SYMBOLS bound to new javascript identifiers.
+(defmacro with-ps-gensyms (symbols &body body)
+ "Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
Each element of SYMBOLS is either a symbol or a list of (symbol
-prefix)."
+gensym-prefix-string)."
`(let* ,(mapcar (lambda (symbol)
(destructuring-bind (symbol &optional prefix)
(if (consp symbol)
symbol
(list symbol))
(if prefix
- `(,symbol (gen-script-name :prefix ,prefix))
- `(,symbol (gen-script-name)))))
+ `(,symbol (ps-gensym ,prefix))
+ `(,symbol (ps-gensym)))))
symbols)
,@body))
-(defvar *var-counter* 0)
-
-(defun script-gensym (&optional (name "js"))
- (intern (format nil "tmp-~A-~A" name (incf *var-counter*)) #.*package*))
-
-(defscriptmacro defaultf (place value)
+(defpsmacro defaultf (place value)
`(setf ,place (or (and (=== undefined ,place) ,value)
,place)))
;;; array literals
-(defscriptmacro list (&rest values)
+(defpsmacro list (&rest values)
`(array ,@values))
-(defscriptmacro make-array (&rest inits)
+(defpsmacro make-array (&rest inits)
`(new (*array ,@inits)))
-;;; eval-when
-(define-script-special-form eval-when (&rest args)
- "(eval-when form-language? (situation*) form*)
-
-The given forms are evaluated only during the given SITUATION in the specified
-FORM-LANGUAGE (either :lisp or :parenscript, def, defaulting to :lisp during
--toplevel and :parenscript during :execute). The accepted SITUATIONS are :execute,
-:scan-toplevel. :scan-toplevel is the phase of compilation when function definitions
-and the like are being added to the compilation environment. :execute is the phase when
-the code is being evaluated by a Javascript engine."
- (multiple-value-bind (body-language situations subforms)
- (process-eval-when-args args)
- (cond
- ((and (compiler-in-situation-p *compilation-environment* :compile-toplevel)
- (find :compile-toplevel situations))
- (error "Should never be processing eval-when :COMPILE-TOPLEVEL forms from here."))
-
- ((and (compiler-in-situation-p *compilation-environment* :execute)
- (find :execute situations))
- (when (eql body-language :parenscript)
- (let ((form `(progn ,@subforms)))
- (compile-to-statement form)))))))
-
;;; slot access
-(defscriptmacro slot-value (obj &rest slots)
+(defpsmacro slot-value (obj &rest slots)
(if (null (rest slots))
`(%js-slot-value ,obj ,(first slots))
`(slot-value (slot-value ,obj ,(first slots)) ,@(rest slots))))
-(defscriptmacro with-slots (slots object &rest body)
+(defpsmacro with-slots (slots object &rest body)
(flet ((slot-var (slot) (if (listp slot) (first slot) slot))
(slot-symbol (slot) (if (listp slot) (second slot) slot)))
`(symbol-macrolet ,(mapcar #'(lambda (slot)
slots)
,@body)))
-;;; script packages
-(defscriptmacro defpackage (name &rest options)
- "Defines a Parenscript package."
- (labels ((opt-name (opt) (if (listp opt) (car opt) opt)))
- (let ((nicknames nil) (lisp-package nil) (secondary-lisp-packages nil)
- (exports nil) (used-packages nil) (documentation nil))
- (dolist (opt options)
- (case (opt-name opt)
- (:lisp-package (setf lisp-package (second opt)))
- (:nicknames (setf nicknames (rest opt)))
- (:secondary-lisp-packages secondary-lisp-packages t)
- (:export (setf exports (rest opt)))
- (:use (setf used-packages (rest opt)))
- (:documentation (setf documentation (second opt)))
- (t (error "Unknown option in DEFPACKAGE: ~A" (opt-name opt)))))
- (create-script-package
- *compilation-environment*
- :name name
- :nicknames nicknames
- :secondary-lisp-packages secondary-lisp-packages
- :used-packages used-packages
- :lisp-package lisp-package
- :exports exports
- :documentation documentation)))
- `(progn))
-
-(defscriptmacro in-package (package-designator)
- "Changes the current script package in the parenscript compilation environment. This mostly
-affects the reader and how it interns non-prefixed symbols"
- (let ((script-package
- (find-script-package package-designator *compilation-environment*)))
- (when (null script-package)
- (error "~A does not designate any script package. Available script package: ~A"
- package-designator
- (mapcar #'script-package-name (comp-env-script-packages *compilation-environment*))))
- (setf (comp-env-current-package *compilation-environment*)
- script-package)
- `(progn)))
-
-(defscriptmacro case (value &rest clauses)
+(defpsmacro case (value &rest clauses)
(labels ((make-clause (val body more)
(cond ((listp val)
(append (mapcar #'list (butlast val))
(make-clause 'default body more))
(more `((,val ,@body break)))
(t `((,val ,@body))))))
- `(switch ,value ,@(mapcon #'(lambda (x)
- (make-clause (car (first x))
- (cdr (first x))
- (rest x)))
+ `(switch ,value ,@(mapcon (lambda (clause)
+ (make-clause (car (first clause))
+ (cdr (first clause))
+ (rest clause)))
clauses))))
-;;; let
-(define-script-special-form let (decls &rest body)
- (let ((defvars (mapcar #'(lambda (decl)
- (if (atom decl)
- (make-instance 'ps-js::js-defvar
- :names (list (compile-to-symbol decl))
- :value nil)
- (let ((name (first decl))
- (value (second decl)))
- (make-instance 'ps-js::js-defvar
- :names (list (compile-to-symbol name))
- :value (compile-to-expression value)))))
- decls)))
- (make-instance 'ps-js::js-sub-block
- :indent " "
- :statements (nconc defvars
- (mapcar #'compile-to-statement body)))))
+(define-ps-special-form let (expecting bindings &rest body)
+ (let ((defvars (mapcar (lambda (binding) (if (atom binding)
+ `(defvar ,binding)
+ `(defvar ,@binding)))
+ bindings)))
+ (compile-parenscript-form `(progn ,@defvars ,@body))))
;;; iteration
-(defscriptmacro dotimes (iter &rest body)
+(defpsmacro dotimes (iter &rest body)
(let ((var (first iter))
(times (second iter)))
`(do ((,var 0 (1+ ,var)))
((>= ,var ,times))
,@body)))
-(defscriptmacro dolist (i-array &rest body)
+(defpsmacro dolist (i-array &rest body)
(let ((var (first i-array))
(array (second i-array))
- (arrvar (script-gensym "arr"))
- (idx (script-gensym "i")))
+ (arrvar (ps-gensym "tmp-arr"))
+ (idx (ps-gensym "tmp-i")))
`(let ((,arrvar ,array))
(do ((,idx 0 (1+ ,idx)))
- ((>= ,idx (slot-value ,arrvar 'global::length)))
+ ((>= ,idx (slot-value ,arrvar 'length)))
(let ((,var (aref ,arrvar ,idx)))
,@body)))))
(*script-macro-env* (cons ,var *script-macro-env*)))
,@body))
-(define-script-special-form macrolet (macros &body body)
+(define-ps-special-form macrolet (expecting macros &body body)
(with-temp-macro-environment (macro-env-dict)
(dolist (macro macros)
(destructuring-bind (name arglist &body body)
(destructuring-bind ,arglist
,args
,@body))))))))
- (compile-script-form `(progn ,@body))))
+ (compile-parenscript-form `(progn ,@body))))
-(define-script-special-form symbol-macrolet (symbol-macros &body body)
+(define-ps-special-form symbol-macrolet (expecting symbol-macros &body body)
(with-temp-macro-environment (macro-env-dict)
(dolist (macro symbol-macros)
(destructuring-bind (name &body expansion)
macro
(setf (get-macro-spec name macro-env-dict)
(cons t (compile nil `(lambda () ,@expansion))))))
- (compile-script-form `(progn ,@body))))
+ (compile-parenscript-form `(progn ,@body))))
-(defscriptmacro defmacro (name args &body body)
- `(lisp (defscriptmacro ,name ,args ,@body) nil))
+(define-ps-special-form defmacro (expecting name args &body body)
+ (define-script-macro% name args body :symbol-macro-p nil)
+ nil)
-(defscriptmacro define-symbol-macro (name &body body)
- `(lisp (define-script-symbol-macro ,name ,@body)))
+(define-ps-special-form define-symbol-macro (expecting name &body body)
+ (define-script-macro% name () body :symbol-macro-p t)
+ nil)
-(defscriptmacro lisp (&body forms)
+(defpsmacro lisp (&body forms)
"Evaluates the given forms in Common Lisp at ParenScript
macro-expansion time. The value of the last form is treated as a
ParenScript expression and is inserted into the generated Javascript
\(use nil for no-op)."
(eval (cons 'progn forms)))
-(defscriptmacro rebind (variables &body body)
+(defpsmacro rebind (variables &body body)
"Creates a new js lexical environment and copies the given
variable(s) there. Executes the body in the new environment. This
has the same effect as a new (let () ...) form in lisp but works on
;; * 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)
-;; * when any keyword variables are in the lambda list, a single 'options' variable is
+;; * when any keyword variables are in the lambda list, a single 'optional-args' variable is
;; appended to the js-lambda list as the last argument. WITH-SLOTS is used for all
;; the variables with inside the body of the function,
- ;; a (with-slots ((var-name key-name)) options ...)
+ ;; a (with-slots ((var-name key-name)) optional-args ...)
(declare (ignore name))
(multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
more? more-context more-count key-object)
(parse-lambda-list lambda-list)
(declare (ignore allow? aux? aux more? more-context more-count))
- (let* ((options-var (or key-object 'options))
+ (let* ((options-var (or key-object 'optional-args))
;; optionals are of form (var default-value)
(effective-args
(remove-if
effective-body)))
(values effective-args effective-body)))))
-(ps:defscriptmacro defun (name lambda-list &body body)
+(defpsmacro defun (name lambda-list &body body)
"An extended defun macro that allows cool things like keyword arguments.
lambda-list::=
(var*
[&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-normal ,name ,lambda-list ,@body)
+ (progn (assert (and (= (length name) 2) (eql 'setf (car name))) ()
+ "(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
+ `(defun-setf ,name ,lambda-list ,@body))))
+
+(defpsmacro defun-normal (name lambda-list &body body)
(multiple-value-bind (effective-args effective-body)
(parse-extended-function lambda-list body name)
`(%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))))
-(ps:defscriptmacro lambda (lambda-list &body body)
+(defpsmacro lambda (lambda-list &body body)
"An extended defun macro that allows cool things like keyword arguments.
lambda-list::=
(var*
`(%js-lambda ,effective-args
,@effective-body)))
-(defpsmacro defsetf (access-fn lambda-list (store-var) form)
- (setf (find-macro-spec access-fn *script-setf-expanders*)
+(defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
+ (setf (get-macro-spec access-fn *script-setf-expanders*)
(compile nil
- (let ((var-bindings (set-difference lambda-list lambda-list-keywords)))
+ (let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
`(lambda (access-fn-args store-form)
(destructuring-bind ,lambda-list
access-fn-args
- (let* ((,store-var (ps:gen-ps-name))
- (gensymed-names (loop repeat ,(length var-bindings) collecting (ps:gen-ps-name)))
+ (let* ((,store-var (ps-gensym))
+ (gensymed-names (loop repeat ,(length var-bindings) collecting (ps-gensym)))
(gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings))))
(destructuring-bind ,var-bindings
gensymed-names
- `(let ((,,store-var ,store-form)
- ,@gensymed-arg-bindings)
+ `(let (,@gensymed-arg-bindings
+ (,,store-var ,store-form))
,,form))))))))
nil)
+(defpsmacro defsetf-short (access-fn update-fn &optional docstring)
+ (declare (ignore docstring))
+ (setf (get-macro-spec access-fn *script-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 setf (&rest args)
(flet ((process-setf-clause (place value-form)
- (if (and (listp place) (find-macro-spec (car place) *script-setf-expanders*))
- (funcall (find-macro-spec (car place) *script-setf-expanders*) (cdr place) value-form)
- (let ((exp-place (expand-script-form place)))
- (if (and (listp exp-place) (find-macro-spec (car exp-place) *script-setf-expanders*))
- (funcall (find-macro-spec (car exp-place) *script-setf-expanders*) (cdr exp-place) value-form)
- `(parenscript.javascript::setf1% ,exp-place ,value-form))))))
+ (if (and (listp place) (get-macro-spec (car place) *script-setf-expanders*))
+ (funcall (get-macro-spec (car place) *script-setf-expanders*) (cdr place) value-form)
+ (let ((exp-place (ps-macroexpand place)))
+ (if (and (listp exp-place) (get-macro-spec (car exp-place) *script-setf-expanders*))
+ (funcall (get-macro-spec (car exp-place) *script-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)))))
HCoop / clinton / parenscript.git / blobdiff