>From 16396c41c63699e261f108af4cf48e15eb54bdde Mon Sep 17 00:00:00 2001 From: Moritz Heidkamp Date: Tue, 21 Jan 2014 12:20:11 +0100 Subject: [PATCH] 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. --- runtime.c | 18 ++++++++++++++++++ scrutinizer.scm | 2 +- tests/library-tests.scm | 35 +++++++++++++++++++++++++++++++++++ types.db | 6 +++--- 4 files changed, 57 insertions(+), 4 deletions(-) diff --git a/runtime.c b/runtime.c index c90b9dd..58dde49 100644 --- a/runtime.c +++ b/runtime.c @@ -5518,6 +5518,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; } @@ -5537,6 +5540,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; } @@ -5556,6 +5562,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; } @@ -5567,6 +5576,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; } @@ -5589,6 +5601,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; } @@ -5599,6 +5614,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 020949d..e29e847 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 5418fbb..df0639f 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 f1d87a3..7156c9b 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)))) -- 1.8.5.2