oop: allow multiple :init, :fini, etc.

The motivation is that struct clause macros defined
using define-struct-clause may want to introduce
their own initializers and finalizers for the specific
stuff they add to the struct. The uniqueness restrictions
on these initializing and finalizing clauses makes
it impossible to use two clause macros which both want
to inject a definition of the same initializer or finalizer
type.

* stdlib/struct.tl (defstruct): Don't enforce that there
be at most one clause in the category of :init,
:postinit, :fini or :postini. Multiple are allowed.
They all execute left-to-right except for :fini.

* tests/012/fini.tl: New tests.

* tests/012/fini.expected: Updated.

* txr.1: Documented.

4 files changed, 87 insertions, 55 deletions

diff --git a/stdlib/struct.tl b/stdlib/struct.tl
index 3a89ee3a..97a7d9ed 100644
--- a/stdlib/struct.tl
+++ b/stdlib/struct.tl
@@ -50,10 +50,10 @@
       (compile-warning form "~s is a built-in type" name))
     (unless (proper-listp slot-specs)
       (compile-error form "bad syntax: dotted form"))
-    (let ((instance-init-form nil)
-          (instance-postinit-form nil)
-          (instance-fini-form nil)
-          (instance-postfini-form nil))
+    (let ((instance-init-forms nil)
+          (instance-postinit-forms nil)
+          (instance-fini-forms nil)
+          (instance-postfini-forms nil))
       (labels ((expand-slot (form slot)
                  (tree-case slot
                    ((op . args)
@@ -83,38 +83,22 @@
                       (:init
                         (unless (bindable arg)
                           (sys:bad-slot-syntax form slot))
-                        (when instance-init-form
-                          (compile-error form
-                                         "duplicate :init"))
-                        (set instance-init-form
-                             (cons arg body))
+                        (push (cons arg body) instance-init-forms)
                         ^((,word nil nil)))
                       (:postinit
                         (unless (bindable arg)
                           (sys:bad-slot-syntax form slot))
-                        (when instance-postinit-form
-                          (compile-error form
-                                         "duplicate :postinit"))
-                        (set instance-postinit-form
-                             (cons arg body))
+                        (push (cons arg body) instance-postinit-forms)
                         ^((,word nil nil)))
                       (:fini
                         (unless (bindable arg)
                           (sys:bad-slot-syntax form slot))
-                        (when instance-fini-form
-                          (compile-error form
-                                         "duplicate :fini"))
-                        (set instance-fini-form
-                             (cons arg body))
+                        (push (cons arg body) instance-fini-forms)
                         ^((,word nil nil)))
                       (:postfini
                         (unless (bindable arg)
                           (sys:bad-slot-syntax form slot))
-                        (when instance-postfini-form
-                          (compile-error form
-                                         "duplicate :postfini"))
-                        (set instance-postfini-form
-                             (cons arg body))
+                        (push (cons arg body) instance-postfini-forms)
                         ^((,word nil nil)))
                       (t (when body
                            (sys:bad-slot-syntax form slot))
@@ -172,27 +156,28 @@
                       ,*(mapcar (aret ^(when (static-slot-p ,arg-sym ',@2)
                                          (static-slot-set ,arg-sym ',@2 ,@3)))
                                 (append func-si-forms val-si-forms))))
-               ,(if (or inst-si-forms instance-init-form
-                        instance-fini-form instance-postfini-form)
+               ,(if (or inst-si-forms instance-init-forms
+                        instance-fini-forms instance-postfini-forms)
                   ^(lambda (,arg-sym)
-                     ,*(if (cdr instance-fini-form)
-                         ^((finalize ,arg-sym (sys:meth-lambda ,name :fini
-                                                               (,(car instance-fini-form))
-                                                ,*(cdr instance-fini-form))
-                                     t)))
-                     ,*(if (cdr instance-postfini-form)
-                         ^((finalize ,arg-sym (sys:meth-lambda ,name :postfini
-                                                               (,(car instance-postfini-form))
-                                                ,*(cdr instance-postfini-form)))))
+                     ,*(append-each ((iff (nreverse instance-fini-forms)))
+                         (if (cdr iff)
+                           ^((finalize ,arg-sym (sys:meth-lambda ,name :fini (,(car iff))
+                                                  ,*(cdr iff))
+                                       t))))
+                     ,*(append-each ((ipf (nreverse instance-postfini-forms)))
+                         (if (cdr ipf)
+                           ^((finalize ,arg-sym (sys:meth-lambda ,name :postfini (,(car ipf))
+                                                ,*(cdr ipf))))))
                      ,*(if inst-si-forms
                          ^((let ((,type-sym (struct-type ,arg-sym)))
                              ,*(mapcar (aret ^(unless (static-slot-p ,type-sym ',@2)
                                                 (slotset ,arg-sym ',@2 ,@3)))
                                        inst-si-forms))))
-                     ,*(if (cdr instance-init-form)
-                         ^((symacrolet ((%fun% '(,name :init)))
-                             (let ((,(car instance-init-form) ,arg-sym))
-                               ,*(cdr instance-init-form)))))))
+                     ,*(append-each ((iif (nreverse instance-init-forms)))
+                         (if (cdr iif)
+                           ^((symacrolet ((%fun% '(,name :init)))
+                               (let ((,(car iif) ,arg-sym))
+                                 ,*(cdr iif))))))))
                ,(when args
                   (when (> (countql : args) 1)
                     (compile-error form
@@ -213,11 +198,12 @@
                            ,*(mapcar (ret ^(if ,@3
                                              (slotset ,arg-sym ',@1 ,@2)))
                                      opt-args o-gens p-gens))))))
-               ,(if instance-postinit-form
+               ,(if instance-postinit-forms
                   ^(sys:meth-lambda ,name :postinit (,arg-sym)
-                     ,*(if (cdr instance-postinit-form)
-                         ^((let ((,(car instance-postinit-form) ,arg-sym))
-                             ,*(cdr instance-postinit-form)))))))))))))
+                     ,*(append-each ((ipf (nreverse instance-postinit-forms)))
+                         (if (cdr ipf)
+                           ^((let ((,(car ipf) ,arg-sym))
+                               ,*(cdr ipf))))))))))))))
 
 (defmacro sys:struct-lit (name . plist)
   ^(sys:make-struct-lit ',name ',plist))
diff --git a/tests/012/fini.expected b/tests/012/fini.expected
index a733802b..72fdc948 100644
--- a/tests/012/fini.expected
+++ b/tests/012/fini.expected
@@ -121,3 +121,11 @@ derived:38 derived postfini
 derived:39 derived postfini
 derived:40 derived postfini
 derived:41 derived postfini
+multi :init: 1
+multi :init: 2
+multi :postinit: 1
+multi :postinit: 2
+multi :fini: 2
+multi :fini: 1
+multi :postfini: 1
+multi :postfini: 2
diff --git a/tests/012/fini.tl b/tests/012/fini.tl
index 775f210f..4036b5d4 100644
--- a/tests/012/fini.tl
+++ b/tests/012/fini.tl
@@ -22,3 +22,23 @@
 
 (mapcar (ret (new derived)) (range 1 20))
 (sys:gc)
+
+(defstruct multi ()
+  (:init (me)
+    (put-line `@{%fun%}: 1`))
+  (:init (me)
+    (put-line `@{%fun%}: 2`))
+  (:postinit (me)
+    (put-line `@{%fun%}: 1`))
+  (:postinit (me)
+    (put-line `@{%fun%}: 2`))
+  (:fini (me)
+    (put-line `@{%fun%}: 1`))
+  (:fini (me)
+    (put-line `@{%fun%}: 2`))
+  (:postfini (me)
+    (put-line `@{%fun%}: 1`))
+  (:postfini (me)
+    (put-line `@{%fun%}: 2`)))
+
+(with-objects ((m (new multi))))
diff --git a/txr.1 b/txr.1
index 275391e4..7f7ac353 100644
--- a/txr.1
+++ b/txr.1
@@ -29342,11 +29342,12 @@ which the variable
 .meta param
 is bound to the structure object.
 
-The
+Multiple
 .code :init
-specifier may not appear more than once in a given
+specifiers may appear in the same
 .code defstruct
-form.
+form. They are executed in their order of appearance,
+left to right.
 
 When an object with one or more levels of inheritance
 is instantiated, the
@@ -29391,6 +29392,7 @@ of an
 .code :init
 specifier are not surrounded by an implicit
 .codn block .
+
 .meIP (:postinit <> ( param ) << body-form *)
 The
 .code :postinit
@@ -29419,8 +29421,13 @@ actions,
 .code :postinit
 actions registered at different levels of the type's
 inheritance hierarchy are invoked in the base-to-derived
-order, and in right-to-left order among multiple bases
-at the same level.
+order, in right-to-left order among multiple bases
+at the same level. Multiple
+.code :postinit
+form in the same
+.code defstruct
+are invoked in left-to-right order.
+
 .meIP (:fini <> ( param ) << body-form *)
 The
 .code :fini
@@ -29454,9 +29461,11 @@ of a
 specifier are not surrounded by an implicit
 .codn block .
 
-At most one
+Multiple
 .code :fini
-may be specified.
+clauses may be specified in the same
+.codn defstruct ,
+in which case they are invoked in reverse, right-to-left order.
 
 Note that an object's finalizers can be called explicitly with
 .codn call-finalizers .
@@ -29464,6 +29473,7 @@ Note: the
 .code with-objects
 macro arranges for finalizers to be called on objects when the execution
 of a scope terminates by any means.
+
 .meIP (:postfini <> ( param ) << body-form *)
 Like
 .codn :fini ,
@@ -29493,17 +29503,25 @@ this omits the
 parameter, which means that
 .code :postfini
 finalizers of derived structures execute after the execution of inherited
-finalizers. When both
+finalizers.  It also means that multiple
+.code :postfini
+finalizers appearing in the same
+.code defstruct
+execute in left-to-right order unlike the reverse right-to-left order of
+.code :fini
+finalizers.
+
+When both
 .code :fini
 and
 .code :postfini
-are specified in the same
+clauses are specified in the same
 .code defstruct
-form, the
+form, all the
 .code :postfini
-finalizer executes after the
+finalizers execute after all the
 .code :fini
-finalizer regardless of the order in which they appear.
+finalizers regardless of the order in which they appear.
 .RE
 .IP
 The slot names given in a