From 2eaa8bdbb3a6d426a9de4d916dad63f77fd54092 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 12 Dec 2019 15:17:15 -0800
Subject: define-option-struct: use multiple inheritance

* share/txr/stdlib/getopts.tl (sys:option-base): New struct
type, holding the boiler-plate methods and slots that were
generated into the user-defined struct by
define-option-struct.
(define-option-struct): Inject the required properties by
inheritance from sys:option-base, greatly reducing code bloat
in the macro. The slot hash and opt-desc-list static slots
have to be redefined in the derived structure so that type has
its own instance of them.
---
 share/txr/stdlib/getopts.tl | 36 ++++++++++++++++++++++--------------
 1 file changed, 22 insertions(+), 14 deletions(-)

(limited to 'share')

diff --git a/share/txr/stdlib/getopts.tl b/share/txr/stdlib/getopts.tl
index a556493d..be6dec4f 100644
--- a/share/txr/stdlib/getopts.tl
+++ b/share/txr/stdlib/getopts.tl
@@ -341,25 +341,33 @@
            (put-line ln)))
     (put-line))))
 
-(defmacro define-option-struct (name super . opts)
+
+(defstruct sys:option-base nil
+  in-args
+  out-args
+  (:static slot-hash)
+  (:static opt-desc-list)
+  (:method add-opt (me opt)
+    (slotset me [me.slot-hash (or opt.desc.long opt.desc.short)] opt.arg))
+  (:method getopts (me args)
+    (set me.in-args args me.out-args args)
+    (let ((opr (new sys:opt-processor od-list me.opt-desc-list opts me)))
+      opr.(parse-opts args)))
+  (:method opthelp (me : (stream *stdout*))
+    (opthelp me.opt-desc-list stream)))
+
+(defmacro define-option-struct (name super-spec . opts)
   (let* ((slots (mapcar (tb ((short long . rest))
                           (or long short))
-                        opts)))
-    ^(defstruct ,name ,super
+                        opts))
+         (supers (if (and super-spec (atom super-spec))
+                   (list super-spec)
+                   super-spec)))
+    ^(defstruct ,name (,*supers sys:option-base)
        ,*slots
-       in-args
-       out-args
        (:static slot-hash #H(() ,*(mapcar [juxt symbol-name identity] slots)))
        (:static opt-desc-list ',(mapcar (tb ((short long . rest))
                                           (opt (if short (symbol-name short))
                                                (if long (symbol-name long))
                                                . rest))
-                                        opts))
-       (:method add-opt (me opt)
-         (slotset me [me.slot-hash (or opt.desc.long opt.desc.short)] opt.arg))
-       (:method getopts (me args)
-         (set me.in-args args me.out-args args)
-         (let ((opr (new sys:opt-processor od-list me.opt-desc-list opts me)))
-           opr.(parse-opts args)))
-       (:method opthelp (me : (stream *stdout*))
-         (opthelp me.opt-desc-list stream)))))
+                                        opts)))))
-- 
cgit v1.2.3