mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 10:10:23 +02:00
Code Activity

cse: Fix out-of-bounds access to the database.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2012-11-21 23:51:16 +01:00
parent 2d37a93494
commit 2c7b7e0f21
2 changed files with 23 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

9
module/language/tree-il/cse.scm
View file

@ -330,10 +330,11 @@
(and (< n env-len) (and (< n env-len)
(match (vlist-ref env n) (match (vlist-ref env n)
((#(exp* name sym db-len*) . h*) ((#(exp* name sym db-len*) . h*)
(and (unroll db m (- db-len db-len*)) (let ((niter (- (- db-len db-len*) m)))
(if (and (= h h*) (tree-il=? exp* exp)) (and (unroll db m niter)
(make-lexical-ref (tree-il-src exp) name sym) (if (and (= h h*) (tree-il=? exp* exp))
(lp (1+ n) (- db-len db-len*)))))))))))) (make-lexical-ref (tree-il-src exp) name sym)
(lp (1+ n) (- db-len db-len*)))))))))))))
(define (lookup-lexical sym env) (define (lookup-lexical sym env)
(let ((env-len (vlist-length env))) (let ((env-len (vlist-length env)))

19
test-suite/tests/cse.test
View file

@ -292,4 +292,21 @@
(begin (cons 1 2 3) 4) (begin (cons 1 2 3) 4)
(begin (begin
(apply (primitive cons) (const 1) (const 2) (const 3)) (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))))