diff options
Diffstat (limited to 'paramlst.scm')
| -rw-r--r-- | paramlst.scm | 150 |
1 files changed, 8 insertions, 142 deletions
diff --git a/paramlst.scm b/paramlst.scm index 706c91c..b4af55a 100644 --- a/paramlst.scm +++ b/paramlst.scm @@ -52,15 +52,14 @@ defaulters parameter-list)) (define (check-parameters checks parameter-list) - (for-each (lambda (check parameter) - (for-each - (lambda (p) - (cond ((and check (not (check p))) - (slib:error (car parameter) - "parameter is wrong type: " p)))) - (cdr parameter))) - checks parameter-list) - parameter-list) + (and (every (lambda (check parameter) + (every + (lambda (p) + (not (and check (not (check p))))) + ;;(slib:error (car parameter) "parameter is wrong type: " p) + (cdr parameter))) + checks parameter-list) + parameter-list)) (define (check-arities arity-specs parameter-list) (and (every identity arity-specs) @@ -128,136 +127,3 @@ (set-cdr! apair (cons #t (cdr apair))))))) apairs parameters) parameter-list))) - -(define (getopt->parameter-list argc argv optnames arities types aliases) - (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)))) - (require 'getopt) - (let ((starting-optind *optind*) - (optlist '()) - (long-opt-list '()) - (optstring #f) - (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)) - (for-each - (lambda (alias) - (define opt (car alias)) - (cond ((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)))) - (else (set! optlist (cons (string-ref opt 0) optlist))))) - aliases) - (set! optstring (list->string (cons #\: optlist))) - (let loop () - (let ((opt (getopt-- argc argv optstring))) - (case 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*))) - (set! *optind* (+ 1 *optind*))) - ((< *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")))))) - (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))) - (cond - ((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)))) - (else - (set! curopt topt) -;;; (slib:warn 'getopt->parameter-list -;;; "= missing for option--" opt) - ))) - (loop))))) - parameter-list)) - -(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)))) |