summaryrefslogtreecommitdiffstats
path: root/paramlst.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commit87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (patch)
tree1eb4f87abd38bea56e08335d939e8171d5e7bfc7 /paramlst.scm
parentbd9733926076885e3417b74de76e4c9c7bc56254 (diff)
downloadslib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.tar.gz
slib-87b82b5822ca54228cfa6df29be3ad9d4bc47d16.zip
Import Upstream version 2d2upstream/2d2
Diffstat (limited to 'paramlst.scm')
-rw-r--r--paramlst.scm33
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))