Import Upstream version 2a6upstream/2a6

1 files changed, 215 insertions, 0 deletions

diff --git a/paramlst.scm b/paramlst.scm
new file mode 100644
index 0000000..f01788b
--- /dev/null
+++ b/paramlst.scm
@@ -0,0 +1,215 @@
+;;; "paramlst.scm" passing parameters by name.
+; Copyright 1995 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.
+;
+;1.  Any copy made of this software must include this copyright notice
+;in full.
+;
+;2.  I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;; Format of arity-spec: (name predicate conversion)
+
+(require 'common-list-functions)
+
+(define arity->arity-spec
+  (let ((table
+	 `((nary
+	    ,(lambda (a) #t)
+	    ,identity)
+	   (nary1
+	    ,(lambda (a) (not (null? a)))
+	    ,identity)
+	   (single
+	    ,(lambda (a) (and (pair? a) (null? (cdr a))))
+	    ,car)
+	   (optional
+	    ,(lambda (a) (or (null? a) (and (pair? a) (null? (cdr a)))))
+	    ,identity)
+	   (boolean
+	    ,(lambda (a)
+	       (or (null? a)
+		   (and (pair? a) (null? (cdr a)) (boolean? (car a)))))
+	    ,(lambda (a) (if (null? a) #f (car a)))))))
+    (lambda (arity)
+      (assq arity table))))
+
+(define (fill-empty-parameters defaults parameter-list)
+  (map (lambda (default parameter)
+	 (cond ((null? (cdr parameter))
+		(cons (car parameter)
+		      (if default (default parameter-list) '())))
+	       (else parameter)))
+       defaults 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)
+
+(define (check-arities arity-specs parameter-list)
+  (and (every identity arity-specs)
+       (every
+	(lambda (arity-spec param)
+	  ((cadr arity-spec) (cdr param)))
+	arity-specs parameter-list)))
+
+(define (parameter-list->arglist positions arities parameter-list)
+  (and (= (length arities) (length positions) (length parameter-list))
+       (let ((arity-specs (map arity->arity-spec arities))
+	     (ans (make-vector (length positions) #f)))
+	 (and (check-arities arity-specs parameter-list)
+	      (for-each
+	       (lambda (pos arity-spec param)
+		 (vector-set! ans (+ -1 pos)
+			      ((caddr arity-spec) (cdr param))))
+	       positions arity-specs parameter-list)
+	      (vector->list ans)))))
+
+(define (make-parameter-list parameter-names)
+  (map list parameter-names))
+
+(define (parameter-list-ref parameter-list i)
+  (let ((ans (assoc i parameter-list)))
+    (and ans (cdr ans))))
+
+(define (parameter-list-expand expanders parms)
+  (do ((lens (map length parms) (map length parms))
+       (olens '() lens))
+      ((equal? lens olens))
+    (for-each (lambda (expander parm)
+		(cond
+		 (expander
+		  (for-each
+		   (lambda (news)
+		     (cond ((adjoin-parameters! parms news))
+			   (else (slib:error
+				  "expanded feature unknown: " news))))
+		   (apply append
+			  (map (lambda (p)
+				 (cond ((expander p))
+				       ((not '()) '())
+				       (else (slib:error
+					      "couldn't expand feature: " p))))
+			       (cdr parm)))))))
+	      expanders
+	      parms)))
+
+(define (adjoin-parameters! parameter-list . parameters)
+  (let ((apairs (map (lambda (param)
+		       (cond ((pair? param)
+			      (assoc (car param) parameter-list))
+			     (else (assoc param parameter-list))))
+		     parameters)))
+    (and (every identity apairs)	;same as APPLY AND?
+	 (for-each
+	  (lambda (apair param)
+	    (cond ((pair? param)
+		   (for-each (lambda (o)
+			       (if (not (member o (cdr apair)))
+				   (set-cdr! apair (cons o (cdr apair)))))
+			     (cdr param)))
+		  (else (if (not (memv #t (cdr apair)))
+			    (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 ((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
+	  ((#\: #\?)
+	   (slib:error
+	    'getopt->parameter-list "unrecognized option"
+	    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)
+	       (rdms:warn
+		'getopt->parameter-list "argument missing for option--" opt))))
+	   (loop)))))
+    parameter-list))
+
+(define (getopt->arglist argc argv optnames positions
+			 arities types defaults checks aliases)
+  (let* ((params (getopt->parameter-list
+		  argc argv optnames arities types aliases))
+	 (fparams (fill-empty-parameters defaults params)))
+    (and (list? params) (check-parameters checks fparams))
+    (and (list? params) (parameter-list->arglist positions arities fparams))))