From: Mark H Weaver <mhw@netris.org>
Date: Mon, 7 Jan 2013 22:23:26 +0000 (-0500)
Subject: Merge remote-tracking branch 'origin/stable-2.0'
X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/e0c211bb2e80605b4ae3fb121c34136f6e266b70

Merge remote-tracking branch 'origin/stable-2.0'

Conflicts:
	GUILE-VERSION
	libguile/posix.c
	module/ice-9/eval.scm
	test-suite/tests/cse.test
---

e0c211bb2e80605b4ae3fb121c34136f6e266b70
diff --cc module/ice-9/eval.scm
index 7098d4f82,4054bd853..d9a4d594d
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@@ -1,7 -1,6 +1,6 @@@
  ;;; -*- mode: scheme; coding: utf-8; -*-
  
- ;;;; Copyright (C) 2009, 2010, 2011
- ;;;; Free Software Foundation, Inc.
 -;;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc.
++;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
  ;;;;
  ;;;; This library is free software; you can redistribute it and/or
  ;;;; modify it under the terms of the GNU Lesser General Public
@@@ -397,20 -398,29 +398,26 @@@
                 (eval body new-env)
                 (lp (cdr inits)
                     (cons (eval (car inits) env) new-env)))))
-       
-         (('lambda (body nreq . tail))
-          (if (null? tail)
-              (make-fixed-closure eval nreq body (capture-env env))
-              (if (null? (cdr tail))
-                  (make-general-closure (capture-env env) body nreq (car tail)
-                                        0 #f '() #f)
-                  (apply make-general-closure (capture-env env) body nreq tail))))
+ 
+         (('lambda (body docstring nreq . tail))
+          (let ((proc
+                 (if (null? tail)
+                     (make-fixed-closure eval nreq body (capture-env env))
+                     (if (null? (cdr tail))
+                         (make-general-closure (capture-env env) body
+                                               nreq (car tail)
+                                               0 #f '() #f)
+                         (apply make-general-closure (capture-env env)
+                                body nreq tail)))))
+            (when docstring
+              (set-procedure-property! proc 'documentation docstring))
+            proc))
  
 -        (('begin (first . rest))
 -         (let lp ((first first) (rest rest))
 -           (if (null? rest)
 -               (eval first env)
 -               (begin
 -                 (eval first env)
 -                 (lp (car rest) (cdr rest))))))
 -      
 +        (('seq (head . tail))
 +         (begin
 +           (eval head env)
 +           (eval tail env)))
 +        
          (('lexical-set! (n . x))
           (let ((val (eval x env)))
             (list-set! env n val)))
diff --cc test-suite/tests/cse.test
index b356852c1,e0219e84d..f9b85d495
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@@ -285,6 -290,23 +285,23 @@@
  
    (pass-if-cse
     (begin (cons 1 2 3) 4)
 -   (begin
 -     (apply (primitive cons) (const 1) (const 2) (const 3))
 +   (seq
 +     (primcall 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))))