~ chicken-core (chicken-5) 0a52536b7cb6b3d5a35ecc8f4c11131041ae873a
commit 0a52536b7cb6b3d5a35ecc8f4c11131041ae873a
Author: Moritz Heidkamp <moritz@twoticketsplease.de>
AuthorDate: Tue Jan 21 12:20:11 2014 +0100
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Jan 26 19:03:05 2014 +0100
Add proper list checks to assq/assv/assoc and memq/memv/member
Previously it was possible to pass any kind of value to these procedures
as their list argument and they would just return #f in that case. This
patch adds checks to the checked variants at the end of the loop so it
will only incur additional runtime cost if either a non-list is passed
as the list argument or if the sought element is not found.
Note that this patch has the side-effect of also erroring out on
improper lists in the not-found case. This lead to an error getting
raised in the scrutinizer which is taken care of in this patch, too.
Furthermore, the test cases added for all procedures affected by this
patch uncovered a bug in the specializations defined for assq, assv, and
assoc in types.db which would specialize to the unsafe inlined variant
of assq for any kind of list rather than lists of pairs. This is also
fixed.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/runtime.c b/runtime.c
index 695abcfe..732edc39 100644
--- a/runtime.c
+++ b/runtime.c
@@ -5525,6 +5525,9 @@ C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
lst = C_u_i_cdr(lst);
}
+ if(lst!=C_SCHEME_END_OF_LIST)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", lst);
+
return C_SCHEME_FALSE;
}
@@ -5544,6 +5547,9 @@ C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
lst = C_u_i_cdr(lst);
}
+ if(lst!=C_SCHEME_END_OF_LIST)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", lst);
+
return C_SCHEME_FALSE;
}
@@ -5563,6 +5569,9 @@ C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)
lst = C_u_i_cdr(lst);
}
+ if(lst!=C_SCHEME_END_OF_LIST)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", lst);
+
return C_SCHEME_FALSE;
}
@@ -5574,6 +5583,9 @@ C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst)
else lst = C_u_i_cdr(lst);
}
+ if(lst!=C_SCHEME_END_OF_LIST)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "memq", lst);
+
return C_SCHEME_FALSE;
}
@@ -5585,6 +5597,9 @@ C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst)
else lst = C_u_i_cdr(lst);
}
+ if(lst!=C_SCHEME_END_OF_LIST)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "memv", lst);
+
return C_SCHEME_FALSE;
}
@@ -5596,6 +5611,9 @@ C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst)
else lst = C_u_i_cdr(lst);
}
+ if(lst!=C_SCHEME_END_OF_LIST)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "memv", lst);
+
return C_SCHEME_FALSE;
}
@@ -5606,6 +5624,9 @@ C_regparm C_word C_fcall C_i_member(C_word x, C_word lst)
if(C_equalp(C_u_i_car(lst), x)) return lst;
else lst = C_u_i_cdr(lst);
}
+
+ if(lst!=C_SCHEME_END_OF_LIST)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "member", lst);
return C_SCHEME_FALSE;
}
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 020949d0..e29e8477 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2029,7 +2029,7 @@
t))
((eq? 'deprecated (car t))
(and (= 2 (length t)) (symbol? (second t)) t))
- ((or (memq '--> t) (memq '-> t)) =>
+ ((and (list? t) (or (memq '--> t) (memq '-> t))) =>
(lambda (p)
(let* ((cleanf (eq? '--> (car p)))
(ok (or (not rec) (not cleanf))))
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 5418fbbd..df0639f0 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -541,3 +541,38 @@ A
(assert (equal? '#(2 3) (subvector '#(1 2 3) 1)))
(assert (equal? '#(2) (subvector '#(1 2 3) 1 2)))
(assert (equal? '#() (subvector '#(1 2 3) 1 1)))
+
+;;; alist accessors
+
+(assert (equal? '(foo) (assq 'foo '((foo)))))
+(assert (not (assq 'foo '())))
+(assert-fail (assq 'foo '(bar)))
+(assert-fail (assq 'foo 'bar))
+
+
+(assert (equal? '(foo) (assv 'foo '((foo)))))
+(assert (not (assv 'foo '())))
+(assert-fail (assv 'foo '(bar)))
+(assert-fail (assv 'foo 'bar))
+
+(assert (equal? '("foo") (assoc "foo" '(("foo")))))
+(assert (not (assoc "foo" '())))
+(assert-fail (assoc "foo" '("bar")))
+(assert-fail (assoc "foo" "bar"))
+
+;;; list membership
+
+(assert (equal? '(foo) (memq 'foo '(bar foo))))
+(assert (not (memq 'foo '(bar))))
+(assert (not (memq 'foo '())))
+(assert-fail (memq 'foo 'foo))
+
+(assert (equal? '(foo) (memv 'foo '(bar foo))))
+(assert (not (memv 'foo '(bar))))
+(assert (not (memv 'foo '())))
+(assert-fail (memv 'foo 'foo))
+
+(assert (equal? '("foo") (member "foo" '("bar" "foo"))))
+(assert (not (member "foo" '("bar"))))
+(assert (not (member "foo" '())))
+(assert-fail (member "foo" "foo"))
diff --git a/types.db b/types.db
index 2fabc94b..d1aaa06a 100644
--- a/types.db
+++ b/types.db
@@ -189,11 +189,11 @@
(assq (forall (a b) (#(procedure #:clean) assq (* (list-of (pair a b)))
(or boolean (pair a b))))
- ((* list) (##core#inline "C_u_i_assq" #(1) #(2))))
+ ((* (list-of pair)) (##core#inline "C_u_i_assq" #(1) #(2))))
(assv (forall (a b) (#(procedure #:clean) assv (* (list-of (pair a b)))
(or boolean (pair a b))))
- (((or symbol immediate procedure) list)
+ (((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))))
@@ -201,7 +201,7 @@
(assoc (forall (a b c) (#(procedure #:clean) assoc (a (list-of (pair b c))
#!optional (procedure (b a) *)) ; sic
(or boolean (pair b c))))
- (((or symbol procedure immediate) list)
+ (((or symbol procedure immediate) (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))))
Trap