Duplicate of report 26209. Kei Kebreau writes: > * gnu/packages/scheme.scm (chicken): Update to 4.12.0. > --- > .../chicken-CVE-2016-6830+CVE-2016-6831.patch | 81 ------------- > gnu/packages/patches/chicken-CVE-2017-6949.patch | 132 +++++++++++++++++++++ > gnu/packages/scheme.scm | 16 +-- > 3 files changed, 136 insertions(+), 93 deletions(-) > delete mode 100644 gnu/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch > create mode 100644 gnu/packages/patches/chicken-CVE-2017-6949.patch > > 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 @@ > -

Returns an optimized SRE matching any of the literal strings in the list, like Emacs' regexp-opt. Note this optimization doesn't help when irregex is able to build a DFA.

> - > -
sre->string
(sre->string <sre>) procedure
> --

Convert an SRE to a POSIX-style regular expression string, if possible.

> -+

Convert an SRE to a PCRE-style regular expression string, if possible.

> -
> --

Previous: Unit extras

Next: Unit srfi-1

> -\ No newline at end of file > -+

Previous: Unit extras

Next: Unit srfi-1

> 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 > +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 > +Signed-off-by: Kooda > +--- > + 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