summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2012-11-21 23:51:16 +0100
committerLudovic Courtès <ludo@gnu.org>2012-11-21 23:51:16 +0100
commit2c7b7e0f214be5ec5184949a94209668775f60bc (patch)
tree031e9ee7a425c91bd562e4b914dd3fa5c5d334aa
parent2d37a9349404c3161d89967c014cbaa1a28e59ea (diff)
downloadguile-2c7b7e0f214be5ec5184949a94209668775f60bc.tar.gz
cse: Fix out-of-bounds access to the database.
Fixes <http://bugs.gnu.org/12883>. * module/language/tree-il/cse.scm (cse)[find-dominating-lexical]: Fix computation of the last argument passed to `unroll'. Patch by Stefan Israelsson Tampe <stefan.itampe@gmail.com>. * test-suite/tests/cse.test ("cse")["http://bugs.gnu.org/12883"]: New test.
-rw-r--r--module/language/tree-il/cse.scm9
-rw-r--r--test-suite/tests/cse.test19
2 files changed, 23 insertions, 5 deletions
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index b8e722967..d8c7e3fc9 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -330,10 +330,11 @@
(and (< n env-len)
(match (vlist-ref env n)
((#(exp* name sym db-len*) . h*)
- (and (unroll db m (- db-len db-len*))
- (if (and (= h h*) (tree-il=? exp* exp))
- (make-lexical-ref (tree-il-src exp) name sym)
- (lp (1+ n) (- db-len db-len*))))))))))))
+ (let ((niter (- (- db-len db-len*) m)))
+ (and (unroll db m niter)
+ (if (and (= h h*) (tree-il=? exp* exp))
+ (make-lexical-ref (tree-il-src exp) name sym)
+ (lp (1+ n) (- db-len db-len*)))))))))))))
(define (lookup-lexical sym env)
(let ((env-len (vlist-length env)))
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index 523635fc7..e0219e84d 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -292,4 +292,21 @@
(begin (cons 1 2 3) 4)
(begin
(apply (primitive cons) (const 1) (const 2) (const 3))
- (const 4))))
+ (const 4)))
+
+ (pass-if "http://bugs.gnu.org/12883"
+ ;; In 2.0.6, compiling this code would trigger an out-of-bounds
+ ;; vlist access in CSE's traversal of its "database".
+ (glil-program?
+ (compile '(define (proc v)
+ (let ((failure (lambda () (bail-out 'match))))
+ (if (and (pair? v)
+ (null? (cdr v)))
+ (let ((w foo)
+ (x (cdr w)))
+ (if (and (pair? x) (null? w))
+ #t
+ (failure)))
+ (failure))))
+ #:from 'scheme
+ #:to 'glil))))