| Paste number 2992: | Would this require a WITH-SETF-EXPANDER? |
| Pasted by: | paakku |
| 3 years, 9 months ago | |
| #lisp | Context in IRC logs | |
| Paste contents: |
| (defmacro symbol-macroletf (((symbol place)) &body body &environment environment) "Like SYMBOL-MACROLET but evaluate subforms just once up front. Binding multiple symbols in the same form has not yet been implemented." (multiple-value-bind (vars vals store-vars writer-form reader-form) (get-setf-expansion place environment) (let ((route (gensym (string symbol)))) `(let* (,@(mapcar #'list vars vals)) (flet ((,route () ,reader-form) ((setf ,route) (,(first store-vars)) ,writer-form)) (symbol-macrolet ((,symbol (,route))) ,@body)))))) ;; this works OK (let ((x 0) (v (copy-seq '(totally alone again)))) (symbol-macroletf ((s (elt v (incf x)))) (values (shiftf s 'wasted) s v))) ;; this doesn't (let ((x 0) (v (copy-seq '(totally alone again)))) (symbol-macroletf ((s (values (elt v (incf x)) (elt v (incf x))))) (shiftf s (values 'successful 'incubation)))) |
Annotations for this paste:
| Annotation number 1: | the way to do it, and features of LOOP |
| Pasted by: | paakku |
| 3 years, 9 months ago | |
| Context in IRC logs | |
| Paste contents: |
| (defmacro symbol-macroletf-helper (store-vars writer-form reader-form) (declare (ignore store-vars writer-form)) reader-form) (define-setf-expander symbol-macroletf-helper (store-vars writer-form reader-form) (values '() '() store-vars writer-form reader-form)) (defmacro symbol-macroletf ((&rest bindings) &body body &environment environment) "Like SYMBOL-MACROLET but evaluate subforms just once up front." (loop with (vars vals store-vars writer-form reader-form) for (symbol place) in bindings do (setf (values vars vals store-vars writer-form reader-form) (get-setf-expansion place environment)) nconc (mapcar #'list vars vals) into let*-bindings collect `(,symbol (symbol-macroletf-helper ,store-vars ,writer-form ,reader-form)) into symbol-macrolet-bindings finally (return `(let* (,@let*-bindings) (symbol-macrolet (,@symbol-macrolet-bindings) ,@body))))) |
| Annotation number 2: | Parallel expansions need separate store variables. |
| Pasted by: | paakku |
| 3 years, 9 months ago | |
| Context in IRC logs | |
| Paste contents: |
| ;; ERROR: The variable #:G1 occurs more than once in the lambda list. (let (x) (symbol-macroletf ((y x)) (setf (values y y) t))) ;; This change fixes it. (define-setf-expander symbol-macroletf-helper (store-vars writer-form reader-form) (let* ((new-store-vars (loop repeat (length store-vars) collect (gensym))) (new-writer-form `(let (,@(mapcar #'list store-vars new-store-vars)) ,writer-form))) (values '() '() new-store-vars new-writer-form reader-form))) |
| Annotation number 3: | almost working WITH-SETF-EXPANDER |
| Pasted by: | paakku |
| 3 years, 9 months ago | |
| Context in IRC logs | |
| Paste contents: |
| (defmacro redirect-place (setf-expander-macro place &environment env) (multiple-value-bind (vars vals stores write read) (funcall (macro-function setf-expander-macro env) place env) (declare (ignore stores write)) `(let* ,(mapcar #'list vars vals) ,read))) (define-setf-expander redirect-place (setf-expander-macro place &environment env) (funcall (macro-function setf-expander-macro env) place env)) (defmacro with-setf-expander ((access-fn lambda-list &body expander-body) &body with-body) (let ((expander (gensym)) (ignore (gensym)) (place (gensym))) `(macrolet ((,expander ,lambda-list ;; PORTABILITY: This assumes MACROLET can define a macro ;; function that returns multiple values. If your Lisp ;; implementation disagrees, you can wrap the values in ;; a list instead. But then you'd have to separate the ;; body into declarations and forms. ,@expander-body) (,access-fn (&whole ,place &rest ,ignore) (declare (ignore ,ignore)) `(redirect-place ,',expander ,,place))) ,@with-body))) ;; test (let ((x 42)) (with-setf-expander (1plus (place &environment env) (multiple-value-bind (vars vals stores write read) (get-setf-expansion place env) (let ((store (gensym))) (values vars vals `(,store) `(multiple-value-bind (,@stores) (1- ,store) ,write) `(1+ ,read))))) (values (1plus x) ; 43 (shiftf (1plus x) 69) ; 43 (1plus x) ; 69 x))) ; 68 |
| Annotation number 4: | corrected & commented test of WITH-SETF-EXPANDER |
| Pasted by: | paakku |
| 3 years, 9 months ago | |
| Context in IRC logs | |
| Paste contents: |
| (let (x) (with-setf-expander (1plus (place &environment env) (multiple-value-bind (vars vals stores write read) (get-setf-expansion place env) (let ((store (gensym))) (values vars vals `(,store) ;; Bind the first store variable ;; to the computed value and the ;; rest to nil. This also handles ;; the case where there are no ;; store variables. `(multiple-value-bind (,@stores) (values (1- ,store)) ,write ;; Remember to return the ;; correct value per 5.1.1.2. (values ,store)) `(1+ ,read))))) (values (setf (1plus x) 42) ; 42 (shiftf (1plus (1plus x)) 69) ; 43 (1plus (1plus x)) ; 69 x))) ; 67 |