summaryrefslogtreecommitdiffstats
path: root/paramlst.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitf24b9140d6f74804d5599ec225717d38ca443813 (patch)
tree0da952f1a5a7c0eacfc05c296766523e32c05fe2 /paramlst.scm
parent8ffbc2df0fde83082610149d24e594c1cd879f4a (diff)
downloadslib-f24b9140d6f74804d5599ec225717d38ca443813.tar.gz
slib-f24b9140d6f74804d5599ec225717d38ca443813.zip
Import Upstream version 2c0upstream/2c0
Diffstat (limited to 'paramlst.scm')
-rw-r--r--paramlst.scm74
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))))