Fellow Chickeneers,
please see the commit message of the attached patch for details!
Cheers
Moritz
>From 16396c41c63699e261f108af4cf48e15eb54bdde Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <mor...@twoticketsplease.de>
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
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
