summaryrefslogtreecommitdiffstats
path: root/getparam.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commit87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (patch)
tree1eb4f87abd38bea56e08335d939e8171d5e7bfc7 /getparam.scm
parentbd9733926076885e3417b74de76e4c9c7bc56254 (diff)
downloadslib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.tar.gz
slib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.zip
Import Upstream version 2d2upstream/2d2
Diffstat (limited to 'getparam.scm')
-rw-r--r--getparam.scm201
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))))
+