~ chicken-core (chicken-5) df99ec3e9b5f5be334a179e57b64984f29af8817
commit df99ec3e9b5f5be334a179e57b64984f29af8817
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Thu Feb 11 21:20:00 2016 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Thu Feb 11 21:20:00 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 38857501..074620f3 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -206,7 +206,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)] )
@@ -226,7 +226,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))
@@ -244,7 +244,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 f2596736..114aac15 100644
--- a/types.db
+++ b/types.db
@@ -174,18 +174,21 @@
(reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a)) (list-of a)))
((null) (null) (let ((#(tmp) #(1))) '())))
-(memq (forall (a b) (#(procedure #:clean) memq (a (list-of b)) (or false (list-of b))))
+(memq (forall (a) (#(procedure #:clean) 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) memv (a (list-of b)) (or false (list-of b))))
+(memv (forall (a) (#(procedure #:clean) 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) member
- (a (list-of b) #!optional (procedure (b a) *)) ; sic
- (or false (list-of b))))
+(member
+ (forall (a b) (#(procedure #:clean) member
+ (a (list-of b) #!optional (procedure (a b) *)) ; sic
+ (or false (list-of b))))
((* null) (let ((#(tmp) #(1))) '#f))
(((or symbol procedure immediate) list)
(##core#inline "C_u_i_memq" #(1) #(2)))
@@ -197,7 +200,7 @@
((* null) (let ((#(tmp) #(1))) '#f))
((* (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2))))
-(assv (forall (a b) (#(procedure #:clean) assv (* (list-of (pair a b)))
+(assv (forall (a b) (#(procedure #:clean) assv (* (list-of (pair a b)))
(or false (pair a b))))
((* null) (let ((#(tmp) #(1))) '#f))
(((or symbol immediate procedure) (list-of pair))
@@ -205,9 +208,9 @@
((* (list-of (pair (or symbol procedure immediate) *)))
(##core#inline "C_u_i_assq" #(1) #(2))))
-(assoc (forall (a b c) (#(procedure #:clean) assoc (a (list-of (pair b c))
- #!optional (procedure (b a) *)) ; sic
- (or false (pair b c))))
+(assoc (forall (a b c) (#(procedure #:clean) assoc
+ (a (list-of (pair b c)) #!optional (procedure (a b) *))
+ (or false (pair b c)))) ; sic
((* null) (let ((#(tmp) #(1))) '#f))
(((or symbol procedure immediate) (list-of pair))
(##core#inline "C_u_i_assq" #(1) #(2)))
@@ -1202,9 +1205,19 @@
(->string (procedure ->string (*) string)
((string) #(1)))
-(alist-ref (#(procedure #:clean #:enforce) alist-ref (* (list-of pair) #!optional (procedure (* *) *) *) *))
-(alist-update! (#(procedure #:enforce) alist-update! (* * (list-of pair) #!optional (procedure (* *) *)) *))
-(alist-update (#(procedure #:clean #:enforce) alist-update (* * (list-of pair) #!optional (procedure (* *) *) *) *))
+(alist-ref (forall (a b c d) (#(procedure #:clean) alist-ref (a (list-of (pair b c)) #!optional (procedure (a b) *) d) (or false c d))))
+
+(alist-update!
+ (forall (a b c d)
+ (#(procedure) alist-update!
+ (a b (list-of (pair c d)) #!optional (procedure (a c) *))
+ (list-of (pair c (or b d))))))
+
+(alist-update
+ (forall (a b c d)
+ (#(procedure #:clean) alist-update
+ (a b (list-of (pair c d)) #!optional (procedure (a c) *))
+ (list-of (pair c (or b d))))))
(any? (#(procedure #:pure) any? (*) boolean)
((*) (let ((#(tmp) #(1))) '#t)))
@@ -1259,7 +1272,11 @@
(queue-remove! (#(procedure #:clean #:enforce) queue-remove! ((struct queue)) *))
(queue? (#(procedure #:pure #:predicate (struct queue)) queue? (*) boolean))
-(rassoc (#(procedure #:clean #:enforce) rassoc (* (list-of pair) #!optional (procedure (* *) *)) *))
+(rassoc
+ (forall (a b c) (#(procedure #:clean) rassoc
+ (a (list-of (pair b c)) #!optional (procedure (a b) *))
+ (or false (pair b c)))))
+
(reverse-string-append (#(procedure #:clean #:enforce) reverse-string-append ((list-of string)) string))
(sort
@@ -1851,10 +1868,21 @@
;; srfi-1
-(alist-cons (forall (a b c) (#(procedure #:clean) alist-cons (a b (list-of c)) (pair a (pair b (list-of c))))))
-(alist-copy (forall (a) (#(procedure #:clean #:enforce) alist-copy ((list-of a)) (list-of a))))
-(alist-delete (forall (a b) (#(procedure #:enforce) alist-delete (a (list-of b) #!optional (procedure (a b) *)) list)))
-(alist-delete! (forall (a b) (#(procedure #:enforce) alist-delete! (a (list-of b) #!optional (procedure (a b) *)) undefined)))
+(alist-cons
+ (forall (a b c) (#(procedure #:pure) alist-cons (a b (list-of c))
+ (pair (pair a b) (list-of c)))))
+(alist-copy
+ (forall (a b) (#(procedure #:clean #:enforce) alist-copy
+ ((list-of (pair a b))) (list-of (pair a b)))))
+(alist-delete
+ (forall (a b c) (#(procedure #:clean) alist-delete
+ (a (list-of (pair b c)) #!optional (procedure (a b) *))
+ (list-of (pair b c)))))
+(alist-delete!
+ (forall (a b c) (#(procedure) alist-delete!
+ (a (list-of (pair b c)) #!optional (procedure (a b) *))
+ (list-of (pair b c)))))
+
(any (forall (a) (#(procedure #:enforce) any ((procedure (a #!rest) *) (list-of a) #!rest list) *)))
(append! (#(procedure #:enforce) append! (#!rest list) list))
Trap