[clinton/parenscript.git] / src / ps-macrology.lisp

(in-package :parenscript)

;;;; The macrology of the Parenscript language.  Special forms and macros.

;;; parenscript gensyms
(defvar *ps-gensym-counter* 0)

(defun ps-gensym (&optional (prefix "_js"))
  (make-symbol (format nil "~A~A" prefix (incf *ps-gensym-counter*))))

(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
gensym-prefix-string)."
  `(let* ,(mapcar (lambda (symbol)
                    (destructuring-bind (symbol &optional prefix)
                        (if (consp symbol)
                            symbol
                            (list symbol))
                      (if prefix
                          `(,symbol (ps-gensym ,prefix))
                          `(,symbol (ps-gensym)))))
                  symbols)
     ,@body))

(defun constant-literal-form-p (form)
  (or (numberp form)
      (stringp form)
      (and (listp form)
           (eql 'js-literal (car form)))))

(defpsmacro defaultf (place value)
  `(setf ,place (or (and (=== undefined ,place) ,value)
		 ,place)))

;;; array literals
(defpsmacro list (&rest values)
  `(array ,@values))

(defpsmacro make-array (&rest inits)
  `(new (*array ,@inits)))

;;; slot access
(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))))

(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)
				   `(,(slot-var slot) (slot-value ,object ',(slot-symbol slot))))
			       slots)
      ,@body)))

(defpsmacro case (value &rest clauses)
  (labels ((make-clause (val body more)
             (cond ((listp val)
                    (append (mapcar #'list (butlast val))
                            (make-clause (first (last val)) body more)))
                   ((member val '(t otherwise))
                    (make-clause 'default body more))
                   (more `((,val ,@body break)))
                   (t `((,val ,@body))))))
    `(switch ,value ,@(mapcon (lambda (clause)
                                (make-clause (car (first clause))
                                             (cdr (first clause))
                                             (rest clause)))
                              clauses))))

(define-ps-special-form let (expecting bindings &rest body)
  (ecase expecting
    (:statement
     (let ((defvars (mapcar (lambda (binding) (if (atom binding)
                                                  `(defvar ,binding)
                                                  `(defvar ,@binding)))
                            bindings)))
       (compile-parenscript-form `(progn ,@defvars ,@body) :expecting :statement)))
    (:expression
     (let ((declared-variables (mapcar (lambda (binding) (if (atom binding) binding (car binding))) bindings))
           (variable-assignments (loop for b in bindings when (listp b) collect (cons 'setf b))))
       (setf *enclosing-lexical-block-declarations* (append declared-variables *enclosing-lexical-block-declarations*))
       (compile-parenscript-form `(progn ,@variable-assignments ,@body) :expecting :expression)))))

;;; iteration
(defpsmacro dotimes (iter &rest body)
  (let ((var (first iter))
        (times (second iter)))
  `(do ((,var 0 (1+ ,var)))
       ((>= ,var ,times))
     ,@body)))

(defpsmacro dolist (i-array &rest body)
  (let ((var (first i-array))
	(array (second i-array))
	(arrvar (ps-gensym "tmp-arr"))
	(idx (ps-gensym "tmp-i")))
    `(let ((,arrvar ,array))
      (do ((,idx 0 (1+ ,idx)))
	  ((>= ,idx (slot-value ,arrvar 'length)))
	(let ((,var (aref ,arrvar ,idx)))
	  ,@body)))))

;;; macros
(defmacro with-temp-macro-environment ((var) &body body)
  `(let* ((,var (make-macro-env-dictionary))
          (*script-macro-env* (cons ,var *script-macro-env*)))
    ,@body))

(define-ps-special-form macrolet (expecting macros &body body)
  (declare (ignore expecting))
  (with-temp-macro-environment (macro-env-dict)
    (dolist (macro macros)
      (destructuring-bind (name arglist &body body)
          macro
	(setf (get-macro-spec name macro-env-dict)
	      (cons nil (make-ps-macro-function arglist body)))))
    (compile-parenscript-form `(progn ,@body))))

(define-ps-special-form symbol-macrolet (expecting symbol-macros &body body)
  (declare (ignore expecting))
  (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 (make-ps-macro-function () (list `',expansion))))))
    (compile-parenscript-form `(progn ,@body))))

(define-ps-special-form defmacro (expecting name args &body body)
  (declare (ignore expecting))
  (define-script-macro% name args body :symbol-macro-p nil)
  nil)

(define-ps-special-form define-symbol-macro (expecting name expansion)
  (declare (ignore expecting))
  (define-script-macro% name () (list `',expansion) :symbol-macro-p t)
  nil)

(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)))

(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
the js side for js closures."
  (unless (listp variables)
    (setf variables (list variables)))
  `((lambda ()
      (let ((new-context (new *object)))
        ,@(loop for variable in variables
                collect `(setf (slot-value new-context ,(symbol-to-js variable))
                               ,variable))
        (with new-context
          ,@body)))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun parse-function-body (body)
    ;; (format t "parsing function body ~A~%" body)
    (let* ((documentation
	    (when (stringp (first body))
	      (first body)))
	   (body-forms (if documentation (rest body) body)))
      (values
       body-forms
       documentation)))

  (defun parse-key-spec (key-spec)
    "parses an &key parameter.  Returns 4 values:
var, init-form,  keyword-name, supplied-p-var, init-form-supplied-p.

Syntax of key spec:
[&key {var | ({var | (keyword-name var)} [init-form [supplied-p-parameter]])}*
"
    (let* ((var (cond ((symbolp key-spec) key-spec)
		      ((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
		      ((and (listp key-spec) (listp (first key-spec)))   (second key-spec))))
	   (keyword-name (if (and (listp key-spec) (listp (first key-spec)))
			     (first (first key-spec))
			     (intern (string var) :keyword)))
	   (init-form (if (listp key-spec) (second key-spec) nil))
	   (init-form-supplied-p (if (listp key-spec) t nil))
	   (supplied-p-var (if (listp key-spec) (third key-spec) nil)))
      (values var init-form keyword-name supplied-p-var init-form-supplied-p)))

  (defun parse-optional-spec (spec)
    "Parses an &optional parameter.  Returns 3 values: var, init-form, supplied-p-var.
[&optional {var | (var [init-form [supplied-p-parameter]])}*] "
    (let* ((var (cond ((symbolp spec) spec)
		      ((and (listp spec) (first spec)))))
	   (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))))

  (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 
;; 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)
;; * 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)) 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 (ps-gensym)))
	     ;; optionals are of form (var default-value)
	     (effective-args
	      (remove-if
	       #'null
	       (append requireds
		       (mapcar #'parse-optional-spec optionals)
		       (when keys (list options-var)))))
	     ;; an alist of arg -> default val
	     (initform-pairs
	      (remove
	       nil
	       (append
		;; optional arguments first
		(mapcar #'(lambda (opt-spec)
			    (multiple-value-bind (var val) (parse-optional-spec opt-spec)
			      (cons var val)))
			optionals)
		(if keys? (list (cons options-var '(create))))
		(mapcar #'(lambda (key-spec)
			    (multiple-value-bind (var val x y specified?) (parse-key-spec key-spec)
			      (declare (ignore x y))
			      (when specified? (cons var val))))
			keys))))
	     (body-paren-forms (parse-function-body body)) ;remove documentation
	     ;;
	     (initform-forms
	      (mapcar #'(lambda (default-pair)
			  `(defaultf ,(car default-pair) ,(cdr default-pair)))
		      initform-pairs))
	     (rest-form
	      (if rest?
                  (with-ps-gensyms (i)
                    `(progn (defvar ,rest array)
                            (dotimes (,i (- arguments.length ,(length effective-args)))
                              (setf (aref ,rest ,i) (aref arguments (+ ,i ,(length effective-args)))))))
		  `(progn)))
	     (effective-body   (append initform-forms (list rest-form) body-paren-forms))
	     (effective-body
	      (if keys?
		  (list `(with-slots ,(mapcar #'(lambda (key-spec)
						  (multiple-value-bind (var x key-name)
						      (parse-key-spec key-spec)
						    (declare (ignore x))
						    (list var key-name)))
					      keys)
			  ,options-var
			  ,@effective-body))
		  effective-body)))
	(values effective-args effective-body)))))

(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]] 
  [&aux {var | (var [init-form])}*])"
  (if (symbolp name)
      `(defun-function ,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-function (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))))

(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]] 
  [&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 defsetf-long (access-fn lambda-list (store-var) form)
  (setf (get-macro-spec access-fn *script-setf-expanders*)
        (compile nil
                 (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-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 (,@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) (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)))))
Commit	Line	Data
5aa10005 RD	1	(in-package :parenscript)
	2
	3	;;;; The macrology of the Parenscript language. Special forms and macros.
	4
	5	;;; parenscript gensyms
4a987e2b	6	(defvar ps-gensym-counter 0)
5aa10005	7
4a987e2b	8	(defun ps-gensym (&optional (prefix "_js"))
0c542be0	9	(make-symbol (format nil "~A~A" prefix (incf ps-gensym-counter))))
5aa10005	10
4a987e2b VS	11	(defmacro with-ps-gensyms (symbols &body body)
4a987e2b VS	12	"Evaluate BODY with SYMBOLS bound to unique ParenScript identifiers.
5aa10005 RD	13
5aa10005 RD	14	Each element of SYMBOLS is either a symbol or a list of (symbol
4a987e2b	15	gensym-prefix-string)."
5aa10005 RD	16	`(let* ,(mapcar (lambda (symbol)
	17	(destructuring-bind (symbol &optional prefix)
	18	(if (consp symbol)
	19	symbol
	20	(list symbol))
	21	(if prefix
4a987e2b VS	22	`(,symbol (ps-gensym ,prefix))
4a987e2b VS	23	`(,symbol (ps-gensym)))))
5aa10005 RD	24	symbols)
	25	,@body))
	26
13b8268e VS	27	(defun constant-literal-form-p (form)
	28	(or (numberp form)
	29	(stringp form)
	30	(and (listp form)
	31	(eql 'js-literal (car form)))))
	32
4a987e2b	33	(defpsmacro defaultf (place value)
bbea4c83 RD	34	`(setf ,place (or (and (=== undefined ,place) ,value)
bbea4c83 RD	35	,place)))
46f794a4	36
5aa10005	37	;;; array literals
4a987e2b	38	(defpsmacro list (&rest values)
5aa10005 RD	39	`(array ,@values))
5aa10005 RD	40
4a987e2b	41	(defpsmacro make-array (&rest inits)
5aa10005 RD	42	`(new (*array ,@inits)))
5aa10005 RD	43
bbea4c83	44	;;; slot access
4a987e2b	45	(defpsmacro slot-value (obj &rest slots)
bbea4c83 RD	46	(if (null (rest slots))
	47	`(%js-slot-value ,obj ,(first slots))
	48	`(slot-value (slot-value ,obj ,(first slots)) ,@(rest slots))))
	49
4a987e2b	50	(defpsmacro with-slots (slots object &rest body)
bbea4c83 RD	51	(flet ((slot-var (slot) (if (listp slot) (first slot) slot))
	52	(slot-symbol (slot) (if (listp slot) (second slot) slot)))
	53	`(symbol-macrolet ,(mapcar #'(lambda (slot)
43a1d5c3	54	`(,(slot-var slot) (slot-value ,object ',(slot-symbol slot))))
bbea4c83 RD	55	slots)
	56	,@body)))
	57
4a987e2b	58	(defpsmacro case (value &rest clauses)
5aa10005 RD	59	(labels ((make-clause (val body more)
	60	(cond ((listp val)
	61	(append (mapcar #'list (butlast val))
	62	(make-clause (first (last val)) body more)))
	63	((member val '(t otherwise))
	64	(make-clause 'default body more))
	65	(more `((,val ,@body break)))
	66	(t `((,val ,@body))))))
4a987e2b VS	67	`(switch ,value ,@(mapcon (lambda (clause)
	68	(make-clause (car (first clause))
	69	(cdr (first clause))
	70	(rest clause)))
5aa10005 RD	71	clauses))))
5aa10005 RD	72
4a987e2b	73	(define-ps-special-form let (expecting bindings &rest body)
e0032a96 VS	74	(ecase expecting
	75	(:statement
	76	(let ((defvars (mapcar (lambda (binding) (if (atom binding)
	77	`(defvar ,binding)
	78	`(defvar ,@binding)))
	79	bindings)))
	80	(compile-parenscript-form `(progn ,@defvars ,@body) :expecting :statement)))
	81	(:expression
	82	(let ((declared-variables (mapcar (lambda (binding) (if (atom binding) binding (car binding))) bindings))
	83	(variable-assignments (loop for b in bindings when (listp b) collect (cons 'setf b))))
	84	(setf enclosing-lexical-block-declarations (append declared-variables enclosing-lexical-block-declarations))
	85	(compile-parenscript-form `(progn ,@variable-assignments ,@body) :expecting :expression)))))
5aa10005 RD	86
5aa10005 RD	87	;;; iteration
4a987e2b	88	(defpsmacro dotimes (iter &rest body)
5aa10005 RD	89	(let ((var (first iter))
	90	(times (second iter)))
	91	`(do ((,var 0 (1+ ,var)))
	92	((>= ,var ,times))
	93	,@body)))
	94
4a987e2b	95	(defpsmacro dolist (i-array &rest body)
5aa10005 RD	96	(let ((var (first i-array))
5aa10005 RD	97	(array (second i-array))
4a987e2b VS	98	(arrvar (ps-gensym "tmp-arr"))
4a987e2b VS	99	(idx (ps-gensym "tmp-i")))
5aa10005 RD	100	`(let ((,arrvar ,array))
5aa10005 RD	101	(do ((,idx 0 (1+ ,idx)))
4a987e2b	102	((>= ,idx (slot-value ,arrvar 'length)))
5aa10005 RD	103	(let ((,var (aref ,arrvar ,idx)))
	104	,@body)))))
	105
	106	;;; macros
	107	(defmacro with-temp-macro-environment ((var) &body body)
	108	`(let* ((,var (make-macro-env-dictionary))
	109	(script-macro-env (cons ,var script-macro-env)))
	110	,@body))
	111
4a987e2b	112	(define-ps-special-form macrolet (expecting macros &body body)
45f8fec1	113	(declare (ignore expecting))
5aa10005 RD	114	(with-temp-macro-environment (macro-env-dict)
	115	(dolist (macro macros)
	116	(destructuring-bind (name arglist &body body)
	117	macro
	118	(setf (get-macro-spec name macro-env-dict)
921f2e02	119	(cons nil (make-ps-macro-function arglist body)))))
4a987e2b	120	(compile-parenscript-form `(progn ,@body))))
5aa10005	121
4a987e2b	122	(define-ps-special-form symbol-macrolet (expecting symbol-macros &body body)
45f8fec1	123	(declare (ignore expecting))
5aa10005 RD	124	(with-temp-macro-environment (macro-env-dict)
5aa10005 RD	125	(dolist (macro symbol-macros)
43a1d5c3	126	(destructuring-bind (name expansion)
5aa10005 RD	127	macro
5aa10005 RD	128	(setf (get-macro-spec name macro-env-dict)
7626bb83	129	(cons t (make-ps-macro-function () (list `',expansion))))))
4a987e2b	130	(compile-parenscript-form `(progn ,@body))))
5aa10005	131
4a987e2b	132	(define-ps-special-form defmacro (expecting name args &body body)
45f8fec1	133	(declare (ignore expecting))
d9fc64c9	134	(define-script-macro% name args body :symbol-macro-p nil)
4a987e2b	135	nil)
5aa10005	136
7626bb83	137	(define-ps-special-form define-symbol-macro (expecting name expansion)
45f8fec1	138	(declare (ignore expecting))
7626bb83	139	(define-script-macro% name () (list `',expansion) :symbol-macro-p t)
4a987e2b	140	nil)
46f794a4	141
4a987e2b	142	(defpsmacro lisp (&body forms)
5aa10005 RD	143	"Evaluates the given forms in Common Lisp at ParenScript
	144	macro-expansion time. The value of the last form is treated as a
	145	ParenScript expression and is inserted into the generated Javascript
1b2da35c	146	\(use nil for no-op)."
5aa10005 RD	147	(eval (cons 'progn forms)))
5aa10005 RD	148
4a987e2b	149	(defpsmacro rebind (variables &body body)
5aa10005	150	"Creates a new js lexical environment and copies the given
34896dae AL	151	variable(s) there. Executes the body in the new environment. This
	152	has the same effect as a new (let () ...) form in lisp but works on
	153	the js side for js closures."
5aa10005 RD	154	(unless (listp variables)
	155	(setf variables (list variables)))
	156	`((lambda ()
	157	(let ((new-context (new *object)))
	158	,@(loop for variable in variables
34896dae AL	159	collect `(setf (slot-value new-context ,(symbol-to-js variable))
34896dae AL	160	,variable))
5aa10005	161	(with new-context
34896dae	162	,@body)))))
46f794a4	163
46f794a4 RD	164	(eval-when (:compile-toplevel :load-toplevel :execute)
	165	(defun parse-function-body (body)
	166	;; (format t "parsing function body ~A~%" body)
	167	(let* ((documentation
	168	(when (stringp (first body))
	169	(first body)))
	170	(body-forms (if documentation (rest body) body)))
	171	(values
	172	body-forms
	173	documentation)))
	174
	175	(defun parse-key-spec (key-spec)
	176	"parses an &key parameter. Returns 4 values:
	177	var, init-form, keyword-name, supplied-p-var, init-form-supplied-p.
	178
	179	Syntax of key spec:
	180	[&key {var \| ({var \| (keyword-name var)} [init-form [supplied-p-parameter]])}*
	181	"
	182	(let* ((var (cond ((symbolp key-spec) key-spec)
	183	((and (listp key-spec) (symbolp (first key-spec))) (first key-spec))
	184	((and (listp key-spec) (listp (first key-spec))) (second key-spec))))
	185	(keyword-name (if (and (listp key-spec) (listp (first key-spec)))
	186	(first (first key-spec))
	187	(intern (string var) :keyword)))
	188	(init-form (if (listp key-spec) (second key-spec) nil))
	189	(init-form-supplied-p (if (listp key-spec) t nil))
	190	(supplied-p-var (if (listp key-spec) (third key-spec) nil)))
	191	(values var init-form keyword-name supplied-p-var init-form-supplied-p)))
	192
	193	(defun parse-optional-spec (spec)
	194	"Parses an &optional parameter. Returns 3 values: var, init-form, supplied-p-var.
	195	[&optional {var \| (var [init-form [supplied-p-parameter]])}*] "
	196	(let* ((var (cond ((symbolp spec) spec)
	197	((and (listp spec) (first spec)))))
	198	(init-form (if (listp spec) (second spec)))
	199	(supplied-p-var (if (listp spec) (third spec))))
	200	(values var init-form supplied-p-var)))
	201
	202	(defun parse-aux-spec (spec)
	203	"Returns two values: variable and init-form"
	204	;; [&aux {var \| (var [init-form])}*])
	205	(values (if (symbolp spec) spec (first spec))
	206	(when (listp spec) (second spec))))
	207
	208	(defun parse-extended-function (lambda-list body &optional name)
	209	"Returns two values: the effective arguments and body for a function with
	210	the given lambda-list and body."
	211
	212	;; The lambda list is transformed as follows, since a javascript lambda list is just a
	213	;; list of variable names, and you have access to the arguments variable inside the function:
	214	;; * standard variables are the mapped directly into the js-lambda list
	215	;; * optional variables' variable names are mapped directly into the lambda list,
	216	;; and for each optional variable with name v and default value d, a form is produced
	217	;; (defaultf v d)
d989d711	218	;; * when any keyword variables are in the lambda list, a single 'optional-args' variable is
46f794a4 RD	219	;; appended to the js-lambda list as the last argument. WITH-SLOTS is used for all
46f794a4 RD	220	;; the variables with inside the body of the function,
d989d711	221	;; a (with-slots ((var-name key-name)) optional-args ...)
46f794a4	222	(declare (ignore name))
bbea4c83 RD	223	(multiple-value-bind (requireds optionals rest? rest keys? keys allow? aux? aux
bbea4c83 RD	224	more? more-context more-count key-object)
46f794a4	225	(parse-lambda-list lambda-list)
bbea4c83	226	(declare (ignore allow? aux? aux more? more-context more-count))
2e593e4c	227	(let* ((options-var (or key-object (ps-gensym)))
46f794a4 RD	228	;; optionals are of form (var default-value)
	229	(effective-args
	230	(remove-if
	231	#'null
	232	(append requireds
	233	(mapcar #'parse-optional-spec optionals)
	234	(when keys (list options-var)))))
	235	;; an alist of arg -> default val
	236	(initform-pairs
	237	(remove
	238	nil
	239	(append
	240	;; optional arguments first
	241	(mapcar #'(lambda (opt-spec)
	242	(multiple-value-bind (var val) (parse-optional-spec opt-spec)
	243	(cons var val)))
	244	optionals)
	245	(if keys? (list (cons options-var '(create))))
	246	(mapcar #'(lambda (key-spec)
	247	(multiple-value-bind (var val x y specified?) (parse-key-spec key-spec)
	248	(declare (ignore x y))
	249	(when specified? (cons var val))))
	250	keys))))
	251	(body-paren-forms (parse-function-body body)) ;remove documentation
	252	;;
	253	(initform-forms
	254	(mapcar #'(lambda (default-pair)
	255	`(defaultf ,(car default-pair) ,(cdr default-pair)))
	256	initform-pairs))
	257	(rest-form
	258	(if rest?
44934751 VS	259	(with-ps-gensyms (i)
	260	`(progn (defvar ,rest array)
	261	(dotimes (,i (- arguments.length ,(length effective-args)))
	262	(setf (aref ,rest ,i) (aref arguments (+ ,i ,(length effective-args)))))))
46f794a4 RD	263	`(progn)))
	264	(effective-body (append initform-forms (list rest-form) body-paren-forms))
	265	(effective-body
	266	(if keys?
	267	(list `(with-slots ,(mapcar #'(lambda (key-spec)
	268	(multiple-value-bind (var x key-name)
	269	(parse-key-spec key-spec)
	270	(declare (ignore x))
	271	(list var key-name)))
	272	keys)
	273	,options-var
	274	,@effective-body))
	275	effective-body)))
	276	(values effective-args effective-body)))))
	277
4a987e2b	278	(defpsmacro defun (name lambda-list &body body)
46f794a4 RD	279	"An extended defun macro that allows cool things like keyword arguments.
	280	lambda-list::=
	281	(var*
	282	[&optional {var \| (var [init-form [supplied-p-parameter]])}*]
	283	[&rest var]
	284	[&key {var \| ({var \| (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
	285	[&aux {var \| (var [init-form])}*])"
dbb7017b	286	(if (symbolp name)
e0032a96	287	`(defun-function ,name ,lambda-list ,@body)
dbb7017b VS	288	(progn (assert (and (= (length name) 2) (eql 'setf (car name))) ()
	289	"(defun ~s ~s ...) needs to have a symbol or (setf symbol) for a name." name lambda-list)
	290	`(defun-setf ,name ,lambda-list ,@body))))
	291
e0032a96	292	(defpsmacro defun-function (name lambda-list &body body)
46f794a4 RD	293	(multiple-value-bind (effective-args effective-body)
	294	(parse-extended-function lambda-list body name)
	295	`(%js-defun ,name ,effective-args
	296	,@effective-body)))
	297
dbb7017b VS	298	(defvar defun-setf-name-prefix "__setf_")
dbb7017b VS	299
4a987e2b	300	(defpsmacro defun-setf (setf-name lambda-list &body body)
dbb7017b VS	301	(let ((mangled-function-name (intern (concatenate 'string defun-setf-name-prefix (symbol-name (second setf-name)))
	302	(symbol-package (second setf-name))))
	303	(function-args (cdr (ordered-set-difference lambda-list lambda-list-keywords))))
	304	`(progn (defsetf ,(second setf-name) ,(cdr lambda-list) (store-var)
	305	`(,',mangled-function-name ,store-var ,@(list ,@function-args)))
	306	(defun ,mangled-function-name ,lambda-list ,@body))))
46f794a4	307
4a987e2b	308	(defpsmacro lambda (lambda-list &body body)
46f794a4 RD	309	"An extended defun macro that allows cool things like keyword arguments.
	310	lambda-list::=
	311	(var*
	312	[&optional {var \| (var [init-form [supplied-p-parameter]])}*]
	313	[&rest var]
	314	[&key {var \| ({var \| (keyword-name var)} [init-form [supplied-p-parameter]])}* [&allow-other-keys]]
	315	[&aux {var \| (var [init-form])}*])"
	316	(multiple-value-bind (effective-args effective-body)
	317	(parse-extended-function lambda-list body)
	318	`(%js-lambda ,effective-args
72332f2a VS	319	,@effective-body)))
72332f2a VS	320
4a987e2b	321	(defpsmacro defsetf-long (access-fn lambda-list (store-var) form)
06babcf5	322	(setf (get-macro-spec access-fn script-setf-expanders)
72332f2a	323	(compile nil
cdf9ab0e	324	(let ((var-bindings (ordered-set-difference lambda-list lambda-list-keywords)))
72332f2a VS	325	`(lambda (access-fn-args store-form)
	326	(destructuring-bind ,lambda-list
	327	access-fn-args
4a987e2b VS	328	(let* ((,store-var (ps-gensym))
4a987e2b VS	329	(gensymed-names (loop repeat ,(length var-bindings) collecting (ps-gensym)))
72332f2a VS	330	(gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings))))
	331	(destructuring-bind ,var-bindings
	332	gensymed-names
cdf9ab0e	333	`(let (,@gensymed-arg-bindings
03eedaa5	334	(,,store-var ,store-form))
72332f2a VS	335	,,form))))))))
	336	nil)
	337
4a987e2b	338	(defpsmacro defsetf-short (access-fn update-fn &optional docstring)
750651b0	339	(declare (ignore docstring))
06babcf5	340	(setf (get-macro-spec access-fn script-setf-expanders)
750651b0 VS	341	(lambda (access-fn-args store-form)
	342	`(,update-fn ,@access-fn-args ,store-form)))
	343	nil)
	344
	345	(defpsmacro defsetf (access-fn &rest args)
	346	`(,(if (= (length args) 3) 'defsetf-long 'defsetf-short) ,access-fn ,@args))
	347
72332f2a VS	348	(defpsmacro setf (&rest args)
72332f2a VS	349	(flet ((process-setf-clause (place value-form)
06babcf5 VS	350	(if (and (listp place) (get-macro-spec (car place) script-setf-expanders))
06babcf5 VS	351	(funcall (get-macro-spec (car place) script-setf-expanders) (cdr place) value-form)
4a987e2b	352	(let ((exp-place (ps-macroexpand place)))
06babcf5 VS	353	(if (and (listp exp-place) (get-macro-spec (car exp-place) script-setf-expanders))
06babcf5 VS	354	(funcall (get-macro-spec (car exp-place) script-setf-expanders) (cdr exp-place) value-form)
4a987e2b	355	`(setf1% ,exp-place ,value-form))))))
72332f2a VS	356	(assert (evenp (length args)) ()
	357	"~s does not have an even number of arguments." (cons 'setf args))
	358	`(progn ,@(loop for (place value) on args by #'cddr collect (process-setf-clause place value)))))