diff options
| -rw-r--r-- | stdlib/doc-syms.tl | 1 | ||||
| -rw-r--r-- | stdlib/struct.tl | 27 | ||||
| -rw-r--r-- | tests/012/oop.tl | 33 | ||||
| -rw-r--r-- | txr.1 | 152 |
4 files changed, 213 insertions, 0 deletions
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl index 8b263b4c..bb51d785 100644 --- a/stdlib/doc-syms.tl +++ b/stdlib/doc-syms.tl @@ -78,6 +78,7 @@ ("/=" "N-003BE40C") (":delegate" "N-037F664C") (":key" "N-01697547") + (":mass-delegate" "N-000BBDEA") (":match" "N-03B92C0D") ("<" "D-0057") ("<!" "N-02B10DF9") diff --git a/stdlib/struct.tl b/stdlib/struct.tl index cb79aad2..e7c39fb9 100644 --- a/stdlib/struct.tl +++ b/stdlib/struct.tl @@ -417,3 +417,30 @@ ,*(if opt (cons : (mapcar (lop list :) opt))) ,*pp.rest) (qref ,delegate-expr (,target-method ,*args)))))) + +(define-struct-clause :mass-delegate (:form form self-var delegate-expr + from-struct . methods) + (let ((from-type (find-struct-type from-struct))) + (flet ((is-meth (slot) + (and (static-slot-p from-type slot) + (let ((f (static-slot from-type slot))) + (and (functionp f) + (plusp (fun-fixparam-count f))))))) + (unless from-type + (compile-error form "~s doesn't name a struct type" from-struct)) + (if (starts-with '(*) methods) + (set methods + (diff [keep-if is-meth (slots from-type)] + (cdr methods))) + (iflet ((badmeth [remove-if is-meth methods])) + (compile-error form "~s aren't methods of type ~s" badmeth from-struct))) + (collect-each ((m methods)) + (let* ((f (static-slot from-type m)) + (fix (fun-fixparam-count f)) + (opt (fun-optparam-count f)) + (var (fun-variadic f)) + (parms ^(,*(take (- fix opt) (cons self-var (gun (gensym)))) + ,*(if (plusp opt) + ^(: ,*(take opt (gun (gensym))))) + ,*(if var (gensym))))) + ^(:delegate ,m ,parms ,delegate-expr)))))) diff --git a/tests/012/oop.tl b/tests/012/oop.tl index a5c57973..b786e0b7 100644 --- a/tests/012/oop.tl +++ b/tests/012/oop.tl @@ -108,3 +108,36 @@ (mtest co.(work) "worker foo works" co.(break) "worker foo relaxes for 15 min" co.(break 5) "worker foo relaxes for 5 min")) + +(defstruct api-x () + (:method get (x a b : c . d) ^(api-x get ,x ,a ,b ,c ,d)) + (:method put (x s) ^(api-x put ,x ,s))) + +(defstruct api-y () + (:method frob (y r : s) ^(api-y frob ,y ,r ,s)) + (:method tweak (y) ^(api-y tweak ,y))) + +(defstruct api-z () + (:method decrement (z n) ^(api-z decrement ,z ,n)) + (:method increment (z n) ^(api-z increment ,z ,n))) + +(defstruct component () + (ax (new api-x)) + (ay (new api-y)) + (az (new api-z)) + (:mass-delegate o o.ax api-x *) + (:mass-delegate o o.ay api-y frob) + (:mass-delegate o o.az api-z * decrement)) + +(let ((c (new component))) + (mtest + c.(get 1 2 3 . 4) (api-x get #S(api-x) 1 2 3 4) + c.(put 5) (api-x put #S(api-x) 5) + c.(get) :error + c.(put 5 6) :error + c.(frob 7 8) (api-y frob #S(api-y) 7 8) + c.(frob 9) (api-y frob #S(api-y) 9 nil) + c.(frob 7 8 9) :error + c.(tweak) :error + c.(increment 1) (api-z increment #S(api-z) 1) + c.(decrement) :error)) @@ -31043,6 +31043,158 @@ method delegates to a differently named method co.(break 5) -> "worker foo relaxes for 5 min" .brev +.coNP Struct clause macro @ :mass-delegate +.synb +.mets (:mass-delegate < self-var < delegate-expr +.mets \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ < from-type <> [ * ] <> [ method ]*) +.syne +.desc +The +:mass-delegate +struct macro provides a way to define multiple methods which are implemented +as delegates to corresponding methods on another object. +The implementation of +.code :mass-delegate +depends on the +.code :delegate +macro. + +The +.meta self-var +argument must be a bindable symbol. In each generated delegate method, +this symbol will be the first argument. The purpose of this symbol is +to enable the +.meta delegate-expr +to refer to the delegating object. + +The +.meta delegate-expr +is an expression which is inserted into every method. It is required +to evaluates to the delegate object. This expression may make a reference to +.meta self-var +in order to retrieve the delegate from the delegating object. + +The +.meta from-type +argument is a symbol naming an existing structure type. If no such +structure type has been defined, an error exception is thrown. + +After the +.meta from-type +argument, either zero or more slot names appear, optionally preceded by the +.code * +(asterisk) symbol. + +If the +.code * +symbol is present, and isn't followed by any other symbols, it indicates +that all methods from +.meta from-type +are to be delegated. If symbols appear after the +.code * +then those specify exceptions: methods not to be delegated. +No validation is performed on the exception list; it may specify +nonexistent method names which have no effect. + +If the +.code * +symbol is absent, then every +.meta method +symbol specifies a method to be delegated. +It is consequently expected to name a method of the +.metn from-type : +a static slot which contains a function. If any +.meta method +isn't a static slot of +.metn from-type , +or not a static slot which contains a function, an error exception is thrown. + +The +.code :mass-delegate +struct macro iterates over all of the methods of +.meta from-type +that selected for delegation, and for each one it generates a +.code :delegate +macro clause based on the existing method's parameter list. +For instance, the delegate for a method which has two required arguments and +one optional will itself have two required arguments and one optional. +Delegates are not simply wrapper functions which take any number of arguments +and try to pass them to the target. + +The generated +.code :delegate +clauses are then processed by that struct clause macro. + +Note: composition with delegation is a useful alternative when +multiple inheritance is not applicable or desired for various reasons. +One such reason is that structures that would be used as multiple inheritance +bases use the same symbols for certain slots, and the semantics of those +slots conflict. Under inheritance, same-named slots coming from different +bases become one slot, + +Note: a particular +.meta from-type +being nominated in the +.code :mass-delegate +clause doesn't mean that the specific methods of that type shall be called +by the generated delegates. The methods that shall be called are those +of the calculated delegate object selected by the +.metn delegate-expr . +The +.meta from-type +is used as a source of the argument info, and method existence validation. +It is up to the application to ensure that the delegation using +.meta from-type +makes sense with respect to the delegate object that is selected by the +.metn delegate-expr : +for instance, by ensuring that this object is an instance of +.meta from-type +or a subtype thereof. + +.TP* Example: + +.verb + (defstruct foo-api () + name + (:method begin (me) ^(foo ,me.name begin)) + (:method increment (me delta) ^(foo ,me.name increment ,delta)) + (:method end (me) ^(foo ,me.name end))) + + (defstruct bar-api () + name + (:method open (me) ^(bar ,me.name open)) + (:method read (me buf) ^(bar ,me.name read ,buf)) + (:method write (me buf) ^(bar ,me.name write ,buf)) + (:method close (me) ^(bar ,me.name close))) + + ;; facade holds the two API objects by composition: + + (defstruct facade () + (foo (new foo-api name "foo")) + (bar (new bar-api name "bar")) + + ;; delegate foo-api style calls via me.foo + (:mass-delegate me me.foo foo-api *) + + ;; delegate bar-api style calls via me.bar + ;; exclude the write method. + (:mass-delegate me me.bar bar-api * write)) + + ;; instantiate facade as variable fa + (defvar fa (new facade)) -> fa + + ;; begin call on facade delegates through foo-api object. + fa.(begin) -> (foo "foo" begin) + + fa.(increment) -> ;; error: too few arguments + + fa.(increment 3) -> (foo "foo" increment 3) + + fa.(open) -> (bar "bar" open) + + fa.(write 4) -> ;; error: fa has no such method +.brev + .SS* Special Structure Functions Special structure functions are user-defined methods or structure functions |