From 782c05da79bfa9110bf45224b64f61c54df7bc3f Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Sun, 15 May 2005 12:36:18 +0000 Subject: [PATCH] Add test for defining a compiler macro on a (setf ...) function name --- ansi-tests/define-compiler-macro.lsp | 29 ++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/ansi-tests/define-compiler-macro.lsp b/ansi-tests/define-compiler-macro.lsp index c27f321c..2d9d993a 100644 --- a/ansi-tests/define-compiler-macro.lsp +++ b/ansi-tests/define-compiler-macro.lsp @@ -86,3 +86,32 @@ (declare (special *x*)) (list (funcall fn 'b) *x*))))) t t t a (b nil)) + +;;; Compiler macros on setf functions + +(deftest define-compiler-macro.4 + (let* ((sym (gensym)) + (fun-def-form `(defun ,sym (x) (car x))) + (setf-fun-def-form `(defun (setf ,sym) (newval x) (setf (car x) newval))) + (setf-compiler-macro-def-form + `(define-compiler-macro (setf ,sym) (newval x) + (declare (special *x*)) + (setf *x* t) + (return-from ,sym `(setf (car ,x) ,newval))))) + (values + (equalt (list sym) (multiple-value-list (eval fun-def-form))) + (equalt `((setf ,sym)) (multiple-value-list (eval setf-fun-def-form))) + (equalt `((setf ,sym)) (multiple-value-list (eval setf-compiler-macro-def-form))) + (notnot (typep (compiler-macro-function `(setf ,sym)) 'function)) + (eval `(,sym (list 'a 'b))) + (eval `(let ((arg (list 1 2))) + (list (setf (,sym arg) 'z) arg))) + (let ((fn (compile nil `(lambda (u v) (setf (,sym u) v))))) + (let ((*x* nil) + (arg (list 1 2))) + (declare (special *x*)) + (list (funcall fn arg 'y) arg))))) + t t t t a (z (z 2)) (y (y 2))) + + + \ No newline at end of file -- GitLab