Import Upstream version 2c3upstream/2c3

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