diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-12-23 07:59:18 -0800 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-12-23 07:59:18 -0800 |
| commit | d1caae1ac6f393d0bc8cbcf62804dbac0033d133 (patch) | |
| tree | cbc49bc073c8086c1f97f1efb5378eb518484896 /stdlib | |
| parent | da6829688c5ff6d294cb6157a84166837c880562 (diff) | |
| download | txr-d1caae1ac6f393d0bc8cbcf62804dbac0033d133.tar.gz txr-d1caae1ac6f393d0bc8cbcf62804dbac0033d133.tar.bz2 txr-d1caae1ac6f393d0bc8cbcf62804dbac0033d133.zip | |
new feature: :mass-delegate struct clause macro.
With :mass-delegate, it is possible to generate delegation
methods in bulk. All of the methods of a struct type can be
mirrored by delegates in another struct type just by writing
a single :mass-delegate clause.
* stdlib/struct.tlk (:mass-delegate): New struct clause macro.
* tests/012/oop.tl: New tests.
* txr.1: Documented.
* stdlib/doc-syms.tl: Updated.
Diffstat (limited to 'stdlib')
| -rw-r--r-- | stdlib/doc-syms.tl | 1 | ||||
| -rw-r--r-- | stdlib/struct.tl | 27 |
2 files changed, 28 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)))))) |