Import Upstream version 2d2upstream/2d2

1 files changed, 21 insertions, 12 deletions

diff --git a/paramlst.scm b/paramlst.scm
index 32fb158..fcee1c9 100644
--- a/paramlst.scm
+++ b/paramlst.scm
@@ -1,9 +1,9 @@
 ;;; "paramlst.scm" 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.
@@ -56,20 +56,19 @@
 		(every
 		 (lambda (p)
 		   (let ((good? (not (and check (not (check p))))))
-		     (if (not good?)
-			 (slib:warn
-			  (car parameter) 'parameter? p))
+		     (if (not good?) (slib:warn (car parameter) 'parameter? p))
 		     good?))
 		 (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)))
+  (every (lambda (arity-spec param)
+	   (cond ((not arity-spec) (slib:warn 'missing 'arity arity-specs) #f)
+		 (((cadr arity-spec) (cdr param)) #t)
+		 ((null? (cdr param)) (slib:warn param 'missing) #f)
+		 (else (slib:warn param 'not (car arity-spec)) #f)))
+	 arity-specs parameter-list))
 
 (define (parameter-list->arglist positions arities parameter-list)
   (and (= (length arities) (length positions) (length parameter-list))
@@ -130,3 +129,13 @@
 			    (set-cdr! apair (cons #t (cdr apair)))))))
 	  apairs parameters)
 	 parameter-list)))
+
+(define (remove-parameter pname parameter-list)
+  (define found? #f)
+  (remove-if (lambda (elt)
+	       (cond ((not (and (pair? elt) (eqv? pname (car elt)))) #f)
+		     (found?
+		      (slib:error
+		       'remove-parameter 'multiple pname 'in parameter-list))
+		     (else (set! found? #t) #t)))
+	     parameter-list))