From 1279b315c5e5df2f41b5554d0cf07f1531090b17 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Thu, 11 Feb 2016 21:48:56 +0100 Subject: [PATCH] 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. Conflicts: types.db --- data-structures.scm | 6 +++--- types.db | 45 +++++++++++++++++++++++---------------------- 2 files changed, 26 insertions(+), 25 deletions(-) diff --git a/data-structures.scm b/data-structures.scm index 65fdad7..f6726ee 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 c902bac..9d94746 100644 --- a/types.db +++ b/types.db @@ -179,46 +179,39 @@ (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 (a list) (or false list))) ((* 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 (a list) (or false list))) ((* 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 + (a list) (or false list))) ((* null) (let ((#(tmp) #(1))) '#f)) (((or symbol procedure immediate) list) (##core#inline "C_u_i_memq" #(1) #(2))) ((* (list-of (or symbol procedure immediate))) (##core#inline "C_u_i_memq" #(1) #(2)))) -(assq (forall (a b) (#(procedure #:clean #:foldable) assq - (* (list-of (pair a b))) - (or false (pair a b)))) +(assq (forall (a) (#(procedure #:clean #:foldable) assq (* (list-of pair)) + (or false pair))) ((* null) (let ((#(tmp) #(1))) '#f)) ((* (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2)))) -(assv (forall (a b) (#(procedure #:clean #:foldable) assv - (* (list-of (pair a b))) - (or false (pair a b)))) +(assv (forall (a) (#(procedure #:clean #:foldable) assv (* (list-of pair)) + (or false pair))) ((* null) (let ((#(tmp) #(1))) '#f)) (((or symbol immediate procedure) (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2))) ((* (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) (#(procedure #:clean #:foldable) assoc + (a (list-of pair)) + (or false pair))) ((* null) (let ((#(tmp) #(1))) '#f)) (((or symbol procedure immediate) (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2))) @@ -1408,9 +1401,15 @@ (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) (#(procedure #:clean #:foldable) alist-ref + (a (list-of pair) #!optional (procedure (a *) *) *) *))) +(chicken.data-structures#alist-update! + (#(procedure) alist-update! + (* * (list-of pair) #!optional (procedure (* *) *)) *)) +(chicken.data-structures#alist-update + (#(procedure #:clean #:foldable) alist-update + (* * (list-of pair) #!optional (procedure (* *) *) *) *)) (chicken.data-structures#any? (#(procedure #:pure #:foldable) chicken.data-structures#any? (*) boolean) ((*) (let ((#(tmp) #(1))) '#t))) @@ -1447,7 +1446,9 @@ (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) (#(procedure #:clean #:foldable) rassoc + (a (list-of pair) #!optional (procedure (a *) *)) *))) (chicken.data-structures#reverse-string-append (#(procedure #:clean #:enforce) chicken.data-structures#reverse-string-append ((list-of string)) string)) (chicken.data-structures#sort -- 2.1.4