Implementation of static slots for structures.

* share/txr/stdlib/struct.tl (sys:bad-slot-syntax): New helper function.
(defstruct): Macro revamped with new slot specifier syntax for
writing static slots as well as methods.

* struct.c (STATIC_SLOT_BASE): New preprocessor symbol.
(struct struct_type): New members, nstslots, stinitfun, stslot.
(make_struct_type_compat): New static function.
(struct_init): Register make-struct-type to make_struct_type_compat
if compatibility is 117 or lower.
Register new intrinsics static-slot, static-slot-set, call-super-method,
call-super-fun, slot-p and static-slot-p.
(call_stinitfun_chain): New static function.
(make_struct_type): Two new arguments for specifying static slots and
an initialization function for them. Logic added for setting
up static slots and handling inheritance.
(struct_type_destroy): New static function.
(struct_type_mark): Mark the new stinitfun member of struct type.
Also iterate over the static slots in the new stslot array and
mark them.
(lookup_slot): Altered to return a loc instead of a raw pointer,
and also to accept the instance object as a member.
Now resolves static slots: it can return a loc which references
a static slot in the structure type, or an instance slot in
the structure.
(lookup_static_slot): New static function.
(slot, slotset): Implementation adjusted due to new lookup_slot interface.
(static_slot, static_slot_set, slot_p, static_slot_p): New functions.
(call_super_method, call_super_fun): New static functions.
(struct_inst_print): This function can no longer assume that the slots
list lines up with the array of slots, since it contains a mixture of
static and instance slots. Earnest slot lookup has to be performed.
(struct_type_ops): Point the destroy function to struct_type_destroy
instead of cobj_destroy_free_op. A structure type now has an array
of static slots to free.

* struct.h (make_struct_type): Declaration updated.
(static_slot, static_slot_set, slot_p, static_slot_p): Declared.

* lib.c (time_init): Update call to make_struct_type with new
arguments.

* sysif.c (sysif_init): Likewise.

* tests/012/struct.tl: Update defstruct macro expansion test.

* txr.1: Documented static slots and new functions.

1 files changed, 50 insertions, 9 deletions

diff --git a/share/txr/stdlib/struct.tl b/share/txr/stdlib/struct.tl
index f5d1cf15..6bef4919 100644
--- a/share/txr/stdlib/struct.tl
+++ b/share/txr/stdlib/struct.tl
@@ -23,6 +23,10 @@
 ;; AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS
 ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
+(macro-time
+  (defun sys:bad-slot-syntax (arg)
+    (throwf 'eval-error "~s: bad slot syntax: ~s" 'defstruct arg)))
+
 (defmacro defstruct (name-spec super . slot-specs)
   (tree-bind (name args) (tree-case name-spec
                            ((atom . args) (list atom args))
@@ -31,17 +35,54 @@
       (throwf 'eval-error "~s: ~s isn't a bindable symbol" 'defstruct name))
     (unless (proper-listp slot-specs)
       (throwf 'eval-error "~s: bad slot syntax" 'defstruct))
-    (let ((slot-init-forms (collect-each ((slot slot-specs))
-                             (tree-case slot
-                               ((sym init-form) slot)
-                               (sym (list sym nil))))))
-      (whenlet ((bad [find-if [notf bindable] slot-init-forms car]))
+    (let* ((slot-init-forms (collect-each ((slot slot-specs))
+                              (tree-case slot
+                                ((word name args . body)
+                                 (caseq word
+                                   (:method
+                                     (when (not args)
+                                       (throwf 'eval-error
+                                               "~s: method ~s needs \
+                                               \ at least one parameter"
+                                               'defstruct name))
+                                     ^(:static ,name (lambda ,args ,*body)))
+                                   (:function ^(:static ,name
+                                                        (lambda ,args ,*body)))
+                                   ((:static :instance)
+                                     (when body
+                                       (sys:bad-slot-syntax slot))
+                                     ^(,word ,name ,args))
+                                   (t (sys:bad-slot-syntax slot))))
+                                ((word name)
+                                   (caseq word
+                                     ((:static :instance)
+                                      ^(,word ,name nil))
+                                     (t ^(:instance ,word ,name))))
+                                ((name)
+                                  ^(:instance ,name nil))
+                                (name
+                                  ^(:instance ,name nil)))))
+           (stat-si-forms [keep-if (op eq :static) slot-init-forms car])
+           (inst-si-forms [keep-if (op eq :instance) slot-init-forms car])
+           (stat-slots [mapcar second stat-si-forms])
+           (inst-slots [mapcar second inst-si-forms]))
+      (whenlet ((bad [find-if [notf bindable]
+                              (append stat-slots inst-slots)]))
         (throwf 'eval-error "~s: slot name ~s isn't a bindable symbol"
-                'defstruct (car bad)))
-      (let ((arg-sym (gensym)))
-        ^(make-struct-type ',name ',super ',[mapcar car slot-init-forms]
+                'defstruct bad))
+      (let ((arg-sym (gensym))
+            (type-sym (gensym)))
+        ^(sys:make-struct-type
+           ',name ',super ',stat-slots ',inst-slots
+           (lambda (,arg-sym)
+             ,*(mapcar (aret ^(when (static-slot-p ,arg-sym ',@2)
+                                (static-slot-set ,arg-sym ',@2 ,@3)))
+                       stat-si-forms))
            (lambda (,arg-sym)
-             ,*(mapcar (aret ^(slotset ,arg-sym ',@1 ,@2)) slot-init-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 args
               (let ((gens (mapcar (ret (gensym)) args)))
                 ^(lambda (,arg-sym ,*gens)