diff options
Diffstat (limited to 'paramlst.scm')
| -rw-r--r-- | paramlst.scm | 74 |
1 files changed, 61 insertions, 13 deletions
diff --git a/paramlst.scm b/paramlst.scm index f01788b..706c91c 100644 --- a/paramlst.scm +++ b/paramlst.scm @@ -1,5 +1,5 @@ ;;; "paramlst.scm" passing parameters by name. -; Copyright 1995 Aubrey Jaffer +; Copyright 1995, 1996, 1997 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 @@ -43,13 +43,13 @@ (lambda (arity) (assq arity table)))) -(define (fill-empty-parameters defaults parameter-list) - (map (lambda (default parameter) +(define (fill-empty-parameters defaulters parameter-list) + (map (lambda (defaulter parameter) (cond ((null? (cdr parameter)) (cons (car parameter) - (if default (default parameter-list) '()))) + (if defaulter (defaulter parameter-list) '()))) (else parameter))) - defaults parameter-list)) + defaulters parameter-list)) (define (check-parameters checks parameter-list) (for-each (lambda (check parameter) @@ -139,7 +139,8 @@ ((expression) val) (else (coerce val ntyp)))) (require 'getopt) - (let ((optlist '()) + (let ((starting-optind *optind*) + (optlist '()) (long-opt-list '()) (optstring #f) (parameter-list (make-parameter-list optnames)) @@ -168,9 +169,55 @@ (let ((opt (getopt-- argc argv optstring))) (case opt ((#\: #\?) - (slib:error - 'getopt->parameter-list "unrecognized option" - getopt:opt)) + (let ((aliast (map list optnames)) + (strlen=1? (lambda (s) (= 1 (string-length s)))) + (cep (current-error-port))) + (require 'printf) + (require 'common-list-functions) + (for-each (lambda (alias) + (let ((apr (assq (cadr alias) aliast))) + (set-cdr! apr (cons (car alias) (cdr apr))))) + aliases) + (fprintf cep "Usage: %s [OPTION ARGUMENT ...] ..." + (list-ref argv (+ -1 starting-optind))) + (newline cep) (newline cep) + (for-each + (lambda (optname arity aliat) + (let loop ((initials (remove-if-not strlen=1? (cdr aliat))) + (longname (remove-if strlen=1? (cdr aliat)))) + (cond ((and (null? initials) (null? longname))) + (else + (fprintf cep + (case arity + ((boolean) " %3s %s") + (else " %3s %s<%s> %s")) + (if (null? initials) + "" + (string-append + "-" (car initials) + (if (null? longname) " " ","))) + (if (null? longname) + " " + (string-append + "--" (car longname) + (case arity + ((boolean) " ") + (else "=")))) + (case arity + ((boolean) "") + (else optname)) + (case arity + ((nary nary1) "...") + (else ""))) + (newline cep) + (loop (if (null? initials) '() (cdr initials)) + (if (null? longname) '() (cdr longname))))))) + optnames arities aliast)) + (slib:error 'getopt->parameter-list + (case opt + ((#\:) "argument missing after") + ((#\?) "unrecognized option")) + (string #\- getopt:opt))) ((#f) (cond ((and (< *optind* argc) (string=? "-" (list-ref argv *optind*))) @@ -201,15 +248,16 @@ (list topt (coerce-val *optarg* curopt)))) (else (set! curopt topt) - (rdms:warn - 'getopt->parameter-list "argument missing for option--" opt)))) +;;; (slib:warn 'getopt->parameter-list +;;; "= missing for option--" opt) + ))) (loop))))) parameter-list)) (define (getopt->arglist argc argv optnames positions - arities types defaults checks aliases) + arities types defaulters checks aliases) (let* ((params (getopt->parameter-list argc argv optnames arities types aliases)) - (fparams (fill-empty-parameters defaults params))) + (fparams (fill-empty-parameters defaulters params))) (and (list? params) (check-parameters checks fparams)) (and (list? params) (parameter-list->arglist positions arities fparams)))) |