From 4b4ef6dfcf12e1db846b26a3b812aa010360d62f Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Mon, 31 Oct 2016 06:49:22 -0700 Subject: Relax restrictions on dwim places. No longer require the leftmost expression in a dwim place to itself be a place, except when the expression evaluates to a list, and the list is subject to an element deletion or a range operation. * eval.c (eval_init): Register dwim-set and dwim-del with one additional argument that the C functions now take. * lib.c (dwim_set, dwim_del): Take a new place_p argument which informs these functions whether the object they are operating on came from a syntactic place. The forbidden situations are diagnosed based on this flag: modification of the subrange of a list, or deletion of a list ref. Some error messages reworded. * lib.h (dwim_set, dwim_del): Declarations updated. * share/txr/stdlib/place.tl (defplace dwim): Produce a different update, clobber and delete expansion when the obj-place form isn't a place. In the non-place case, do not assign the result of the sys:dwim-set or sys:dwim-del operation back obj-place. Furthermore, pass a Boolean flag to sys:dwim-set and sys:dwim-del indicating which situation is the case: did the object argument come from a place or non-place. * txr.1: Documentation updated. --- share/txr/stdlib/place.tl | 76 +++++++++++++++++++++++++++++++++-------------- 1 file changed, 54 insertions(+), 22 deletions(-) (limited to 'share') diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl index eaf6bda6..7112f0ae 100644 --- a/share/txr/stdlib/place.tl +++ b/share/txr/stdlib/place.tl @@ -659,32 +659,54 @@ (with-gensyms (ogetter-sym osetter-sym obj-sym newval-sym) (let ((arg-syms (mapcar (ret (gensym)) args)) (sys:*lisp1* t)) - (with-update-expander (ogetter-sym osetter-sym) obj-place nil - ^(rlet ((,obj-sym (,ogetter-sym)) + (if (place-form-p obj-place sys:*pl-env*) + (with-update-expander (ogetter-sym osetter-sym) obj-place nil + ^(rlet ((,obj-sym (,ogetter-sym)) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args)) + (macrolet ((,getter () + '[,obj-sym ,*arg-syms]) + (,setter (val) + ^(rlet ((,',newval-sym ,val)) + (,',osetter-sym + (sys:dwim-set t ,',obj-sym + ,*',arg-syms ,',newval-sym)) + ,',newval-sym))) + ,body))) + ^(rlet ((,obj-sym ,obj-place) ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args)) (macrolet ((,getter () '[,obj-sym ,*arg-syms]) (,setter (val) ^(rlet ((,',newval-sym ,val)) - (,',osetter-sym - (sys:dwim-set ,',obj-sym - ,*',arg-syms ,',newval-sym)) + (sys:dwim-set nil ,',obj-sym + ,*',arg-syms ,',newval-sym) ,',newval-sym))) ,body)))))) (ssetter (with-gensyms (osetter-sym ogetter-sym obj-sym newval-sym) (let ((arg-syms (mapcar (ret (gensym)) args)) (sys:*lisp1* t)) - (with-update-expander (ogetter-sym osetter-sym) obj-place nil + (if (place-form-p obj-place sys:*pl-env*) + (with-update-expander (ogetter-sym osetter-sym) obj-place nil + ^(macrolet ((,ssetter (val) + ^(rlet ((,',obj-sym (,',ogetter-sym)) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) + ',arg-syms ',args) + (,',newval-sym ,val)) + (,',osetter-sym + (sys:dwim-set t ,',obj-sym + ,*',arg-syms + ,',newval-sym)) + ,',newval-sym))) + ,body)) ^(macrolet ((,ssetter (val) - ^(rlet ((,',obj-sym (,',ogetter-sym)) + ^(rlet ((,',obj-sym ,',obj-place) ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) ',arg-syms ',args) (,',newval-sym ,val)) - (,',osetter-sym - (sys:dwim-set ,',obj-sym - ,*',arg-syms - ,',newval-sym)) + (sys:dwim-set nil ,',obj-sym + ,*',arg-syms + ,',newval-sym) ,',newval-sym))) ,body))))) @@ -692,17 +714,27 @@ (with-gensyms (osetter-sym ogetter-sym obj-sym oldval-sym) (let ((arg-syms (mapcar (ret (gensym)) args)) (sys:*lisp1* t)) - (with-update-expander (ogetter-sym osetter-sym) obj-place nil - ^(macrolet ((,deleter () ;; todo: place must not have optional val - ^(rlet ((,',obj-sym (,',ogetter-sym)) - ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) - ',arg-syms ',args)) - (let ((,',oldval-sym [,',obj-sym ,*',arg-syms])) - (progn - (,',osetter-sym - (sys:dwim-del ,',obj-sym ,*',arg-syms)) - ,',oldval-sym))))) - ,body)))))) + (if (place-form-p obj-place sys:*pl-env*) + (with-update-expander (ogetter-sym osetter-sym) obj-place nil + ^(macrolet ((,deleter () + ^(rlet ((,',obj-sym (,',ogetter-sym)) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) + ',arg-syms ',args)) + (let ((,',oldval-sym [,',obj-sym ,*',arg-syms])) + (progn + (,',osetter-sym + (sys:dwim-del t ,',obj-sym ,*',arg-syms)) + ,',oldval-sym))))) + ,body)) + ^(macrolet ((,deleter () + ^(rlet ((,',obj-sym ,',obj-place) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) + ',arg-syms ',args)) + (let ((,',oldval-sym [,',obj-sym ,*',arg-syms])) + (progn + (sys:dwim-del nil ,',obj-sym ,*',arg-syms) + ,',oldval-sym))))) + ,body)))))) (defplace (force promise) body (getter setter -- cgit v1.2.3