new feature: defstruct clause macros.

* lisplib.c (struct_set_entries): Trigger autoload on new
symbols define-struct-clause and *struct-clause-expander*.

* stdlib/struct.tl (*struct-clause-expander*): New variable.
(defstruct): expand-slot local function now returns list of
expanded slots, not a single slot; every case in the tree-case
is converted to return a list. The syntax of a slot clause is
first expanded through *struct-clause-expander hash; if that
works then the resulting list is further scanned for
expansions.
(define-struct-clause): New macro.
(:delegate): New struct clause defined with
define-struct-clause. Provides single-slot delegation.

* tests/012/oop.tl: Tests for :delegate.

* txr.1: Documented define-struct-clause and :delegate.

* stdlib/doc-syms.tl: Updated.

5 files changed, 313 insertions, 18 deletions

diff --git a/lisplib.c b/lisplib.c
index 7e6dd39f..d556a764 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -213,7 +213,8 @@ 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
+    lit("meth"), lit("umeth"), lit("usl"), lit("defmeth"), lit("rslot"),
+    lit("*struct-clause-expander*"), lit("define-struct-clause"), nil
   };
 
   set_dlt_entries_sys(dlt, sys_name, fun);
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index 63894b85..8b263b4c 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -76,6 +76,7 @@
       ("/" "D-0049")
       ("//" "N-0054C409")
       ("/=" "N-003BE40C")
+      (":delegate" "N-037F664C")
       (":key" "N-01697547")
       (":match" "N-03B92C0D")
       ("<" "D-0057")
@@ -468,6 +469,7 @@
       ("define-option-struct" "N-0126C738")
       ("define-param-expander" "N-019F25A5")
       ("define-place-macro" "N-02C3089A")
+      ("define-struct-clause" "N-00FF2A51")
       ("defmacro" "N-02CAEF0B")
       ("defmatch" "N-0049315A")
       ("defmeth" "N-0047C7E8")
diff --git a/stdlib/struct.tl b/stdlib/struct.tl
index 55a30721..cb79aad2 100644
--- a/stdlib/struct.tl
+++ b/stdlib/struct.tl
@@ -24,6 +24,9 @@
 ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 ;; POSSIBILITY OF SUCH DAMAGE.
+
+(defvar *struct-clause-expander* (hash))
+
 (defun sys:bad-slot-syntax (form arg)
   (compile-error form "bad slot syntax ~s" arg))
 
@@ -48,22 +51,27 @@
           (instance-fini-form nil))
       (labels ((expand-slot (form slot)
                  (tree-case slot
+                   ((op . args)
+                    (iflet ((expander [*struct-clause-expander* op]))
+                      (append-each ((exslot [expander slot form]))
+                        [expand-slot form exslot])
+                      :))
                    ((word name args . body)
                     (caseq word
                       (:method
                         (when (not args)
                           (compile-error form "method ~s needs at least one parameter" name))
-                        ^(:function ,name
-                           (lambda ,args
-                             (block ,name ,*body))))
-                      (:function ^(,word ,name
-                                         (lambda ,args
-                                           (block ,name
-                                             ,*body))))
+                        ^((:function ,name
+                            (lambda ,args
+                              (block ,name ,*body)))))
+                      (:function ^((,word ,name
+                                          (lambda ,args
+                                            (block ,name
+                                              ,*body)))))
                       ((:static :instance)
                        (when body
                          (sys:bad-slot-syntax form slot))
-                       ^(,word ,name ,args))
+                       ^((,word ,name ,args)))
                       (t :)))
                    ((word (arg) . body)
                     (caseq word
@@ -75,7 +83,7 @@
                                          "duplicate :init"))
                         (set instance-init-form
                              (cons arg body))
-                        ^(,word nil nil))
+                        ^((,word nil nil)))
                       (:postinit
                         (unless (bindable arg)
                           (sys:bad-slot-syntax form slot))
@@ -84,7 +92,7 @@
                                          "duplicate :postinit"))
                         (set instance-postinit-form
                              (cons arg body))
-                        ^(,word nil nil))
+                        ^((,word nil nil)))
                       (:fini
                         (unless (bindable arg)
                           (sys:bad-slot-syntax form slot))
@@ -93,24 +101,24 @@
                                          "duplicate :fini"))
                         (set instance-fini-form
                              (cons arg body))
-                        ^(,word nil nil))
+                        ^((,word nil nil)))
                       (t (when body
                            (sys:bad-slot-syntax form slot))
                          :)))
                    ((word name)
                     (caseq word
                       ((:static)
-                       ^(,word ,name))
+                       ^((,word ,name)))
                       ((:instance)
-                       ^(,word ,name nil))
+                       ^((,word ,name nil)))
                       ((:method :function)
                        (sys:bad-slot-syntax form slot))
-                      (t ^(:instance ,word ,name))))
+                      (t ^((:instance ,word ,name)))))
                    ((name)
-                    ^(:instance ,name nil))
+                    ^((:instance ,name nil)))
                    (name
-                     ^(:instance ,name nil)))))
-        (let* ((slot-init-forms (collect-each ((slot slot-specs))
+                     ^((:instance ,name nil))))))
+        (let* ((slot-init-forms (append-each ((slot slot-specs))
                                   (expand-slot form slot)))
                (supers (if (and super-spec (atom super-spec))
                          (list super-spec)
@@ -380,3 +388,32 @@
                                    (sys:rslotset ,',struct ,',sym
                                              ,',meth-sym ,val))))
        ,body)))
+
+(defmacro define-struct-clause (:form form keyword (. params) . body)
+  (if (meq keyword :static :instance :function :method :init :postinit :fini)
+    (compile-error form "~s is a reserved defstruct clause keyword" keyword))
+  (unless (keywordp keyword)
+    (compile-error form "~s: clauses must be named by keyword symbols" keyword))
+  (with-gensyms (slot form)
+    ^(progn
+       (set [*struct-clause-expander* ,keyword]
+          (lambda (,slot ,form)
+            (mac-param-bind ,form ,params (cdr ,slot) ,*body)))
+       ,keyword)))
+
+(compile-only
+  (load-for (struct sys:param-parser-base "param")))
+
+(define-struct-clause :delegate (:form form
+                                 meth-name params delegate-expr
+                                 : (target-method meth-name))
+  (unless params
+    (compile-error form "delegate method requires at least one argument"))
+  (let* ((obj (car params))
+         (pp (new (fun-param-parser (cdr params) form)))
+         (opt pp.(opt-syms))
+         (args (append pp.req opt pp.rest)))
+    ^((:method ,meth-name (,obj ,*pp.req
+                           ,*(if opt (cons : (mapcar (lop list :) opt)))
+                           ,*pp.rest)
+        (qref ,delegate-expr (,target-method ,*args))))))
diff --git a/tests/012/oop.tl b/tests/012/oop.tl
index bab4ab68..a5c57973 100644
--- a/tests/012/oop.tl
+++ b/tests/012/oop.tl
@@ -93,3 +93,18 @@
     (new* type a 3 b 4)) #S(ab a 3 b 4)
   (let ((type (find-struct-type 'ab)))
     (new* (type 3 4))) #S(ab a 3 b 4))
+
+(defstruct worker ()
+  name
+  (:method work (me) `worker @{me.name} works`)
+  (:method relax (me : (min 15)) `worker @{me.name} relaxes for @min min`))
+
+(defstruct contractor ()
+  sub
+  (:delegate work (me) me.sub.sub)
+  (:delegate break (me : min) me.sub.sub relax))
+
+(let ((co (new contractor sub (new contractor sub (new worker name "foo")))))
+  (mtest co.(work) "worker foo works"
+         co.(break) "worker foo relaxes for 15 min"
+         co.(break 5) "worker foo relaxes for 5 min"))
diff --git a/txr.1 b/txr.1
index 46cfe27b..81440eb9 100644
--- a/txr.1
+++ b/txr.1
@@ -28196,6 +28196,23 @@ compares the replacement object in place of the original, and an
 hash table uses the replacement object as the key for the purposes of
 hashing and comparison.
 
+.NP* Custom Slot Expansion
+
+The
+.code defstruct
+macro has a provision for for application-defined clauses, which may
+be defined using the
+.code define-struct-clause
+macro. This macro associates new clause keywords with custom expansion.
+The
+.code :delegate
+clause of
+.code defstruct
+is in fact implemented externally to
+.code defstruct
+using
+.codn define-struct-clause .
+
 .coNP Macro @ defstruct
 .synb
 .mets (defstruct >> { name | >> ( name << arg *)} < super
@@ -30803,6 +30820,229 @@ if there are no forms. The invocations of
 .code call-finalizers
 take place just before the value of the last form is returned.
 
+.coNP Macro @ define-struct-clause
+.synb
+.mets (define-struct-clause < keyword < params <> [ body-form ]*)
+.syne
+.desc
+The
+.code define-struct-clause
+macro makes available a new, application-defined
+.code defstruct
+clause. The clause is named by
+.metn keyword ,
+which must be a keyword symbol, and is implemented as a macro
+transformation by the
+.meta params
+and
+.metn body-form s
+of the definition. The definition established by
+.code define-struct-clause
+is called a
+.IR "struct clause macro" .
+
+A struct clause macro is invoked when
+.code defstruct
+syntax is processed which contains one or more clauses which are
+headed by the matching
+.meta keyword
+symbol.
+
+The
+.meta params
+comprise a macro-style parameter list which must match the
+invoking clause, otherwise an error exception is thrown.
+When
+.meta params
+successfully matches the clause parameters, the parameters
+are destructured into the parameters and the
+.metn body-form s
+are evaluated in the scope of those parameters.
+
+The
+.metn body-form s
+must return a possibly list of
+.code defstruct
+clauses, not a single clause.
+
+Each of the returned clauses is examined for the possibility that
+it may be a struct clause macro; if so, it is expanded.
+
+The built-in clause keywords
+.codn :static ,
+.codn :instance ,
+.codn :function ,
+.codn :method ,
+.codn :init ,
+.code :postinit
+and
+.code :fini
+may not be used as the names of a struct clause macro; if any of these
+symbols is used as the
+.meta keyword
+parameter of
+.codn define-struct-clause ,
+an error exception is thrown.
+
+The return value of a
+.code define-struct-clause
+macro invocation is the
+.meta keyword
+argument.
+
+.TP* Examples:
+
+.verb
+  ;; Trivial struct clause macro which consumes any number of
+  ;; arguments and produces no slots:
+
+  (define-struct-clause :nothing (. ignored-args))
+
+  ;; Consequently, the following defines a struct with one slot, x:
+  ;; The (:nothing ...) clause disappears by producing no clauses.
+
+  (defstruct foo ()
+    (:nothing 1 2 3 beeblebrox)
+    x)
+
+  ;; struct clause macro called :multi which takes an initial value
+  ;; and zero or more slot names. It produces instance slot definitions
+  ;; which all use that same initial value.
+
+  (define-struct-clause :multi (init-val . names)
+    (mapcar (lop list init-val) names))
+
+  ;; define a struct with three slots initialized to zero:
+
+  (defstruct bar ()
+    (:multi 0 a b c)) ;; expands to (a 0) (b 0) (c 0)
+
+  ;; struct clause macro to define a slot along with a
+  ;; get and set method.
+
+  (define-struct-clause :getset (slot getter setter : init-val)
+    ^((,slot ,init-val)
+      (:method ,getter (obj) obj.,slot)
+      (:method ,setter (obj new) (set obj.,slot new))))
+
+  ;; Example use:
+
+  (defstruct point ()
+    (:getset x get-x set-x 0)
+    (:getset y get-y set-y 0))
+
+  ;; This has exactly the same effect as the following defstruct:
+
+  (defstruct point ()
+    (x 0)
+    (y 0)
+    (:method get-x (obj) obj.x)
+    (:method set-x (ob new) (set obj.x new))
+    (:method get-y (obj) obj.y)
+    (:method set-y (ob new) (set obj.y new)))
+.brev
+
+.coNP Struct clause macro @ :delegate
+.synb
+.mets (:delegate < name <> ( param +) < delegate-expr <> [ target-name ])
+.syne
+.desc
+The
+:delegate
+struct clause macro provides a way to define a method  which is implemented entirely
+by delegation to a different object.  The name of the method is
+.meta name
+and its parameter list is specified in the sme way as in the
+.meta :method
+clause. Instead of a method body, the
+.code :delegate
+clause has an expression
+.meta delegate-expr
+and an optional
+.meta target-name
+which defaults to
+.metn name .
+The
+.meta delegate-expr
+must be an expression which the delegate method can evaluate to
+produce a delegate object. The delegate method then passes its
+arguments to the target method, given by the
+.meta target-name
+argument, invoked on the delegate object. If the delegate method has optional
+parameters which have not received an argument value, those parameters
+are treated as if they had received the colon symbol
+.code :
+as their value, and that value is passed on. If the delegate method has
+variadic parameters, they are applied to the target. If optional parameters
+specified in
+.code :delegate
+are given argument values, those are discarded, playing no role in the
+delegation.
+
+.TP* Example:
+
+Structure definitions:
+
+.verb
+  (defstruct worker ()
+    name
+    (:method work (me)
+      `worker @{me.name} works`)
+    (:method relax (me : (min 15))
+      `worker @{me.name} relaxes for @min min`))
+
+  ;; "contractor" class has a sub ("subcontractor") slot
+  ;; which is another contractor of the same type.
+  ;; The subcontractor's own sub slot, however is going
+  ;; to be a worker.
+
+  (defstruct contractor ()
+    sub
+    (:delegate work (me) me.sub.sub)
+    (:delegate break (me : min) me.sub.sub relax))
+.brev
+
+The
+.code contractor
+structure's
+.code work
+and
+.code break
+methods delegate to the sub-subcontractor, which is going to be
+instantiated as a
+.code worker
+object.  Note that the
+.code break
+method delegates to a differently named method
+.codn relax .
+
+.verb
+  ;; The objects are set up as described above.
+  ;; general contractor co has a co.sub subcontractor,
+  ;; and co.sub.sub is a worker:
+
+  (defvar co (new contractor
+                  sub (new contractor
+                           sub (new worker name "foo"))))
+
+  ;; Call work method on general contractor:
+  ;; this invokes co.sub.sub.(work) on the worker.
+
+  co.(work) -> "worker foo works"
+
+  ;; Call break method on general contractor with
+  ;; no argument. This causes co.sub.sub.(relax :)
+  ;; to be invoked, triggering argument defaulting:
+
+  co.(break) -> "worker foo relaxes for 15 min"
+
+  ;; Call break method with argument. This
+  ;; invokes co.sub.sub.(relax 5), specifying a
+  ;; value for the default argument:
+
+  co.(break 5) -> "worker foo relaxes for 5 min"
+.brev
+
 .SS* Special Structure Functions
 
 Special structure functions are user-defined methods or structure functions