diff options
| -rw-r--r-- | eval.c | 4 | ||||
| -rw-r--r-- | lib.c | 43 | ||||
| -rw-r--r-- | lib.h | 4 | ||||
| -rw-r--r-- | share/txr/stdlib/place.tl | 76 | ||||
| -rw-r--r-- | txr.1 | 26 |
5 files changed, 107 insertions, 46 deletions
@@ -5347,8 +5347,8 @@ void eval_init(void) reg_fun(intern(lit("ref"), user_package), func_n2(ref)); reg_fun(intern(lit("refset"), user_package), func_n3(refset)); reg_fun(intern(lit("replace"), user_package), func_n4o(replace, 2)); - reg_fun(intern(lit("dwim-set"), system_package), func_n1v(dwim_set)); - reg_fun(intern(lit("dwim-del"), system_package), func_n2(dwim_del)); + reg_fun(intern(lit("dwim-set"), system_package), func_n2v(dwim_set)); + reg_fun(intern(lit("dwim-del"), system_package), func_n3(dwim_del)); reg_fun(intern(lit("update"), user_package), func_n2(update)); reg_fun(intern(lit("search"), user_package), func_n4o(search, 2)); reg_fun(intern(lit("rsearch"), user_package), func_n4o(rsearch, 2)); @@ -8435,7 +8435,7 @@ val replace(val seq, val items, val from, val to) } } -val dwim_set(val seq, varg vargs) +val dwim_set(val place_p, val seq, varg vargs) { switch (type(seq)) { case COBJ: @@ -8459,8 +8459,10 @@ val dwim_set(val seq, varg vargs) return seq; } - if (structp(seq)) - return funcall(method_args(seq, lambda_set_s, vargs)); + if (structp(seq)) { + (void) funcall(method_args(seq, lambda_set_s, vargs)); + return seq; + } } /* fallthrough */ default: @@ -8468,7 +8470,7 @@ val dwim_set(val seq, varg vargs) cnum index = 0; val ind_range, newval; if (!args_two_more(vargs, 0)) - uw_throwf(error_s, lit("dwim place assignment: missing required arguments"), nao); + uw_throwf(error_s, lit("index/range assignment: missing required arguments"), nao); ind_range = args_get(vargs, &index); newval = args_get(vargs, &index); @@ -8477,10 +8479,14 @@ val dwim_set(val seq, varg vargs) case CONS: case LCONS: case VEC: + if (!place_p && listp(seq)) + goto notplace; return replace(seq, newval, ind_range, colon_k); case RNG: { range_bind (x, y, ind_range); + if (!place_p && listp(seq)) + goto notplace; return replace(seq, newval, x, y); } default: @@ -8489,14 +8495,33 @@ val dwim_set(val seq, varg vargs) } } } +notplace: + uw_throwf(error_s, lit("range assignment: list form must be place"), nao); } -val dwim_del(val seq, val ind_range) +val dwim_del(val place_p, val seq, val ind_range) { - if (hashp(seq)) { - (void) remhash(seq, ind_range); - return seq; - } else if (rangep(ind_range)) { + switch (type(seq)) { + case NIL: + case CONS: + case LCONS: + if (!place_p) + uw_throwf(error_s, lit("index/range delete: list form must be place"), + nao); + break; + case COBJ: + if (seq->co.cls == hash_s) { + (void) remhash(seq, ind_range); + return seq; + } + if (structp(seq)) + uw_throwf(error_s, lit("index/range delete: not supported for structs"), + nao); + default: + break; + } + + if (rangep(ind_range)) { return replace(seq, nil, from(ind_range), to(ind_range)); } else { return replace(seq, nil, ind_range, succ(ind_range)); @@ -962,8 +962,8 @@ val empty(val seq); val sub(val seq, val from, val to); val ref(val seq, val ind); val refset(val seq, val ind, val newval); -val dwim_set(val seq, varg); -val dwim_del(val seq, val ind_range); +val dwim_set(val place_p, val seq, varg); +val dwim_del(val place_p, val seq, val ind_range); val butlast(val seq, val idx); val replace(val seq, val items, val from, val to); val update(val seq, val fun); 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 @@ -12634,14 +12634,18 @@ at the specified .metn index , which is a nonnegative integer. -This form is also a place if the -.meta sequence -subform is a place. If a value is stored to this place, it replaces the +This form is also a syntactic place. +If a value is stored to this place, it replaces the element. The place may also be deleted, which has the effect of removing the element from the sequence, shifting the elements at higher indices, if any, down one element position, and shortening the sequence by one. +If the place is deleted, and if +.meta sequence +is a list, then the +.meta sequence +form itself must be a place. .meIP >> [ sequence << from-index..to-below-index ] Retrieve the specified range of elements. @@ -12655,14 +12659,17 @@ fields of a range object. The .code rcons function. See the section on Range Indexing below. -This form is also a syntactic place, if the -.meta sequence -subform is a place. Storing a value in this place +This form is also a syntactic place. Storing a value in this place has the effect of replacing the subsequence with a new subsequence. Deleting the place has the effect of removing the specified subsequence from .metn sequence . +If +.meta sequence +is a list, then the +.meta sequence +form must itself be a place. The .meta new-value argument in a range assignment can be a string, vector or list, @@ -22519,7 +22526,7 @@ This has an effect which can be described by the following code: .cblk (progn - (set s s.(lambda-set a b c d v)) + s s.(lambda-set a b c d v) v) .cble @@ -22560,10 +22567,7 @@ arguments. The return value of .code lambda-set -is significant. Unless there is a very good reason for the method to -do otherwise, it should return the structure itself. This is because -the place-mutating operators store this returned value back to the place -which holds the structure itself. +is ignored. .TP* Example |