$OpenBSD: patch-data-structures_scm,v 1.2 2015/06/16 14:45:04 jasper Exp $

Security fix for CVE-2014-9651
http://lists.nongnu.org/archive/html/chicken-hackers/2014-12/msg00000.html

Security fix for CVE-2015-4556
http://lists.nongnu.org/archive/html/chicken-hackers/2015-06/msg00037.html

--- data-structures.scm.orig	Tue Jun 16 10:11:50 2015
+++ data-structures.scm	Tue Jun 16 10:11:37 2015
@@ -303,15 +303,21 @@
   (define (traverse which where start test loc)
     (##sys#check-string which loc)
     (##sys#check-string where loc)
-    (let ([wherelen (##sys#size where)]
-	  [whichlen (##sys#size which)] )
+    (let* ((wherelen (##sys#size where))
+	   (whichlen (##sys#size which))
+	   (end (fx- wherelen whichlen)))
       (##sys#check-exact start loc)
-      (let loop ([istart start] [iend whichlen])
-	(cond [(fx> iend wherelen) #f]
-	      [(test istart whichlen) istart]
-	      [else 
-	       (loop (fx+ istart 1)
-		     (fx+ iend 1) ) ] ) ) ) )
+      (if (and (fx>= start 0)
+	       (fx> wherelen start))
+	  (let loop ((istart start))
+	    (cond ((fx> istart end) #f)
+		  ((test istart whichlen) istart)
+		  (else (loop (fx+ istart 1)))))
+	  (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
+			    loc
+			    start
+			    wherelen))))
+
   (set! ##sys#substring-index 
     (lambda (which where start)
       (traverse 
@@ -504,7 +510,7 @@
 (define (string-translate* str smap)
   (##sys#check-string str 'string-translate*)
   (##sys#check-list smap 'string-translate*)
-  (let ([len (##sys#size str)])
+  (let ((len (##sys#size str)))
     (define (collect i from total fs)
       (if (fx>= i len)
 	  (##sys#fragments->string
@@ -513,15 +519,16 @@
 	    (if (fx> i from) 
 		(cons (##sys#substring str from i) fs)
 		fs) ) )
-	  (let loop ([smap smap])
+	  (let loop ((smap smap))
 	    (if (null? smap) 
 		(collect (fx+ i 1) from (fx+ total 1) fs)
-		(let* ([p (car smap)]
-		       [sm (car p)]
-		       [smlen (string-length sm)]
-		       [st (cdr p)] )
-		  (if (##core#inline "C_substring_compare" str sm i 0 smlen)
-		      (let ([i2 (fx+ i smlen)])
+		(let* ((p (car smap))
+		       (sm (car p))
+		       (smlen (string-length sm))
+		       (st (cdr p)) )
+		  (if (and (fx<= (fx+ i smlen) len)
+			   (##core#inline "C_substring_compare" str sm i 0 smlen))
+		      (let ((i2 (fx+ i smlen)))
 			(when (fx> i from)
 			  (set! fs (cons (##sys#substring str from i) fs)) )
 			(collect 
