diff options
| -rw-r--r-- | share/txr/stdlib/getopts.tl | 36 |
1 files changed, 22 insertions, 14 deletions
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))))) |