;;; Assignment is done using the `SETF' form, which is transformed
;;; into a series of assignments using the JavaScript `=' operator.
-(setf a 1) => a = 1
+(setf a 1) => a = 1;
(setf a 2 b 3 c 4 x (+ a b c))
=> a = 2;
;;; operator expression using this variable into a more "efficient"
;;; assignment operator form. For example:
-(setf a (1+ a)) => a++
+(setf a (1+ a)) => a++;
-(setf a (+ a 2 3 4 a)) => a += 2 + 3 + 4 + a
+(setf a (+ a 2 3 4 a)) => a += 2 + 3 + 4 + a;
-(setf a (- 1 a)) => a = 1 - a
+(setf a (- 1 a)) => a = 1 - a;
;;;# Single argument statements
;;;t \index{single-argument statement}
(let ((expr (compile-to-expression x)))
(make-instance 'one-op :pre-p t :op "~" :value expr)))
-;;; progn
(define-script-special-form progn (&rest body)
- (make-instance 'js-block
- :statements (mapcar #'compile-to-statement body)))
+ (make-instance 'js-block :statements (mapcar #'compile-to-statement body)))
(defmethod expression-precedence ((body js-block))
(if (= (length (block-statements body)) 1)
(t (make-instance 'js-setf :lhs lhs :rhsides (list rhs)))))
(make-instance 'js-setf :lhs lhs :rhsides (list rhs))))
-(define-script-special-form setf (&rest args)
- (let ((assignments (loop for (lhs rhs) on args by #'cddr
- for rexpr = (compile-to-expression rhs)
- for lexpr = (compile-to-expression lhs)
- collect (make-js-test lexpr rexpr))))
- (if (= (length assignments) 1)
- (first assignments)
- (make-instance 'js-block :indent "" :statements assignments))))
+(define-script-special-form setf1% (lhs rhs)
+ (make-js-test (compile-to-expression lhs) (compile-to-expression rhs)))
(defmethod expression-precedence ((setf js-setf))
(op-precedence '=))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-macro-env-dictionary ()
"Creates a standard macro dictionary."
- (make-hash-table :test (macro-name-hash-function)))
+ (make-hash-table :test (macro-name-hash-function)))
(defvar *script-macro-toplevel* (make-macro-env-dictionary)
- "Toplevel macro environment dictionary. Key is symbol-name of the macro, value
-is (symbol-macro-p . expansion-function).")
+ "Toplevel macro environment dictionary. Key is the symbol of the
+macro, value is (symbol-macro-p . expansion-function).")
(defvar *script-macro-env* (list *script-macro-toplevel*) ;(list nil)
"Current macro environment.")
+
+ (defvar *script-setf-expanders* (make-macro-env-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 find-macro-spec (name env-dict)
(if *enable-package-system*
(defmacro 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-op expansion-function)."
+SPEC is of the form (symbol-macro-p . expansion-function)."
`(find-macro-spec ,name ,env-dict))
(defun lookup-macro-spec (name &optional (environment *script-macro-env*))
(multiple-value-bind (effective-args effective-body)
(parse-extended-function lambda-list body)
`(%js-lambda ,effective-args
- ,@effective-body)))
\ No newline at end of file
+ ,@effective-body)))
+
+(defpsmacro defsetf (access-fn lambda-list (store-var) form)
+ (setf (find-macro-spec access-fn *script-setf-expanders*)
+ (compile nil
+ (let ((var-bindings (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)))
+ (gensymed-arg-bindings (mapcar #'list gensymed-names (list ,@var-bindings))))
+ (destructuring-bind ,var-bindings
+ gensymed-names
+ `(let ((,,store-var ,store-form)
+ ,@gensymed-arg-bindings)
+ ,,form))))))))
+ nil)
+
+(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))))))
+ (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)))))
(test-ps-js plus-is-not-commutative
(setf x (+ "before" x "after"))
- "x = 'before' + x + 'after'")
+ "x = 'before' + x + 'after';")
(test-ps-js plus-works-if-first
(setf x (+ x "middle" "after"))
- "x += 'middle' + 'after'")
+ "x += 'middle' + 'after';")
(test-ps-js setf-side-effects
(progn
(test-ps-js slot-value-setf
(setf (slot-value x 'y) (+ (+ a 3) 4))
- "x.y = (a + 3) + 4")
+ "x.y = (a + 3) + 4;")
(test-ps-js slot-value-conditional1
(slot-value (if zoo foo bar) 'x)
(test-ps-js quoted-nil
'nil
- "null")
\ No newline at end of file
+ "null")
+
+(test defsetf1
+ (ps (defsetf baz (x y) (newval) `(set-baz ,x ,y ,newval)))
+ (is (string= "var _ps_1 = 3; var _ps_2 = 2; var _ps_3 = 1; setBaz(_ps_3, _ps_2, _ps_1);"
+ (normalize-js-code (let ((*enable-package-system* nil)
+ (ps::*gen-script-name-counter* 0))
+ (ps (setf (baz 1 2) 3)))))))
(test-ps-js assignment-1
(setf a 1)
- "a = 1")
+ "a = 1;")
(test-ps-js assignment-2
(setf a 2 b 3 c 4 x (+ a b c))
(test-ps-js assignment-3
(setf a (1+ a))
- "a++")
+ "a++;")
(test-ps-js assignment-4
(setf a (+ a 2 3 4 a))
- "a += 2 + 3 + 4 + a")
+ "a += 2 + 3 + 4 + a;")
(test-ps-js assignment-5
(setf a (- 1 a))
- "a = 1 - a")
+ "a = 1 - a;")
(test-ps-js single-argument-statements-1
(return 1)
HCoop / clinton / parenscript.git / commitdiff