summaryrefslogtreecommitdiffstats
path: root/paramlst.scm
diff options
context:
space:
mode:
authorDavid N. Welton <davidw@efn.org>1998-11-09 21:18:01 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commit926b1b647ac830660933a5e63eb52d4a2552e264 (patch)
treee25db5f6e1441d67f5d9af063432018ee20a5f51 /paramlst.scm
parentb21cac3362022718634f7086964208b2eed8e897 (diff)
parentfa3f23105ddcf07c5900de47f19af43d1db1b597 (diff)
downloadslib-926b1b647ac830660933a5e63eb52d4a2552e264.tar.gz
slib-926b1b647ac830660933a5e63eb52d4a2552e264.zip
Import Debian changes 2c3-3debian/2c3-3
slib (2c3-3) frozen unstable; urgency=low * Fixes #16235. * Fixes #19943. * Fixes #20265. * Fixes #24917. * Fixes #27389. slib (2c3-2) frozen unstable; urgency=low * Re-uploaded for slink freeze. slib (2c3-1) unstable; urgency=low * New upstream release.
Diffstat (limited to 'paramlst.scm')
-rw-r--r--paramlst.scm150
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))))