diff options
| -rw-r--r-- | lisplib.c | 1 | ||||
| -rw-r--r-- | share/txr/stdlib/struct.tl | 62 | ||||
| -rw-r--r-- | txr.1 | 27 |
3 files changed, 64 insertions, 26 deletions
@@ -209,6 +209,7 @@ static val struct_set_entries(val dlt, val fun) }; val name[] = { lit("defstruct"), lit("qref"), lit("uref"), lit("new"), lit("lnew"), + lit("new*"), lit("lnew*"), lit("meth"), lit("umeth"), lit("usl"), lit("defmeth"), lit("rslot"), nil }; diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl index 5aa61d74..424748e7 100644 --- a/share/txr/stdlib/struct.tl +++ b/share/txr/stdlib/struct.tl @@ -244,36 +244,46 @@ (t (with-gensyms (ovar) ^(lambda (,ovar) (qref ,ovar ,*args)))))) -(defmacro new (:form form spec . pairs) - (if (oddp (length pairs)) - (throwf 'eval-error "~s: slot initform arguments must occur pairwise" - 'new)) +(defun sys:new-type (op form type) + (caseq op + ((new lnew) (sys:check-struct form type) ^',type) + (t type))) + +(defun sys:new-expander (op form spec pairs) + (when (oddp (length pairs)) + (compile-error form + "~s: slot initform arguments must occur pairwise" op)) (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs)))) (tree-case spec - ((atom . args) - (sys:check-struct form atom) - (if qpairs - ^(make-struct ',atom (list ,*qpairs) ,*args) - ^(struct-from-args ',atom ,*args))) - (atom - (sys:check-struct form atom) - ^(struct-from-plist ',atom ,*qpairs))))) + ((texpr . args) + (let ((type (sys:new-type op form texpr))) + (caseq op + ((new new*) (if qpairs + ^(make-struct ,type (list ,*qpairs) ,*args) + ^(struct-from-args ,type ,*args))) + ((new* lnew*) ^(make-lazy-struct ,type + (lambda () + (cons (list ,*qpairs) + (list ,*args)))))))) + (texpr + (let ((type (sys:new-type op form texpr))) + (caseq op + ((new new*) ^(struct-from-plist ,type ,*qpairs)) + ((lnew lnew*) ^(make-lazy-struct type + (lambda () + (list (list ,*qpairs))))))))))) + +(defmacro new (:form form spec . pairs) + (sys:new-expander (car form) form spec pairs)) + +(defmacro new* (:form form spec . pairs) + (sys:new-expander (car form) form spec pairs)) (defmacro lnew (:form form spec . pairs) - (if (oddp (length pairs)) - (throwf 'eval-error "~s: slot initform arguments must occur pairwise" - 'lnew)) - (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs)))) - (tree-case spec - ((atom . args) - (sys:check-struct form atom) - ^(make-lazy-struct ',atom - (lambda () - (cons (list ,*qpairs) - (list ,*args))))) - (atom - (sys:check-struct form atom) - ^(make-lazy-struct ',atom (lambda () (list (list ,*qpairs)))))))) + (sys:new-expander (car form) form spec pairs)) + +(defmacro lnew* (:form form spec . pairs) + (sys:new-expander (car form) form spec pairs)) (defmacro meth (obj slot . bound-args) ^[(fun method) ,obj ',slot ,*bound-args]) @@ -24297,6 +24297,33 @@ initialization. Thus, during initialization, its instance slots may be freely accessed. Slots not yet initialized evaluate as .codn nil . +.coNP Macros @ new* and @ lnew* +.synb +.mets (new* >> { expr | >> ( expr << arg *)} >> { slot << init-form }*) +.mets (lnew* >> { expr | >> ( expr << arg *)} >> { slot << init-form }*) +.syne +.desc +The +.code new* +and +.code lnew* +macros are variants, respectively, of +.code new +and +.codn lnew . + +The only difference in behavior in these macros relative to +.code new +and +.code lnew +is that the +.meta name +argument is replaced with an expression +.meta expr +which is evaluated. The value of +.meta expr +must be a struct type, or a symbol which is the name of a struct type. + .coNP Macro @ with-slots .synb .mets (with-slots >> ({ slot | >> ( sym << slot )}*) < struct-expr |