Import Upstream version 2d2upstream/2d2

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))))
+