diff options
Diffstat (limited to 'getparam.scm')
| -rw-r--r-- | getparam.scm | 201 |
1 files changed, 131 insertions, 70 deletions
diff --git a/getparam.scm b/getparam.scm index ad4baba..3e2d7f1 100644 --- a/getparam.scm +++ b/getparam.scm @@ -1,9 +1,9 @@ ;;; "getparam.scm" convert getopt to passing parameters by name. -; Copyright 1995, 1996, 1997 Aubrey Jaffer +; Copyright 1995, 1996, 1997, 2001 Aubrey Jaffer ; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. ; ;1. Any copy made of this software must include this copyright notice ;in full. @@ -18,39 +18,78 @@ ;each case. (require 'getopt) +(require 'coerce) -(define (getopt->parameter-list argc argv optnames arities types aliases) +(define (getopt->parameter-list argc argv optnames arities types aliases + . description) (define (can-take-arg? opt) - (not (eq? (list-ref arities (position opt optnames)) - 'boolean))) - (define (coerce-val val curopt) - (define ntyp (list-ref types (position curopt optnames))) - (case ntyp - ((expression) val) - (else (coerce val ntyp)))) - (let ((starting-optind *optind*) + (not (eq? 'boolean (list-ref arities (position opt optnames))))) + (let ((progname (list-ref argv (+ -1 *optind*))) (optlist '()) (long-opt-list '()) (optstring #f) + (pos-args '()) (parameter-list (make-parameter-list optnames)) - (curopt '*unclaimed-argument*)) - (set! aliases (map (lambda (alias) - (define str (string-copy (car alias))) - (do ((i (+ -1 (string-length str)) (+ -1 i))) - ((negative? i) (cons str (cdr alias))) - (cond ((char=? #\ (string-ref str i)) - (string-set! str i #\-))))) - aliases)) + (curopt '*unclaimed-argument*) + (positional? (assv 0 aliases)) + (unclaimeds '())) + (define (adjoin-val val curopt) + (define ntyp (list-ref types (position curopt optnames))) + (adjoin-parameters! parameter-list + (list curopt (case ntyp + ((expression) val) + (else (coerce val ntyp)))))) + (define (finish) + (cond + (positional? + (set! unclaimeds (reverse unclaimeds)) + (do ((idx 2 (+ 1 idx)) + (alias+ (assv 1 aliases) (assv idx aliases)) + (alias- (assv -1 aliases) (assv (- idx) aliases))) + ((or (not (or alias+ alias-)) (null? unclaimeds))) + (set! unclaimeds (reverse unclaimeds)) + (cond (alias- + (set! curopt (cadr alias-)) + (adjoin-val (car unclaimeds) curopt) + (set! unclaimeds (cdr unclaimeds)))) + (set! unclaimeds (reverse unclaimeds)) + (cond ((and alias+ (not (null? unclaimeds))) + (set! curopt (cadr alias+)) + (adjoin-val (car unclaimeds) curopt) + (set! unclaimeds (cdr unclaimeds))))) + (let ((alias (assv '0 aliases))) + (cond (alias + (set! curopt (cadr alias)) + (for-each (lambda (unc) (adjoin-val unc curopt)) unclaimeds) + (set! unclaimeds '())))))) + (cond ((not (null? unclaimeds)) + (slib:warn 'getopt->parameter-list 'arguments 'unclaimed unclaimeds) + (apply parameter-list->getopt-usage + progname optnames arities types aliases description)) + (else parameter-list))) + (set! aliases + (map (lambda (alias) + (cond ((string? (car alias)) + (let ((str (string-copy (car alias)))) + (do ((i (+ -1 (string-length str)) (+ -1 i))) + ((negative? i) (cons str (cdr alias))) + (cond ((char=? #\ (string-ref str i)) + (string-set! str i #\-)))))) + ((number? (car alias)) + (set! positional? (car alias)) + alias) + (else alias))) + aliases)) (for-each (lambda (alias) (define opt (car alias)) - (cond ((not (string? opt))) + (cond ((number? opt) (set! pos-args (cons opt pos-args))) + ((not (string? opt))) ((< 1 (string-length opt)) (set! long-opt-list (cons opt long-opt-list))) ((not (= 1 (string-length opt)))) ((can-take-arg? (cadr alias)) - (set! optlist (cons (string-ref opt 0) - (cons #\: optlist)))) + (set! optlist (cons (string-ref opt 0) (cons #\: optlist)))) (else (set! optlist (cons (string-ref opt 0) optlist))))) aliases) (set! optstring (list->string (cons #\: optlist))) @@ -58,50 +97,52 @@ (let ((opt (getopt-- argc argv optstring))) (case opt ((#\: #\?) - (parameter-list->getopt-usage (list-ref argv (+ -1 starting-optind)) - optnames arities types aliases) - (slib:error 'getopt->parameter-list - (case opt - ((#\:) "argument missing after") - ((#\?) "unrecognized option")) - (string #\- getopt:opt))) + (slib:warn 'getopt->parameter-list + (case opt + ((#\:) "argument missing after") + ((#\?) "unrecognized option")) + (string #\- getopt:opt)) + (apply parameter-list->getopt-usage + progname optnames arities types aliases description)) ((#f) (cond ((and (< *optind* argc) (string=? "-" (list-ref argv *optind*))) - (set! *optind* (+ 1 *optind*))) + (set! *optind* (+ 1 *optind*)) + (finish)) ((< *optind* argc) - (cond ((and (member curopt optnames) - (adjoin-parameters! - parameter-list - (list curopt - (coerce-val (list-ref argv *optind*) - curopt)))) - (set! *optind* (+ 1 *optind*)) - (loop)) - (else (slib:error 'getopt->parameter-list curopt - (list-ref argv *optind*) - "not supported")))))) + (let ((topt (assoc curopt aliases))) + (if topt (set! curopt (cadr topt))) + (cond + ((and positional? (not topt)) + (set! unclaimeds + (cons (list-ref argv *optind*) unclaimeds)) + (set! *optind* (+ 1 *optind*)) (loop)) + ((and (member curopt optnames) + (adjoin-val (list-ref argv *optind*) curopt)) + (set! *optind* (+ 1 *optind*)) (loop)) + (else (slib:error 'getopt->parameter-list curopt + (list-ref argv *optind*) + 'not 'supported))))) + (else (finish)))) (else (cond ((char? opt) (set! opt (string opt)))) (let ((topt (assoc opt aliases))) - (cond (topt (set! topt (cadr topt))) - (else (slib:error "Option not recognized -" opt))) + (if topt (set! topt (cadr topt))) (cond + ((not topt) + (slib:warn "Option not recognized -" opt) + (apply parameter-list->getopt-usage + progname optnames arities types aliases description)) ((not (can-take-arg? topt)) - (adjoin-parameters! parameter-list (list topt #t))) - (*optarg* - (set! curopt topt) - (adjoin-parameters! parameter-list - (list topt (coerce-val *optarg* curopt)))) + (adjoin-parameters! parameter-list (list topt #t)) + (loop)) + (*optarg* (set! curopt topt) (adjoin-val *optarg* curopt) (loop)) (else - (set! curopt topt) -;;; (slib:warn 'getopt->parameter-list -;;; "= missing for option--" opt) - ))) - (loop))))) - parameter-list)) +;;; (slib:warn 'getopt->parameter-list "= missing for option--" opt) + (set! curopt topt) (loop)))))))))) -(define (parameter-list->getopt-usage comname optnames arities types aliases) +(define (parameter-list->getopt-usage comname optnames arities types aliases + . description) (require 'printf) (require 'common-list-functions) (let ((aliast (map list optnames)) @@ -112,16 +153,29 @@ (set-cdr! apr (cons (car alias) (cdr apr))))) aliases) (fprintf cep "Usage: %s [OPTION ARGUMENT ...] ..." comname) - (newline cep) (newline cep) + (do ((pos+ '()) (pos- '()) + (idx 2 (+ 1 idx)) + (alias+ (assv 1 aliases) (assv idx aliases)) + (alias- (assv -1 aliases) (assv (- idx) aliases))) + ((not (or alias+ alias-)) + (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias))) + (reverse pos+)) + (let ((alias (assv 0 aliases))) + (if alias (fprintf cep " <%s> ..." (cadr alias)))) + (for-each (lambda (alias) (fprintf cep " <%s>" (cadr alias))) + pos-)) + (cond (alias- (set! pos- (cons alias- pos-)))) + (cond (alias+ (set! pos+ (cons alias+ pos+))))) + (fprintf cep "\\n\\n") (for-each (lambda (optname arity aliat) - (let loop ((initials (remove-if-not strlen=1? (cdr aliat))) - (longname (remove-if strlen=1? (cdr aliat)))) + (let loop ((initials (remove-if-not strlen=1? (remove-if number? (cdr aliat)))) + (longname (remove-if strlen=1? (remove-if number? (cdr aliat))))) (cond ((and (null? initials) (null? longname))) (else (fprintf cep (case arity - ((boolean) " %3s %s") - (else " %3s %s<%s> %s")) + ((boolean) " %3s %s\\n") + (else " %3s %s<%s> %s\\n")) (if (null? initials) "" (string-append "-" (car initials) @@ -138,15 +192,22 @@ (case arity ((nary nary1) "...") (else ""))) - (newline cep) (loop (if (null? initials) '() (cdr initials)) (if (null? longname) '() (cdr longname))))))) - optnames arities aliast))) + optnames arities aliast) + (for-each (lambda (desc) (fprintf cep " %s\\n" desc)) description)) + #f) (define (getopt->arglist argc argv optnames positions - arities types defaulters checks aliases) - (let* ((params (getopt->parameter-list - argc argv optnames arities types aliases)) - (fparams (fill-empty-parameters defaulters params))) - (and (list? params) (check-parameters checks fparams)) - (and (list? params) (parameter-list->arglist positions arities fparams)))) + arities types defaulters checks aliases . description) + (define progname (list-ref argv (+ -1 *optind*))) + (let* ((params (apply getopt->parameter-list + argc argv optnames arities types aliases description)) + (fparams (and params (fill-empty-parameters defaulters params)))) + (cond ((and (list? params) + (check-parameters checks fparams) + (parameter-list->arglist positions arities fparams))) + (params (apply parameter-list->getopt-usage + progname optnames arities types aliases description)) + (else #f)))) + |