diff options
author | Ludovic Courtès <ludo@gnu.org> | 2012-11-21 23:51:16 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2012-11-21 23:51:16 +0100 |
commit | 2c7b7e0f214be5ec5184949a94209668775f60bc (patch) | |
tree | 031e9ee7a425c91bd562e4b914dd3fa5c5d334aa | |
parent | 2d37a9349404c3161d89967c014cbaa1a28e59ea (diff) | |
download | guile-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.scm | 9 | ||||
-rw-r--r-- | test-suite/tests/cse.test | 19 |
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)))) |