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

Conflicts:
	libguile/deprecated.c
	libguile/ports.c
	libguile/ports.h
	libguile/strports.c
	test-suite/tests/cse.test

module/ice-9/command-line.scm

@@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law."))
 (define* (version-etc package version #:key
                       (port (current-output-port))
                       ;; FIXME: authors
-                      (copyright-year 2011)
+                      (copyright-year 2012)
                       (copyright-holder "Free Software Foundation, Inc.")
                       (copyright (format #f "Copyright (C) ~a ~a"
                                          copyright-year copyright-holder))

module/ice-9/ftw.scm

@@ -538,26 +538,29 @@ of file names is sorted according to ENTRY<?, which defaults to
   (define (enter? dir stat result)
     (and stat (string=? dir name)))
 
-  (define (leaf name stat result)
-    (if (select? name)
-        (and (pair? result)                      ; must have a "." entry
-             (cons (basename name) result))
+  (define (visit basename result)
+    (if (select? basename)
+        (cons basename result)
         result))
 
+  (define (leaf name stat result)
+    (and result
+         (visit (basename name) result)))
+
   (define (down name stat result)
-    (list "."))
+    (visit "." '()))
 
   (define (up name stat result)
-    (cons ".." result))
+    (visit ".." result))
 
   (define (skip name stat result)
     ;; All the sub-directories are skipped.
-    (cons (basename name) result))
+    (visit (basename name) result))
 
   (define (error name* stat errno result)
     (if (string=? name name*)             ; top-level NAME is unreadable
         result
-        (cons (basename name*) result)))
+        (visit (basename name*) result)))
 
   (and=> (file-system-fold enter? leaf down up skip error #f name stat)
          (lambda (files)

module/ice-9/match.scm

@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 ;;;
-;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 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
@@ -52,7 +52,7 @@
 ;; `match' doesn't support clauses of the form `(pat => exp)'.
 
 ;; Unmodified public domain code by Alex Shinn retrieved from
-;; the Chibi-Scheme repository, commit 876:528cdab3f818.
+;; the Chibi-Scheme repository, commit 1206:acd808700e91.
 ;;
 ;; Note: Make sure to update `match.test.upstream' when updating this
 ;; file.

module/ice-9/match.upstream.scm

@@ -210,6 +210,7 @@
 ;; performance can be found at
 ;;   http://synthcode.com/scheme/match-cond-expand.scm
 ;;
+;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
 ;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
 ;;              the pattern (thanks to Stefan Israelsson Tampe)
 ;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
@@ -479,7 +480,8 @@
      (match-one v p . x))
     ((_ v (p . q) g+s sk fk i)
      ;; match one and try the remaining on failure
-     (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i))
+     (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
+       (match-one v p g+s sk (fk2) i)))
     ))
 
 ;; We match a pattern (p ...) by matching the pattern p in a loop on

module/ice-9/pretty-print.scm

@@ -320,9 +320,10 @@ sub-expression, via the @var{breadth-first?} keyword argument."
       (let ((e "…"))
         (catch 'encoding-error
           (lambda ()
-            (with-output-to-string
-              (lambda ()
-                (display e))))
+            (with-fluids ((%default-port-conversion-strategy 'error))
+              (with-output-to-string
+                (lambda ()
+                  (display e)))))
           (lambda (key . args)
             "..."))))
 

module/language/ecmascript/base.scm

@@ -92,7 +92,7 @@
   (pdel o (string->symbol p)))
 
 (define-method (has-property? (o <js-object>) p)
-  (if (hashq-get-handle (js-props o) v)
+  (if (hashq-get-handle (js-props o) p)
       #t
       (let ((proto (js-prototype o)))
         (if proto
@@ -176,9 +176,9 @@
         ((boolean? x) (if x 1 0))
         ((null? x) 0)
         ((eq? x *undefined*) +nan.0)
-        ((is-a? x <js-object>) (object->number x))
+        ((is-a? x <js-object>) (object->number x #t))
         ((string? x) (string->number x))
-        (else (throw 'TypeError o '->number))))
+        (else (throw 'TypeError x '->number))))
 
 (define (->integer x)
   (let ((n (->number x)))

module/language/tree-il/cse.scm

@@ -270,11 +270,11 @@
            #f)))
        (_
         (cond
-         ((find-dominating-expression exp effects #f db)
+         ((find-dominating-expression exp effects 'test db)
           ;; We have an EXP fact, so we infer #t.
           (log 'inferring exp #t)
           (make-const (tree-il-src exp) #t))
-         ((find-dominating-expression (negate exp 'test) effects #f db)
+         ((find-dominating-expression (negate exp 'test) effects 'test db)
           ;; We have a (not EXP) fact, so we infer #f.
           (log 'inferring exp #f)
           (make-const (tree-il-src exp) #f))

module/language/tree-il/primitives.scm

@@ -55,6 +55,8 @@
 
     char<? char<=? char>=? char>?
 
+    integer->char char->integer number->string string->number
+
     acons cons cons*
 
     list vector
@@ -155,6 +157,7 @@
     pair? null? list? symbol? vector? struct? string? number? char? nil
     complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
     char<? char<=? char>=? char>?
+    integer->char char->integer number->string string->number
     struct-vtable
     string-length vector-length
     ;; These all should get expanded out by expand-primitives!.

module/oop/goops/dispatch.scm

@@ -25,6 +25,7 @@
   #:use-module (oop goops)
   #:use-module (oop goops util)
   #:use-module (oop goops compile)
+  #:use-module (system base target)
   #:export (memoize-method!)
   #:no-backtrace)
 
@@ -178,11 +179,15 @@
                      '())
                  (acons gf gf-sym '()))))
   (define (comp exp vals)
-    (let ((p ((@ (system base compile) compile) exp
-              #:env *dispatch-module*
-              #:opts '(#:partial-eval? #f #:cse? #f))))
-      (apply p vals)))
-  
+    ;; When cross-compiling Guile itself, the native Guile must generate
+    ;; code for the host.
+    (with-target %host-type
+      (lambda ()
+        (let ((p ((@ (system base compile) compile) exp
+                  #:env *dispatch-module*
+                  #:opts '(#:partial-eval? #f #:cse? #f))))
+          (apply p vals)))))
+
   ;; kick it.
   (scan))
 

module/srfi/srfi-6.scm

@@ -1,6 +1,6 @@
 ;;; srfi-6.scm --- Basic String Ports
 
-;; 	Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2002, 2003, 2006, 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
@@ -23,10 +23,20 @@
 ;;; Code:
 
 (define-module (srfi srfi-6)
-  #:re-export (open-input-string open-output-string get-output-string))
+  #:replace (open-input-string open-output-string)
+  #:re-export (get-output-string))
 
-;; Currently, guile provides these functions by default, so no action
-;; is needed, and this file is just a placeholder.
+;; SRFI-6 says nothing about encodings, and assumes that any character
+;; or string can be written to a string port.  Thus, make all SRFI-6
+;; string ports Unicode capable.  See <http://bugs.gnu.org/11197>.
+
+(define (open-input-string s)
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    ((@ (guile) open-input-string) s)))
+
+(define (open-output-string)
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    ((@ (guile) open-output-string))))
 
 (cond-expand-provide (current-module) '(srfi-6))