Toggle diff (267 lines)
diff --git a/gnu/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch b/gnu/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch
deleted file mode 100644
index 59decde0e..000000000
--- a/gnu/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch
+++ /dev/null
@@ -1,81 +0,0 @@
-diff -ur a/irregex-core.scm b/irregex-core.scm
---- a/irregex-core.scm 2016-09-11 19:03:00.000000000 -0400
-+++ b/irregex-core.scm 2017-01-01 22:24:08.000000000 -0500
-@@ -30,6 +30,8 @@
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;; History
-+;; 0.9.6: 2016/12/05 - fixed exponential memory use of + in compilation
-+;; of backtracking matcher.
- ;; 0.9.5: 2016/09/10 - fixed a bug in irregex-fold handling of bow
- ;; 0.9.4: 2015/12/14 - performance improvement for {n,m} matches
- ;; 0.9.3: 2014/07/01 - R7RS library
-@@ -3170,16 +3172,7 @@
- ((sre-empty? (sre-sequence (cdr sre)))
- (error "invalid sre: empty *" sre))
- (else
-- (letrec
-- ((body
-- (lp (sre-sequence (cdr sre))
-- n
-- flags
-- (lambda (cnk init src str i end matches fail)
-- (body cnk init src str i end matches
-- (lambda ()
-- (next cnk init src str i end matches fail)
-- ))))))
-+ (let ((body (rec (list '+ (sre-sequence (cdr sre))))))
- (lambda (cnk init src str i end matches fail)
- (body cnk init src str i end matches
- (lambda ()
-@@ -3204,10 +3197,21 @@
- (lambda ()
- (body cnk init src str i end matches fail))))))))
- ((+)
-- (lp (sre-sequence (cdr sre))
-- n
-- flags
-- (rec (list '* (sre-sequence (cdr sre))))))
-+ (cond
-+ ((sre-empty? (sre-sequence (cdr sre)))
-+ (error "invalid sre: empty +" sre))
-+ (else
-+ (letrec
-+ ((body
-+ (lp (sre-sequence (cdr sre))
-+ n
-+ flags
-+ (lambda (cnk init src str i end matches fail)
-+ (body cnk init src str i end matches
-+ (lambda ()
-+ (next cnk init src str i end matches fail)
-+ ))))))
-+ body))))
- ((=)
- (rec `(** ,(cadr sre) ,(cadr sre) ,@(cddr sre))))
- ((>=)
-diff -ur a/irregex-utils.scm b/irregex-utils.scm
---- a/irregex-utils.scm 2016-09-11 19:03:00.000000000 -0400
-+++ b/irregex-utils.scm 2017-01-01 22:25:25.000000000 -0500
-@@ -89,7 +89,7 @@
- (case (car x)
- ((: seq)
- (cond
-- ((and (pair? (cddr x)) (pair? (cddr x)) (not (eq? x obj)))
-+ ((and (pair? (cdr x)) (pair? (cddr x)) (not (eq? x obj)))
- (display "(?:" out) (for-each lp (cdr x)) (display ")" out))
- (else (for-each lp (cdr x)))))
- ((submatch)
-diff -ur "a/manual-html/Unit irregex.html" "b/manual-html/Unit irregex.html"
---- "a/manual-html/Unit irregex.html" 2016-09-11 19:10:47.000000000 -0400
-+++ "b/manual-html/Unit irregex.html" 2017-01-01 22:26:05.000000000 -0500
-@@ -353,6 +353,6 @@
- <dd class="defsig"><p>Returns an optimized SRE matching any of the literal strings in the list, like Emacs' <tt>regexp-opt</tt>. Note this optimization doesn't help when irregex is able to build a DFA.</p></dd>
- </dl>
- <h5 id="sec:sre-.3estring"><a href="#sec:sre-.3estring">sre->string</a></h5><dl class="defsig"><dt class="defsig" id="def:sre-.3estring"><span class="sig"><tt>(sre->string <sre>)</tt></span> <span class="type">procedure</span></dt>
--<dd class="defsig"><p>Convert an SRE to a POSIX-style regular expression string, if possible.</p></dd>
-+<dd class="defsig"><p>Convert an SRE to a PCRE-style regular expression string, if possible.</p></dd>
- </dl>
--<hr /><p>Previous: <a href="Unit%20extras.html">Unit extras</a></p><p>Next: <a href="Unit%20srfi-1.html">Unit srfi-1</a></p></div></div></body>
-\ No newline at end of file
-+<hr /><p>Previous: <a href="Unit%20extras.html">Unit extras</a></p><p>Next: <a href="Unit%20srfi-1.html">Unit srfi-1</a></p></div></div></body>
diff --git a/gnu/packages/patches/chicken-CVE-2017-6949.patch b/gnu/packages/patches/chicken-CVE-2017-6949.patch
new file mode 100644
index 000000000..00552eec7
--- /dev/null
+++ b/gnu/packages/patches/chicken-CVE-2017-6949.patch
@@ -0,0 +1,132 @@
+From: LemonBoy <thatlemon@gmail.com>
+Date: Fri, 10 Mar 2017 16:29:47 +0100
+Subject: [PATCH] Add bound checking to all srfi-4 vector allocations.
+
+Do what C_allocate_vector already does and prevent the creation of a
+vector that's too big or too small.
+We should be very careful to avoid the latter case because the
+allocation size is directly fed into `malloc' as 'x + sizeof(C_header)'
+thus making possible to successfully allocate a vector smaller than the
+C_header structure and get C_block_header_init to write over
+uninitialized memory.
+
+To reduce code duplication, type checking is moved from each of the
+make-*vector procedures to the common "alloc" helper procedure.
+
+Signed-off-by: Peter Bex <peter@more-magic.net>
+Signed-off-by: Kooda <kooda@upyum.com>
+---
+ srfi-4.scm | 34 +++++++++++++++-------------------
+ 1 file changed, 15 insertions(+), 19 deletions(-)
+
+diff --git a/srfi-4.scm b/srfi-4.scm
+index 7f5412b..69f58ba 100644
+--- a/srfi-4.scm
++++ b/srfi-4.scm
+@@ -255,24 +255,28 @@ EOF
+
+ ;;; Basic constructors:
+
+-(let* ([ext-alloc
+- (foreign-lambda* scheme-object ([int bytes])
+- "C_word *buf = (C_word *)C_malloc(bytes + sizeof(C_header));"
++(let* ((ext-alloc
++ (foreign-lambda* scheme-object ((size_t bytes))
++ "C_word *buf;"
++ "if (bytes > C_HEADER_SIZE_MASK) C_return(C_SCHEME_FALSE);"
++ "buf = (C_word *)C_malloc(bytes + sizeof(C_header));"
+ "if(buf == NULL) C_return(C_SCHEME_FALSE);"
+ "C_block_header_init(buf, C_make_header(C_BYTEVECTOR_TYPE, bytes));"
+- "C_return(buf);") ]
+- [ext-free
+- (foreign-lambda* void ([scheme-object bv])
+- "C_free((void *)C_block_item(bv, 1));") ]
+- [alloc
++ "C_return(buf);") )
++ (ext-free
++ (foreign-lambda* void ((scheme-object bv))
++ "C_free((void *)C_block_item(bv, 1));") )
++ (alloc
+ (lambda (loc len ext?)
++ (##sys#check-exact len loc)
++ (when (fx< len 0) (##sys#error loc "size is negative" len))
+ (if ext?
+- (let ([bv (ext-alloc len)])
++ (let ((bv (ext-alloc len)))
+ (or bv
+ (##sys#error loc "not enough memory - cannot allocate external number vector" len)) )
+- (let ([bv (##sys#allocate-vector len #t #f #t)]) ; this could be made better...
++ (let ((bv (##sys#allocate-vector len #t #f #t))) ; this could be made better...
+ (##core#inline "C_string_to_bytevector" bv)
+- bv) ) ) ] )
++ bv) ) ) ) )
+
+ (set! release-number-vector
+ (lambda (v)
+@@ -282,7 +286,6 @@ EOF
+
+ (set! make-u8vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+- (##sys#check-exact len 'make-u8vector)
+ (let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector len ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+@@ -295,7 +298,6 @@ EOF
+
+ (set! make-s8vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+- (##sys#check-exact len 'make-s8vector)
+ (let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector len ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+@@ -308,7 +310,6 @@ EOF
+
+ (set! make-u16vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+- (##sys#check-exact len 'make-u16vector)
+ (let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+@@ -321,7 +322,6 @@ EOF
+
+ (set! make-s16vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+- (##sys#check-exact len 'make-s16vector)
+ (let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+@@ -334,7 +334,6 @@ EOF
+
+ (set! make-u32vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+- (##sys#check-exact len 'make-u32vector)
+ (let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+@@ -347,7 +346,6 @@ EOF
+
+ (set! make-s32vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+- (##sys#check-exact len 'make-s32vector)
+ (let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+@@ -360,7 +358,6 @@ EOF
+
+ (set! make-f32vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+- (##sys#check-exact len 'make-f32vector)
+ (let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+@@ -375,7 +372,6 @@ EOF
+
+ (set! make-f64vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+- (##sys#check-exact len 'make-f64vector)
+ (let ((v (##sys#make-structure
+ 'f64vector
+ (alloc 'make-f64vector (##core#inline "C_fixnum_shift_left" len 3) ext?))))
+--
+2.1.4
+
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index e1dba9bed..fec872f5f 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -325,18 +325,16 @@ mashups, office (web agendas, mail clients, ...), etc.")
(define-public chicken
(package
(name "chicken")
- (version "4.11.1")
+ (version "4.12.0")
(source (origin
(method url-fetch)
- (uri (string-append "http://code.call-cc.org/releases/"
+ (uri (string-append "https://code.call-cc.org/releases/"
version "/chicken-" version ".tar.gz"))
- (uri (string-append "http://code.call-cc.org/dev-snapshots/"
- "2016/09/12/chicken-" version ".tar.gz"))
(sha256
(base32
- "1rwymbbmnwdyhdzilv9w75an989xw9kjf3x52iqdng3nphpflcga"))
+ "12b9gaa9lqh39lj1v4wm48f6z8ww3jdkvc5bh9gqqvn6kd2wwnk0"))
(patches
- (search-patches "chicken-CVE-2016-6830+CVE-2016-6831.patch"))))
+ (search-patches "chicken-CVE-2017-6949.patch"))))
(build-system gnu-build-system)
(arguments
`(#:modules ((guix build gnu-build-system)
@@ -359,12 +357,6 @@ mashups, office (web agendas, mail clients, ...), etc.")
;; Parallel builds are not supported, as noted in README.
#:parallel-build? #f))
- ;; One of the tests ("testing direct invocation can detect calls of too
- ;; many arguments...") times out when building with a more recent GCC.
- ;; The problem was reported here:
- ;; https://lists.gnu.org/archive/html/chicken-hackers/2015-04/msg00059.html
- (native-inputs
- `(("gcc" ,gcc-4.8)))
(home-page "http://www.call-cc.org/")
(synopsis "R5RS Scheme implementation that compiles native code via C")
(description
--
2.12.0
