~ chicken-core (chicken-5) b376d3a0b87f1d48f5555edd676c8eaed21c66d8
commit b376d3a0b87f1d48f5555edd676c8eaed21c66d8
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Fri Feb 12 20:17:03 2016 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Fri Feb 12 20:17:03 2016 +0100
Fix type signatures of a few alist procedures
Thanks to Joerg Wittenberger for pointing out that the types weren't
exactly right.
This also makes the types and higher order procedures consistent in how
they call their argument predicates: always the supplied key first, and
the "thing in the list" second.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/data-structures.scm b/data-structures.scm
index 65fdad71..f6726eee 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -223,7 +223,7 @@
(let loop ([lst lst])
(and (pair? lst)
(let ([a (##sys#slot lst 0)])
- (if (and (pair? a) (cmp (##sys#slot a 0) x))
+ (if (and (pair? a) (cmp x (##sys#slot a 0)))
a
(loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ]
[item (aq x lst)] )
@@ -243,7 +243,7 @@
(let ((a (##sys#slot lst 0)))
(cond ((not (pair? a))
(error 'alist-update "bad argument type" a))
- ((cmp (##sys#slot a 0) k)
+ ((cmp k (##sys#slot a 0))
(cons (cons k v) (##sys#slot lst 1)))
(else
(cons (cons (##sys#slot a 0) (##sys#slot a 1))
@@ -261,7 +261,7 @@
((pair? lst)
(let ((a (##sys#slot lst 0)))
(##sys#check-pair a 'alist-ref)
- (if (cmp (##sys#slot a 0) x)
+ (if (cmp x (##sys#slot a 0))
a
(loop (##sys#slot lst 1)) ) ))
(else (error 'alist-ref "bad argument type" lst)) ) ) ) ) ) )
diff --git a/types.db b/types.db
index c902bac2..b5a53336 100644
--- a/types.db
+++ b/types.db
@@ -179,22 +179,19 @@
(reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a)) (list-of a)))
((null) (null) (let ((#(tmp) #(1))) '())))
-(memq (forall (a b) (#(procedure #:clean #:foldable) memq
- (a (list-of b))
- (or false (list-of b))))
+(memq (forall (a) (#(procedure #:clean #:foldable) memq (* (list-of a))
+ (or false (list-of a))))
((* null) (let ((#(tmp) #(1))) '#f))
((* list) (##core#inline "C_u_i_memq" #(1) #(2))))
-(memv (forall (a b) (#(procedure #:clean #:foldable) memv
- (a (list-of b))
- (or false (list-of b))))
+(memv (forall (a) (#(procedure #:clean #:foldable) memv (* (list-of a))
+ (or false (list-of a))))
((* null) (let ((#(tmp) #(1))) '#f))
(((or symbol procedure immediate) list)
(##core#inline "C_u_i_memq" #(1) #(2))))
-(member (forall (a b) (#(procedure #:clean #:foldable) member
- (a (list-of b))
- (or false (list-of b))))
+(member (forall (a) (#(procedure #:clean #:foldable) member
+ (* (list-of a)) (or false (list-of a))))
((* null) (let ((#(tmp) #(1))) '#f))
(((or symbol procedure immediate) list)
(##core#inline "C_u_i_memq" #(1) #(2)))
@@ -216,9 +213,9 @@
((* (list-of (pair (or symbol procedure immediate) *)))
(##core#inline "C_u_i_assq" #(1) #(2))))
-(assoc (forall (a b c) (#(procedure #:clean #:foldable) assoc
- (a (list-of (pair b c)))
- (or false (pair b c))))
+(assoc (forall (a b) (#(procedure #:clean #:foldable) assoc
+ (* (list-of (pair a b)))
+ (or false (pair a b))))
((* null) (let ((#(tmp) #(1))) '#f))
(((or symbol procedure immediate) (list-of pair))
(##core#inline "C_u_i_assq" #(1) #(2)))
@@ -1408,9 +1405,21 @@
(chicken.data-structures#->string (procedure chicken.data-structures#->string (*) string)
((string) #(1)))
-(chicken.data-structures#alist-ref (#(procedure #:clean #:enforce #:foldable) chicken.data-structures#alist-ref (* (list-of pair) #!optional (procedure (* *) *) *) *))
-(chicken.data-structures#alist-update! (#(procedure #:enforce) chicken.data-structures#alist-update! (* * (list-of pair) #!optional (procedure (* *) *)) *))
-(chicken.data-structures#alist-update (#(procedure #:clean #:enforce #:foldable) chicken.data-structures#alist-update (* * (list-of pair) #!optional (procedure (* *) *) *) *))
+(chicken.data-structures#alist-ref
+ (forall (a b c d)
+ (#(procedure #:clean #:foldable) chicken.data-structures#alist-ref
+ (a (list-of (pair b c)) #!optional (procedure (a b) *) d)
+ (or false c d))))
+(chicken.data-structures#alist-update!
+ (forall (a b c d)
+ (#(procedure) chicken.data-structures#alist-update!
+ (a b (list-of (pair c d)) #!optional (procedure (a c) *))
+ (list-of (pair c (or b d))))))
+(chicken.data-structures#alist-update
+ (forall (a b c d)
+ (#(procedure #:clean) chicken.data-structures#alist-update
+ (a b (list-of (pair c d)) #!optional (procedure (a c) *))
+ (list-of (pair c (or b d))))))
(chicken.data-structures#any? (#(procedure #:pure #:foldable) chicken.data-structures#any? (*) boolean)
((*) (let ((#(tmp) #(1))) '#t)))
@@ -1446,8 +1455,10 @@
(chicken.data-structures#o (#(procedure #:clean #:enforce) chicken.data-structures#o (#!rest (procedure (*) *)) (procedure (*) *)))
-;; TODO: Should this accept a test procedure?
-(chicken.data-structures#rassoc (#(procedure #:clean #:enforce #:foldable) chicken.data-structures#rassoc (* (list-of pair) #!optional (procedure (* *) *)) *))
+(chicken.data-structures#rassoc
+ (forall (a b c) (#(procedure #:clean #:foldable) chicken.data-structures#rassoc
+ (a (list-of (pair b c)) #!optional (procedure (a b) *))
+ (or false (pair b c)))))
(chicken.data-structures#reverse-string-append (#(procedure #:clean #:enforce) chicken.data-structures#reverse-string-append ((list-of string)) string))
(chicken.data-structures#sort
Trap