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.

1 files changed, 29 insertions, 43 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))