Merge remote branch 'origin/stable-2.0'

Conflicts:
	GUILE-VERSION
	test-suite/tests/srfi-4.test

Makefile.am

@@ -1,6 +1,7 @@
 ## Process this file with automake to produce Makefile.in.
 ##
-##  	Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+##  	Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007,
+##        2008, 2009, 2010, 2011 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -34,6 +35,7 @@ SUBDIRS =					\
 	emacs					\
 	test-suite				\
 	benchmark-suite				\
+	gc-benchmarks				\
 	am					\
 	doc
 

NEWS

@@ -5,6 +5,21 @@ See the end for copying conditions.
 Please send Guile bug reports to bug-guile@gnu.org.
 
 
+Changes in 2.0.1 (since 2.0.0):
+
+* New procedures (see the manual for details)
+
+** exact-integer-sqrt, imported into core from (rnrs base)
+
+* Bugs fixed
+
+** exact-integer-sqrt now handles large integers correctly
+
+exact-integer-sqrt now works correctly when applied to very large
+integers (too large to be precisely represented by a C double).
+It has also been imported into core from (rnrs base).
+
+
 Changes in 2.0.0 (changes since the 1.8.x series):
 
 * New modules (see the manual for details)

README

@@ -1,20 +1,8 @@
-!!! This is not a Guile release; it is a source tree retrieved via
+This is version 2.0 of Guile, Project GNU's extension language library.
-Git or as a nightly snapshot at some random time after the
+Guile is an implementation of the Scheme programming language, packaged
-Guile 1.8 release.  If this were a Guile release, you would not see
+as a library that can be linked into applications to give them their own
-this message. !!!  [fixme: zonk on release]
+extension language.  Guile supports other languages as well, giving
-
+users of Guile-based applications a choice of languages.
-This is a 1.9 development version of Guile, Project GNU's extension
-language library.  Guile is an interpreter for Scheme, packaged as a
-library that you can link into your applications to give them their
-own scripting language.  Guile will eventually support other languages
-as well, giving users of Guile-based applications a choice of
-languages.
-
-Guile versions with an odd middle number, i.e. 1.9.* are unstable
-development versions.  Even middle numbers indicate stable versions.
-This has been the case since the 1.3.* series.
-
-The next stable release will likely be version 2.0.0.
 
 Please send bug reports to bug-guile@gnu.org.
 

THANKS

@@ -62,6 +62,7 @@ For fixes or providing information which led to a fix:
           Barry Fishman
         Charles Gagnon
              Fu-gangqiang
+          Aidan Gauland
           Peter Gavin
            Nils Gey
            Eric Gillespie, Jr

am/Makefile.am

@@ -21,7 +21,7 @@
 
 AUTOMAKE_OPTIONS = gnu
 
-am_frags = pre-inst-guile maintainer-dirs guilec
+am_frags = maintainer-dirs guilec
 
 EXTRA_DIST = $(am_frags) ChangeLog-2008
 

am/pre-inst-guile

@@ -1,34 +0,0 @@
-## am/pre-inst-guile --- define preinstguile and preinstguiletool vars
-
-##	Copyright (C) 2002, 2006 Free Software Foundation
-##
-##   This file is part of GUILE.
-##
-##   GUILE is free software; you can redistribute it and/or modify
-##   it under the terms of the GNU Lesser General Public License as
-##   published by the Free Software Foundation; either version 3, or
-##   (at your option) any later version.
-##
-##   GUILE is distributed in the hope that it will be useful, but
-##   WITHOUT ANY WARRANTY; without even the implied warranty of
-##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-##   GNU Lesser General Public License for more details.
-##
-##   You should have received a copy of the GNU Lesser General Public
-##   License along with GUILE; see the file COPYING.LESSER.  If not, write
-##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-##   Floor, Boston, MA 02110-1301 USA
-
-## Commentary:
-
-## This fragment defines two variables: preinstguile, preinstguiletool.
-## It can be included in any Makefile.am by adding the line:
-##   include $(top_srcdir)/am/pre-inst-guile
-## See devel/build/pre-inst-guile.text (CVS only) for more info.
-
-## Code:
-
-preinstguile     = $(top_builddir_absolute)/meta/guile
-preinstguiletool = GUILE="$(preinstguile)" $(top_srcdir)/scripts
-
-## am/pre-inst-guile ends here

benchmark-suite/Makefile.am

@@ -6,6 +6,7 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm		\
                  benchmarks/if.bm			\
                  benchmarks/logand.bm			\
 		 benchmarks/ports.bm			\
+		 benchmarks/r6rs-arithmetic.bm		\
 		 benchmarks/read.bm			\
 		 benchmarks/srfi-1.bm			\
 		 benchmarks/srfi-13.bm			\
@@ -14,7 +15,8 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm		\
 		 benchmarks/uniform-vector-read.bm	\
 		 benchmarks/vectors.bm			\
 		 benchmarks/vlists.bm			\
-		 benchmarks/write.bm
+		 benchmarks/write.bm			\
+		 benchmarks/strings.bm
 
 EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS)	\
 	     ChangeLog-2008

benchmark-suite/benchmarks/arithmetic.bm

@@ -58,7 +58,7 @@
     (repeat (+ 2 <>) 7 100))
 
   (benchmark "-" 1e7
-    (repeat (+ 2 <>) 7 100))
+    (repeat (- 2 <>) 7 100))
 
   (benchmark "*" 1e7
     (repeat (* 1 <>) 1 100))

benchmark-suite/benchmarks/r6rs-arithmetic.bm

@@ -0,0 +1,35 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;; R6RS-specific arithmetic benchmarks
+;;;
+;;; Copyright (C) 2011 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
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (benchmarks r6rs-arithmetic)
+  #:use-module (benchmark-suite lib)
+  #:use-module (rnrs arithmetic fixnums))
+
+
+(with-benchmark-prefix "fixnum"
+
+  (benchmark "fixnum? [yes]" 1e7
+    (fixnum? 10000))
+
+  (let ((n (+ most-positive-fixnum 100)))
+    (benchmark "fixnum? [no]" 1e7
+      (fixnum? n)))
+
+  (benchmark "fxxor [2]" 1e7
+    (fxxor 3 8)))

benchmark-suite/benchmarks/strings.bm

@@ -0,0 +1,537 @@
+;;; -*- Mode: scheme; coding: utf-8; -*-
+;;; strings.bm
+;;;
+;;; Copyright (C) 2011  Free Software Foundation, Inc.
+;;;
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 3, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this software; see the file COPYING.LESSER.  If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks strings)
+  #:use-module (benchmark-suite lib)
+  #:use-module (ice-9 i18n))
+
+(use-modules (ice-9 i18n))
+
+(seed->random-state 1)
+
+;; Start from a known locale state
+(setlocale LC_ALL "C")
+
+(define char-set:cased (char-set-union char-set:lower-case
+                                       char-set:upper-case
+                                       char-set:title-case))
+(define *latin1*
+  (char-set->list (char-set-xor
+                   (char-set-intersection (ucs-range->char-set 0 255)
+                                          char-set:cased)
+                   (->char-set #\µ))))  ; Can't do a case-insensitive comparison of a string
+                                        ; with mu in fr_FR.iso88591 since it case-folds into a
+                                        ; non-Latin-1 character.
+
+(define *cased*
+  (char-set->list char-set:cased))
+
+(define (random-string c-list n)
+  (let ((len (length c-list)))
+    (apply string
+           (map
+            (lambda (x)
+              (list-ref c-list (random len)))
+            (iota n)))))
+
+(define (diff-at-start str)
+  (string-append "!" (substring str 1)))
+(define (diff-in-middle str)
+  (let ((x (floor (/ (string-length str) 2))))
+    (string-append (substring str 0 x)
+                   "!"
+                   (substring str (1+ x)))))
+(define (diff-at-end str)
+  (string-append (substring str 0 (1- (string-length str)))
+                 "!"))
+
+(define short-latin1-string  (random-string *latin1* 10))
+(define medium-latin1-string (random-string *latin1* 100))
+(define long-latin1-string   (random-string *latin1* 1000))
+
+(define short-latin1-string-diff-at-start   (diff-at-start short-latin1-string))
+(define medium-latin1-string-diff-at-start  (diff-at-start medium-latin1-string))
+(define long-latin1-string-diff-at-start    (diff-at-start long-latin1-string))
+
+(define short-latin1-string-diff-in-middle  (diff-in-middle short-latin1-string))
+(define medium-latin1-string-diff-in-middle (diff-in-middle medium-latin1-string))
+(define long-latin1-string-diff-in-middle   (diff-in-middle long-latin1-string))
+
+(define short-latin1-string-diff-at-end     (diff-at-end short-latin1-string))
+(define medium-latin1-string-diff-at-end    (diff-at-end medium-latin1-string))
+(define long-latin1-string-diff-at-end      (diff-at-end long-latin1-string))
+
+(define short-cased-string  (random-string *cased* 10))
+(define medium-cased-string (random-string *cased* 100))
+(define long-cased-string   (random-string *cased* 1000))
+
+(define short-cased-string-diff-at-start    (diff-at-start short-cased-string))
+(define medium-cased-string-diff-at-start   (diff-at-start medium-cased-string))
+(define long-cased-string-diff-at-start     (diff-at-start long-cased-string))
+
+(define short-cased-string-diff-in-middle   (diff-in-middle short-cased-string))
+(define medium-cased-string-diff-in-middle  (diff-in-middle medium-cased-string))
+(define long-cased-string-diff-in-middle    (diff-in-middle long-cased-string))
+
+(define short-cased-string-diff-at-end      (diff-at-end short-cased-string))
+(define medium-cased-string-diff-at-end     (diff-at-end medium-cased-string))
+(define long-cased-string-diff-at-end       (diff-at-end long-cased-string))
+
+(define %french-locale-name      "fr_FR.ISO-8859-1")
+
+(define %french-utf8-locale-name "fr_FR.UTF-8")
+
+(define %french-locale
+  (false-if-exception
+   (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
+                %french-locale-name)))
+
+(define %french-utf8-locale
+  (false-if-exception
+   (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME)
+                %french-utf8-locale-name)))
+
+(define (under-locale-or-unresolved locale thunk)
+  ;; On non-GNU systems, an exception may be raised only when the locale is
+  ;; actually used rather than at `make-locale'-time.  Thus, we must guard
+  ;; against both.
+  (if locale
+      (if (string-contains %host-type "-gnu")
+          (thunk)
+          (catch 'system-error thunk
+                 (lambda (key . args)
+                   (throw 'unresolved))))
+      (throw 'unresolved)))
+
+(define (under-french-locale-or-unresolved thunk)
+  (under-locale-or-unresolved %french-locale thunk))
+
+(define (under-french-utf8-locale-or-unresolved thunk)
+  (under-locale-or-unresolved %french-utf8-locale thunk))
+
+(define (string-op str1 str2)
+  (string<? str1 str2)
+  (string>? str1 str2))
+
+(define (string-ci-op str1 str2)
+  (string-ci<? str1 str2)
+  (string-ci>? str1 str2))
+
+(define (string-fr-op str1 str2)
+  (under-french-locale-or-unresolved
+   (lambda ()
+     (string-locale<? str1 str2 %french-locale)
+     (string-locale>? str1 str2 %french-locale))))
+
+(define (string-fr-utf8-op str1 str2)
+  (under-french-utf8-locale-or-unresolved
+   (lambda ()
+     (string-locale<? str1 str2 %french-utf8-locale)
+     (string-locale>? str1 str2 %french-utf8-locale))))
+
+(define (string-fr-ci-op str1 str2)
+  (under-french-locale-or-unresolved
+   (lambda ()
+     (string-locale-ci<? str1 str2 %french-locale)
+     (string-locale-ci>? str1 str2 %french-locale))))
+
+(define (string-fr-utf8-ci-op str1 str2)
+  (under-french-utf8-locale-or-unresolved
+   (lambda ()
+     (string-locale-ci<? str1 str2 %french-utf8-locale)
+     (string-locale-ci>? str1 str2 %french-utf8-locale))))
+
+
+(with-benchmark-prefix "string ops"
+
+  (with-benchmark-prefix "short Latin1"
+
+    (benchmark "compare initially differing strings" 100000
+      (string-op short-latin1-string short-latin1-string-diff-at-start))
+
+    (benchmark "compare medially differing strings" 100000
+      (string-op short-latin1-string short-latin1-string-diff-in-middle))
+
+    (benchmark "compare terminally differing strings" 100000
+      (string-op short-latin1-string short-latin1-string-diff-at-end))
+
+    (benchmark "compare identical strings" 100000
+      (string-op short-latin1-string short-latin1-string))
+
+    (benchmark "case compare initially differing strings" 100000
+      (string-ci-op short-latin1-string short-latin1-string-diff-at-start))
+
+    (benchmark "case compare medially differing strings" 100000
+      (string-ci-op short-latin1-string short-latin1-string-diff-in-middle))
+
+    (benchmark "case compare terminally differing strings" 100000
+      (string-ci-op short-latin1-string short-latin1-string-diff-at-end))
+
+    (benchmark "case compare identical strings" 100000
+      (string-ci-op short-latin1-string short-latin1-string))
+
+    (benchmark "French Latin-1 locale compare initially differing strings" 100000
+      (string-fr-op short-latin1-string short-latin1-string-diff-at-start))
+
+    (benchmark "French Latin-1 locale compare medially differing strings" 100000
+      (string-fr-op short-latin1-string short-latin1-string-diff-in-middle))
+
+    (benchmark "French Latin-1 locale compare terminally differing strings" 100000
+      (string-fr-op short-latin1-string short-latin1-string-diff-at-end))
+
+    (benchmark "French Latin-1 locale compare identical strings" 100000
+      (string-fr-op short-latin1-string short-latin1-string))
+
+    (benchmark "French Latin-1 locale case compare initially differing strings" 100000
+      (string-fr-ci-op short-latin1-string short-latin1-string-diff-at-start))
+
+    (benchmark "French Latin-1 locale case compare medially differing strings" 100000
+      (string-fr-ci-op short-latin1-string short-latin1-string-diff-in-middle))
+
+    (benchmark "French Latin-1 locale case compare terminally differing strings" 100000
+      (string-fr-ci-op short-latin1-string short-latin1-string-diff-at-end))
+
+    (benchmark "French Latin-1 locale case compare identical strings" 100000
+      (string-fr-ci-op short-latin1-string short-latin1-string))
+
+    (benchmark "French UTF-8 locale compare initially differing strings" 100000
+      (string-fr-utf8-op short-latin1-string short-latin1-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale compare medially differing strings" 100000
+      (string-fr-utf8-op short-latin1-string short-latin1-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale compare terminally differing strings" 100000
+      (string-fr-utf8-op short-latin1-string short-latin1-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale compare identical strings" 100000
+      (string-fr-utf8-op short-latin1-string short-latin1-string))
+
+    (benchmark "French UTF-8 locale case compare initially differing strings" 100000
+      (string-fr-utf8-ci-op short-latin1-string short-latin1-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale case compare medially differing strings" 100000
+      (string-fr-utf8-ci-op short-latin1-string short-latin1-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale case compare terminally differing strings" 100000
+      (string-fr-utf8-ci-op short-latin1-string short-latin1-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale case compare identical strings" 100000
+      (string-fr-utf8-ci-op short-latin1-string short-latin1-string)))
+
+  (with-benchmark-prefix "medium Latin1"
+
+    (benchmark "compare initially differing strings" 10000
+      (string-op medium-latin1-string medium-latin1-string-diff-at-start))
+
+    (benchmark "compare medially differing strings" 10000
+      (string-op medium-latin1-string medium-latin1-string-diff-in-middle))
+
+    (benchmark "compare terminally differing strings" 10000
+      (string-op medium-latin1-string medium-latin1-string-diff-at-end))
+
+    (benchmark "compare identical strings" 10000
+      (string-op medium-latin1-string medium-latin1-string))
+
+    (benchmark "case compare initially differing strings" 10000
+      (string-ci-op medium-latin1-string medium-latin1-string-diff-at-start))
+
+    (benchmark "case compare medially differing strings" 10000
+      (string-ci-op medium-latin1-string medium-latin1-string-diff-in-middle))
+
+    (benchmark "case compare terminally differing strings" 10000
+      (string-ci-op medium-latin1-string medium-latin1-string-diff-at-end))
+
+    (benchmark "case compare identical strings" 10000
+      (string-ci-op medium-latin1-string medium-latin1-string))
+
+    (benchmark "French Latin-1 locale compare initially differing strings" 10000
+      (string-fr-op medium-latin1-string medium-latin1-string-diff-at-start))
+
+    (benchmark "French Latin-1 locale compare medially differing strings" 10000
+      (string-fr-op medium-latin1-string medium-latin1-string-diff-in-middle))
+
+    (benchmark "French Latin-1 locale compare terminally differing strings" 10000
+      (string-fr-op medium-latin1-string medium-latin1-string-diff-at-end))
+
+    (benchmark "French Latin-1 locale compare identical strings" 10000
+      (string-fr-op medium-latin1-string medium-latin1-string))
+
+    (benchmark "French Latin-1 locale case compare initially differing strings" 10000
+      (string-fr-ci-op medium-latin1-string medium-latin1-string-diff-at-start))
+
+    (benchmark "French Latin-1 locale case compare medially differing strings" 10000
+      (string-fr-ci-op medium-latin1-string medium-latin1-string-diff-in-middle))
+
+    (benchmark "French Latin-1 locale case compare terminally differing strings" 10000
+      (string-fr-ci-op medium-latin1-string medium-latin1-string-diff-at-end))
+
+    (benchmark "French Latin-1 locale case compare identical strings" 10000
+      (string-fr-ci-op medium-latin1-string medium-latin1-string))
+
+   (benchmark "French UTF-8 locale compare initially differing strings" 10000
+      (string-fr-utf8-op medium-latin1-string medium-latin1-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale compare medially differing strings" 10000
+      (string-fr-utf8-op medium-latin1-string medium-latin1-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale compare terminally differing strings" 10000
+      (string-fr-utf8-op medium-latin1-string medium-latin1-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale compare identical strings" 10000
+      (string-fr-utf8-op medium-latin1-string medium-latin1-string))
+
+    (benchmark "French UTF-8 locale case compare initially differing strings" 10000
+      (string-fr-utf8-ci-op medium-latin1-string medium-latin1-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale case compare medially differing strings" 10000
+      (string-fr-utf8-ci-op medium-latin1-string medium-latin1-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale case compare terminally differing strings" 10000
+      (string-fr-utf8-ci-op medium-latin1-string medium-latin1-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale case compare identical strings" 10000
+      (string-fr-utf8-ci-op medium-latin1-string medium-latin1-string)))
+
+  (with-benchmark-prefix "long Latin1"
+
+    (benchmark "compare initially differing strings" 1000
+      (string-op long-latin1-string long-latin1-string-diff-at-start))
+
+    (benchmark "compare medially differing strings" 1000
+      (string-op long-latin1-string long-latin1-string-diff-in-middle))
+
+    (benchmark "compare terminally differing strings" 1000
+      (string-op long-latin1-string long-latin1-string-diff-at-end))
+
+    (benchmark "compare identical strings" 1000
+      (string-op long-latin1-string long-latin1-string))
+
+    (benchmark "case compare initially differing strings" 1000
+      (string-ci-op long-latin1-string long-latin1-string-diff-at-start))
+
+    (benchmark "case compare medially differing strings" 1000
+      (string-ci-op long-latin1-string long-latin1-string-diff-in-middle))
+
+    (benchmark "case compare terminally differing strings" 1000
+      (string-ci-op long-latin1-string long-latin1-string-diff-at-end))
+
+    (benchmark "case compare identical strings" 1000
+      (string-ci-op long-latin1-string long-latin1-string))
+
+    (benchmark "French Latin-1 locale compare initially differing strings" 1000
+      (string-fr-op long-latin1-string long-latin1-string-diff-at-start))
+
+    (benchmark "French Latin-1 locale compare medially differing strings" 1000
+      (string-fr-op long-latin1-string long-latin1-string-diff-in-middle))
+
+    (benchmark "French Latin-1 locale compare terminally differing strings" 1000
+      (string-fr-op long-latin1-string long-latin1-string-diff-at-end))
+
+    (benchmark "French Latin-1 locale compare identical strings" 1000
+      (string-fr-op long-latin1-string long-latin1-string))
+
+    (benchmark "French Latin-1 locale case compare initially differing strings" 1000
+      (string-fr-ci-op long-latin1-string long-latin1-string-diff-at-start))
+
+    (benchmark "French Latin-1 locale case compare medially differing strings" 1000
+      (string-fr-ci-op long-latin1-string long-latin1-string-diff-in-middle))
+
+    (benchmark "French Latin-1 locale case compare terminally differing strings" 1000
+      (string-fr-ci-op long-latin1-string long-latin1-string-diff-at-end))
+
+    (benchmark "French Latin-1 locale case compare identical strings" 1000
+      (string-fr-ci-op long-latin1-string long-latin1-string))
+
+    (benchmark "French UTF-8 locale compare initially differing strings" 1000
+      (string-fr-utf8-op long-latin1-string long-latin1-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale compare medially differing strings" 1000
+      (string-fr-utf8-op long-latin1-string long-latin1-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale compare terminally differing strings" 1000
+      (string-fr-utf8-op long-latin1-string long-latin1-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale compare identical strings" 1000
+      (string-fr-utf8-op long-latin1-string long-latin1-string))
+
+    (benchmark "French UTF-8 locale case compare initially differing strings" 1000
+      (string-fr-utf8-ci-op long-latin1-string long-latin1-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale case compare medially differing strings" 1000
+      (string-fr-utf8-ci-op long-latin1-string long-latin1-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale case compare terminally differing strings" 1000
+      (string-fr-utf8-ci-op long-latin1-string long-latin1-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale case compare identical strings" 1000
+      (string-fr-utf8-ci-op long-latin1-string long-latin1-string)))
+
+  (with-benchmark-prefix "short Unicode"
+
+    (benchmark "compare initially differing strings" 100000
+      (string-op short-cased-string short-cased-string-diff-at-start))
+
+    (benchmark "compare medially differing strings" 100000
+      (string-op short-cased-string short-cased-string-diff-in-middle))
+
+    (benchmark "compare terminally differing strings" 100000
+      (string-op short-cased-string short-cased-string-diff-at-end))
+
+    (benchmark "compare identical strings" 100000
+      (string-op short-cased-string short-cased-string))
+
+    (benchmark "case compare initially differing strings" 100000
+      (string-ci-op short-cased-string short-cased-string-diff-at-start))
+
+    (benchmark "case compare medially differing strings" 100000
+      (string-ci-op short-cased-string short-cased-string-diff-in-middle))
+
+    (benchmark "case compare terminally differing strings" 100000
+      (string-ci-op short-cased-string short-cased-string-diff-at-end))
+
+    (benchmark "case compare identical strings" 100000
+      (string-ci-op short-cased-string short-cased-string))
+
+    (benchmark "French UTF-8 locale compare initially differing strings" 100000
+      (string-fr-utf8-op short-cased-string short-cased-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale compare medially differing strings" 100000
+      (string-fr-utf8-op short-cased-string short-cased-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale compare terminally differing strings" 100000
+      (string-fr-utf8-op short-cased-string short-cased-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale compare identical strings" 100000
+      (string-fr-utf8-op short-cased-string short-cased-string))
+
+    (benchmark "French UTF-8 locale case compare initially differing strings" 100000
+      (string-fr-utf8-ci-op short-cased-string short-cased-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale case compare medially differing strings" 100000
+      (string-fr-utf8-ci-op short-cased-string short-cased-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale case compare terminally differing strings" 100000
+      (string-fr-utf8-ci-op short-cased-string short-cased-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale case compare identical strings" 100000
+      (string-fr-utf8-ci-op short-cased-string short-cased-string)))
+
+  (with-benchmark-prefix "medium Unicode"
+
+    (benchmark "compare initially differing strings" 10000
+      (string-op medium-cased-string medium-cased-string-diff-at-start))
+
+    (benchmark "compare medially differing strings" 10000
+      (string-op medium-cased-string medium-cased-string-diff-in-middle))
+
+    (benchmark "compare terminally differing strings" 10000
+      (string-op medium-cased-string medium-cased-string-diff-at-end))
+
+    (benchmark "compare identical strings" 10000
+      (string-op medium-cased-string medium-cased-string))
+
+    (benchmark "case compare initially differing strings" 10000
+      (string-ci-op medium-cased-string medium-cased-string-diff-at-start))
+
+    (benchmark "case compare medially differing strings" 10000
+      (string-ci-op medium-cased-string medium-cased-string-diff-in-middle))
+
+    (benchmark "case compare terminally differing strings" 10000
+      (string-ci-op medium-cased-string medium-cased-string-diff-at-end))
+
+    (benchmark "case compare identical strings" 10000
+      (string-ci-op medium-cased-string medium-cased-string))
+
+    (benchmark "French UTF-8 locale compare initially differing strings" 10000
+      (string-fr-utf8-op medium-cased-string medium-cased-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale compare medially differing strings" 10000
+      (string-fr-utf8-op medium-cased-string medium-cased-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale compare terminally differing strings" 10000
+      (string-fr-utf8-op medium-cased-string medium-cased-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale compare identical strings" 10000
+      (string-fr-utf8-op medium-cased-string medium-cased-string))
+
+    (benchmark "French UTF-8 locale case compare initially differing strings" 10000
+      (string-fr-utf8-ci-op medium-cased-string medium-cased-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale case compare medially differing strings" 10000
+      (string-fr-utf8-ci-op medium-cased-string medium-cased-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale case compare terminally differing strings" 10000
+      (string-fr-utf8-ci-op medium-cased-string medium-cased-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale case compare identical strings" 10000
+      (string-fr-utf8-ci-op medium-cased-string medium-cased-string)))
+
+  (with-benchmark-prefix "long Unicode"
+
+    (benchmark "compare initially differing strings" 1000
+      (string-op long-cased-string long-cased-string-diff-at-start))
+
+    (benchmark "compare medially differing strings" 1000
+      (string-op long-cased-string long-cased-string-diff-in-middle))
+
+    (benchmark "compare terminally differing strings" 1000
+      (string-op long-cased-string long-cased-string-diff-at-end))
+
+    (benchmark "compare identical strings" 1000
+      (string-op long-cased-string long-cased-string))
+
+    (benchmark "case compare initially differing strings" 1000
+      (string-ci-op long-cased-string long-cased-string-diff-at-start))
+
+    (benchmark "case compare medially differing strings" 1000
+      (string-ci-op long-cased-string long-cased-string-diff-in-middle))
+
+    (benchmark "case compare terminally differing strings" 1000
+      (string-ci-op long-cased-string long-cased-string-diff-at-end))
+
+    (benchmark "case compare identical strings" 1000
+      (string-ci-op long-cased-string long-cased-string))
+
+    (benchmark "French UTF-8 locale compare initially differing strings" 1000
+      (string-fr-utf8-op long-cased-string long-cased-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale compare medially differing strings" 1000
+      (string-fr-utf8-op long-cased-string long-cased-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale compare terminally differing strings" 1000
+      (string-fr-utf8-op long-cased-string long-cased-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale compare identical strings" 1000
+      (string-fr-utf8-op long-cased-string long-cased-string))
+
+    (benchmark "French UTF-8 locale case compare initially differing strings" 1000
+      (string-fr-utf8-ci-op long-cased-string long-cased-string-diff-at-start))
+
+    (benchmark "French UTF-8 locale case compare medially differing strings" 1000
+      (string-fr-utf8-ci-op long-cased-string long-cased-string-diff-in-middle))
+
+    (benchmark "French UTF-8 locale case compare terminally differing strings" 1000
+      (string-fr-utf8-ci-op long-cased-string long-cased-string-diff-at-end))
+
+    (benchmark "French UTF-8 locale case compare identical strings" 1000
+      (string-fr-utf8-ci-op long-cased-string long-cased-string))))
+
+

build-aux/config.rpath

@@ -57,13 +57,6 @@ else
     aix*)
       wl='-Wl,'
       ;;
-    darwin*)
-      case $cc_basename in
-        xlc*)
-          wl='-Wl,'
-          ;;
-      esac
-      ;;
     mingw* | cygwin* | pw32* | os2* | cegcc*)
       ;;
     hpux9* | hpux10* | hpux11*)
@@ -72,9 +65,7 @@ else
     irix5* | irix6* | nonstopux*)
       wl='-Wl,'
       ;;
-    newsos6)
+    linux* | k*bsd*-gnu | kopensolaris*-gnu)
-      ;;
-    linux* | k*bsd*-gnu)
       case $cc_basename in
         ecc*)
           wl='-Wl,'
@@ -85,17 +76,26 @@ else
         lf95*)
           wl='-Wl,'
           ;;
-        pgcc | pgf77 | pgf90)
+        nagfor*)
+          wl='-Wl,-Wl,,'
+          ;;
+        pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*)
           wl='-Wl,'
           ;;
         ccc*)
           wl='-Wl,'
           ;;
+        xl* | bgxl* | bgf* | mpixl*)
+          wl='-Wl,'
+          ;;
         como)
           wl='-lopt='
           ;;
         *)
           case `$CC -V 2>&1 | sed 5q` in
+            *Sun\ F* | *Sun*Fortran*)
+              wl=
+              ;;
             *Sun\ C*)
               wl='-Wl,'
               ;;
@@ -103,13 +103,24 @@ else
           ;;
       esac
       ;;
+    newsos6)
+      ;;
+    *nto* | *qnx*)
+      ;;
     osf3* | osf4* | osf5*)
       wl='-Wl,'
       ;;
     rdos*)
       ;;
     solaris*)
-      wl='-Wl,'
+      case $cc_basename in
+        f77* | f90* | f95* | sunf77* | sunf90* | sunf95*)
+          wl='-Qoption ld '
+          ;;
+        *)
+          wl='-Wl,'
+          ;;
+      esac
       ;;
     sunos4*)
       wl='-Qoption ld '
@@ -171,15 +182,14 @@ if test "$with_gnu_ld" = yes; then
       fi
       ;;
     amigaos*)
-      hardcode_libdir_flag_spec='-L$libdir'
+      case "$host_cpu" in
-      hardcode_minus_L=yes
+        powerpc)
-      # Samuel A. Falvo II <kc5tja@dolphin.openprojects.net> reports
+          ;;
-      # that the semantics of dynamic libraries on AmigaOS, at least up
+        m68k)
-      # to version 4, is to share data among multiple programs linked
+          hardcode_libdir_flag_spec='-L$libdir'
-      # with the same dynamic library.  Since this doesn't match the
+          hardcode_minus_L=yes
-      # behavior of shared libraries on other platforms, we cannot use
+          ;;
-      # them.
+      esac
-      ld_shlibs=no
       ;;
     beos*)
       if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
@@ -198,11 +208,13 @@ if test "$with_gnu_ld" = yes; then
         ld_shlibs=no
       fi
       ;;
+    haiku*)
+      ;;
     interix[3-9]*)
       hardcode_direct=no
       hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
       ;;
-    gnu* | linux* | k*bsd*-gnu)
+    gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu)
       if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
         :
       else
@@ -325,10 +337,14 @@ else
       fi
       ;;
     amigaos*)
-      hardcode_libdir_flag_spec='-L$libdir'
+      case "$host_cpu" in
-      hardcode_minus_L=yes
+        powerpc)
-      # see comment about different semantics on the GNU ld section
+          ;;
-      ld_shlibs=no
+        m68k)
+          hardcode_libdir_flag_spec='-L$libdir'
+          hardcode_minus_L=yes
+          ;;
+      esac
       ;;
     bsdi[45]*)
       ;;
@@ -342,16 +358,10 @@ else
       ;;
     darwin* | rhapsody*)
       hardcode_direct=no
-      if test "$GCC" = yes ; then
+      if { case $cc_basename in ifort*) true;; *) test "$GCC" = yes;; esac; }; then
         :
       else
-        case $cc_basename in
+        ld_shlibs=no
-          xlc*)
-            ;;
-          *)
-            ld_shlibs=no
-            ;;
-        esac
       fi
       ;;
     dgux*)
@@ -417,6 +427,8 @@ else
       hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
       hardcode_libdir_separator=:
       ;;
+    *nto* | *qnx*)
+      ;;
     openbsd*)
       if test -f /usr/libexec/ld.so; then
         hardcode_direct=yes
@@ -512,7 +524,12 @@ case "$host_os" in
     library_names_spec='$libname$shrext'
     ;;
   amigaos*)
-    library_names_spec='$libname.a'
+    case "$host_cpu" in
+      powerpc*)
+        library_names_spec='$libname$shrext' ;;
+      m68k)
+        library_names_spec='$libname.a' ;;
+    esac
     ;;
   beos*)
     library_names_spec='$libname$shrext'
@@ -542,6 +559,9 @@ case "$host_os" in
   gnu*)
     library_names_spec='$libname$shrext'
     ;;
+  haiku*)
+    library_names_spec='$libname$shrext'
+    ;;
   hpux9* | hpux10* | hpux11*)
     case $host_cpu in
       ia64*)
@@ -577,7 +597,7 @@ case "$host_os" in
     ;;
   linux*oldld* | linux*aout* | linux*coff*)
     ;;
-  linux* | k*bsd*-gnu)
+  linux* | k*bsd*-gnu | kopensolaris*-gnu)
     library_names_spec='$libname$shrext'
     ;;
   knetbsd*-gnu)
@@ -589,7 +609,7 @@ case "$host_os" in
   newsos6)
     library_names_spec='$libname$shrext'
     ;;
-  nto-qnx*)
+  *nto* | *qnx*)
     library_names_spec='$libname$shrext'
     ;;
   openbsd*)
@@ -620,6 +640,9 @@ case "$host_os" in
   sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
     library_names_spec='$libname$shrext'
     ;;
+  tpf*)
+    library_names_spec='$libname$shrext'
+    ;;
   uts4*)
     library_names_spec='$libname$shrext'
     ;;

build-aux/git-version-gen

@@ -1,6 +1,6 @@
 #!/bin/sh
 # Print a version string.
-scriptversion=2011-01-04.17; # UTC
+scriptversion=2011-02-19.19; # UTC
 
 # Copyright (C) 2007-2011 Free Software Foundation, Inc.
 #
@@ -80,6 +80,7 @@ nl='
 
 # Avoid meddling by environment variable of the same name.
 v=
+v_from_git=
 
 # First see if there is a tarball-only version file.
 # then try "git describe", then default.
@@ -134,24 +135,30 @@ then
     # Change the first '-' to a '.', so version-comparing tools work properly.
     # Remove the "g" in git describe's output string, to save a byte.
     v=`echo "$v" | sed 's/-/./;s/\(.*\)-g/\1-/'`;
+    v_from_git=1
 else
     v=UNKNOWN
 fi
 
 v=`echo "$v" |sed 's/^v//'`
 
-# Don't declare a version "dirty" merely because a time stamp has changed.
+# Test whether to append the "-dirty" suffix only if the version
-git update-index --refresh > /dev/null 2>&1
+# string we're using came from git.  I.e., skip the test if it's "UNKNOWN"
+# or if it came from .tarball-version.
+if test -n "$v_from_git"; then
+  # Don't declare a version "dirty" merely because a time stamp has changed.
+  git update-index --refresh > /dev/null 2>&1
 
-dirty=`exec 2>/dev/null;git diff-index --name-only HEAD` || dirty=
+  dirty=`exec 2>/dev/null;git diff-index --name-only HEAD` || dirty=
-case "$dirty" in
+  case "$dirty" in
-    '') ;;
+      '') ;;
-    *) # Append the suffix only if there isn't one already.
+      *) # Append the suffix only if there isn't one already.
-        case $v in
+          case $v in
-          *-dirty) ;;
+            *-dirty) ;;
-          *) v="$v-dirty" ;;
+            *) v="$v-dirty" ;;
-        esac ;;
+          esac ;;
-esac
+  esac
+fi
 
 # Omit the trailing newline, so that m4_esyscmd can use the result directly.
 echo "$v" | tr -d "$nl"

configure.ac

@@ -29,9 +29,7 @@ Floor, Boston, MA 02110-1301, USA.
 AC_PREREQ(2.61)
 
 AC_INIT([GNU Guile],
-        m4_esyscmd([build-aux/git-version-gen					\
+        m4_esyscmd([build-aux/git-version-gen .tarball-version]),
-          .tarball-version							\
-          's/^release_\([0-9][0-9]*\)-\([0-9][0-9]*\)-\([0-9][0-9]*\)/v\1.\2\.\3/g']),
         [bug-guile@gnu.org])
 AC_CONFIG_AUX_DIR([build-aux])
 AC_CONFIG_MACRO_DIR([m4])
@@ -775,7 +773,7 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime
 #   cuserid - on Tru64 5.1b the declaration is documented to be available
 #       only with `_XOPEN_SOURCE' or some such.
 #
-AC_CHECK_HEADERS([crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h])
+AC_CHECK_HEADERS([crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h sys/mman.h])
 AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname)
 AC_CHECK_DECLS([sethostname, hstrerror, cuserid])
 
@@ -1240,7 +1238,7 @@ save_LIBS="$LIBS"
 LIBS="$BDW_GC_LIBS $LIBS"
 CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
 
-AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active])
+AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask])
 
 # Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
 # declared, and has a different type (returning void instead of
@@ -1258,6 +1256,13 @@ AC_CHECK_TYPE([GC_fn_type],
   [],
   [#include <gc/gc.h>])
 
+# `GC_stack_base' is not available in GC 7.1 and earlier.
+AC_CHECK_TYPE([struct GC_stack_base],
+  [AC_DEFINE([HAVE_GC_STACK_BASE], [1],
+    [Define this if the `GC_stack_base' type is available.])],
+  [],
+  [#include <gc/gc.h>])
+
 LIBS="$save_LIBS"
 
 
@@ -1489,7 +1494,7 @@ if test "$cross_compiling" = "yes"; then
   AC_MSG_CHECKING(guile for build)
   GUILE_FOR_BUILD="${GUILE_FOR_BUILD-guile}"
 else
-  GUILE_FOR_BUILD='$(preinstguile)'
+  GUILE_FOR_BUILD='this-value-will-never-be-used'
 fi   
 
 ## AC_MSG_CHECKING("if we are cross compiling")
@@ -1498,7 +1503,7 @@ if test "$cross_compiling" = "yes"; then
    AC_MSG_RESULT($GUILE_FOR_BUILD)
 fi
 AC_ARG_VAR(GUILE_FOR_BUILD,[guile for build system])
-AC_SUBST(GUILE_FOR_BUILD)
+AM_SUBST_NOTMAKE(GUILE_FOR_BUILD)
   			
 ## If we're using GCC, ask for aggressive warnings.
 GCC_CFLAGS=""
@@ -1568,9 +1573,27 @@ AC_SUBST(LIBGUILE_I18N_INTERFACE)
 
 #######################################################################
 
-dnl Tell guile-config what flags guile users should compile and link with.
+dnl Tell guile-config what flags guile users should compile and link
+dnl with, keeping only `-I' flags from $CPPFLAGS.
+GUILE_CFLAGS=""
+next_is_includedir=false
+for flag in $CPPFLAGS
+do
+  if $next_is_includedir; then
+    GUILE_CFLAGS="$GUILE_CFLAGS -I $flag"
+    next_is_includedir=false
+  else
+    case "$flag" in
+      -I)  next_is_includedir=true;;
+      -I*) GUILE_CFLAGS="$GUILE_CFLAGS $flag";;
+      *)   ;;
+    esac
+  fi
+done
+
+GUILE_CFLAGS="$GUILE_CFLAGS $PTHREAD_CFLAGS"
 GUILE_LIBS="$LDFLAGS $LIBS"
-GUILE_CFLAGS="$CPPFLAGS $PTHREAD_CFLAGS"
+
 AC_SUBST(GUILE_LIBS)
 AC_SUBST(GUILE_CFLAGS)
 
@@ -1602,6 +1625,7 @@ AC_CONFIG_FILES([
   am/Makefile
   lib/Makefile
   benchmark-suite/Makefile
+  gc-benchmarks/Makefile
   doc/Makefile
   doc/r5rs/Makefile
   doc/ref/Makefile

doc/guile.1

@@ -3,113 +3,210 @@
 .\" Process this file with
 .\" groff -man -Tascii foo.1
 .\"
-.TH GUILE 1
+.\" title section date source manual
+.TH GUILE 1 "2011-03-04" GNU "GNU Guile 2.0"
+.
 .SH NAME
-guile \- the GNU extension language
+guile \- The GNU Project Extension Language
+.
 .SH SYNOPSIS
-.B guile [-L DIRECTORY] [-l FILE] [-e FUNCTION] [\\\\]
+.B guile
-.B [-c EXPR] [-s SCRIPT] [--] [SCRIPT] [ARG...]
+.RB [\| \-L
+.IR DIRECTORY \|]
+.RB [\| \-l
+.IR FILE \|]
+.RB [\| \-e
+.IR FUNCTION \|]
+.\".RI [\| \\\\ \|]
+.RB [\| \e \|]
+.RB [\| \-c
+.IR EXPR \|]
+.RB [\| \-s
+.IR SCRIPT \|]
+.RB [\| \-\- \|]
+.RI [\| SCRIPT
+.RI [\| ARGs\ for\ SCRIPT \|]\c
+.RI ]
 
-Only the most useful options are listed here; see below for the
+Only the most useful options are listed here;
-remainder.
+see below for the remainder.
+.
 .SH DESCRIPTION
-GNU Guile is an implemention of the Scheme programming language.  It
+GNU Guile is an implementation of the Scheme programming language.
-extends the R5RS and R6RS language standards, providing additional
+It extends the R5RS and R6RS language standards,
-features necessary for real-world use.  Guile works well for interactive
+providing additional features necessary for real-world use.
-use, basic scripting, and extension of larger applications, as well as
+
-for stand-alone Scheme application development.
+Guile works well for interactive use,
+basic scripting,
+and extension of larger applications,
+as well as for stand-alone Scheme application development.
 
 The
 .B guile
 executable itself provides a stand-alone interactive compiler and
-run-time for Scheme programs, both for interactive use and for executing
+run-time for Scheme programs,
-Scheme scripts or programs.
+both for interactive use and for executing Scheme scripts or programs.
 
 This manual page provides only brief instruction in invoking
 .B guile
-from the command line.  Please consult the guile info documentation
+from the command line.
-(type 
+Please consult the Guile info documentation for more information,
-.B info "guile(Invoking Guile)"
+(type \fB info "(guile)Invoking Guile"\fR at a command prompt).
-at a command prompt) for more information.
+.
-
 .SH OPTIONS
-.IP -L DIRECTORY
+.TP
-Add DIRECTORY to the front of Guile's module load path.
+.BI -L \ DIRECTORY
-.IP -l FILE
+Add \fIDIRECTORY\fR to the front of Guile's module load path.
-Load scheme source code from file.
+.
-.IP -e FUNCTION
+.TP
-After reading script, apply FUNCTION to command-line arguments.  Note
+.BI -l \ FILE
-that FUNCTION is evaluated, so e.g.
+Load Scheme source code from \fIFILE\fR.
+.
+.TP
+.BI -e \ FUNCTION
+After reading \fISCRIPT\fR, apply \fIFUNCTION\fR to command-line arguments.
+Note that \fIFUNCTION\fR is evaluated,
+so, for example,
 .B (@ (my-module) my-proc)
 is valid here.
-.IP \\\\
+.
+.TP
+.B \e
 The "meta switch", used to work around limitations in #! scripts.
-See "The Meta Switch" in the texinfo documentation, for more details.
+See "The Meta Switch" in the texinfo documentation for more details.
-.IP --
+.
-Stop argument processing, start guile in interactive mode.
+.TP
-.IP -c EXPR
+.B --
-Stop argument processing, evaluate EXPR as a scheme expression.
+Stop argument processing, and start
-.IP -s SCRIPT-FILE
+.B guile
-Load Scheme source from SCRIPT-FILE and execute as a script.  Note that
+in interactive mode.
-the in many cases it is not necessary to use -s; one may invoke Guile
+.
-just as
+.TP
-.B guile SCRIPT-FILE ARG...
+.BI -c \ EXPR
-.IP -ds
+Stop argument processing,
-Do -s SCRIPT at this point.  Note that this argument must be used in
+and evaluate \fIEXPR\fR as a Scheme expression.
-conjuction with -s.
+.
-.IP --debug
+.TP
-Start guile with the debugging VM.  By default, on when invoked
+.BI -s \ SCRIPT-FILE
-interactively, off otherwise.
+Load Scheme source from \fISCRIPT-FILE\fR and execute as a script.
-.IP --auto-compile
+Note that in many cases it is not necessary to use \fB-s\fR;
+one may invoke
+.B guile
+simply as
+.B guile
+.I SCRIPT-FILE ARG...
+.
+.TP
+.B -ds
+Carry out \fB\-s \fISCRIPT\fR at this point in the option sequence.
+Note that this argument must be used in conjunction with \fB\-s\fR.
+.
+.TP
+.B --debug
+Start
+.B guile
+with the debugging VM.
+By default, debugging is on when
+.B guile
+is invoked interactively;
+it is off otherwise.
+.
+.TP
+.B --no-debug
+Start
+.B guile
+without the debugging VM,
+even if
+.B guile
+is being run interactively.
+.
+.TP
+.B --auto-compile
 Compile source files automatically (default behavior).
-.IP --no-auto-compile
+.
+.TP
+.B --no-autocompile
 Disable automatic source file compilation.
-.IP --listen[=P]
+.
-Listen on a port or socket for remote REPL connections.  See the manual
+.TP
-for more details.
+\fB\-\-listen\fR[=\fIP\fR]
-.IP --use-srfi=N,M...
+Listen on a port or socket for remote REPL connections.
-Load SRFI extensions N, M, etc. For example, "--use-srfi=8,13".
+See the manual for more details.
-.IP -x EXTENSION
+.
-Add EXTENSION to the Guile's load extension list.
+.TP
-.IP --help 
+\fB\-\-use\-srfi\fR=\fIN,M\fR...
-Describe command line options and exit
+Load SRFI extensions \fIN\fR, \fIM\fR, etc.
-.IP --version
+For example,
+\fB \-\-use\-srfi\fR=\fI8,13\fR.
+.
+.TP
+.BI -x \ EXTENSION
+Add \fIEXTENSION\fR to the
+.B guile
+load extension list.
+.
+.TP
+\fB\-h\fR, \fB\-\-help\fR
+Describe command-line options and exit.
+.
+.TP
+\fB\-v\fR, \fB\-\-version\fR
 Display guile version and exit.
-.IP -q
+.
-In interactive mode, suppress loading the user's ~/.guile file.
+.TP
-
+.B -q
+In interactive mode,
+suppress loading the user's initialization file,
+.I ~/.guile.
+.
 .SH ENVIRONMENT
 .\".TP \w'MANROFFSEQ\ \ 'u
 .TP
 .B GUILE_LOAD_PATH
 If
 .RB $ GUILE_LOAD_PATH
-is set, its value is used to agument the path to search for scheme
+is set before
-files when loading.  It should be a colon separated list of
+.B guile
-directories which will be prepended to the default %load-path.
+is started,
-
+its value is used to augment the path to search for Scheme files when
+loading.
+It should be a colon-separated list of directories,
+which will be prefixed to the default
+.B %load-path.
+.TP
 .B GUILE_LOAD_COMPILED_PATH
 If
 .RB $ GUILE_LOAD_COMPILED_PATH
-is set, its value is used to agument the path to search for compiled
+is set before
-Scheme files (.go files) when loading.  It should be a colon separated
+.B guile
-list of directories which will be prepended to the default %load-path.
+is started,
-
+its value is used to augment the path to search for compiled
+Scheme files (.go files) when loading.
+It should be a colon-separated list of directories,
+which will be prefixed to the default
+.B %load-compiled-path.
+.
 .SH FILES
+.TP
 .I ~/.guile
-is a guile script that is executed before any other processing occurs.
+A Guile script that is executed before any other processing occurs.
-For example, the following .guile activates guile's readline
+For example, the following
-interface:
+.I .guile
+activates guile's readline interface:
 
-.RS 4
+.RS 9
-(use-modules (ice-9 readline))
+.B (use-modules (ice-9 readline))
 .RS 0
-(activate-readline)
+.B (activate-readline)
-
+.
 .SH "SEE ALSO"
-The full documentation for guile is maintained as a Texinfo manual.  If
+The full documentation for Guile is maintained as a Texinfo manual.
-the info and guile programs are properly installed at your site, the
+If the
-command
+.B info
+and
+.B guile
+programs are properly installed at your site,
+the command
 .IP
 .B info guile
 .PP
@@ -117,39 +214,45 @@ should give you access to the complete manual.
 
 http://www.schemers.org provides a general introduction to the
 Scheme language.
-
+.
 .SH "REPORTING BUGS"
-There is a mailing list, bug-guile@gnu.org, for reporting Guile bugs and
+There is a mailing list,
-fixes.  But before reporting something as a bug, please try to be sure
+bug-guile@gnu.org,
-that it really is a bug, not a misunderstanding or a deliberate feature.
+for reporting Guile bugs and fixes.
+But before reporting something as a bug,
+please try to be sure that it really is a bug,
+not a misunderstanding or a deliberate feature.
 We ask you to read the section ``Reporting Bugs'' in the Guile reference
-manual (or Info system) for hints on how and when to report bugs.  Also,
+manual (or Info system) for hints on how and when to report bugs.
-include the version number of the Guile you are running in every bug
+Also, include the version number of the Guile you are running in every bug
-report that you send in.  Bugs tend actually to be fixed if they can be
+report that you send in.
-isolated, so it is in your interest to report them in such a way that
+Bugs tend actually to get fixed if they can be isolated,
-they can be easily reproduced.
+so it is in your interest to report them in such a way that they can be
-
+easily reproduced.
+.
 .SH COPYING
-Copyright (C) 2010 Free Software Foundation, Inc.
+Copyright (C) 2010, 2011 Free Software Foundation, Inc.
 
 Permission is granted to make and distribute verbatim copies of this
 document provided the copyright notice and this permission notice are
 preserved on all copies.
 
 Permission is granted to copy and distribute modified versions of this
-document under the conditions for verbatim copying, provided that the
+document under the conditions for verbatim copying,
-entire resulting derived work is distributed under the terms of a
+provided that the entire resulting derived work is distributed under the
-permission notice identical to this one.
+terms of a permission notice identical to this one.
 
 Permission is granted to copy and distribute translations of this
-document into another language, under the above conditions for modified
+document into another language,
-versions, except that this permission notice may be stated in a
+under the above conditions for modified versions,
+except that this permission notice may be stated in a
 translation approved by the Free Software Foundation.
-
+.
 .SH AUTHORS
-Robert Merkel <rgmerk@mira.net> wrote this manpage.  
+Robert Merkel <rgmerk@mira.net> wrote this manpage.
 Rob Browning <rlb@cs.utexas.edu> has added to it.
 
-.B guile 
+.B guile
-is GNU software.  Guile is originally based on Aubrey Jaffer's
+is GNU software.
-SCM interpreter, and is the work of many individuals.
+Guile is originally based on Aubrey Jaffer's SCM interpreter,
+and is the work of many individuals.

doc/ref/Makefile.am

@@ -111,8 +111,6 @@ noinst_DATA = $(PICTURES)
 
 EXTRA_DIST = ChangeLog-2008 $(PICTURES)
 
-include $(top_srcdir)/am/pre-inst-guile
-
 # Automated snarfing
 
 autoconf.texi: autoconf-macros.texi
@@ -129,7 +127,8 @@ snarf_doc = standard-library
 $(snarf_doc).am: $(snarf_doc).scm
 	GUILE_AUTO_COMPILE=0 ;							\
 	variable="`echo $(snarf_doc) | tr - _`_scm_files" ;			\
-	"$(preinstguile)" -l "$(srcdir)/$(snarf_doc).scm" -c "			\
+	"$(top_builddir_absolute)/meta/guile" -l "$(srcdir)/$(snarf_doc).scm"   \
+	 -c "			 						\
 	 (format #t \"# Automatically generated, do not edit.~%\")		\
 	 (format #t \"$$variable = \")						\
 	 (for-each (lambda (m)							\
@@ -143,7 +142,7 @@ include standard-library.am
 
 $(snarf_doc).texi: $(standard_library_scm_files)
 	GUILE_AUTO_COMPILE=0				\
-	"$(preinstguile)" "$(srcdir)/make-texinfo.scm"	\
+	"$(top_builddir_absolute)/meta/guile" "$(srcdir)/make-texinfo.scm"	\
 	  "$(abs_srcdir)/$(snarf_doc).scm" > "$@.tmp"
 	mv "$@.tmp" "$@"
 

doc/ref/api-data.texi

@@ -959,6 +959,18 @@ Return @var{n} raised to the integer exponent
 @end lisp
 @end deffn
 
+@deftypefn {Scheme Procedure} {} exact-integer-sqrt @var{k}
+@deftypefnx {C Function} void scm_exact_integer_sqrt (SCM @var{k}, SCM *@var{s}, SCM *@var{r})
+Return two exact non-negative integers @var{s} and @var{r}
+such that @math{@var{k} = @var{s}^2 + @var{r}} and
+@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.
+An error is raised if @var{k} is not an exact non-negative integer.
+
+@lisp
+(exact-integer-sqrt 10) @result{} 3 and 1
+@end lisp
+@end deftypefn
+
 @node Comparison
 @subsubsection Comparison Predicates
 @rnindex zero?
@@ -1308,7 +1320,7 @@ both @var{q} and @var{r}, and is more efficient than computing each
 separately.  Note that @var{r}, if non-zero, will have the same sign
 as @var{y}.
 
-When @var{x} and @var{y} are exact integers, @code{floor-remainder} is
+When @var{x} and @var{y} are integers, @code{floor-remainder} is
 equivalent to the R5RS integer-only operator @code{modulo}.
 
 @lisp
@@ -1365,7 +1377,7 @@ both @var{q} and @var{r}, and is more efficient than computing each
 separately.  Note that @var{r}, if non-zero, will have the same sign
 as @var{x}.
 
-When @var{x} and @var{y} are exact integers, these operators are
+When @var{x} and @var{y} are integers, these operators are
 equivalent to the R5RS integer-only operators @code{quotient} and
 @code{remainder}.
 
@@ -4171,8 +4183,7 @@ using @code{scm_dynwind_free} inside an appropriate dynwind context,
 @deftypefn  {C Function} SCM scm_from_locale_string (const char *str)
 @deftypefnx {C Function} SCM scm_from_locale_stringn (const char *str, size_t len)
 Creates a new Scheme string that has the same contents as @var{str} when
-interpreted in the locale character encoding of the
+interpreted in the character encoding of the current locale.
-@code{current-input-port}.
 
 For @code{scm_from_locale_string}, @var{str} must be null-terminated.
 
@@ -4201,9 +4212,9 @@ can then use @var{str} directly as its internal representation.
 
 @deftypefn  {C Function} {char *} scm_to_locale_string (SCM str)
 @deftypefnx {C Function} {char *} scm_to_locale_stringn (SCM str, size_t *lenp)
-Returns a C string with the same contents as @var{str} in the locale
+Returns a C string with the same contents as @var{str} in the character
-encoding of the @code{current-output-port}.  The C string must be freed
+encoding of the current locale.  The C string must be freed with
-with @code{free} eventually, maybe by using @code{scm_dynwind_free},
+@code{free} eventually, maybe by using @code{scm_dynwind_free},
 @xref{Dynamic Wind}.
 
 For @code{scm_to_locale_string}, the returned string is
@@ -4217,13 +4228,14 @@ returned string will not be null-terminated in this case.  If
 @var{lenp} is @code{NULL}, @code{scm_to_locale_stringn} behaves like
 @code{scm_to_locale_string}.
 
-If a character in @var{str} cannot be represented in the locale encoding
+If a character in @var{str} cannot be represented in the character
-of the current output port, the port conversion strategy of the current
+encoding of the current locale, the default port conversion strategy is
-output port will determine the result, @xref{Ports}.  If output port's
+used.  @xref{Ports}, for more on conversion strategies.
-conversion strategy is @code{error}, an error will be raised.  If it is
+
-@code{substitute}, a replacement character, such as a question mark, will
+If the conversion strategy is @code{error}, an error will be raised.  If
-be inserted in its place.  If it is @code{escape}, a hex escape will be
+it is @code{substitute}, a replacement character, such as a question
-inserted in its place.
+mark, will be inserted in its place.  If it is @code{escape}, a hex
+escape will be inserted in its place.
 @end deftypefn
 
 @deftypefn {C Function} size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)

doc/ref/api-evaluation.texi

@@ -426,7 +426,9 @@ Modify the print options.
 @node Fly Evaluation
 @subsection Procedures for On the Fly Evaluation
 
-@xref{Environments}.
+Scheme has the lovely property that its expressions may be represented
+as data.  The @code{eval} procedure takes a Scheme datum and evaluates
+it as code.
 
 @rnindex eval
 @c ARGFIXME environment/environment specifier
@@ -451,19 +453,46 @@ return the environment in which the implementation would
 evaluate expressions dynamically typed by the user.
 @end deffn
 
-@deffn {Scheme Procedure} eval-string string [module]
+@xref{Environments}, for other environments.
-@deffnx {C Function} scm_eval_string (string)
+
+One does not always receive code as Scheme data, of course, and this is
+especially the case for Guile's other language implementations
+(@pxref{Other Languages}).  For the case in which all you have is a
+string, we have @code{eval-string}.  There is a legacy version of this
+procedure in the default environment, but you really want the one from
+@code{(ice-9 eval-string)}, so load it up:
+
+@example
+(use-modules (ice-9 eval-string))
+@end example
+
+@deffn {Scheme Procedure} eval-string string [module=#f] [file=#f] [line=#f] [column=#f] [lang=(current-language)] [compile?=#f]
+Parse @var{string} according to the current language, normally Scheme.
+Evaluate or compile the expressions it contains, in order, returning the
+last expression.
+
+If the @var{module} keyword argument is set, save a module excursion
+(@pxref{Module System Reflection}) and set the current module to
+@var{module} before evaluation.
+
+The @var{file}, @var{line}, and @var{column} keyword arguments can be
+used to indicate that the source string begins at a particular source
+location.
+
+Finally, @var{lang} is a language, defaulting to the current language,
+and the expression is compiled if @var{compile?} is true or there is no
+evaluator for the given language.
+@end deffn
+
+@deffn {C Function} scm_eval_string (string)
 @deffnx {C Function} scm_eval_string_in_module (string, module)
-Evaluate @var{string} as the text representation of a Scheme form or
+These C bindings call @code{eval-string} from @code{(ice-9
-forms, and return whatever value they produce.  Evaluation takes place
+eval-string)}, evaluating within @var{module} or the current module.
-in the given module, or in the current module when no module is given.
-While the code is evaluated, the given module is made the current one.
-The current module is restored when this procedure returns.
 @end deffn
 
 @deftypefn {C Function} SCM scm_c_eval_string (const char *string)
-@code{scm_eval_string}, but taking a C string instead of an
+@code{scm_eval_string}, but taking a C string in locale encoding instead
-@code{SCM}.
+of an @code{SCM}.
 @end deftypefn
 
 @deffn {Scheme Procedure} apply proc arg1 @dots{} argN arglst
@@ -493,9 +522,17 @@ then there's no @var{arg1}@dots{}@var{argN} and @var{arg} is the
 @deffnx {C Function} scm_call_2 (proc, arg1, arg2)
 @deffnx {C Function} scm_call_3 (proc, arg1, arg2, arg3)
 @deffnx {C Function} scm_call_4 (proc, arg1, arg2, arg3, arg4)
+@deffnx {C Function} scm_call_5 (proc, arg1, arg2, arg3, arg4, arg5)
+@deffnx {C Function} scm_call_6 (proc, arg1, arg2, arg3, arg4, arg5, arg6)
 Call @var{proc} with the given arguments.
 @end deffn
 
+@deffn {C Function} scm_call_n (proc, argv, nargs)
+Call @var{proc} with the array of arguments @var{argv}, as a
+@code{SCM*}.  The length of the arguments should be passed in
+@var{nargs}, as a @code{size_t}.
+@end deffn
+
 @deffn {Scheme Procedure} apply:nconc2last lst
 @deffnx {C Function} scm_nconc2last (lst)
 @var{lst} should be a list (@var{arg1} @dots{} @var{argN}

doc/ref/api-foreign.texi

@@ -79,6 +79,12 @@ Normally, @var{library} is just the name of some shared library file
 that will be searched for in the places where shared libraries usually
 reside, such as in @file{/usr/lib} and @file{/usr/local/lib}.
 
+@var{library} should not contain an extension such as @code{.so}.  The
+correct file name extension for the host operating system is provided
+automatically, according to libltdl's rules (@pxref{Libltdl interface,
+lt_dlopenext, @code{lt_dlopenext}, libtool, Shared Library Support for
+GNU}).
+
 When @var{library} is omitted, a @dfn{global symbol handle} is returned.  This
 handle provides access to the symbols available to the program at run-time,
 including those exported by the program itself and the shared libraries already
@@ -196,12 +202,13 @@ In that case, you would statically link your program with the desired
 library, and register its init function right after Guile has been
 initialized.
 
-LIB should be a string denoting a shared library without any file type
+As for @code{dynamic-link}, @var{lib} should not contain any suffix such
-suffix such as ".so".  The suffix is provided automatically.  It
+as @code{.so} (@pxref{Foreign Libraries, dynamic-link}).  It
 should also not contain any directory components.  Libraries that
 implement Guile Extensions should be put into the normal locations for
 shared libraries.  We recommend to use the naming convention
-libguile-bla-blum for a extension related to a module `(bla blum)'.
+@file{libguile-bla-blum} for a extension related to a module @code{(bla
+blum)}.
 
 The normal way for a extension to be used is to write a small Scheme
 file that defines a module, and to load the extension into this
@@ -360,8 +367,8 @@ When loaded with @code{(use-modules (foo bar))}, the
 @code{load-extension} call looks for the @file{foobar-c-code.so} (etc)
 object file in Guile's @code{extensiondir}, which is usually a
 subdirectory of the @code{libdir}. For example, if your libdir is
-@file{/usr/lib}, the @code{extensiondir} for the Guile 2.0.@var{x}
+@file{/usr/lib}, the @code{extensiondir} for the Guile @value{EFFECTIVE-VERSION}.@var{x}
-series will be @file{/usr/lib/guile/2.0/}.
+series will be @file{/usr/lib/guile/@value{EFFECTIVE-VERSION}/}.
 
 The extension path includes the major and minor version of Guile (the
 ``effective version''), because Guile guarantees compatibility within a
@@ -399,7 +406,7 @@ with the following in a @file{Makefile}, using @command{sed}
 
 @example
 foo.scm: foo.scm.in
-        sed 's|XXextensiondirXX|$(libdir)/guile/2.0|' <foo.scm.in >foo.scm
+        sed 's|XXextensiondirXX|$(libdir)/guile/@value{EFFECTIVE-VERSION}|' <foo.scm.in >foo.scm
 @end example
 
 The actual pattern @code{XXextensiondirXX} is arbitrary, it's only something
@@ -561,6 +568,20 @@ A foreign pointer whose value is 0.
 Return @code{#t} if @var{pointer} is the null pointer, @code{#f} otherwise.
 @end deffn
 
+For the purpose of passing SCM values directly to foreign functions, and
+allowing them to return SCM values, Guile also supports some unsafe
+casting operators.
+
+@deffn {Scheme Procedure} scm->pointer scm
+Return a foreign pointer object with the @code{object-address}
+of @var{scm}.
+@end deffn
+
+@deffn {Scheme Procedure} pointer->scm pointer
+Unsafely cast @var{pointer} to a Scheme object.
+Cross your fingers!
+@end deffn
+
 
 @node Void Pointers and Byte Access
 @subsubsection Void Pointers and Byte Access
@@ -605,20 +626,22 @@ Assuming @var{pointer} points to a memory region that holds a pointer,
 return this pointer.
 @end deffn
 
-@deffn {Scheme Procedure} string->pointer string
+@deffn {Scheme Procedure} string->pointer string [encoding]
 Return a foreign pointer to a nul-terminated copy of @var{string} in the
-current locale encoding.  The C string is freed when the returned
+given @var{encoding}, defaulting to the current locale encoding.  The C
-foreign pointer becomes unreachable.
+string is freed when the returned foreign pointer becomes unreachable.
 
-This is the Scheme equivalent of @code{scm_to_locale_string}.
+This is the Scheme equivalent of @code{scm_to_stringn}.
 @end deffn
 
-@deffn {Scheme Procedure} pointer->string pointer
+@deffn {Scheme Procedure} pointer->string pointer [length] [encoding]
-Return the string representing the C nul-terminated string
+Return the string representing the C string pointed to by @var{pointer}.
-pointed to by @var{pointer}.  The C string is assumed to be
+If @var{length} is omitted or @code{-1}, the string is assumed to be
-in the current locale encoding.
+nul-terminated.  Otherwise @var{length} is the number of bytes in memory
+pointed to by @var{pointer}.  The C string is assumed to be in the given
+@var{encoding}, defaulting to the current locale encoding.
 
-This is the Scheme equivalent of @code{scm_from_locale_string}.
+This is the Scheme equivalent of @code{scm_from_stringn}.
 @end deffn
 
 @cindex wrapped pointer types

doc/ref/api-io.texi

@@ -949,9 +949,8 @@ used only during port creation are not retained.
 
 @deffn {Scheme Procedure} port-filename port
 @deffnx {C Function} scm_port_filename (port)
-Return the filename associated with @var{port}.  This function returns
+Return the filename associated with @var{port}, or @code{#f} if no
-the strings "standard input", "standard output" and "standard error"
+filename is associated with the port.
-when called on the current input, output and error ports respectively.
 
 @var{port} must be open, @code{port-filename} cannot be used once the
 port is closed.
@@ -1156,8 +1155,7 @@ string I/O, that complement or refine Guile's historical port API
 presented above (@pxref{Input and Output}).
 
 @c FIXME: Update description when implemented.
-@emph{Note}: The implementation of this R6RS API is currently far from
+@emph{Note}: The implementation of this R6RS API is not complete yet.
-complete, notably due to the lack of support for Unicode I/O and strings.
 
 @menu
 * R6RS End-of-File::            The end-of-file object.

doc/ref/api-modules.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, 2009, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, 2009, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -935,6 +935,62 @@ value of @code{scm_c_call_with_current_module} is the return value of
 @var{func}.
 @end deftypefn
 
+@deftypefn SCM scm_public_variable (SCM @var{module_name}, SCM @var{name})
+@deftypefnx SCM scm_c_public_variable (const char * @var{module_name}, const char * @var{name})
+Find a the variable bound to the symbol @var{name} in the public
+interface of the module named @var{module_name}.
+
+ @var{module_name} should be a list of symbols, when represented as a
+Scheme object, or a space-separated string, in the @code{const char *}
+case.  See @code{scm_c_define_module} below, for more examples.
+
+Signals an error if no module was found with the given name.  If
+@var{name} is not bound in the module, just returns @code{#f}.
+@end deftypefn
+
+@deftypefn SCM scm_private_variable (SCM @var{module_name}, SCM @var{name})
+@deftypefnx SCM scm_c_private_variable (const char * @var{module_name}, const char * @var{name})
+Like @code{scm_public_variable}, but looks in the internals of the
+module named @var{module_name} instead of the public interface.
+Logically, these procedures should only be called on modules you write.
+@end deftypefn
+
+@deftypefn SCM scm_public_lookup (SCM @var{module_name}, SCM @var{name})
+@deftypefnx SCM scm_c_public_lookup (const char * @var{module_name}, const char * @var{name})
+@deftypefnx SCM scm_private_lookup (SCM @var{module_name}, SCM @var{name})
+@deftypefnx SCM scm_c_private_lookup (const char * @var{module_name}, const char * @var{name})
+Like @code{scm_public_variable} or @code{scm_private_variable}, but if
+the @var{name} is not bound in the module, signals an error.  Returns a
+variable, always.
+
+@example
+SCM my_eval_string (SCM str)
+@{
+  static SCM eval_string_var = SCM_BOOL_F;
+
+  if (scm_is_false (eval_string_var))
+    eval_string_var =
+      scm_c_public_lookup ("ice-9 eval-string", "eval-string");
+
+  return scm_call_1 (scm_variable_ref (eval_string_var), str);
+@}
+@end example
+@end deftypefn
+
+@deftypefn SCM scm_public_ref (SCM @var{module_name}, SCM @var{name})
+@deftypefnx SCM scm_c_public_ref (const char * @var{module_name}, const char * @var{name})
+@deftypefnx SCM scm_private_ref (SCM @var{module_name}, SCM @var{name})
+@deftypefnx SCM scm_c_private_ref (const char * @var{module_name}, const char * @var{name})
+Like @code{scm_public_lookup} or @code{scm_private_lookup}, but
+additionally dereferences the variable.  If the variable object is
+unbound, signals an error.  Returns the value bound to @var{name} in
+@var{module}.
+@end deftypefn
+
+In addition, there are a number of other lookup-related procedures.  We
+suggest that you use the @code{scm_public_} and @code{scm_private_}
+family of procedures instead, if possible.
+
 @deftypefn {C Procedure} SCM scm_c_lookup (const char *@var{name})
 Return the variable bound to the symbol indicated by @var{name} in the
 current module.  If there is no such binding or the symbol is not
@@ -951,6 +1007,13 @@ Like @code{scm_c_lookup} and @code{scm_lookup}, but the specified
 module is used instead of the current one.
 @end deftypefn
 
+@deftypefn {C Procedure} SCM scm_module_variable (SCM @var{module}, SCM @var{name})
+Like @code{scm_module_lookup}, but if the binding does not exist, just
+returns @code{#f} instead of raising an error.
+@end deftypefn
+
+To define a value, use @code{scm_define}:
+
 @deftypefn {C Procedure} SCM scm_c_define (const char *@var{name}, SCM @var{val})
 Bind the symbol indicated by @var{name} to a variable in the current
 module and set that variable to @var{val}.  When @var{name} is already

doc/ref/api-options.texi

@@ -171,13 +171,14 @@ guileversion, libguileinterface, buildstamp
 @end table
 
 Values are all strings.  The value for @code{LIBS} is typically found
-also as a part of "guile-config link" output.  The value for
+also as a part of @code{pkg-config --libs
+guile-@value{EFFECTIVE-VERSION}} output.  The value for
 @code{guileversion} has form X.Y.Z, and should be the same as returned
-by @code{(version)}.  The value for @code{libguileinterface} is
+by @code{(version)}.  The value for @code{libguileinterface} is libtool
-libtool compatible and has form CURRENT:REVISION:AGE
+compatible and has form CURRENT:REVISION:AGE (@pxref{Versioning,,
-(@pxref{Versioning,, Library interface versions, libtool, GNU
+Library interface versions, libtool, GNU Libtool}).  The value for
-Libtool}).  The value for @code{buildstamp} is the output of the
+@code{buildstamp} is the output of the command @samp{date -u +'%Y-%m-%d
-command @samp{date -u +'%Y-%m-%d %T'} (UTC).
+%T'} (UTC).
 
 In the source, @code{%guile-build-info} is initialized from
 libguile/libpath.h, which is completely generated, so deleting this file

doc/ref/api-procedures.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -16,6 +16,7 @@
 * Higher-Order Functions::      Function that take or return functions.
 * Procedure Properties::        Procedure properties and meta-information.
 * Procedures with Setters::     Procedures with setters.
+* Inlinable Procedures::        Procedures that can be inlined.
 @end menu
 
 
@@ -797,6 +798,32 @@ Return the setter of @var{proc}, which must be either a procedure with
 setter or an operator struct.
 @end deffn
 
+@node Inlinable Procedures
+@subsection Inlinable Procedures
+
+You can define an @dfn{inlinable procedure} by using
+@code{define-inlinable} instead of @code{define}.  An inlinable
+procedure behaves the same as a regular procedure, but direct calls will
+result in the procedure body being inlined into the caller.
+
+Procedures defined with @code{define-inlinable} are @emph{always}
+inlined, at all direct call sites.  This eliminates function call
+overhead at the expense of an increase in code size.  Additionally, the
+caller will not transparently use the new definition if the inline
+procedure is redefined.  It is not possible to trace an inlined
+procedures or install a breakpoint in it (@pxref{Traps}).  For these
+reasons, you should not make a procedure inlinable unless it
+demonstrably improves performance in a crucial way.
+
+In general, only small procedures should be considered for inlining, as
+making large procedures inlinable will probably result in an increase in
+code size.  Additionally, the elimination of the call overhead rarely
+matters for for large procedures.
+
+@deffn {Scheme Syntax} define-inlinable (name parameter ...) body ...
+Define @var{name} as a procedure with parameters @var{parameter}s and
+body @var{body}.
+@end deffn
 
 @c Local Variables:
 @c TeX-master: "guile.texi"

doc/ref/autoconf.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -97,25 +97,25 @@ to instantiate macros at top-level.
 
 We now include two examples, one simple and one complicated.
 
-The first example is for a package that uses libguile, and thus needs to know
+The first example is for a package that uses libguile, and thus needs to
-how to compile and link against it.  So we use @code{GUILE_FLAGS} to set the
+know how to compile and link against it.  So we use
-vars @code{GUILE_CFLAGS} and @code{GUILE_LDFLAGS}, which are automatically
+@code{PKG_CHECK_MODULES} to set the vars @code{GUILE_CFLAGS} and
-substituted in the Makefile.
+@code{GUILE_LIBS}, which are automatically substituted in the Makefile.
 
 @example
 In configure.ac:
 
-  GUILE_FLAGS
+  PKG_CHECK_MODULES([GUILE], [guile-@value{EFFECTIVE-VERSION}])
 
 In Makefile.in:
 
   GUILE_CFLAGS  = @@GUILE_CFLAGS@@
-  GUILE_LDFLAGS = @@GUILE_LDFLAGS@@
+  GUILE_LIBS = @@GUILE_LIBS@@
 
   myprog.o: myprog.c
           $(CC) -o $@ $(GUILE_CFLAGS) $<
   myprog: myprog.o
-          $(CC) -o $@ $< $(GUILE_LDFLAGS)
+          $(CC) -o $@ $< $(GUILE_LIBS)
 @end example
 
 The second example is for a package of Guile Scheme modules that uses an

doc/ref/history.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  2008, 2010
+@c Copyright (C)  2008, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -214,15 +214,15 @@ user-space threading was removed in favor of POSIX pre-emptive
 threads, providing true multiprocessing. Gettext support was added,
 and Guile's C API was cleaned up and orthogonalized in a massive way.
 
-@item 2.0 --- April 2010
+@item 2.0 --- 16 February 2010
 A virtual machine was added to Guile, along with the associated compiler
 and toolchain. Support for internationalization was finally
 reimplemented, in terms of unicode, locales, and libunistring. Running
 Guile instances became controllable and debuggable from within Emacs,
-via GDS and Geiser. Guile caught up to features found in a number of
+via Geiser. Guile caught up to features found in a number of other
-other Schemes: SRFI-18 threads, including thread cancellation,
+Schemes: SRFI-18 threads, module-hygienic macros, a profiler, tracer,
-module-hygienic macros, a profiler, tracer, and debugger, SSAX XML
+and debugger, SSAX XML integration, bytevectors, a dynamic FFI,
-integration, bytevectors, module versions, and partial support for R6RS.
+delimited continuations, module versions, and partial support for R6RS.
 @end table
 
 @node Status

doc/ref/libguile-extensions.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -64,7 +64,7 @@ Consider the following file @file{bessel.c}.
 SCM
 j0_wrapper (SCM x)
 @{
-  return scm_make_real (j0 (scm_num2dbl (x, "j0")));
+  return scm_from_double (j0 (scm_to_double (x)));
 @}
 
 void
@@ -78,7 +78,8 @@ This C source file needs to be compiled into a shared library.  Here is
 how to do it on GNU/Linux:
 
 @smallexample
-gcc -shared -o libguile-bessel.so -fPIC bessel.c
+gcc `pkg-config --cflags guile-@value{EFFECTIVE-VERSION}` \
+  -shared -o libguile-bessel.so -fPIC bessel.c
 @end smallexample
 
 For creating shared libraries portably, we recommend the use of GNU

doc/ref/libguile-linking.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -16,16 +16,24 @@ head of any C source file that uses identifiers described in this
 manual.  Once you've compiled your source files, you need to link them
 against the Guile object code library, @code{libguile}.
 
-On most systems, you should not need to tell the compiler and linker
+@code{<libguile.h>} is not in the default search path for headers,
-explicitly where they can find @file{libguile.h} and @file{libguile}.
+because Guile supports parallel installation of multiple versions of
-When Guile has been installed in a peculiar way, or when you are on a
+Guile, with each version's headers under their own directories.  This is
-peculiar system, things might not be so easy and you might need to pass
+to allow development against, say, both Guile 2.0 and 2.2.
-additional @code{-I} or @code{-L} options to the compiler.  Guile
+
-provides the utility program @code{guile-config} to help you find the
+To compile code that includes @code{<libguile.h>}, or links to
-right values for these options.  You would typically run
+@code{libguile}, you need to select the effective version you are
-@code{guile-config} during the configuration phase of your program and
+interested in, and then ask @code{pkg-config} for the compilation flags
+or linking instructions.  For effective version
+@value{EFFECTIVE-VERSION}, for example, you would invoke
+@code{pkg-config --cflags --libs guile-@value{EFFECTIVE-VERSION}} to get
+the compilation and linking flags necessary to link to version
+@value{EFFECTIVE-VERSION} of Guile.  You would typically run
+@code{pkg-config} during the configuration phase of your program and
 use the obtained information in the Makefile.
 
+See the @code{pkg-config} man page, for more information.
+
 @menu
 * Guile Initialization Functions::  What to call first.
 * A Sample Guile Main Program::  Sources and makefiles.
@@ -98,17 +106,17 @@ ready, it invokes @code{inner_main}, which calls @code{scm_shell} to
 process the command-line arguments in the usual way.
 
 Here is a Makefile which you can use to compile the above program.  It
-uses @code{guile-config} to learn about the necessary compiler and
+uses @code{pkg-config} to learn about the necessary compiler and
 linker flags.
 @example
 # Use GCC, if you have it installed.
 CC=gcc
 
 # Tell the C compiler where to find <libguile.h>
-CFLAGS=`guile-config compile`
+CFLAGS=`pkg-config --cflags guile-@value{EFFECTIVE-VERSION}`
 
 # Tell the linker what libraries to use and where to find them.
-LIBS=`guile-config link`
+LIBS=`pkg-config --libs guile-@value{EFFECTIVE-VERSION}`
 
 simple-guile: simple-guile.o
         $@{CC@} simple-guile.o $@{LIBS@} -o simple-guile
@@ -120,13 +128,11 @@ simple-guile.o: simple-guile.c
 If you are using the GNU Autoconf package to make your application more
 portable, Autoconf will settle many of the details in the Makefile above
 automatically, making it much simpler and more portable; we recommend
-using Autoconf with Guile.  Guile also provides the @code{GUILE_FLAGS}
+using Autoconf with Guile.  Here is a @file{configure.ac} file for
-macro for autoconf that performs all necessary checks.  Here is a
+@code{simple-guile} that uses the standard @code{PKG_CHECK_MODULES}
-@file{configure.in} file for @code{simple-guile} that uses this macro.
+macro to check for Guile.  Autoconf will process this file into a
-Autoconf can use this file as a template to generate a @code{configure}
+@code{configure} script.  We recommend invoking Autoconf via the
-script.  In order for Autoconf to find the @code{GUILE_FLAGS} macro, you
+@code{autoreconf} utility.
-will need to run @code{aclocal} first (@pxref{Invoking aclocal,,,
-automake, GNU Automake}).
 
 @example
 AC_INIT(simple-guile.c)
@@ -135,19 +141,21 @@ AC_INIT(simple-guile.c)
 AC_PROG_CC
 
 # Check for Guile
-GUILE_FLAGS
+PKG_CHECK_MODULES([GUILE], [guile-@value{EFFECTIVE-VERSION}])
 
 # Generate a Makefile, based on the results.
 AC_OUTPUT(Makefile)
 @end example
 
+Run @code{autoreconf -vif} to generate @code{configure}.
+
 Here is a @code{Makefile.in} template, from which the @code{configure}
 script produces a Makefile customized for the host system:
 @example
 # The configure script fills in these values.
 CC=@@CC@@
 CFLAGS=@@GUILE_CFLAGS@@
-LIBS=@@GUILE_LDFLAGS@@
+LIBS=@@GUILE_LIBS@@
 
 simple-guile: simple-guile.o
         $@{CC@} simple-guile.o $@{LIBS@} -o simple-guile
@@ -156,23 +164,28 @@ simple-guile.o: simple-guile.c
 @end example
 
 The developer should use Autoconf to generate the @file{configure}
-script from the @file{configure.in} template, and distribute
+script from the @file{configure.ac} template, and distribute
 @file{configure} with the application.  Here's how a user might go about
 building the application:
 
 @example
 $ ls
-Makefile.in     configure*      configure.in    simple-guile.c
+Makefile.in     configure*      configure.ac    simple-guile.c
 $ ./configure
-creating cache ./config.cache
+checking for gcc... ccache gcc
-checking for gcc... (cached) gcc
+checking whether the C compiler works... yes
-checking whether the C compiler (gcc  ) works... yes
+checking for C compiler default output file name... a.out
-checking whether the C compiler (gcc  ) is a cross-compiler... no
+checking for suffix of executables... 
-checking whether we are using GNU C... (cached) yes
+checking whether we are cross compiling... no
-checking whether gcc accepts -g... (cached) yes
+checking for suffix of object files... o
-checking for Guile... yes
+checking whether we are using the GNU C compiler... yes
-creating ./config.status
+checking whether ccache gcc accepts -g... yes
-creating Makefile
+checking for ccache gcc option to accept ISO C89... none needed
+checking for pkg-config... /usr/bin/pkg-config
+checking pkg-config is at least version 0.9.0... yes
+checking for GUILE... yes
+configure: creating ./config.status
+config.status: creating Makefile
 $ make
 [...]
 $ ./simple-guile

doc/ref/libguile-smobs.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -686,9 +686,9 @@ Here is a sample build and interaction with the code from the
 
 @example
 zwingli:example-smob$ make CC=gcc
-gcc `guile-config compile`   -c image-type.c -o image-type.o
+gcc `pkg-config --cflags guile-@value{EFFECTIVE-VERSION}` -c image-type.c -o image-type.o
-gcc `guile-config compile`   -c myguile.c -o myguile.o
+gcc `pkg-config --cflags guile-@value{EFFECTIVE-VERSION}` -c myguile.c -o myguile.o
-gcc image-type.o myguile.o `guile-config link` -o myguile
+gcc image-type.o myguile.o `pkg-config --libs guile-@value{EFFECTIVE-VERSION}` -o myguile
 zwingli:example-smob$ ./myguile
 guile> make-image
 #<primitive-procedure make-image>

doc/ref/r6rs.texi

@@ -38,9 +38,11 @@ does not restore it.  This is a bug.
 
 @item
 R6RS unicode escapes within strings are disabled by default, because
-they conflict with Guile's already-existing escapes. R6RS behavior can
+they conflict with Guile's already-existing escapes. The same is the
-be turned on via a reader option. @xref{String Syntax}, for more
+case for R6RS treatment of escaped newlines in strings.
-information.
+
+R6RS behavior can be turned on via a reader option. @xref{String
+Syntax}, for more information.
 
 @item
 A @code{set!} to a variable transformer may only expand to an 
@@ -51,23 +53,8 @@ expression was in definition context.
 Instead of using the algorithm detailed in chapter 10 of the R6RS,
 expansion of toplevel forms happens sequentially.
 
-For example, while the expansion of the following set of recursive
+For example, while the expansion of the following set of toplevel
-nested definitions does do the correct thing:
+definitions does the correct thing:
-
-@example
-(let ()
-  (define even?
-    (lambda (x)
-      (or (= x 0) (odd? (- x 1)))))
-  (define-syntax odd?
-    (syntax-rules ()
-      ((odd? x) (not (even? x)))))
-  (even? 10))
-@result{} #t
-@end example
-
-@noindent
-The same definitions at the toplevel do not:
 
 @example
 (begin
@@ -78,6 +65,20 @@ The same definitions at the toplevel do not:
    (syntax-rules ()
      ((odd? x) (not (even? x)))))
  (even? 10))
+@result{} #t
+@end example
+
+@noindent
+The same definitions outside of the @code{begin} wrapper do not:
+
+@example
+(define even?
+  (lambda (x)
+    (or (= x 0) (odd? (- x 1)))))
+(define-syntax odd?
+  (syntax-rules ()
+    ((odd? x) (not (even? x)))))
+(even? 10)
 <unnamed port>:4:18: In procedure even?:
 <unnamed port>:4:18: Wrong type to apply: #<syntax-transformer odd?>
 @end example
@@ -86,10 +87,10 @@ This is because when expanding the right-hand-side of @code{even?}, the
 reference to @code{odd?} is not yet marked as a syntax transformer, so
 it is assumed to be a function.
 
-While it is likely that we can fix the case of toplevel forms nested in
+This bug will only affect top-level programs, not code in @code{library}
-a @code{begin} or a @code{library} form, a fix for toplevel programs
+forms.  Fixing it for toplevel forms seems doable, but tricky to
-seems trickier to implement in a backward-compatible way. Suggestions
+implement in a backward-compatible way. Suggestions and/or patches would
-and/or patches would be appreciated.
+be appreciated.
 
 @item
 The @code{(rnrs io ports)} module is mostly unimplemented. Work is
@@ -378,6 +379,7 @@ grouped below by the existing manual sections to which they correspond.
 @deffnx {Scheme Procedure} even? n
 @deffnx {Scheme Procedure} gcd x ...
 @deffnx {Scheme Procedure} lcm x ...
+@deffnx {Scheme Procedure} exact-integer-sqrt k
 @xref{Integer Operations}, for documentation.
 @end deffn
 
@@ -524,11 +526,6 @@ This is a consequence of the requirement that
 @end lisp
 @end deffn
 
-@deffn {Scheme Procedure} exact-integer-sqrt k
-This procedure returns two nonnegative integer objects @code{s} and 
-@code{r} such that k = s^2 + r and k < (s + 1)^2.
-@end deffn
-
 @deffn {Scheme Procedure} real-valued? obj
 @deffnx {Scheme Procedure} rational-valued? obj
 @deffnx {Scheme Procedure} integer-valued? obj

doc/ref/scheme-scripts.texi

@@ -196,6 +196,11 @@ interactive session.  When executing a script with @code{-s} or
 Do not use the debugging VM engine, even when entering an interactive
 session.
 
+@item -q
+Do not the local initialization file, @code{.guile}.  This option only
+has an effect when running interactively; running scripts does not load
+the @code{.guile} file.  @xref{Init File}.
+
 @item --listen[=@var{p}]
 While this program runs, listen on a local port or a path for REPL
 clients.  If @var{p} starts with a number, it is assumed to be a local

doc/ref/scheme-using.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2006, 2010
+@c Copyright (C) 2006, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -35,6 +35,7 @@ current language is @code{scheme}, and the current module is
 support for languages other than Scheme.
 
 @menu
+* Init File::
 * Readline::                    
 * Value History::              
 * REPL Commands::               
@@ -43,6 +44,22 @@ support for languages other than Scheme.
 @end menu
 
 
+@node Init File
+@subsection The Init File, @file{~/.guile}
+
+@cindex .guile
+When run interactively, Guile will load a local initialization file from
+@file{~/.guile}.  This file should contain Scheme expressions for
+evaluation.
+
+This facility lets the user customize their interactive Guile
+environment, pulling in extra modules or parameterizing the REPL
+implementation.
+
+To run Guile without loading the init file, use the @code{-q}
+command-line option.
+
+
 @node Readline
 @subsection Readline
 
@@ -58,10 +75,8 @@ scheme@@(guile-user)> (activate-readline)
 @end lisp
 
 It's a good idea to put these two lines (without the
-@code{scheme@@(guile-user)>} prompts) in your @file{.guile} file.  Guile
+@code{scheme@@(guile-user)>} prompts) in your @file{.guile} file.
-reads this file when it starts up interactively, so anything in this
+@xref{Init File}, for more on @file{.guile}.
-file has the same effect as if you type it in by hand at the
-@code{scheme@@(guile-user)>} prompt.
 
 
 @node Value History
@@ -337,6 +352,12 @@ Show the VM registers associated with the current frame.
 @xref{Stack Layout}, for more information on VM stack frames.
 @end deffn
 
+@deffn {REPL Command} width [cols]
+Sets the number of display columns in the output of @code{,backtrace}
+and @code{,locals} to @var{cols}.  If @var{cols} is not given, the width
+of the terminal is used.
+@end deffn
+
 The next 3 commands work at any REPL.
 
 @deffn {REPL Command} break proc
@@ -404,6 +425,35 @@ List/show/set options.
 Quit this session.
 @end deffn
 
+Current REPL options include:
+
+@table @code
+@item compile-options
+The options used when compiling expressions entered at the REPL.
+@xref{Compilation}, for more on compilation options.
+@item interp
+Whether to interpret or compile expressions given at the REPL, if such a
+choice is available.  Off by default (indicating compilation).
+@item prompt
+A customized REPL prompt.  @code{#f} by default, indicating the default
+prompt.
+@item value-history
+Whether value history is on or not.  @xref{Value History}.
+@item on-error
+What to do when an error happens.  By default, @code{debug}, meaning to
+enter the debugger.  Other values include @code{backtrace}, to show a
+backtrace without entering the debugger, or @code{report}, to simply
+show a short error printout.
+@end table
+
+Default values for REPL options may be set using
+@code{repl-default-option-set!} from @code{(system repl common)}:
+
+@deffn {Scheme Procedure} repl-set-default-option! key value
+Set the default value of a REPL option.  This function is particularly
+useful in a user's init file.  @xref{Init File}.
+@end deffn
+
 
 @node Error Handling
 @subsection Error Handling

doc/ref/srfi-modules.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -35,6 +35,7 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-17::                     Generalized set!
 * SRFI-18::                     Multithreading support
 * SRFI-19::                     Time/Date library.
+* SRFI-23::                     Error reporting
 * SRFI-26::                     Specializing parameters
 * SRFI-27::                     Sources of Random Bits
 * SRFI-30::                     Nested multi-line block comments
@@ -1927,6 +1928,13 @@ The functions created by @code{define-record-type} are ordinary
 top-level @code{define}s.  They can be redefined or @code{set!} as
 desired, exported from a module, etc.
 
+@unnumberedsubsubsec Non-toplevel Record Definitions
+
+The SRFI-9 specification explicitly disallows record definitions in a
+non-toplevel context, such as inside @code{lambda} body or inside a
+@var{let} block.  However, Guile's implementation does not enforce that
+restriction.
+
 @unnumberedsubsubsec Custom Printers
 
 You may use @code{set-record-type-printer!} to customize the default printing
@@ -3128,6 +3136,11 @@ Conversion is locale-dependent on systems that support it
 locale.
 @end defun
 
+@node SRFI-23
+@subsection SRFI-23 - Error Reporting
+@cindex SRFI-23
+
+The SRFI-23 @code{error} procedure is always available.
 
 @node SRFI-26
 @subsection SRFI-26 - specializing parameters

doc/ref/tools.texi

@@ -303,14 +303,11 @@ is rather byzantine, so for now @emph{NO} doc snarfing programs are installed.
 @cindex executable modules
 @cindex scripts
 
-When Guile is installed, in addition to the @code{(ice-9 FOO)} modules,
+When Guile is installed, in addition to the @code{(ice-9 FOO)} modules, a set
-a set of @dfn{executable modules} @code{(scripts BAR)} is also installed.
+of @dfn{guile-tools modules} @code{(scripts BAR)} is also installed.  Each is
-Each is a regular Scheme module that has some additional packaging so
+a regular Scheme module that has some additional packaging so that it can be
-that it can be called as a program in its own right, from the shell.  For this
+used by guile-tools, from the shell.  For this reason, we sometimes use the
-reason, we sometimes use the term @dfn{script} in this context to mean the
+term @dfn{script} in this context to mean the same thing.
-same thing.
-
-@c wow look at this hole^!  variable-width font users eat your heart out.
 
 As a convenience, the @code{guile-tools} wrapper program is installed along w/
 @code{guile}; it knows where a particular module is installed and calls it
@@ -346,16 +343,10 @@ executable module.  Feel free to skip to the next chapter.
 
 See template file @code{PROGRAM} for a quick start.
 
-Programs must follow the @dfn{executable module} convention, documented here:
+Programs must follow the @dfn{guile-tools} convention, documented here:
 
 @itemize
 
-@item
-The file name must not end in ".scm".
-
-@item
-The file must be executable (chmod +x).
-
 @item
 The module name must be "(scripts PROGRAM)".  A procedure named PROGRAM w/
 signature "(PROGRAM . args)" must be exported.  Basically, use some variant
@@ -377,20 +368,10 @@ There must be the alias:
 
 However, `main' must NOT be exported.
 
-@item
-The beginning of the file must use the following invocation sequence:
-
-@example
-#!/bin/sh
-main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
-exec $@{GUILE-guile@} -l $0 -c "(apply $main (cdr (command-line)))" "$@@"
-!#
-@end example
-
 @end itemize
 
 Following these conventions allows the program file to be used as module
-@code{(scripts PROGRAM)} in addition to as a standalone executable.  Please
+@code{(scripts PROGRAM)} in addition to being invoked by guile-tools.  Please
 also include a helpful Commentary section w/ some usage info.
 
 @c tools.texi ends here

doc/ref/tour.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010
+@c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -115,7 +115,7 @@ can be compiled and linked like this:
 
 @example
 $ gcc -o simple-guile simple-guile.c \
-    `pkg-config --cflags --libs guile-2.0`
+    `pkg-config --cflags --libs guile-@value{EFFECTIVE-VERSION}`
 @end example
 
 When it is run, it behaves just like the @code{guile} program except
@@ -163,7 +163,8 @@ This C source file needs to be compiled into a shared library.  Here is
 how to do it on GNU/Linux:
 
 @smallexample
-gcc -shared -o libguile-bessel.so -fPIC bessel.c
+gcc `pkg-config --cflags guile-@value{EFFECTIVE-VERSION}` \
+  -shared -o libguile-bessel.so -fPIC bessel.c
 @end smallexample
 
 For creating shared libraries portably, we recommend the use of GNU

doc/ref/vm.texi

@@ -1,6 +1,6 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
-@c Copyright (C)  2008, 2009, 2010, 2011
+@c Copyright (C)  2008,2009,2010
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
@@ -1063,7 +1063,7 @@ embedded in the stream as a string.
 @end deffn
 @deffn Instruction load-string length
 Load a string from the instruction stream. The string is assumed to be
-Latin-1-encoded.
+encoded in the ``latin1'' locale.
 @end deffn
 @deffn Instruction load-wide-string length
 Load a UTF-32 string from the instruction stream. @var{length} is the
@@ -1071,7 +1071,7 @@ length in bytes, not in codepoints.
 @end deffn
 @deffn Instruction load-symbol length
 Load a symbol from the instruction stream. The symbol is assumed to be
-Latin-1-encoded. Symbols backed by wide strings may
+encoded in the ``latin1'' locale. Symbols backed by wide strings may
 be loaded via @code{load-wide-string} then @code{make-symbol}.
 @end deffn
 @deffn Instruction load-array length

doc/ref/web.texi

@@ -59,8 +59,8 @@ valid dates.  Error handling for a number of basic cases, like invalid
 dates, occurs on the boundary in which we produce a SRFI 19 date record
 from other types, like strings.
 
-With regards to the web, data types are help in the two broad phases of
+With regards to the web, data types are helpful in the two broad phases
-HTTP messages: parsing and generation.
+of HTTP messages: parsing and generation.
 
 Consider a server, which has to parse a request, and produce a response.
 Guile will parse the request into an HTTP request object
@@ -339,7 +339,7 @@ For example:
 
 (string->header "FOO")
 @result{} foo
-(header->string 'foo
+(header->string 'foo)
 @result{} "Foo"
 @end example
 
@@ -387,12 +387,6 @@ leaving it as a string.  You could register this header with Guile's
 HTTP stack like this:
 
 @example
-(define (parse-ip str)
-  (inet-aton str)
-(define (validate-ip ip)
-(define (write-ip ip port)
-  (display (inet-ntoa ip) port))
-
 (declare-header! "X-Client-Address"
   (lambda (str)
     (inet-aton str))
@@ -1331,13 +1325,20 @@ If the read failed, the @code{read} hook may return #f for the client
 socket, request, and body.
 
 @item
-A user-provided handler procedure is called, with the request
+A user-provided handler procedure is called, with the request and body
-and body as its arguments.  The handler should return two
+as its arguments.  The handler should return two values: the response,
-values: the response, as a @code{<response>} record from @code{(web
+as a @code{<response>} record from @code{(web response)}, and the
-response)}, and the response body as a string, bytevector, or
+response body as bytevector, or @code{#f} if not present.
-@code{#f} if not present.  We also allow the response to be simply an
+
-alist of headers, in which case a default response object is
+The respose and response body are run through @code{sanitize-response},
-constructed with those headers.
+documented below.  This allows the handler writer to take some
+convenient shortcuts: for example, instead of a @code{<response>}, the
+handler can simply return an alist of headers, in which case a default
+response object is constructed with those headers.  Instead of a
+bytevector for the body, the handler can return a string, which will be
+serialized into an appropriate encoding; or it can return a procedure,
+which will be called on a port to write out the data.  See the
+@code{sanitize-response} documentation, for more.
 
 @item
 The @code{write} hook is called with three arguments: the client
@@ -1581,7 +1582,7 @@ probably know, we'll want to return a 404 response.
 (define (not-found request)
   (values (build-response #:code 404)
           (string-append "Resource not found: "
-                         (unparse-uri (request-uri request)))))
+                         (uri->string (request-uri request)))))
 
 ;; Now paste this to let the web server keep going:
 ,continue

gc-benchmarks/Makefile.am

@@ -0,0 +1,55 @@
+## Process this file with automake to produce Makefile.in.
+##
+##  	Copyright (C) 2011 Free Software Foundation, Inc.
+##
+##   This file is part of GUILE.
+##
+##   GUILE is free software; you can redistribute it and/or modify it
+##   under the terms of the GNU Lesser General Public License as
+##   published by the Free Software Foundation; either version 3, or
+##   (at your option) any later version.
+##
+##   GUILE is distributed in the hope that it will be useful, but
+##   WITHOUT ANY WARRANTY; without even the implied warranty of
+##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+##   GNU Lesser General Public License for more details.
+##
+##   You should have received a copy of the GNU Lesser General Public
+##   License along with GUILE; see the file COPYING.LESSER.  If not,
+##   write to the Free Software Foundation, Inc., 51 Franklin Street,
+##   Fifth Floor, Boston, MA 02110-1301 USA
+
+EXTRA_DIST =					\
+  gc-profile.scm				\
+  gcbench.scm					\
+  guile-test.scm				\
+  loop.scm					\
+  run-benchmark.scm				\
+  string.scm					\
+  $(benchmarks)
+
+# GPLv2+ Larceny GC benchmarks by Lars Hansen et al. from
+# <http://www.ccs.neu.edu/home/will/GC/sourcecode.html>.
+benchmarks =					\
+  larceny/GPL					\
+  larceny/README				\
+  larceny/dumb.sch				\
+  larceny/dummy.sch				\
+  larceny/dynamic-input-large.sch		\
+  larceny/dynamic-input-small.sch		\
+  larceny/dynamic.sch				\
+  larceny/earley.sch				\
+  larceny/gcbench.sch				\
+  larceny/gcold.scm				\
+  larceny/graphs.sch				\
+  larceny/lattice.sch				\
+  larceny/nboyer.sch				\
+  larceny/nucleic2.sch				\
+  larceny/perm.sch				\
+  larceny/run-benchmark.chez			\
+  larceny/sboyer.sch				\
+  larceny/softscheme.sch			\
+  larceny/twobit-input-long.sch			\
+  larceny/twobit-input-short.sch		\
+  larceny/twobit-smaller.sch			\
+  larceny/twobit.sch

gc-benchmarks/gc-profile.scm

@@ -3,7 +3,7 @@
 exec ${GUILE-guile} --no-debug -q -l "$0" \
                     -c '(apply main (cdr (command-line)))' "$@"
 !#
-;;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;; Copyright (C) 2008, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public License
@@ -38,13 +38,18 @@ memory mapping of process @var{pid}.  This information is obtained by reading
 @file{/proc/PID/smaps} on Linux.  See `procs(5)' for details."
 
   (define mapping-line-rx
+    ;; As of Linux 2.6.32.28, an `smaps' line looks like this:
+    ;; "00400000-00401000 r-xp 00000000 fe:00 108264 /home/ludo/soft/bin/guile"
     (make-regexp
-     "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [0-9]{2}:[0-9]{2} [0-9]+[[:blank:]]+(.*)$"))
+     "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [[:xdigit:]]{2}:[[:xdigit:]]{2} [0-9]+[[:blank:]]+(.*)$"))
 
   (define rss-line-rx
     (make-regexp
      "^Rss:[[:blank:]]+([[:digit:]]+) kB$"))
 
+  (if (not (string-contains %host-type "-linux-"))
+      (error "this procedure only works on Linux-based systems" %host-type))
+
   (with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid))
     (lambda ()
       (let loop ((line   (read-line))
@@ -83,7 +88,7 @@ memory mapping of process @var{pid}.  This information is obtained by reading
                    (loop (read-line) result))))))))
 
 (define (total-heap-size pid)
-  "Return the total heap size of process @var{pid}."
+  "Return a pair representing the total and RSS heap size of PID."
 
   (define heap-or-anon-rx
     (make-regexp "\\[(heap|anon)\\]"))

lib/Makefile.am

@@ -9,7 +9,7 @@
 # the same distribution terms as the rest of that program.
 #
 # Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl close connect duplocale environ extensions flock fpieee full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan lib-symbol-versions lib-symbol-visibility libunistring listen locale log1p maintainer-makefile malloc-gnu malloca nproc putenv recv recvfrom round send sendto setsockopt shutdown socket stat-time stdlib strcase strftime striconveh string sys_stat trunc verify version-etc-fsf vsnprintf warnings
+# Reproduce by: gnulib-tool --import --dir=. --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil close connect duplocale environ extensions flock floor fpieee frexp full-read full-write func gendocs getaddrinfo getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen locale log1p maintainer-makefile malloc-gnu malloca nproc putenv recv recvfrom send sendto setsockopt shutdown socket stat-time stdlib strcase strftime striconveh string sys_stat trunc verify version-etc-fsf vsnprintf warnings wchar
 
 AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
 
@@ -37,7 +37,9 @@ libgnu_la_DEPENDENCIES = $(gl_LTLIBOBJS)
 EXTRA_libgnu_la_SOURCES =
 libgnu_la_LDFLAGS = $(AM_LDFLAGS)
 libgnu_la_LDFLAGS += -no-undefined
+libgnu_la_LDFLAGS += $(CEIL_LIBM)
 libgnu_la_LDFLAGS += $(FLOOR_LIBM)
+libgnu_la_LDFLAGS += $(FREXP_LIBM)
 libgnu_la_LDFLAGS += $(GETADDRINFO_LIB)
 libgnu_la_LDFLAGS += $(HOSTENT_LIB)
 libgnu_la_LDFLAGS += $(INET_NTOP_LIB)
@@ -45,12 +47,12 @@ libgnu_la_LDFLAGS += $(INET_PTON_LIB)
 libgnu_la_LDFLAGS += $(ISNAND_LIBM)
 libgnu_la_LDFLAGS += $(ISNANF_LIBM)
 libgnu_la_LDFLAGS += $(ISNANL_LIBM)
+libgnu_la_LDFLAGS += $(LDEXP_LIBM)
 libgnu_la_LDFLAGS += $(LIBSOCKET)
 libgnu_la_LDFLAGS += $(LOG1P_LIBM)
 libgnu_la_LDFLAGS += $(LTLIBICONV)
 libgnu_la_LDFLAGS += $(LTLIBINTL)
 libgnu_la_LDFLAGS += $(LTLIBUNISTRING)
-libgnu_la_LDFLAGS += $(ROUND_LIBM)
 libgnu_la_LDFLAGS += $(SERVENT_LIB)
 libgnu_la_LDFLAGS += $(TRUNC_LIBM)
 
@@ -231,6 +233,15 @@ EXTRA_libgnu_la_SOURCES += canonicalize-lgpl.c
 
 ## end   gnulib module canonicalize-lgpl
 
+## begin gnulib module ceil
+
+
+EXTRA_DIST += ceil.c
+
+EXTRA_libgnu_la_SOURCES += ceil.c
+
+## end   gnulib module ceil
+
 ## begin gnulib module close
 
 
@@ -257,6 +268,13 @@ EXTRA_libgnu_la_SOURCES += connect.c
 
 ## end   gnulib module connect
 
+## begin gnulib module dosname
+
+
+EXTRA_DIST += dosname.h
+
+## end   gnulib module dosname
+
 ## begin gnulib module duplocale
 
 
@@ -343,6 +361,15 @@ EXTRA_libgnu_la_SOURCES += floor.c
 
 ## end   gnulib module floor
 
+## begin gnulib module frexp
+
+
+EXTRA_DIST += frexp.c
+
+EXTRA_libgnu_la_SOURCES += frexp.c
+
+## end   gnulib module frexp
+
 ## begin gnulib module full-read
 
 libgnu_la_SOURCES += full-read.h full-read.c
@@ -558,6 +585,15 @@ EXTRA_libgnu_la_SOURCES += isnan.c isnand.c
 
 ## end   gnulib module isnand
 
+## begin gnulib module isnand-nolibm
+
+
+EXTRA_DIST += float+.h isnan.c isnand-nolibm.h isnand.c
+
+EXTRA_libgnu_la_SOURCES += isnan.c isnand.c
+
+## end   gnulib module isnand-nolibm
+
 ## begin gnulib module isnanf
 
 
@@ -904,15 +940,6 @@ EXTRA_libgnu_la_SOURCES += recvfrom.c
 
 ## end   gnulib module recvfrom
 
-## begin gnulib module round
-
-
-EXTRA_DIST += round.c
-
-EXTRA_libgnu_la_SOURCES += round.c
-
-## end   gnulib module round
-
 ## begin gnulib module safe-read
 
 
@@ -1097,6 +1124,7 @@ stdint.h: stdint.in.h
 	      -e 's/@''HAVE_INTTYPES_H''@/$(HAVE_INTTYPES_H)/g' \
 	      -e 's/@''HAVE_SYS_INTTYPES_H''@/$(HAVE_SYS_INTTYPES_H)/g' \
 	      -e 's/@''HAVE_SYS_BITYPES_H''@/$(HAVE_SYS_BITYPES_H)/g' \
+	      -e 's/@''HAVE_WCHAR_H''@/$(HAVE_WCHAR_H)/g' \
 	      -e 's/@''HAVE_LONG_LONG_INT''@/$(HAVE_LONG_LONG_INT)/g' \
 	      -e 's/@''HAVE_UNSIGNED_LONG_LONG_INT''@/$(HAVE_UNSIGNED_LONG_LONG_INT)/g' \
 	      -e 's/@''APPLE_UNIVERSAL_BUILD''@/$(APPLE_UNIVERSAL_BUILD)/g' \
@@ -1229,9 +1257,7 @@ stdio.h: stdio.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
 	mv $@-t $@
 MOSTLYCLEANFILES += stdio.h stdio.h-t
 
-EXTRA_DIST += stdio-write.c stdio.in.h
+EXTRA_DIST += stdio.in.h
-
-EXTRA_libgnu_la_SOURCES += stdio-write.c
 
 ## end   gnulib module stdio
 
@@ -1256,6 +1282,7 @@ stdlib.h: stdlib.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
 	      -e 's|@''GNULIB_GETSUBOPT''@|$(GNULIB_GETSUBOPT)|g' \
 	      -e 's|@''GNULIB_GRANTPT''@|$(GNULIB_GRANTPT)|g' \
 	      -e 's|@''GNULIB_MALLOC_POSIX''@|$(GNULIB_MALLOC_POSIX)|g' \
+	      -e 's|@''GNULIB_MBTOWC''@|$(GNULIB_MBTOWC)|g' \
 	      -e 's|@''GNULIB_MKDTEMP''@|$(GNULIB_MKDTEMP)|g' \
 	      -e 's|@''GNULIB_MKOSTEMP''@|$(GNULIB_MKOSTEMP)|g' \
 	      -e 's|@''GNULIB_MKOSTEMPS''@|$(GNULIB_MKOSTEMPS)|g' \
@@ -1274,6 +1301,7 @@ stdlib.h: stdlib.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
 	      -e 's|@''GNULIB_SYSTEM_POSIX''@|$(GNULIB_SYSTEM_POSIX)|g' \
 	      -e 's|@''GNULIB_UNLOCKPT''@|$(GNULIB_UNLOCKPT)|g' \
 	      -e 's|@''GNULIB_UNSETENV''@|$(GNULIB_UNSETENV)|g' \
+	      -e 's|@''GNULIB_WCTOMB''@|$(GNULIB_WCTOMB)|g' \
 	      < $(srcdir)/stdlib.in.h | \
 	  sed -e 's|@''HAVE__EXIT''@|$(HAVE__EXIT)|g' \
 	      -e 's|@''HAVE_ATOLL''@|$(HAVE_ATOLL)|g' \
@@ -1302,6 +1330,7 @@ stdlib.h: stdlib.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
 	      -e 's|@''REPLACE_CALLOC''@|$(REPLACE_CALLOC)|g' \
 	      -e 's|@''REPLACE_CANONICALIZE_FILE_NAME''@|$(REPLACE_CANONICALIZE_FILE_NAME)|g' \
 	      -e 's|@''REPLACE_MALLOC''@|$(REPLACE_MALLOC)|g' \
+	      -e 's|@''REPLACE_MBTOWC''@|$(REPLACE_MBTOWC)|g' \
 	      -e 's|@''REPLACE_MKSTEMP''@|$(REPLACE_MKSTEMP)|g' \
 	      -e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \
 	      -e 's|@''REPLACE_REALLOC''@|$(REPLACE_REALLOC)|g' \
@@ -1309,6 +1338,7 @@ stdlib.h: stdlib.in.h $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H)
 	      -e 's|@''REPLACE_SETENV''@|$(REPLACE_SETENV)|g' \
 	      -e 's|@''REPLACE_STRTOD''@|$(REPLACE_STRTOD)|g' \
 	      -e 's|@''REPLACE_UNSETENV''@|$(REPLACE_UNSETENV)|g' \
+	      -e 's|@''REPLACE_WCTOMB''@|$(REPLACE_WCTOMB)|g' \
 	      -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \
 	      -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \
 	      -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)'; \

lib/ceil.c

@@ -0,0 +1,109 @@
+/* Round towards positive infinity.
+   Copyright (C) 2007, 2010-2011 Free Software Foundation, Inc.
+
+   This program is free software: you can redistribute it and/or modify
+   it under the terms of the GNU Lesser General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+/* Written by Bruno Haible <bruno@clisp.org>, 2007.  */
+
+#include <config.h>
+
+/* Specification.  */
+#include <math.h>
+
+#include <float.h>
+
+#undef MIN
+
+#ifdef USE_LONG_DOUBLE
+# define FUNC ceill
+# define DOUBLE long double
+# define MANT_DIG LDBL_MANT_DIG
+# define MIN LDBL_MIN
+# define L_(literal) literal##L
+#elif ! defined USE_FLOAT
+# define FUNC ceil
+# define DOUBLE double
+# define MANT_DIG DBL_MANT_DIG
+# define MIN DBL_MIN
+# define L_(literal) literal
+#else /* defined USE_FLOAT */
+# define FUNC ceilf
+# define DOUBLE float
+# define MANT_DIG FLT_MANT_DIG
+# define MIN FLT_MIN
+# define L_(literal) literal##f
+#endif
+
+/* -0.0.  See minus-zero.h.  */
+#if defined __hpux || defined __sgi || defined __ICC
+# define MINUS_ZERO (-MIN * MIN)
+#else
+# define MINUS_ZERO L_(-0.0)
+#endif
+
+/* 2^(MANT_DIG-1).  */
+static const DOUBLE TWO_MANT_DIG =
+  /* Assume MANT_DIG <= 5 * 31.
+     Use the identity
+       n = floor(n/5) + floor((n+1)/5) + ... + floor((n+4)/5).  */
+  (DOUBLE) (1U << ((MANT_DIG - 1) / 5))
+  * (DOUBLE) (1U << ((MANT_DIG - 1 + 1) / 5))
+  * (DOUBLE) (1U << ((MANT_DIG - 1 + 2) / 5))
+  * (DOUBLE) (1U << ((MANT_DIG - 1 + 3) / 5))
+  * (DOUBLE) (1U << ((MANT_DIG - 1 + 4) / 5));
+
+DOUBLE
+FUNC (DOUBLE x)
+{
+  /* The use of 'volatile' guarantees that excess precision bits are dropped
+     at each addition step and before the following comparison at the caller's
+     site.  It is necessary on x86 systems where double-floats are not IEEE
+     compliant by default, to avoid that the results become platform and compiler
+     option dependent.  'volatile' is a portable alternative to gcc's
+     -ffloat-store option.  */
+  volatile DOUBLE y = x;
+  volatile DOUBLE z = y;
+
+  if (z > L_(0.0))
+    {
+      /* Avoid rounding errors for values near 2^k, where k >= MANT_DIG-1.  */
+      if (z < TWO_MANT_DIG)
+        {
+          /* Round to the next integer (nearest or up or down, doesn't matter).  */
+          z += TWO_MANT_DIG;
+          z -= TWO_MANT_DIG;
+          /* Enforce rounding up.  */
+          if (z < y)
+            z += L_(1.0);
+        }
+    }
+  else if (z < L_(0.0))
+    {
+      /* For -1 < x < 0, return -0.0 regardless of the current rounding
+         mode.  */
+      if (z > L_(-1.0))
+        z = MINUS_ZERO;
+      /* Avoid rounding errors for values near -2^k, where k >= MANT_DIG-1.  */
+      else if (z > - TWO_MANT_DIG)
+        {
+          /* Round to the next integer (nearest or up or down, doesn't matter).  */
+          z -= TWO_MANT_DIG;
+          z += TWO_MANT_DIG;
+          /* Enforce rounding up.  */
+          if (z < y)
+            z += L_(1.0);
+        }
+    }
+  return z;
+}

lib/dosname.h

@@ -0,0 +1,53 @@
+/* File names on MS-DOS/Windows systems.
+
+   Copyright (C) 2000-2001, 2004-2006, 2009-2011 Free Software Foundation, Inc.
+
+   This program is free software: you can redistribute it and/or modify
+   it under the terms of the GNU Lesser General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+   From Paul Eggert and Jim Meyering.  */
+
+#ifndef _DOSNAME_H
+#define _DOSNAME_H
+
+#if (defined _WIN32 || defined __WIN32__ ||     \
+     defined __MSDOS__ || defined __CYGWIN__ || \
+     defined __EMX__ || defined __DJGPP__)
+   /* This internal macro assumes ASCII, but all hosts that support drive
+      letters use ASCII.  */
+# define _IS_DRIVE_LETTER(C) (((unsigned int) (C) | ('a' - 'A')) - 'a'  \
+                              <= 'z' - 'a')
+# define FILE_SYSTEM_PREFIX_LEN(Filename) \
+          (_IS_DRIVE_LETTER ((Filename)[0]) && (Filename)[1] == ':' ? 2 : 0)
+# ifndef __CYGWIN__
+#  define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 1
+# endif
+# define ISSLASH(C) ((C) == '/' || (C) == '\\')
+#else
+# define FILE_SYSTEM_PREFIX_LEN(Filename) 0
+# define ISSLASH(C) ((C) == '/')
+#endif
+
+#ifndef FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE
+# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 0
+#endif
+
+#if FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE
+#  define IS_ABSOLUTE_FILE_NAME(F) ISSLASH ((F)[FILE_SYSTEM_PREFIX_LEN (F)])
+# else
+#  define IS_ABSOLUTE_FILE_NAME(F)                              \
+     (ISSLASH ((F)[0]) || FILE_SYSTEM_PREFIX_LEN (F) != 0)
+#endif
+#define IS_RELATIVE_FILE_NAME(F) (! IS_ABSOLUTE_FILE_NAME (F))
+
+#endif /* DOSNAME_H_ */

lib/flock.c

@@ -27,13 +27,13 @@
 #if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
 
 /* _get_osfhandle */
-#include <io.h>
+# include <io.h>
 
 /* LockFileEx */
-#define WIN32_LEAN_AND_MEAN
+# define WIN32_LEAN_AND_MEAN
-#include <windows.h>
+# include <windows.h>
 
-#include <errno.h>
+# include <errno.h>
 
 /* Determine the current size of a file.  Because the other braindead
  * APIs we'll call need lower/upper 32 bit pairs, keep the file size
@@ -47,9 +47,9 @@ file_size (HANDLE h, DWORD * lower, DWORD * upper)
 }
 
 /* LOCKFILE_FAIL_IMMEDIATELY is undefined on some Windows systems. */
-#ifndef LOCKFILE_FAIL_IMMEDIATELY
+# ifndef LOCKFILE_FAIL_IMMEDIATELY
-# define LOCKFILE_FAIL_IMMEDIATELY 1
+#  define LOCKFILE_FAIL_IMMEDIATELY 1
-#endif
+# endif
 
 /* Acquire a lock. */
 static BOOL
@@ -160,17 +160,17 @@ flock (int fd, int operation)
 
 #else /* !Windows */
 
-#ifdef HAVE_STRUCT_FLOCK_L_TYPE
+# ifdef HAVE_STRUCT_FLOCK_L_TYPE
 /* We know how to implement flock in terms of fcntl. */
 
-#include <fcntl.h>
+#  include <fcntl.h>
 
-#ifdef HAVE_UNISTD_H
+#  ifdef HAVE_UNISTD_H
-#include <unistd.h>
+#   include <unistd.h>
-#endif
+#  endif
 
-#include <errno.h>
+#  include <errno.h>
-#include <string.h>
+#  include <string.h>
 
 int
 flock (int fd, int operation)
@@ -211,10 +211,10 @@ flock (int fd, int operation)
   return r;
 }
 
-#else /* !HAVE_STRUCT_FLOCK_L_TYPE */
+# else /* !HAVE_STRUCT_FLOCK_L_TYPE */
 
-#error "This platform lacks flock function, and Gnulib doesn't provide a replacement. This is a bug in Gnulib."
+#  error "This platform lacks flock function, and Gnulib doesn't provide a replacement. This is a bug in Gnulib."
 
-#endif /* !HAVE_STRUCT_FLOCK_L_TYPE */
+# endif /* !HAVE_STRUCT_FLOCK_L_TYPE */
 
 #endif /* !Windows */

lib/frexp.c

@@ -0,0 +1,166 @@
+/* Split a double into fraction and mantissa.
+   Copyright (C) 2007-2011 Free Software Foundation, Inc.
+
+   This program is free software: you can redistribute it and/or modify
+   it under the terms of the GNU Lesser General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+/* Written by Paolo Bonzini <bonzini@gnu.org>, 2003, and
+   Bruno Haible <bruno@clisp.org>, 2007.  */
+
+#include <config.h>
+
+/* Specification.  */
+#include <math.h>
+
+#include <float.h>
+#ifdef USE_LONG_DOUBLE
+# include "isnanl-nolibm.h"
+# include "fpucw.h"
+#else
+# include "isnand-nolibm.h"
+#endif
+
+/* This file assumes FLT_RADIX = 2.  If FLT_RADIX is a power of 2 greater
+   than 2, or not even a power of 2, some rounding errors can occur, so that
+   then the returned mantissa is only guaranteed to be <= 1.0, not < 1.0.  */
+
+#ifdef USE_LONG_DOUBLE
+# define FUNC frexpl
+# define DOUBLE long double
+# define ISNAN isnanl
+# define DECL_ROUNDING DECL_LONG_DOUBLE_ROUNDING
+# define BEGIN_ROUNDING() BEGIN_LONG_DOUBLE_ROUNDING ()
+# define END_ROUNDING() END_LONG_DOUBLE_ROUNDING ()
+# define L_(literal) literal##L
+#else
+# define FUNC frexp
+# define DOUBLE double
+# define ISNAN isnand
+# define DECL_ROUNDING
+# define BEGIN_ROUNDING()
+# define END_ROUNDING()
+# define L_(literal) literal
+#endif
+
+DOUBLE
+FUNC (DOUBLE x, int *expptr)
+{
+  int sign;
+  int exponent;
+  DECL_ROUNDING
+
+  /* Test for NaN, infinity, and zero.  */
+  if (ISNAN (x) || x + x == x)
+    {
+      *expptr = 0;
+      return x;
+    }
+
+  sign = 0;
+  if (x < 0)
+    {
+      x = - x;
+      sign = -1;
+    }
+
+  BEGIN_ROUNDING ();
+
+  {
+    /* Since the exponent is an 'int', it fits in 64 bits.  Therefore the
+       loops are executed no more than 64 times.  */
+    DOUBLE pow2[64]; /* pow2[i] = 2^2^i */
+    DOUBLE powh[64]; /* powh[i] = 2^-2^i */
+    int i;
+
+    exponent = 0;
+    if (x >= L_(1.0))
+      {
+        /* A positive exponent.  */
+        DOUBLE pow2_i; /* = pow2[i] */
+        DOUBLE powh_i; /* = powh[i] */
+
+        /* Invariants: pow2_i = 2^2^i, powh_i = 2^-2^i,
+           x * 2^exponent = argument, x >= 1.0.  */
+        for (i = 0, pow2_i = L_(2.0), powh_i = L_(0.5);
+             ;
+             i++, pow2_i = pow2_i * pow2_i, powh_i = powh_i * powh_i)
+          {
+            if (x >= pow2_i)
+              {
+                exponent += (1 << i);
+                x *= powh_i;
+              }
+            else
+              break;
+
+            pow2[i] = pow2_i;
+            powh[i] = powh_i;
+          }
+        /* Avoid making x too small, as it could become a denormalized
+           number and thus lose precision.  */
+        while (i > 0 && x < pow2[i - 1])
+          {
+            i--;
+            powh_i = powh[i];
+          }
+        exponent += (1 << i);
+        x *= powh_i;
+        /* Here 2^-2^i <= x < 1.0.  */
+      }
+    else
+      {
+        /* A negative or zero exponent.  */
+        DOUBLE pow2_i; /* = pow2[i] */
+        DOUBLE powh_i; /* = powh[i] */
+
+        /* Invariants: pow2_i = 2^2^i, powh_i = 2^-2^i,
+           x * 2^exponent = argument, x < 1.0.  */
+        for (i = 0, pow2_i = L_(2.0), powh_i = L_(0.5);
+             ;
+             i++, pow2_i = pow2_i * pow2_i, powh_i = powh_i * powh_i)
+          {
+            if (x < powh_i)
+              {
+                exponent -= (1 << i);
+                x *= pow2_i;
+              }
+            else
+              break;
+
+            pow2[i] = pow2_i;
+            powh[i] = powh_i;
+          }
+        /* Here 2^-2^i <= x < 1.0.  */
+      }
+
+    /* Invariants: x * 2^exponent = argument, and 2^-2^i <= x < 1.0.  */
+    while (i > 0)
+      {
+        i--;
+        if (x < powh[i])
+          {
+            exponent -= (1 << i);
+            x *= pow2[i];
+          }
+      }
+    /* Here 0.5 <= x < 1.0.  */
+  }
+
+  if (sign < 0)
+    x = - x;
+
+  END_ROUNDING ();
+
+  *expptr = exponent;
+  return x;
+}

lib/isnand-nolibm.h

@@ -0,0 +1,33 @@
+/* Test for NaN that does not need libm.
+   Copyright (C) 2007-2011 Free Software Foundation, Inc.
+
+   This program is free software: you can redistribute it and/or modify
+   it under the terms of the GNU Lesser General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU Lesser General Public License for more details.
+
+   You should have received a copy of the GNU Lesser General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+#if HAVE_ISNAND_IN_LIBC
+/* Get declaration of isnan macro.  */
+# include <math.h>
+# if __GNUC__ >= 4
+   /* GCC 4.0 and newer provides three built-ins for isnan.  */
+#  undef isnand
+#  define isnand(x) __builtin_isnan ((double)(x))
+# else
+#  undef isnand
+#  define isnand(x) isnan ((double)(x))
+# endif
+#else
+/* Test whether X is a NaN.  */
+# undef isnand
+# define isnand rpl_isnand
+extern int isnand (double x);
+#endif

lib/round.c

@@ -1,168 +0,0 @@
-/* Round toward nearest, breaking ties away from zero.
-   Copyright (C) 2007, 2010-2011 Free Software Foundation, Inc.
-
-   This program is free software; you can redistribute it and/or modify
-   it under the terms of the GNU Lesser General Public License as published by
-   the Free Software Foundation; either version 2, or (at your option)
-   any later version.
-
-   This program is distributed in the hope that it will be useful,
-   but WITHOUT ANY WARRANTY; without even the implied warranty of
-   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-   GNU Lesser General Public License for more details.
-
-   You should have received a copy of the GNU Lesser General Public License along
-   with this program; if not, write to the Free Software Foundation,
-   Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.  */
-
-/* Written by Ben Pfaff <blp@gnu.org>, 2007.
-   Based heavily on code by Bruno Haible. */
-
-#include <config.h>
-
-/* Specification.  */
-#include <math.h>
-
-#include <float.h>
-
-#undef MIN
-
-#ifdef USE_LONG_DOUBLE
-# define ROUND roundl
-# define FLOOR floorl
-# define CEIL ceill
-# define DOUBLE long double
-# define MANT_DIG LDBL_MANT_DIG
-# define MIN LDBL_MIN
-# define L_(literal) literal##L
-# define HAVE_FLOOR_AND_CEIL HAVE_FLOORL_AND_CEILL
-#elif ! defined USE_FLOAT
-# define ROUND round
-# define FLOOR floor
-# define CEIL ceil
-# define DOUBLE double
-# define MANT_DIG DBL_MANT_DIG
-# define MIN DBL_MIN
-# define L_(literal) literal
-# define HAVE_FLOOR_AND_CEIL 1
-#else /* defined USE_FLOAT */
-# define ROUND roundf
-# define FLOOR floorf
-# define CEIL ceilf
-# define DOUBLE float
-# define MANT_DIG FLT_MANT_DIG
-# define MIN FLT_MIN
-# define L_(literal) literal##f
-# define HAVE_FLOOR_AND_CEIL HAVE_FLOORF_AND_CEILF
-#endif
-
-/* -0.0.  See minus-zero.h.  */
-#if defined __hpux || defined __sgi || defined __ICC
-# define MINUS_ZERO (-MIN * MIN)
-#else
-# define MINUS_ZERO L_(-0.0)
-#endif
-
-/* If we're being included from test-round2[f].c, it already defined names for
-   our round implementations.  Otherwise, pick the preferred implementation for
-   this machine. */
-#if !defined FLOOR_BASED_ROUND && !defined FLOOR_FREE_ROUND
-# if HAVE_FLOOR_AND_CEIL
-#  define FLOOR_BASED_ROUND ROUND
-# else
-#  define FLOOR_FREE_ROUND ROUND
-# endif
-#endif
-
-#ifdef FLOOR_BASED_ROUND
-/* An implementation of the C99 round function based on floor and ceil.  We use
-   this when floor and ceil are available, on the assumption that they are
-   faster than the open-coded versions below. */
-DOUBLE
-FLOOR_BASED_ROUND (DOUBLE x)
-{
-  if (x >= L_(0.0))
-    {
-      DOUBLE y = FLOOR (x);
-      if (x - y >= L_(0.5))
-        y += L_(1.0);
-      return y;
-    }
-  else
-    {
-      DOUBLE y = CEIL (x);
-      if (y - x >= L_(0.5))
-        y -= L_(1.0);
-      return y;
-    }
-}
-#endif /* FLOOR_BASED_ROUND */
-
-#ifdef FLOOR_FREE_ROUND
-/* An implementation of the C99 round function without floor or ceil.
-   We use this when floor or ceil is missing. */
-DOUBLE
-FLOOR_FREE_ROUND (DOUBLE x)
-{
-  /* 2^(MANT_DIG-1).  */
-  static const DOUBLE TWO_MANT_DIG =
-    /* Assume MANT_DIG <= 5 * 31.
-       Use the identity
-       n = floor(n/5) + floor((n+1)/5) + ... + floor((n+4)/5).  */
-    (DOUBLE) (1U << ((MANT_DIG - 1) / 5))
-    * (DOUBLE) (1U << ((MANT_DIG - 1 + 1) / 5))
-    * (DOUBLE) (1U << ((MANT_DIG - 1 + 2) / 5))
-    * (DOUBLE) (1U << ((MANT_DIG - 1 + 3) / 5))
-    * (DOUBLE) (1U << ((MANT_DIG - 1 + 4) / 5));
-
-  /* The use of 'volatile' guarantees that excess precision bits are dropped at
-     each addition step and before the following comparison at the caller's
-     site.  It is necessary on x86 systems where double-floats are not IEEE
-     compliant by default, to avoid that the results become platform and
-     compiler option dependent.  'volatile' is a portable alternative to gcc's
-     -ffloat-store option.  */
-  volatile DOUBLE y = x;
-  volatile DOUBLE z = y;
-
-  if (z > L_(0.0))
-    {
-      /* Avoid rounding error for x = 0.5 - 2^(-MANT_DIG-1).  */
-      if (z < L_(0.5))
-        z = L_(0.0);
-      /* Avoid rounding errors for values near 2^k, where k >= MANT_DIG-1.  */
-      else if (z < TWO_MANT_DIG)
-        {
-          /* Add 0.5 to the absolute value.  */
-          y = z += L_(0.5);
-          /* Round to the next integer (nearest or up or down, doesn't
-             matter).  */
-          z += TWO_MANT_DIG;
-          z -= TWO_MANT_DIG;
-          /* Enforce rounding down.  */
-          if (z > y)
-            z -= L_(1.0);
-        }
-    }
-  else if (z < L_(0.0))
-    {
-      /* Avoid rounding error for x = -(0.5 - 2^(-MANT_DIG-1)).  */
-      if (z > - L_(0.5))
-        z = MINUS_ZERO;
-      /* Avoid rounding errors for values near -2^k, where k >= MANT_DIG-1.  */
-      else if (z > -TWO_MANT_DIG)
-        {
-          /* Add 0.5 to the absolute value.  */
-          y = z -= L_(0.5);
-          /* Round to the next integer (nearest or up or down, doesn't
-             matter).  */
-          z -= TWO_MANT_DIG;
-          z += TWO_MANT_DIG;
-          /* Enforce rounding up.  */
-          if (z < y)
-            z += L_(1.0);
-        }
-    }
-  return z;
-}
-#endif /* FLOOR_FREE_ROUND */
-

lib/stat.c

@@ -37,6 +37,7 @@ orig_stat (const char *filename, struct stat *buf)
 #include <limits.h>
 #include <stdbool.h>
 #include <string.h>
+#include "dosname.h"
 
 /* Store information about NAME into ST.  Work around bugs with
    trailing slashes.  Mingw has other bugs (such as st_ino always

lib/stdint.in.h

@@ -497,7 +497,12 @@ typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof (uintmax_t)
    sequence of nested includes
    <wchar.h> -> <stdio.h> -> <getopt.h> -> <stdlib.h>, and the latter includes
    <stdint.h> and assumes its types are already defined.  */
-#if ! (defined WCHAR_MIN && defined WCHAR_MAX)
+#if @HAVE_WCHAR_H@ && ! (defined WCHAR_MIN && defined WCHAR_MAX)
+  /* BSD/OS 4.0.1 has a bug: <stddef.h>, <stdio.h> and <time.h> must be
+     included before <wchar.h>.  */
+# include <stddef.h>
+# include <stdio.h>
+# include <time.h>
 # define _GL_JUST_INCLUDE_SYSTEM_WCHAR_H
 # include <wchar.h>
 # undef _GL_JUST_INCLUDE_SYSTEM_WCHAR_H

lib/stdio-write.c

@@ -1,148 +0,0 @@
-/* POSIX compatible FILE stream write function.
-   Copyright (C) 2008-2011 Free Software Foundation, Inc.
-   Written by Bruno Haible <bruno@clisp.org>, 2008.
-
-   This program is free software: you can redistribute it and/or modify
-   it under the terms of the GNU Lesser General Public License as published by
-   the Free Software Foundation; either version 3 of the License, or
-   (at your option) any later version.
-
-   This program is distributed in the hope that it will be useful,
-   but WITHOUT ANY WARRANTY; without even the implied warranty of
-   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-   GNU Lesser General Public License for more details.
-
-   You should have received a copy of the GNU Lesser General Public License
-   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
-
-#include <config.h>
-
-/* Specification.  */
-#include <stdio.h>
-
-/* Replace these functions only if module 'sigpipe' is requested.  */
-#if GNULIB_SIGPIPE
-
-/* On native Windows platforms, SIGPIPE does not exist.  When write() is
-   called on a pipe with no readers, WriteFile() fails with error
-   GetLastError() = ERROR_NO_DATA, and write() in consequence fails with
-   error EINVAL.  This write() function is at the basis of the function
-   which flushes the buffer of a FILE stream.  */
-
-# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__
-
-#  include <errno.h>
-#  include <signal.h>
-#  include <io.h>
-
-#  define WIN32_LEAN_AND_MEAN  /* avoid including junk */
-#  include <windows.h>
-
-#  define CALL_WITH_SIGPIPE_EMULATION(RETTYPE, EXPRESSION, FAILED) \
-  if (ferror (stream))                                                        \
-    return (EXPRESSION);                                                      \
-  else                                                                        \
-    {                                                                         \
-      RETTYPE ret;                                                            \
-      SetLastError (0);                                                       \
-      ret = (EXPRESSION);                                                     \
-      if (FAILED && GetLastError () == ERROR_NO_DATA && ferror (stream))      \
-        {                                                                     \
-          int fd = fileno (stream);                                           \
-          if (fd >= 0                                                         \
-              && GetFileType ((HANDLE) _get_osfhandle (fd)) == FILE_TYPE_PIPE)\
-            {                                                                 \
-              /* Try to raise signal SIGPIPE.  */                             \
-              raise (SIGPIPE);                                                \
-              /* If it is currently blocked or ignored, change errno from     \
-                 EINVAL to EPIPE.  */                                         \
-              errno = EPIPE;                                                  \
-            }                                                                 \
-        }                                                                     \
-      return ret;                                                             \
-    }
-
-#  if !REPLACE_PRINTF_POSIX /* avoid collision with printf.c */
-int
-printf (const char *format, ...)
-{
-  int retval;
-  va_list args;
-
-  va_start (args, format);
-  retval = vfprintf (stdout, format, args);
-  va_end (args);
-
-  return retval;
-}
-#  endif
-
-#  if !REPLACE_FPRINTF_POSIX /* avoid collision with fprintf.c */
-int
-fprintf (FILE *stream, const char *format, ...)
-{
-  int retval;
-  va_list args;
-
-  va_start (args, format);
-  retval = vfprintf (stream, format, args);
-  va_end (args);
-
-  return retval;
-}
-#  endif
-
-#  if !REPLACE_VPRINTF_POSIX /* avoid collision with vprintf.c */
-int
-vprintf (const char *format, va_list args)
-{
-  return vfprintf (stdout, format, args);
-}
-#  endif
-
-#  if !REPLACE_VFPRINTF_POSIX /* avoid collision with vfprintf.c */
-int
-vfprintf (FILE *stream, const char *format, va_list args)
-#undef vfprintf
-{
-  CALL_WITH_SIGPIPE_EMULATION (int, vfprintf (stream, format, args), ret == EOF)
-}
-#  endif
-
-int
-putchar (int c)
-{
-  return fputc (c, stdout);
-}
-
-int
-fputc (int c, FILE *stream)
-#undef fputc
-{
-  CALL_WITH_SIGPIPE_EMULATION (int, fputc (c, stream), ret == EOF)
-}
-
-int
-fputs (const char *string, FILE *stream)
-#undef fputs
-{
-  CALL_WITH_SIGPIPE_EMULATION (int, fputs (string, stream), ret == EOF)
-}
-
-int
-puts (const char *string)
-#undef puts
-{
-  FILE *stream = stdout;
-  CALL_WITH_SIGPIPE_EMULATION (int, puts (string), ret == EOF)
-}
-
-size_t
-fwrite (const void *ptr, size_t s, size_t n, FILE *stream)
-#undef fwrite
-{
-  CALL_WITH_SIGPIPE_EMULATION (size_t, fwrite (ptr, s, n, stream), ret < n)
-}
-
-# endif
-#endif

lib/stdlib.in.h

@@ -274,6 +274,21 @@ _GL_WARN_ON_USE (malloc, "malloc is not POSIX compliant everywhere - "
                  "use gnulib module malloc-posix for portability");
 #endif
 
+/* Convert a multibyte character to a wide character.  */
+#if @GNULIB_MBTOWC@
+# if @REPLACE_MBTOWC@
+#  if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+#   undef mbtowc
+#   define mbtowc rpl_mbtowc
+#  endif
+_GL_FUNCDECL_RPL (mbtowc, int, (wchar_t *pwc, const char *s, size_t n));
+_GL_CXXALIAS_RPL (mbtowc, int, (wchar_t *pwc, const char *s, size_t n));
+# else
+_GL_CXXALIAS_SYS (mbtowc, int, (wchar_t *pwc, const char *s, size_t n));
+# endif
+_GL_CXXALIASWARN (mbtowc);
+#endif
+
 #if @GNULIB_MKDTEMP@
 /* Create a unique temporary directory from TEMPLATE.
    The last six characters of TEMPLATE must be "XXXXXX";
@@ -723,6 +738,21 @@ _GL_WARN_ON_USE (unsetenv, "unsetenv is unportable - "
 # endif
 #endif
 
+/* Convert a wide character to a multibyte character.  */
+#if @GNULIB_WCTOMB@
+# if @REPLACE_WCTOMB@
+#  if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+#   undef wctomb
+#   define wctomb rpl_wctomb
+#  endif
+_GL_FUNCDECL_RPL (wctomb, int, (char *s, wchar_t wc));
+_GL_CXXALIAS_RPL (wctomb, int, (char *s, wchar_t wc));
+# else
+_GL_CXXALIAS_SYS (wctomb, int, (char *s, wchar_t wc));
+# endif
+_GL_CXXALIASWARN (wctomb);
+#endif
+
 
 #endif /* _GL_STDLIB_H */
 #endif /* _GL_STDLIB_H */

lib/vasnprintf.c

@@ -935,11 +935,11 @@ decode_long_double (long double x, int *ep, mpn_t *mp)
         abort ();
       m.limbs[--i] = (hi << (GMP_LIMB_BITS / 2)) | lo;
     }
-#if 0 /* On FreeBSD 6.1/x86, 'long double' numbers sometimes have excess
+#  if 0 /* On FreeBSD 6.1/x86, 'long double' numbers sometimes have excess
-         precision.  */
+           precision.  */
   if (!(y == 0.0L))
     abort ();
-#endif
+#  endif
   /* Normalise.  */
   while (m.nlimbs > 0 && m.limbs[m.nlimbs - 1] == 0)
     m.nlimbs--;

lib/vasnprintf.h

@@ -24,16 +24,16 @@
 /* Get size_t.  */
 #include <stddef.h>
 
-#ifndef __attribute__
 /* The __attribute__ feature is available in gcc versions 2.5 and later.
    The __-protected variants of the attributes 'format' and 'printf' are
    accepted by gcc versions 2.6.4 (effectively 2.7) and later.
-   We enable __attribute__ only if these are supported too, because
+   We enable _GL_ATTRIBUTE_FORMAT only if these are supported too, because
    gnulib and libintl do '#define printf __printf__' when they override
    the 'printf' function.  */
-# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 7)
+#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7)
-#  define __attribute__(Spec)   /* empty */
+# define _GL_ATTRIBUTE_FORMAT(spec) __attribute__ ((__format__ spec))
-# endif
+#else
+# define _GL_ATTRIBUTE_FORMAT(spec) /* empty */
 #endif
 
 #ifdef __cplusplus
@@ -69,9 +69,9 @@ extern "C" {
 # define vasnprintf rpl_vasnprintf
 #endif
 extern char * asnprintf (char *resultbuf, size_t *lengthp, const char *format, ...)
-       __attribute__ ((__format__ (__printf__, 3, 4)));
+       _GL_ATTRIBUTE_FORMAT ((__printf__, 3, 4));
 extern char * vasnprintf (char *resultbuf, size_t *lengthp, const char *format, va_list args)
-       __attribute__ ((__format__ (__printf__, 3, 0)));
+       _GL_ATTRIBUTE_FORMAT ((__printf__, 3, 0));
 
 #ifdef __cplusplus
 }

lib/version-etc.h

@@ -23,11 +23,11 @@
 # include <stdio.h>
 
 /* The `sentinel' attribute was added in gcc 4.0.  */
-#ifndef ATTRIBUTE_SENTINEL
+#ifndef _GL_ATTRIBUTE_SENTINEL
 # if 4 <= __GNUC__
-#  define ATTRIBUTE_SENTINEL __attribute__ ((__sentinel__))
+#  define _GL_ATTRIBUTE_SENTINEL __attribute__ ((__sentinel__))
 # else
-#  define ATTRIBUTE_SENTINEL /* empty */
+#  define _GL_ATTRIBUTE_SENTINEL /* empty */
 # endif
 #endif
 
@@ -70,7 +70,7 @@ extern void version_etc (FILE *stream,
                          const char *command_name, const char *package,
                          const char *version,
                          /* const char *author1, ..., NULL */ ...)
-  ATTRIBUTE_SENTINEL;
+  _GL_ATTRIBUTE_SENTINEL;
 
 /* Display the usual `Report bugs to' stanza */
 extern void emit_bug_reporting_address (void);

libguile/Makefile.am

@@ -460,7 +460,9 @@ version_info = @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGU
 
 libguile_@GUILE_EFFECTIVE_VERSION@_la_LDFLAGS =	\
   $(BDW_GC_LIBS) $(LIBFFI_LIBS)			\
+  $(CEIL_LIBM)					\
   $(FLOOR_LIBM)					\
+  $(FREXP_LIBM)					\
   $(GETADDRINFO_LIB)				\
   $(HOSTENT_LIB)				\
   $(INET_NTOP_LIB)				\
@@ -468,12 +470,12 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_LDFLAGS =	\
   $(ISNAND_LIBM)				\
   $(ISNANF_LIBM)				\
   $(ISNANL_LIBM)				\
+  $(LDEXP_LIBM)					\
   $(LIBSOCKET)					\
   $(LOG1P_LIBM)					\
   $(LTLIBICONV)					\
   $(LTLIBINTL)					\
   $(LTLIBUNISTRING)				\
-  $(ROUND_LIBM)					\
   $(SERVENT_LIB)				\
   $(TRUNC_LIBM)					\
   -version-info $(version_info)			\

libguile/array-handle.h

@@ -3,7 +3,8 @@
 #ifndef SCM_ARRAY_HANDLE_H
 #define SCM_ARRAY_HANDLE_H
 
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2004, 2006,
+ *   2008, 2009, 2011 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 License
@@ -64,25 +65,26 @@ typedef struct scm_t_array_dim
   ssize_t inc;
 } scm_t_array_dim;
 
-typedef enum {    
+typedef enum
-  SCM_ARRAY_ELEMENT_TYPE_SCM = 0, /* SCM values */
+  {
-  SCM_ARRAY_ELEMENT_TYPE_CHAR = 1, /* characters */
+    SCM_ARRAY_ELEMENT_TYPE_SCM = 0,   /* SCM values */
-  SCM_ARRAY_ELEMENT_TYPE_BIT = 2, /* packed numeric values */
+    SCM_ARRAY_ELEMENT_TYPE_CHAR = 1,  /* characters */
-  SCM_ARRAY_ELEMENT_TYPE_VU8 = 3,
+    SCM_ARRAY_ELEMENT_TYPE_BIT = 2,   /* packed numeric values */
-  SCM_ARRAY_ELEMENT_TYPE_U8 = 4,
+    SCM_ARRAY_ELEMENT_TYPE_VU8 = 3,
-  SCM_ARRAY_ELEMENT_TYPE_S8 = 5,
+    SCM_ARRAY_ELEMENT_TYPE_U8 = 4,
-  SCM_ARRAY_ELEMENT_TYPE_U16 = 6,
+    SCM_ARRAY_ELEMENT_TYPE_S8 = 5,
-  SCM_ARRAY_ELEMENT_TYPE_S16 = 7,
+    SCM_ARRAY_ELEMENT_TYPE_U16 = 6,
-  SCM_ARRAY_ELEMENT_TYPE_U32 = 8,
+    SCM_ARRAY_ELEMENT_TYPE_S16 = 7,
-  SCM_ARRAY_ELEMENT_TYPE_S32 = 9,
+    SCM_ARRAY_ELEMENT_TYPE_U32 = 8,
-  SCM_ARRAY_ELEMENT_TYPE_U64 = 10,
+    SCM_ARRAY_ELEMENT_TYPE_S32 = 9,
-  SCM_ARRAY_ELEMENT_TYPE_S64 = 11,
+    SCM_ARRAY_ELEMENT_TYPE_U64 = 10,
-  SCM_ARRAY_ELEMENT_TYPE_F32 = 12,
+    SCM_ARRAY_ELEMENT_TYPE_S64 = 11,
-  SCM_ARRAY_ELEMENT_TYPE_F64 = 13,
+    SCM_ARRAY_ELEMENT_TYPE_F32 = 12,
-  SCM_ARRAY_ELEMENT_TYPE_C32 = 14,
+    SCM_ARRAY_ELEMENT_TYPE_F64 = 13,
-  SCM_ARRAY_ELEMENT_TYPE_C64 = 15,
+    SCM_ARRAY_ELEMENT_TYPE_C32 = 14,
-  SCM_ARRAY_ELEMENT_TYPE_LAST = 15,
+    SCM_ARRAY_ELEMENT_TYPE_C64 = 15,
-} scm_t_array_element_type;
+    SCM_ARRAY_ELEMENT_TYPE_LAST = 15
+  } scm_t_array_element_type;
 
 SCM_INTERNAL SCM scm_i_array_element_types[];
 

libguile/arrays.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 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 License
@@ -860,7 +860,6 @@ SCM
 scm_i_read_array (SCM port, int c)
 {
   ssize_t rank;
-  int got_rank;
   char tag[80];
   int tag_len;
 
@@ -888,7 +887,6 @@ scm_i_read_array (SCM port, int c)
 	  return SCM_BOOL_F;
 	}
       rank = 1;
-      got_rank = 1;
       tag[0] = 'f';
       tag_len = 1;
       goto continue_reading_tag;

libguile/backtrace.c

@@ -278,9 +278,7 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0,
     scm_print_state *pstate;
       
     /* Create a string port used for adaptation of printing parameters. */
-    sport = scm_mkstrport (SCM_INUM0,
+    sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
-                           scm_make_string (scm_from_int (240),
-                                            SCM_UNDEFINED),
                            SCM_OPN | SCM_WRTNG,
                            FUNC_NAME);
 
@@ -431,7 +429,7 @@ display_backtrace_body (struct display_backtrace_args *a)
 #define FUNC_NAME "display_backtrace_body"
 {
   int n_frames, beg, end, n, i, j;
-  int nfield, indent_p, indentation;
+  int nfield, indentation;
   SCM frame, sport, print_state;
   SCM last_file;
   scm_print_state *pstate;
@@ -473,8 +471,7 @@ display_backtrace_body (struct display_backtrace_args *a)
   SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace);
 
   /* Create a string port used for adaptation of printing parameters. */
-  sport = scm_mkstrport (SCM_INUM0,
+  sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
-			 scm_make_string (scm_from_int (240), SCM_UNDEFINED),
 			 SCM_OPN | SCM_WRTNG,
 			 FUNC_NAME);
 
@@ -485,9 +482,6 @@ display_backtrace_body (struct display_backtrace_args *a)
   pstate->fancyp = 1;
   pstate->highlight_objects = a->highlight_objects;
 
-  /* First find out if it's reasonable to do indentation. */
-  indent_p = 0;
-  
   /* Determine size of frame number field. */
   j = end;
   for (i = 0; j > 0; ++i) j /= 10;

libguile/bdw-gc.h

@@ -1,7 +1,7 @@
 #ifndef SCM_BDW_GC_H
 #define SCM_BDW_GC_H
 
-/* Copyright (C) 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009, 2011 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 License
@@ -32,6 +32,11 @@
 # define GC_THREADS 1
 # define GC_REDIRECT_TO_LOCAL 1
 
+/* Don't #define pthread routines to their GC_pthread counterparts.
+   Instead we will be careful inside Guile to use the GC_pthread
+   routines.  */
+# define GC_NO_THREAD_REDIRECTS 1
+
 #endif
 
 #include <gc/gc.h>

libguile/continuations.c

@@ -460,6 +460,45 @@ scm_i_with_continuation_barrier (scm_t_catch_body body,
   return result;
 }
 
+
+
+static int
+should_print_backtrace (SCM tag, SCM stack)
+{
+  return SCM_BACKTRACE_P
+    && scm_is_true (stack)
+    && scm_initialized_p
+    /* It's generally not useful to print backtraces for errors reading
+       or expanding code in these fallback catch statements. */
+    && !scm_is_eq (tag, scm_from_latin1_symbol ("read-error"))
+    && !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"));
+}
+
+static void
+print_exception_and_backtrace (SCM port, SCM tag, SCM args)
+{
+  SCM stack, frame;
+
+  /* We get here via a throw to a catch-all.  In that case there is the
+     throw frame active, and this catch closure, so narrow by two
+     frames.  */
+  stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+  frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
+
+  if (should_print_backtrace (tag, stack))
+    {
+      scm_puts ("Backtrace:\n", port);
+      scm_display_backtrace_with_highlights (stack, port,
+                                             SCM_BOOL_F, SCM_BOOL_F,
+                                             SCM_EOL);
+      scm_newline (port);
+    }
+
+  scm_print_exception (port, frame, tag, args);
+}
+
+
+
 struct c_data {
   void *(*func) (void *);
   void *data;
@@ -477,11 +516,27 @@ c_body (void *d)
 static SCM
 c_handler (void *d, SCM tag, SCM args)
 {
-  struct c_data *data = (struct c_data *)d;
+  struct c_data *data;
+
+  /* If TAG is `quit', exit() the process.  */
+  if (scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
+    exit (scm_exit_status (args));
+
+  data = (struct c_data *)d;
   data->result = NULL;
   return SCM_UNSPECIFIED;
 }
 
+static SCM
+pre_unwind_handler (void *error_port, SCM tag, SCM args)
+{
+  /* Print the exception unless TAG is  `quit'.  */
+  if (!scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
+    print_exception_and_backtrace (PTR2SCM (error_port), tag, args);
+
+  return SCM_UNSPECIFIED;
+}
+
 void *
 scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
 {
@@ -490,7 +545,8 @@ scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
   c_data.data = data;
   scm_i_with_continuation_barrier (c_body, &c_data,
 				   c_handler, &c_data,
-				   scm_handle_by_message_noexit, NULL);
+				   pre_unwind_handler,
+                                   SCM2PTR (scm_current_error_port ()));
   return c_data.result;
 }
 
@@ -508,6 +564,10 @@ scm_body (void *d)
 static SCM
 scm_handler (void *d, SCM tag, SCM args)
 {
+  /* Print a message.  Note that if TAG is `quit', this will exit() the
+     process.  */
+  scm_handle_by_message_noexit (NULL, tag, args);
+
   return SCM_BOOL_F;
 }
 
@@ -529,7 +589,8 @@ SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0,
   scm_data.proc = proc;
   return scm_i_with_continuation_barrier (scm_body, &scm_data,
 					  scm_handler, &scm_data,
-					  scm_handle_by_message_noexit, NULL);
+					  pre_unwind_handler,
+                                          SCM2PTR (scm_current_error_port ()));
 }
 #undef FUNC_NAME
 

libguile/control.c

@@ -55,18 +55,18 @@ scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
 
 /* Only to be called if the SCM_PROMPT_SETJMP returns 1 */
 SCM
-scm_i_prompt_pop_abort_args_x (SCM prompt)
+scm_i_prompt_pop_abort_args_x (SCM vm)
 {
   size_t i, n;
   SCM vals = SCM_EOL;
 
-  n = scm_to_size_t (SCM_PROMPT_REGISTERS (prompt)->sp[0]);
+  n = scm_to_size_t (SCM_VM_DATA (vm)->sp[0]);
   for (i = 0; i < n; i++)
-    vals = scm_cons (SCM_PROMPT_REGISTERS (prompt)->sp[-(i + 1)], vals);
+    vals = scm_cons (SCM_VM_DATA (vm)->sp[-(i + 1)], vals);
 
   /* The abort did reset the VM's registers, but then these values
      were pushed on; so we need to pop them ourselves. */
-  SCM_VM_DATA (scm_the_vm ())->sp -= n + 1;
+  SCM_VM_DATA (vm)->sp -= n + 1;
   /* FIXME NULLSTACK */
 
   return vals;

libguile/control.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2010  Free Software Foundation, Inc.
+/* Copyright (C) 2010, 2011  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 License
@@ -46,7 +46,7 @@ SCM_INTERNAL SCM scm_c_make_prompt (SCM k, SCM *fp, SCM *sp,
                                     scm_t_uint8 escape_only_p,
                                     scm_t_int64 vm_cookie,
                                     SCM winds);
-SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM prompt);
+SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM vm);
 
 SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
                                scm_t_int64 cookie) SCM_NORETURN;

libguile/deprecated.c

@@ -2281,7 +2281,7 @@ scm_allocate_string (size_t len)
 {
   scm_c_issue_deprecation_warning
     ("`scm_allocate_string' is deprecated. Use scm_c_make_string instead.");
-  return scm_i_make_string (len, NULL);
+  return scm_i_make_string (len, NULL, 0);
 }
 
 SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, 

libguile/dynl.c

@@ -115,9 +115,8 @@ sysdep_dynl_value (const char *symb, void *handle, const char *subr)
 
   fptr = lt_dlsym ((lt_dlhandle) handle, symb);
   if (!fptr)
-    {
+    scm_misc_error (subr, "Symbol not found: ~a",
-      scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
+                    scm_list_1 (scm_from_locale_string (symb)));
-    }
   return fptr;
 }
 

libguile/eval.c

@@ -424,7 +424,7 @@ eval (SCM x, SCM env)
           {
             /* The prompt exited nonlocally. */
             proc = handler;
-            args = scm_i_prompt_pop_abort_args_x (prompt);
+            args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
             goto apply_proc;
           }
         
@@ -476,6 +476,21 @@ scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
   return scm_c_vm_run (scm_the_vm (), proc, args, 4);
 }
 
+SCM
+scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
+{
+  SCM args[] = { arg1, arg2, arg3, arg4, arg5 };
+  return scm_c_vm_run (scm_the_vm (), proc, args, 5);
+}
+
+SCM
+scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
+            SCM arg6)
+{
+  SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
+  return scm_c_vm_run (scm_the_vm (), proc, args, 6);
+}
+
 SCM
 scm_call_n (SCM proc, SCM *argv, size_t nargs)
 {
@@ -543,11 +558,7 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
   SCM *lloc;
   SCM_VALIDATE_NONEMPTYLIST (1, lst);
   lloc = &lst;
-  while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be
+  while (!scm_is_null (SCM_CDR (*lloc)))
-                                          SCM_NULL_OR_NIL_P, but not
-                                          needed in 99.99% of cases,
-                                          and it could seriously hurt
-                                          performance. - Neil */
     lloc = SCM_CDRLOC (*lloc);
   SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
   *lloc = SCM_CAR (*lloc);

libguile/eval.h

@@ -3,7 +3,7 @@
 #ifndef SCM_EVAL_H
 #define SCM_EVAL_H
 
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -68,6 +68,10 @@ SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
 SCM_API SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2);
 SCM_API SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
 SCM_API SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4);
+SCM_API SCM scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
+                        SCM arg5);
+SCM_API SCM scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
+                        SCM arg5, SCM arg6);
 SCM_API SCM scm_call_n (SCM proc, SCM *argv, size_t nargs);
 SCM_API SCM scm_apply_0 (SCM proc, SCM args);
 SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);

libguile/filesys.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2009, 2010, 2011 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 License
@@ -845,7 +845,6 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
   {
     struct dirent_or_dirent64 de; /* just for sizeof */
     DIR    *ds = (DIR *) SCM_SMOB_DATA_1 (port);
-    size_t namlen;
 #ifdef NAME_MAX
     char   buf [SCM_MAX (sizeof (de),
                          sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
@@ -865,8 +864,6 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
     if (! rdent)
       return SCM_EOF_VAL;
 
-    namlen = NAMLEN (rdent);
-
     return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
             : SCM_EOF_VAL);
   }

libguile/foreign.c

@@ -177,6 +177,34 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_pointer_to_scm, "pointer->scm", 1, 0, 0,
+	    (SCM pointer),
+	    "Unsafely cast @var{pointer} to a Scheme object.\n"
+	    "Cross your fingers!")
+#define FUNC_NAME s_scm_pointer_to_scm
+{
+  SCM_VALIDATE_POINTER (1, pointer);
+  
+  return SCM_PACK ((scm_t_bits) SCM_POINTER_VALUE (pointer));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0,
+	    (SCM scm),
+	    "Return a foreign pointer object with the @code{object-address}\n"
+            "of @var{scm}.")
+#define FUNC_NAME s_scm_scm_to_pointer
+{
+  SCM ret;
+
+  ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL);
+  if (SCM_NIMP (ret))
+    register_weak_reference (ret, scm);
+
+  return ret;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0,
 	    (SCM pointer, SCM len, SCM offset, SCM uvec_type),
 	    "Return a bytevector aliasing the @var{len} bytes pointed\n"
@@ -327,13 +355,13 @@ SCM_DEFINE (scm_dereference_pointer, "dereference-pointer", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 0, 0,
+SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 1, 0,
-	    (SCM string),
+	    (SCM string, SCM encoding),
 	    "Return a foreign pointer to a nul-terminated copy of\n"
-	    "@var{string} in the current locale encoding.  The C\n"
+	    "@var{string} in the given @var{encoding}, defaulting to\n"
-	    "string is freed when the returned foreign pointer\n"
+            "the current locale encoding.  The C string is freed when\n"
-	    "becomes unreachable.\n\n"
+            "the returned foreign pointer becomes unreachable.\n\n"
-            "This is the Scheme equivalent of @code{scm_to_locale_string}.")
+            "This is the Scheme equivalent of @code{scm_to_stringn}.")
 #define FUNC_NAME s_scm_string_to_pointer
 {
   SCM_VALIDATE_STRING (1, string);
@@ -341,21 +369,72 @@ SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 0, 0,
   /* XXX: Finalizers slow down libgc; they could be avoided if
      `scm_to_string' & co. were able to use libgc-allocated memory.  */
 
-  return scm_from_pointer (scm_to_locale_string (string), free);
+  if (SCM_UNBNDP (encoding))
+    return scm_from_pointer (scm_to_locale_string (string), free);
+  else
+    {
+      char *enc;
+      SCM ret;
+      
+      SCM_VALIDATE_STRING (2, encoding);
+
+      enc = scm_to_locale_string (encoding);
+      scm_dynwind_begin (0);
+      scm_dynwind_free (enc);
+
+      ret = scm_from_pointer
+        (scm_to_stringn (string, NULL, enc,
+                         scm_i_get_conversion_strategy (SCM_BOOL_F)),
+         free);
+
+      scm_dynwind_end ();
+
+      return ret;
+    }
 }
 #undef FUNC_NAME
 
-SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 0, 0,
+SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 2, 0,
-	    (SCM pointer),
+	    (SCM pointer, SCM length, SCM encoding),
-	    "Return the string representing the C nul-terminated string\n"
+	    "Return the string representing the C string pointed to by\n"
-	    "pointed to by @var{pointer}.  The C string is assumed to be\n"
+            "@var{pointer}.  If @var{length} is omitted or @code{-1}, the\n"
-	    "in the current locale encoding.\n\n"
+            "string is assumed to be nul-terminated.  Otherwise\n"
-	    "This is the Scheme equivalent of @code{scm_from_locale_string}.")
+            "@var{length} is the number of bytes in memory pointed to by\n"
+            "@var{pointer}.  The C string is assumed to be in the given\n"
+            "@var{encoding}, defaulting to the current locale encoding.\n\n"
+	    "This is the Scheme equivalent of @code{scm_from_stringn}.")
 #define FUNC_NAME s_scm_pointer_to_string
 {
+  size_t len;
+
   SCM_VALIDATE_POINTER (1, pointer);
 
-  return scm_from_locale_string (SCM_POINTER_VALUE (pointer));
+  if (SCM_UNBNDP (length)
+      || scm_is_true (scm_eqv_p (length, scm_from_int (-1))))
+    len = (size_t)-1;
+  else
+    len = scm_to_size_t (length);
+    
+  if (SCM_UNBNDP (encoding))
+    return scm_from_locale_stringn (SCM_POINTER_VALUE (pointer), len);
+  else
+    {
+      char *enc;
+      SCM ret;
+      
+      SCM_VALIDATE_STRING (3, encoding);
+
+      enc = scm_to_locale_string (encoding);
+      scm_dynwind_begin (0);
+      scm_dynwind_free (enc);
+
+      ret = scm_from_stringn (SCM_POINTER_VALUE (pointer), len, enc,
+                              scm_i_get_conversion_strategy (SCM_BOOL_F));
+
+      scm_dynwind_end ();
+
+      return ret;
+    }
 }
 #undef FUNC_NAME
 
@@ -402,8 +481,24 @@ SCM_DEFINE (scm_alignof, "alignof", 1, 0, 0, (SCM type),
     /* a pointer */
     return scm_from_size_t (alignof (void*));
   else if (scm_is_pair (type))
-    /* a struct, yo */
+    {
-    return scm_alignof (scm_car (type));
+      /* TYPE is a structure.  Section 3-3 of the i386, x86_64, PowerPC,
+	 and SPARC P.S. of the System V ABI all say: "Aggregates
+	 (structures and arrays) and unions assume the alignment of
+	 their most strictly aligned component."  */
+      size_t max;
+
+      for (max = 0; scm_is_pair (type); type = SCM_CDR (type))
+	{
+	  size_t align;
+
+	  align = scm_to_size_t (scm_alignof (SCM_CAR (type)));
+	  if (align  > max)
+	    max = align;
+	}
+
+      return scm_from_size_t (max);
+    }
   else
     scm_wrong_type_arg (FUNC_NAME, 1, type);
 }
@@ -861,6 +956,9 @@ unpack (const ffi_type *type, void *loc, SCM x)
       SCM_VALIDATE_POINTER (1, x);
       *(void **) loc = SCM_POINTER_VALUE (x);
       break;
+    case FFI_TYPE_VOID:
+      /* Do nothing.  */
+      break;
     default:
       abort ();
     }

libguile/foreign.h

@@ -72,8 +72,8 @@ SCM_INTERNAL void scm_i_pointer_print (SCM pointer, SCM port,
                                        scm_print_state *pstate);
 
 SCM_INTERNAL SCM scm_dereference_pointer (SCM pointer);
-SCM_INTERNAL SCM scm_string_to_pointer (SCM string);
+SCM_INTERNAL SCM scm_string_to_pointer (SCM string, SCM encoding);
-SCM_INTERNAL SCM scm_pointer_to_string (SCM pointer);
+SCM_INTERNAL SCM scm_pointer_to_string (SCM pointer, SCM length, SCM encoding);
 
 
 

libguile/frames.c

@@ -124,7 +124,7 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
   while (p <= sp)
     {
-      if (p + 1 < sp && p[1] == (SCM)0)
+      if (p[0] == (SCM)0)
         /* skip over not-yet-active frame */
         p += 3;
       else
@@ -154,7 +154,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
   while (p <= sp)
     {
-      if (p + 1 < sp && p[1] == (SCM)0)
+      if (p[0] == (SCM)0)
         /* skip over not-yet-active frame */
         p += 3;
       else if (n == i)
@@ -186,7 +186,7 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
   while (p <= sp)
     {
-      if (p + 1 < sp && p[1] == (SCM)0)
+      if (p[0] == (SCM)0)
         /* skip over not-yet-active frame */
         p += 3;
       else if (n == i)

libguile/gc.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011 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 License
@@ -69,10 +69,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
 #include <unistd.h>
 #endif
 
-/* Lock this mutex before doing lazy sweeping.
- */
-scm_i_pthread_mutex_t scm_i_sweep_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
 /* Set this to != 0 if every cell that is accessed shall be checked:
  */
 int scm_debug_cell_accesses_p = 0;
@@ -206,23 +202,13 @@ unsigned long scm_gc_ports_collected = 0;
 static unsigned long protected_obj_count = 0;
 
 
-SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
+SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
 SCM_SYMBOL (sym_heap_size, "heap-size");
 SCM_SYMBOL (sym_heap_free_size, "heap-free-size");
 SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated");
-SCM_SYMBOL (sym_mallocated, "bytes-malloced");
+SCM_SYMBOL (sym_heap_allocated_since_gc, "heap-allocated-since-gc");
-SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
-SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
-SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
-SCM_SYMBOL (sym_gc_mark_time_taken, "gc-mark-time-taken");
-SCM_SYMBOL (sym_times, "gc-times");
-SCM_SYMBOL (sym_cells_marked, "cells-marked");
-SCM_SYMBOL (sym_cells_marked_conservatively, "cells-marked-conservatively");
-SCM_SYMBOL (sym_cells_swept, "cells-swept");
-SCM_SYMBOL (sym_malloc_yield, "malloc-yield");
-SCM_SYMBOL (sym_cell_yield, "cell-yield");
 SCM_SYMBOL (sym_protected_objects, "protected-objects");
-SCM_SYMBOL (sym_total_cells_allocated, "total-cells-allocated");
+SCM_SYMBOL (sym_times, "gc-times");
 
 
 /* Number of calls to SCM_NEWCELL since startup.  */
@@ -287,33 +273,14 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
   total_bytes    = GC_get_total_bytes ();
   gc_times       = GC_gc_no;
 
-  /* njrev: can any of these scm_cons's or scm_list_n signal a memory
-     error?  If so we need a frame here. */
   answer =
     scm_list_n (scm_cons (sym_gc_time_taken, SCM_INUM0),
-#if 0
-		scm_cons (sym_cells_allocated,
-			  scm_from_ulong (local_scm_cells_allocated)),
-		scm_cons (sym_mallocated,
-			  scm_from_ulong (local_scm_mallocated)),
-		scm_cons (sym_mtrigger,
-			  scm_from_ulong (local_scm_mtrigger)),
-		scm_cons (sym_gc_mark_time_taken,
-			  scm_from_ulong (local_scm_gc_mark_time_taken)),
-		scm_cons (sym_cells_marked,
-			  scm_from_double (local_scm_gc_cells_marked)),
-		scm_cons (sym_cells_swept,
-			  scm_from_double (local_scm_gc_cells_swept)),
-		scm_cons (sym_malloc_yield,
-			  scm_from_long (local_scm_gc_malloc_yield_percentage)),
-		scm_cons (sym_cell_yield,
-			  scm_from_long (local_scm_gc_cell_yield_percentage)),
-		scm_cons (sym_heap_segments, heap_segs),
-#endif
 		scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
 		scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
 		scm_cons (sym_heap_total_allocated,
 			  scm_from_size_t (total_bytes)),
+                scm_cons (sym_heap_allocated_since_gc,
+			  scm_from_size_t (bytes_since_gc)),
 		scm_cons (sym_protected_objects,
 			  scm_from_ulong (protected_obj_count)),
 		scm_cons (sym_times, scm_from_size_t (gc_times)),
@@ -377,17 +344,7 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
 	    "no longer accessible.")
 #define FUNC_NAME s_scm_gc
 {
-  scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
   scm_i_gc ("call");
-  /* njrev: It looks as though other places, e.g. scm_realloc,
-     can call scm_i_gc without acquiring the sweep mutex.  Does this
-     matter?  Also scm_i_gc (or its descendants) touch the
-     scm_sys_protects, which are protected in some cases
-     (e.g. scm_permobjs above in scm_gc_stats) by a critical section,
-     not by the sweep mutex.  Shouldn't all the GC-relevant objects be
-     protected in the same way? */
-  scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
-  scm_c_hook_run (&scm_after_gc_c_hook, 0);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -587,6 +544,23 @@ scm_gc_unregister_roots (SCM *b, unsigned long n)
     scm_gc_unregister_root (p);
 }
 
+static void
+scm_c_register_gc_callback (void *key, void (*func) (void *, void *),
+                            void *data)
+{
+  if (!key)
+    key = GC_MALLOC_ATOMIC (sizeof (void*));
+  
+  GC_REGISTER_FINALIZER_NO_ORDER (key, func, data, NULL, NULL);
+}
+
+static void
+system_gc_callback (void *key, void *data)
+{
+  scm_c_register_gc_callback (key, system_gc_callback, data);
+  scm_c_hook_run (&scm_after_gc_c_hook, NULL);
+}
+
 
 
 
@@ -642,6 +616,8 @@ scm_storage_prehistory ()
   scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
   scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
   scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
+
+  scm_c_register_gc_callback (NULL, system_gc_callback, NULL);
 }
 
 scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;

libguile/gdbint.c

@@ -1,5 +1,5 @@
 /* GDB interface for Guile
- * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009
+ * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -248,15 +248,13 @@ scm_init_gdbint ()
   SCM port;
 
   scm_print_carefully_p = 0;
-  
+
-  port = scm_mkstrport (SCM_INUM0,
+  port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
-			scm_c_make_string (0, SCM_UNDEFINED),
 			SCM_OPN | SCM_WRTNG,
 			s);
   gdb_output_port = scm_permanent_object (port);
-  
+
-  port = scm_mkstrport (SCM_INUM0,
+  port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
-			scm_c_make_string (0, SCM_UNDEFINED),
 			SCM_OPN | SCM_RDNG | SCM_WRTNG,
 			s);
   gdb_input_port = scm_permanent_object (port);

libguile/gen-scmconfig.c

@@ -318,6 +318,24 @@ main (int argc, char *argv[])
   pf ("#define SCM_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER %d /* 0 or 1 */\n",
       SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER);
 
+#ifdef HAVE_GC_PTHREAD_CANCEL
+  pf ("#define SCM_HAVE_GC_PTHREAD_CANCEL 1 /* 0 or 1 */\n");
+#else
+  pf ("#define SCM_HAVE_GC_PTHREAD_CANCEL 0 /* 0 or 1 */\n");
+#endif
+
+#ifdef HAVE_GC_PTHREAD_EXIT
+  pf ("#define SCM_HAVE_GC_PTHREAD_EXIT 1 /* 0 or 1 */\n");
+#else
+  pf ("#define SCM_HAVE_GC_PTHREAD_EXIT 0 /* 0 or 1 */\n");
+#endif
+
+#ifdef HAVE_GC_PTHREAD_SIGMASK
+  pf ("#define SCM_HAVE_GC_PTHREAD_SIGMASK 1 /* 0 or 1 */\n");
+#else
+  pf ("#define SCM_HAVE_GC_PTHREAD_SIGMASK 0 /* 0 or 1 */\n");
+#endif
+
   pf ("\n\n/*** File system access ***/\n");
 
   pf ("/* Define to 1 if `struct dirent64' is available.  */\n");

libguile/goops.c

@@ -670,7 +670,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
     SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
 		    scm_list_1 (nfields));
 
-  layout = scm_i_make_string (n, &s);
+  layout = scm_i_make_string (n, &s, 0);
   i = 0;
   while (scm_is_pair (getters_n_setters))
     {

libguile/guile-snarf.in

@@ -51,7 +51,20 @@ modern_snarf ()                         # writes stdout
     ## empty file.
     echo "/* cpp arguments: $@ */" ;
     ${cpp} -DSCM_MAGIC_SNARF_INITS -DSCM_MAGIC_SNARFER "$@" > ${temp} && cpp_ok_p=true
-    grep "^ *\^ *\^" ${temp} | sed -e "s/ *\^ *\^//g" -e "s/\^ *: *\^/;/g"
+    sed -ne 's/ *\^ *: *\^/\
+/
+h
+s/\n.*//
+t x
+d
+: x
+s/.*\^ *\^ *\(.*\)/\1;/
+t y
+d
+: y
+p
+x
+D' ${temp}
 }
 
 ## main

libguile/hashtab.c

@@ -33,6 +33,7 @@
 #include "libguile/root.h"
 #include "libguile/vectors.h"
 #include "libguile/ports.h"
+#include "libguile/bdw-gc.h"
 
 #include "libguile/validate.h"
 #include "libguile/hashtab.h"
@@ -120,6 +121,26 @@ scm_fixup_weak_alist (SCM alist, size_t *removed_items)
   return result;
 }
 
+static void
+vacuum_weak_hash_table (SCM table)
+{
+  SCM buckets = SCM_HASHTABLE_VECTOR (table);
+  unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+  size_t len = SCM_HASHTABLE_N_ITEMS (table);
+
+  while (k--)
+    {
+      size_t removed;
+      SCM alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
+      alist = scm_fixup_weak_alist (alist, &removed);
+      assert (removed <= len);
+      len -= removed;
+      SCM_SIMPLE_VECTOR_SET (buckets, k, alist);
+    }
+
+  SCM_SET_HASHTABLE_N_ITEMS (table, len);
+}
+
 
 /* Packed arguments for `do_weak_bucket_fixup'.  */
 struct t_fixup_args
@@ -397,6 +418,34 @@ SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
 }
 #undef FUNC_NAME
 
+static void
+weak_gc_callback (void *ptr, void *data)
+{
+  void **weak = ptr;
+  void *val = *weak;
+  
+  if (val)
+    {
+      void (*callback) (SCM) = data;
+
+      GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_callback, data, NULL, NULL);
+      
+      callback (PTR2SCM (val));
+    }
+}
+
+static void
+scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
+{
+  void **weak = GC_MALLOC_ATOMIC (sizeof (void**));
+
+  *weak = SCM2PTR (obj);
+  GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
+
+  GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_callback, (void*)callback,
+                                  NULL, NULL);
+}
+
 SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, 
 	    (SCM n),
 	    "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
@@ -407,11 +456,17 @@ SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
 	    "would modify regular hash tables. (@pxref{Hash Tables})")
 #define FUNC_NAME s_scm_make_weak_key_hash_table
 {
+  SCM ret;
+
   if (SCM_UNBNDP (n))
-    return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
+    ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
   else
-    return make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
+    ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
-			    scm_to_ulong (n), FUNC_NAME);
+                           scm_to_ulong (n), FUNC_NAME);
+
+  scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
+
+  return ret;
 }
 #undef FUNC_NAME
 
@@ -422,13 +477,17 @@ SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1,
 	    "(@pxref{Hash Tables})")
 #define FUNC_NAME s_scm_make_weak_value_hash_table
 {
+  SCM ret;
+
   if (SCM_UNBNDP (n))
-    return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
+    ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
   else
-    {
+    ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
-      return make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
+                           scm_to_ulong (n), FUNC_NAME);
-			      scm_to_ulong (n), FUNC_NAME);
+
-    }
+  scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
+
+  return ret;
 }
 #undef FUNC_NAME
 
@@ -439,16 +498,18 @@ SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0
 	    "buckets.  (@pxref{Hash Tables})")
 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
 {
+  SCM ret;
+
   if (SCM_UNBNDP (n))
-    return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
+    ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
-			    0,
+                           0, FUNC_NAME);
-			    FUNC_NAME);
   else
-    {
+    ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
-      return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
+                           scm_to_ulong (n), FUNC_NAME);
-			      scm_to_ulong (n),
+
-			      FUNC_NAME);
+  scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
-    }
+
+  return ret;
 }
 #undef FUNC_NAME
 
@@ -651,12 +712,9 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
 	}
       SCM_SETCDR (new_bucket, SCM_SIMPLE_VECTOR_REF (buckets, k));
       SCM_SIMPLE_VECTOR_SET (buckets, k, new_bucket);
-      /* Update element count and maybe rehash the table.  The
-         table might have too few entries here since weak hash
-         tables used with the hashx_* functions can not be
-         rehashed after GC.
-      */
       SCM_HASHTABLE_INCREMENT (table);
+
+      /* Maybe rehash the table.  */
       if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)
           || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table))
         scm_i_rehash (table, hash_fn, closure, FUNC_NAME);

libguile/i18n.c

@@ -766,16 +766,10 @@ compare_u32_strings (SCM s1, SCM s2, SCM locale, const char *func_name)
 static const char *
 locale_language ()
 {
-  /* FIXME: If the locale has been set with 'uselocale',
+  /* Note: If the locale has been set with 'uselocale', uc_locale_language
-     libunistring's uc_locale_language will return the incorrect
+     from libunistring versions 0.9.1 and older will return the incorrect
-     language: it will return the language appropriate for the global
+     (non-thread-specific) locale.  This is fixed in versions 0.9.2 and
-     (non-thread-specific) locale.
+     newer.  */
-
-     There appears to be no portable way to extract the language from
-     the thread-specific locale_t.  There is no LANGUAGE capability in
-     nl_langinfo or nl_langinfo_l.
-
-     Thus, uc_locale_language needs to be fixed upstream.  */
   return uc_locale_language ();
 }
 
@@ -1113,23 +1107,19 @@ chr_to_case (SCM chr, scm_t_locale c_locale,
 #define FUNC_NAME func_name
 {
   int ret;
-  scm_t_wchar *buf;
+  scm_t_uint32 c;
   scm_t_uint32 *convbuf;
   size_t convlen;
-  SCM str, convchar;
+  SCM convchar;
 
-  str = scm_i_make_wide_string (1, &buf);
+  c = SCM_CHAR (chr);
-  buf[0] = SCM_CHAR (chr);
 
   if (c_locale != NULL)
     RUN_IN_LOCALE_SECTION (c_locale, ret =
-                           u32_locale_tocase ((scm_t_uint32 *) buf, 1,
+                           u32_locale_tocase (&c, 1, &convbuf, &convlen, func));
-                                              &convbuf,
-                                              &convlen, func));
   else
     ret =
-      u32_locale_tocase ((scm_t_uint32 *) buf, 1, &convbuf,
+      u32_locale_tocase (&c, 1, &convbuf, &convlen, func);
-                         &convlen, func);
 
   if (SCM_UNLIKELY (ret != 0))
     {
@@ -1256,7 +1246,7 @@ str_to_case (SCM str, scm_t_locale c_locale,
       return NULL;
     }
 
-  convstr = scm_i_make_wide_string (convlen, &c_buf);
+  convstr = scm_i_make_wide_string (convlen, &c_buf, 0);
   memcpy (c_buf, c_convstr, convlen * sizeof (scm_t_wchar));
   free (c_convstr);
 
@@ -1564,11 +1554,14 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
 	  {
 	    char *p;
 
-	    /* In this cases, the result is to be interpreted as a list of
+	    /* In this cases, the result is to be interpreted as a list
-	       numbers.  If the last item is `CHARS_MAX', it has the special
+	       of numbers.  If the last item is `CHAR_MAX' or a negative
-	       meaning "no more grouping".  */
+	       number, it has the special meaning "no more grouping"
+	       (negative numbers aren't specified in POSIX but can be
+	       used by glibc; see
+	       <http://lists.gnu.org/archive/html/bug-guile/2011-02/msg00159.html>).  */
 	    result = SCM_EOL;
-	    for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++)
+	    for (p = c_result; (*p > 0) && (*p != CHAR_MAX); p++)
 	      result = scm_cons (SCM_I_MAKINUM ((int) *p), result);
 
 	    {
@@ -1576,7 +1569,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
 
 	      result = scm_reverse_x (result, SCM_EOL);
 
-	      if (*p != CHAR_MAX)
+	      if (*p == 0)
 		{
 		  /* Cyclic grouping information.  */
 		  if (last_pair != SCM_EOL)

libguile/init.c

@@ -157,7 +157,6 @@ typedef struct
 {
   int fdes;
   char *mode;
-  char *name;
 } stream_body_data;
 
 /* proc to be called in scope of exception handler stream_handler. */
@@ -165,8 +164,7 @@ static SCM
 stream_body (void *data)
 {
   stream_body_data *body_data = (stream_body_data *) data;
-  SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode,
+  SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode, SCM_BOOL_F);
-			       scm_from_locale_string (body_data->name));
 
   SCM_REVEALED (port) = 1;
   return port;
@@ -182,21 +180,19 @@ stream_handler (void *data SCM_UNUSED,
 }
 
 /* Convert a file descriptor to a port, using scm_fdes_to_port.
-   - NAME is a C string, not a Guile string
    - set the revealed count for FILE's file descriptor to 1, so
    that fdes won't be closed when the port object is GC'd.
    - catch exceptions: allow Guile to be able to start up even
    if it has been handed bogus stdin/stdout/stderr.  replace the
    bad ports with void ports.  */
 static SCM
-scm_standard_stream_to_port (int fdes, char *mode, char *name)
+scm_standard_stream_to_port (int fdes, char *mode)
 {
   SCM port;
   stream_body_data body_data;
 
   body_data.fdes = fdes;
   body_data.mode = mode;
-  body_data.name = name;
   port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data, 
 			     stream_handler, NULL);
   if (scm_is_false (port))
@@ -223,17 +219,11 @@ scm_init_standard_ports ()
      block buffering for higher performance.  */
 
   scm_set_current_input_port 
-    (scm_standard_stream_to_port (0, 
+    (scm_standard_stream_to_port (0, isatty (0) ? "r0" : "r"));
-				  isatty (0) ? "r0" : "r",
-				  "standard input"));
   scm_set_current_output_port
-    (scm_standard_stream_to_port (1,
+    (scm_standard_stream_to_port (1, isatty (1) ? "w0" : "w"));
-				  isatty (1) ? "w0" : "w",
-				  "standard output"));
   scm_set_current_error_port
-    (scm_standard_stream_to_port (2,
+    (scm_standard_stream_to_port (2, isatty (2) ? "w0" : "w"));
-				  isatty (2) ? "w0" : "w",
-				  "standard error"));
 }
 
 
@@ -386,17 +376,11 @@ cleanup_for_exit ()
 }
 
 void
-scm_i_init_guile (SCM_STACKITEM *base)
+scm_i_init_guile (void *base)
 {
   if (scm_initialized_p)
     return;
 
-  if (base == NULL)
-    {
-      fprintf (stderr, "cannot determine stack base!\n");
-      abort ();
-    }
-
   if (sizeof (mpz_t) > (3 * sizeof (scm_t_bits)))
     {
       fprintf (stderr,

libguile/init.h

@@ -3,7 +3,7 @@
 #ifndef SCM_INIT_H
 #define SCM_INIT_H
 
-/* Copyright (C) 1995,1996,1997,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,2000, 2006, 2008, 2011 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 License
@@ -38,7 +38,7 @@ SCM_API void scm_boot_guile (int argc, char **argv,
 						char **argv),
 			     void *closure);
 
-SCM_INTERNAL void scm_i_init_guile (SCM_STACKITEM *base);
+SCM_INTERNAL void scm_i_init_guile (void *base);
 
 SCM_API void scm_load_startup_files (void);
 

libguile/modules.c

@@ -56,6 +56,9 @@ static SCM module_public_interface_var;
 static SCM module_export_x_var;
 static SCM default_duplicate_binding_procedures_var;
 
+/* The #:ensure keyword.  */
+static SCM k_ensure;
+
 
 static SCM unbound_variable (const char *func, SCM sym)
 {
@@ -751,6 +754,124 @@ scm_lookup (SCM sym)
   return var;
 }
 
+SCM
+scm_public_variable (SCM module_name, SCM name)
+{
+  SCM mod, iface;
+  
+  mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
+                    k_ensure, SCM_BOOL_F);
+
+  if (scm_is_false (mod))
+    scm_misc_error ("public-lookup", "Module named ~s does not exist",
+                    scm_list_1 (module_name));
+  
+  iface = scm_module_public_interface (mod);
+
+  if (scm_is_false (iface))
+    scm_misc_error ("public-lookup", "Module ~s has no public interface",
+                    scm_list_1 (mod));
+  
+  return scm_module_variable (iface, name);
+}
+
+SCM
+scm_private_variable (SCM module_name, SCM name)
+{
+  SCM mod;
+  
+  mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
+                    k_ensure, SCM_BOOL_F);
+
+  if (scm_is_false (mod))
+    scm_misc_error ("private-lookup", "Module named ~s does not exist",
+                    scm_list_1 (module_name));
+  
+  return scm_module_variable (mod, name);
+}
+
+SCM
+scm_c_public_variable (const char *module_name, const char *name)
+{
+  return scm_public_variable (convert_module_name (module_name),
+                              scm_from_locale_symbol (name));
+}
+
+SCM
+scm_c_private_variable (const char *module_name, const char *name)
+{
+  return scm_private_variable (convert_module_name (module_name),
+                               scm_from_locale_symbol (name));
+}
+
+SCM
+scm_public_lookup (SCM module_name, SCM name)
+{
+  SCM var;
+  
+  var = scm_public_variable (module_name, name);
+
+  if (scm_is_false (var))
+    scm_misc_error ("public-lookup", "No variable bound to ~s in module ~s",
+                    scm_list_2 (name, module_name));
+  
+  return var;
+}
+
+SCM
+scm_private_lookup (SCM module_name, SCM name)
+{
+  SCM var;
+  
+  var = scm_private_variable (module_name, name);
+
+  if (scm_is_false (var))
+    scm_misc_error ("private-lookup", "No variable bound to ~s in module ~s",
+                    scm_list_2 (name, module_name));
+  
+  return var;
+}
+
+SCM
+scm_c_public_lookup (const char *module_name, const char *name)
+{
+  return scm_public_lookup (convert_module_name (module_name),
+                            scm_from_locale_symbol (name));
+}
+
+SCM
+scm_c_private_lookup (const char *module_name, const char *name)
+{
+  return scm_private_lookup (convert_module_name (module_name),
+                             scm_from_locale_symbol (name));
+}
+
+SCM
+scm_public_ref (SCM module_name, SCM name)
+{
+  return scm_variable_ref (scm_public_lookup (module_name, name));
+}
+
+SCM
+scm_private_ref (SCM module_name, SCM name)
+{
+  return scm_variable_ref (scm_private_lookup (module_name, name));
+}
+
+SCM
+scm_c_public_ref (const char *module_name, const char *name)
+{
+  return scm_public_ref (convert_module_name (module_name),
+                         scm_from_locale_symbol (name));
+}
+
+SCM
+scm_c_private_ref (const char *module_name, const char *name)
+{
+  return scm_private_ref (convert_module_name (module_name),
+                          scm_from_locale_symbol (name));
+}
+
 SCM
 scm_c_module_define (SCM module, const char *name, SCM value)
 {
@@ -903,6 +1024,7 @@ scm_post_boot_init_modules ()
   default_duplicate_binding_procedures_var = 
     scm_c_lookup ("default-duplicate-binding-procedures");
   module_public_interface_var = scm_c_lookup ("module-public-interface");
+  k_ensure = scm_from_locale_keyword ("ensure");
 
   scm_module_system_booted_p = 1;
 }

libguile/modules.h

@@ -3,7 +3,7 @@
 #ifndef SCM_MODULES_H
 #define SCM_MODULES_H
 
-/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008, 2011 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 License
@@ -93,6 +93,21 @@ SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM val);
 SCM_API SCM scm_module_export (SCM module, SCM symbol_list);
 SCM_API SCM scm_module_reverse_lookup (SCM module, SCM variable);
 
+SCM_API SCM scm_public_variable (SCM module_name, SCM name);
+SCM_API SCM scm_private_variable (SCM module_name, SCM name);
+SCM_API SCM scm_c_public_variable (const char *module_name, const char *name);
+SCM_API SCM scm_c_private_variable (const char *module_name, const char *name);
+
+SCM_API SCM scm_public_lookup (SCM module_name, SCM name);
+SCM_API SCM scm_private_lookup (SCM module_name, SCM name);
+SCM_API SCM scm_c_public_lookup (const char *module_name, const char *name);
+SCM_API SCM scm_c_private_lookup (const char *module_name, const char *name);
+
+SCM_API SCM scm_public_ref (SCM module_name, SCM name);
+SCM_API SCM scm_private_ref (SCM module_name, SCM name);
+SCM_API SCM scm_c_public_ref (const char *module_name, const char *name);
+SCM_API SCM scm_c_private_ref (const char *module_name, const char *name);
+
 SCM_API SCM scm_c_resolve_module (const char *name);
 SCM_API SCM scm_resolve_module (SCM name);
 SCM_API SCM scm_c_define_module (const char *name,

libguile/numbers.c

@@ -146,7 +146,7 @@ static double atanh (double x) { return 0.5 * log ((1 + x) / (1 - x)); }
 
 
 #if defined (GUILE_I)
-#if HAVE_COMPLEX_DOUBLE
+#if defined HAVE_COMPLEX_DOUBLE
 
 /* For an SCM object Z which is a complex number (ie. satisfies
    SCM_COMPLEXP), return its value as a C level "complex double". */
@@ -5668,7 +5668,7 @@ mem2decimal_from_point (SCM result, SCM mem,
 	  if (sign == 1)
 	    result = scm_product (result, e);
 	  else
-	    result = scm_divide2real (result, e);
+	    result = scm_divide (result, e);
 
 	  /* We've seen an exponent, thus the value is implicitly inexact. */
 	  x = INEXACT;
@@ -9449,7 +9449,8 @@ SCM_PRIMITIVE_GENERIC (scm_log, "log", 1, 0, 0,
 {
   if (SCM_COMPLEXP (z))
     {
-#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG && defined (SCM_COMPLEX_VALUE)
+#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
+  && defined (SCM_COMPLEX_VALUE)
       return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
 #else
       double re = SCM_COMPLEX_REAL (z);
@@ -9534,7 +9535,8 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0,
 {
   if (SCM_COMPLEXP (z))
     {
-#if HAVE_COMPLEX_DOUBLE && HAVE_CEXP && defined (SCM_COMPLEX_VALUE)
+#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
+  && defined (SCM_COMPLEX_VALUE)
       return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
 #else
       return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
@@ -9553,6 +9555,70 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0,
 #undef FUNC_NAME
 
 
+SCM_DEFINE (scm_i_exact_integer_sqrt, "exact-integer-sqrt", 1, 0, 0,
+	    (SCM k),
+	    "Return two exact non-negative integers @var{s} and @var{r}\n"
+	    "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
+	    "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
+	    "An error is raised if @var{k} is not an exact non-negative integer.\n"
+	    "\n"
+	    "@lisp\n"
+	    "(exact-integer-sqrt 10) @result{} 3 and 1\n"
+	    "@end lisp")
+#define FUNC_NAME s_scm_i_exact_integer_sqrt
+{
+  SCM s, r;
+
+  scm_exact_integer_sqrt (k, &s, &r);
+  return scm_values (scm_list_2 (s, r));
+}
+#undef FUNC_NAME
+
+void
+scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp)
+{
+  if (SCM_LIKELY (SCM_I_INUMP (k)))
+    {
+      scm_t_inum kk = SCM_I_INUM (k);
+      scm_t_inum uu = kk;
+      scm_t_inum ss;
+
+      if (SCM_LIKELY (kk > 0))
+	{
+	  do
+	    {
+	      ss = uu;
+	      uu = (ss + kk/ss) / 2;
+	    } while (uu < ss);
+	  *sp = SCM_I_MAKINUM (ss);
+	  *rp = SCM_I_MAKINUM (kk - ss*ss);
+	}
+      else if (SCM_LIKELY (kk == 0))
+	*sp = *rp = SCM_INUM0;
+      else
+	scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
+				"exact non-negative integer");
+    }
+  else if (SCM_LIKELY (SCM_BIGP (k)))
+    {
+      SCM s, r;
+
+      if (mpz_sgn (SCM_I_BIG_MPZ (k)) < 0)
+	scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
+				"exact non-negative integer");
+      s = scm_i_mkbig ();
+      r = scm_i_mkbig ();
+      mpz_sqrtrem (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (k));
+      scm_remember_upto_here_1 (k);
+      *sp = scm_i_normbig (s);
+      *rp = scm_i_normbig (r);
+    }
+  else
+    scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
+			    "exact non-negative integer");
+}
+
+
 SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
 		       (SCM z),
 	"Return the square root of @var{z}.  Of the two possible roots\n"

libguile/numbers.h

@@ -289,6 +289,7 @@ SCM_API SCM scm_log (SCM z);
 SCM_API SCM scm_log10 (SCM z);
 SCM_API SCM scm_exp (SCM z);
 SCM_API SCM scm_sqrt (SCM z);
+SCM_API void scm_exact_integer_sqrt (SCM k, SCM *s, SCM *r);
 
 SCM_INTERNAL SCM scm_i_min (SCM x, SCM y, SCM rest);
 SCM_INTERNAL SCM scm_i_max (SCM x, SCM y, SCM rest);
@@ -296,6 +297,7 @@ SCM_INTERNAL SCM scm_i_sum (SCM x, SCM y, SCM rest);
 SCM_INTERNAL SCM scm_i_difference (SCM x, SCM y, SCM rest);
 SCM_INTERNAL SCM scm_i_product (SCM x, SCM y, SCM rest);
 SCM_INTERNAL SCM scm_i_divide (SCM x, SCM y, SCM rest);
+SCM_INTERNAL SCM scm_i_exact_integer_sqrt (SCM k);
 
 /* bignum internal functions */
 SCM_INTERNAL SCM scm_i_mkbig (void);

libguile/objcodes.c

@@ -23,12 +23,18 @@
 #include <string.h>
 #include <fcntl.h>
 #include <unistd.h>
+
+#ifdef HAVE_SYS_MMAN_H
 #include <sys/mman.h>
+#endif
+
 #include <sys/stat.h>
 #include <sys/types.h>
 #include <assert.h>
 #include <alignof.h>
 
+#include <full-read.h>
+
 #include "_scm.h"
 #include "programs.h"
 #include "objcodes.h"
@@ -44,6 +50,52 @@ verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
  * Objcode type
  */
 
+static void
+verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
+#define FUNC_NAME "make_objcode_from_file"
+{
+  /* The cookie ends with a version of the form M.N, where M is the
+     major version and N is the minor version.  For this Guile to be
+     able to load an objcode, M must be SCM_OBJCODE_MAJOR_VERSION, and N
+     must be less than or equal to SCM_OBJCODE_MINOR_VERSION.  Since N
+     is the last character, we do a strict comparison on all but the
+     last, then a <= on the last one.  */
+  if (memcmp (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE) - 1))
+    {
+      SCM args = scm_list_1 (scm_from_latin1_stringn
+                             (cookie, strlen (SCM_OBJCODE_COOKIE)));
+      if (map_fd >= 0)
+        {
+          (void) close (map_fd);
+#ifdef HAVE_SYS_MMAN_H
+          (void) munmap (map_addr, st->st_size);
+#endif
+        }
+      scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
+    }
+
+  {
+    char minor_version = cookie[strlen (SCM_OBJCODE_COOKIE) - 1];
+
+    if (minor_version > SCM_OBJCODE_MINOR_VERSION_STRING[0])
+      {
+        if (map_fd >= 0)
+          {
+            (void) close (map_fd);
+#ifdef HAVE_SYS_MMAN_H
+            (void) munmap (map_addr, st->st_size);
+#endif
+          }
+
+        scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)",
+                        scm_list_2 (scm_from_latin1_stringn (&minor_version, 1),
+                                    scm_from_latin1_string
+                                    (SCM_OBJCODE_MINOR_VERSION_STRING)));
+      }
+  }
+}
+#undef FUNC_NAME
+
 /* The words in an objcode SCM object are as follows:
      - scm_tc7_objcode | type | flags
      - the struct scm_objcode C object
@@ -53,77 +105,91 @@ verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
  */
 
 static SCM
-make_objcode_by_mmap (int fd)
+make_objcode_from_file (int fd)
-#define FUNC_NAME "make_objcode_by_mmap"
+#define FUNC_NAME "make_objcode_from_file"
 {
   int ret;
-  char *addr;
+  /* The SCM_OBJCODE_COOKIE is a string literal, and thus has an extra
+     trailing NUL, hence the - 1. */
+  char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
   struct stat st;
-  SCM sret = SCM_BOOL_F;
-  struct scm_objcode *data;
 
   ret = fstat (fd, &st);
   if (ret < 0)
     SCM_SYSERROR;
 
-  if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE))
+  if (st.st_size <= sizeof (struct scm_objcode) + sizeof cookie)
     scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
 		    scm_list_1 (SCM_I_MAKINUM (st.st_size)));
 
-  addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
+#ifdef HAVE_SYS_MMAN_H
-  if (addr == MAP_FAILED)
-    {
-      (void) close (fd);
-      SCM_SYSERROR;
-    }
-
-  /* The cookie ends with a version of the form M.N, where M is the
-     major version and N is the minor version.  For this Guile to be
-     able to load an objcode, M must be SCM_OBJCODE_MAJOR_VERSION, and N
-     must be less than or equal to SCM_OBJCODE_MINOR_VERSION.  Since N
-     is the last character, we do a strict comparison on all but the
-     last, then a <= on the last one.  */
-  if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE) - 1))
-    {
-      SCM args = scm_list_1 (scm_from_latin1_stringn
-                             (addr, strlen (SCM_OBJCODE_COOKIE)));
-      (void) close (fd);
-      (void) munmap (addr, st.st_size);
-      scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
-    }
-
   {
-    char minor_version = addr[strlen (SCM_OBJCODE_COOKIE) - 1];
+    char *addr;
+    struct scm_objcode *data;
 
-    if (minor_version > SCM_OBJCODE_MINOR_VERSION_STRING[0])
+    addr = mmap (0, st.st_size, PROT_READ, MAP_PRIVATE, fd, 0);
-      scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)",
+
-                      scm_list_2 (scm_from_latin1_stringn (&minor_version, 1),
+    if (addr == MAP_FAILED)
-                                  scm_from_latin1_string
+      {
-                                  (SCM_OBJCODE_MINOR_VERSION_STRING)));
+        int errno_save = errno;
+        (void) close (fd);
+        errno = errno_save;
+        SCM_SYSERROR;
+      }
+    else
+      {
+        memcpy (cookie, addr, sizeof cookie);
+        data = (struct scm_objcode *) (addr + sizeof cookie);
+      }
+
+    verify_cookie (cookie, &st, fd, addr);
+
+
+    if (data->len + data->metalen
+        != (st.st_size - sizeof (*data) - sizeof cookie))
+      {
+        size_t total_len = sizeof (*data) + data->len + data->metalen;
+
+        (void) close (fd);
+        (void) munmap (addr, st.st_size);
+
+        scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
+                        scm_list_2 (scm_from_size_t (st.st_size),
+                                    scm_from_size_t (total_len)));
+      }
+
+    /* FIXME: we leak ourselves and the file descriptor. but then again so does
+       dlopen(). */
+    return scm_permanent_object
+      (scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0),
+                        (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
+                        SCM_UNPACK (scm_from_int (fd)), 0));
   }
+#else
+  {
+    SCM bv = scm_c_make_bytevector (st.st_size - sizeof cookie);
 
-  data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE));
+    if (full_read (fd, cookie, sizeof cookie) != sizeof cookie
+        || full_read (fd, SCM_BYTEVECTOR_CONTENTS (bv),
+                      SCM_BYTEVECTOR_LENGTH (bv)) != SCM_BYTEVECTOR_LENGTH (bv))
+      {
+        int errno_save = errno;
+        (void) close (fd);
+        errno = errno_save;
+        SCM_SYSERROR;
+      }
 
-  if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE)))
+    (void) close (fd);
-    {
-      (void) close (fd);
-      (void) munmap (addr, st.st_size);
-      scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
-		      scm_list_2 (scm_from_size_t (st.st_size),
-				  scm_from_uint32 (sizeof (*data) + data->len
-						   + data->metalen)));
-    }
 
-  sret = scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0),
+    verify_cookie (cookie, &st, -1, NULL);
-                          (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
-                          SCM_UNPACK (scm_from_int (fd)), 0);
 
-  /* FIXME: we leak ourselves and the file descriptor. but then again so does
+    return scm_bytecode_to_objcode (bv);
-     dlopen(). */
+  }
-  return scm_permanent_object (sret);
+#endif
 }
 #undef FUNC_NAME
 
+
 SCM
 scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
 #define FUNC_NAME "make-objcode-slice"
@@ -233,7 +299,7 @@ SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
   free (c_file);
   if (fd < 0) SCM_SYSERROR;
 
-  return make_objcode_by_mmap (fd);
+  return make_objcode_from_file (fd);
 }
 #undef FUNC_NAME
 

libguile/ports.c

@@ -352,7 +352,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
 
   if (count)
     {
-      result = scm_i_make_string (count, &data);
+      result = scm_i_make_string (count, &data, 0);
       scm_take_from_input_buffers (port, data, count);
     }
   else
@@ -522,12 +522,9 @@ static void finalize_port (GC_PTR, GC_PTR);
 static SCM_C_INLINE_KEYWORD void
 register_finalizer_for_port (SCM port)
 {
-  long port_type;
   GC_finalization_proc prev_finalizer;
   GC_PTR prev_finalization_data;
 
-  port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
-
   /* Register a finalizer for PORT so that its iconv CDs get freed and
      optionally its type's `free' function gets called.  */
   GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0,
@@ -661,6 +658,19 @@ scm_i_remove_port (SCM port)
   scm_port_non_buffer (p);
   p->putback_buf = NULL;
   p->putback_buf_size = 0;
+
+  if (p->input_cd != (iconv_t) -1)
+    {
+      iconv_close (p->input_cd);
+      p->input_cd = (iconv_t) -1;
+    }
+  
+  if (p->output_cd != (iconv_t) -1)
+    {
+      iconv_close (p->output_cd);
+      p->output_cd = (iconv_t) -1;
+    }
+
   SCM_SETPTAB_ENTRY (port, 0);
 
   scm_hashq_remove_x (scm_i_port_weak_hash, port);
@@ -1929,9 +1939,8 @@ SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
 
 SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
             (SCM port),
-	    "Return the filename associated with @var{port}.  This function returns\n"
+	    "Return the filename associated with @var{port}, or @code{#f}\n"
-	    "the strings \"standard input\", \"standard output\" and \"standard error\"\n"
+	    "if no filename is associated with the port.")
-	    "when called on the current input, output and error ports respectively.")
 #define FUNC_NAME s_scm_port_filename
 {
   port = SCM_COERCE_OUTPORT (port);
@@ -2099,6 +2108,7 @@ SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0,
 
   enc_str = scm_to_locale_string (enc);
   scm_i_set_port_encoding_x (port, enc_str);
+  free (enc_str);
 
   return SCM_UNSPECIFIED;
 }

libguile/posix.c

@@ -1713,12 +1713,10 @@ SCM_DEFINE (scm_nice, "nice", 1, 0, 0,
 	    "The return value is unspecified.")
 #define FUNC_NAME s_scm_nice
 {
-  int nice_value;
-
   /* nice() returns "prio-NZERO" on success or -1 on error, but -1 can arise
      from "prio-NZERO", so an error must be detected from errno changed */
   errno = 0;
-  nice_value = nice (scm_to_int (incr));
+  nice (scm_to_int (incr));
   if (errno != 0)
     SCM_SYSERROR;
 

libguile/print.c

@@ -309,15 +309,10 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref)
 /* Print the name of a symbol. */
 
 static int
-quote_keywordish_symbol (SCM symbol)
+quote_keywordish_symbols (void)
 {
-  SCM option;
+  SCM option = SCM_PRINT_KEYWORD_STYLE;
 
-  if (scm_i_symbol_ref (symbol, 0) != ':'
-      && scm_i_symbol_ref (symbol, scm_i_symbol_length (symbol) - 1) !=  ':')
-    return 0;
-
-  option = SCM_PRINT_KEYWORD_STYLE;
   if (scm_is_false (option))
     return 0;
   if (scm_is_eq (option, sym_reader))
@@ -325,91 +320,114 @@ quote_keywordish_symbol (SCM symbol)
   return 1;
 }
 
-void
+#define INITIAL_IDENTIFIER_MASK                                      \
-scm_i_print_symbol_name (SCM str, SCM port)
+  (UC_CATEGORY_MASK_Lu | UC_CATEGORY_MASK_Ll | UC_CATEGORY_MASK_Lt   \
-{
+   | UC_CATEGORY_MASK_Lm | UC_CATEGORY_MASK_Lo | UC_CATEGORY_MASK_Mn \
-  /* This points to the first character that has not yet been written to the
+   | UC_CATEGORY_MASK_Nl | UC_CATEGORY_MASK_No | UC_CATEGORY_MASK_Pd \
-   * port. */
+   | UC_CATEGORY_MASK_Pc | UC_CATEGORY_MASK_Po | UC_CATEGORY_MASK_Sc \
-  size_t pos = 0;
+   | UC_CATEGORY_MASK_Sm | UC_CATEGORY_MASK_Sk | UC_CATEGORY_MASK_So \
-  /* This points to the character we're currently looking at. */
+   | UC_CATEGORY_MASK_Co)
-  size_t end;
-  /* If the name contains weird characters, we'll escape them with
-   * backslashes and set this flag; it indicates that we should surround the
-   * name with "#{" and "}#". */
-  int weird = 0;
-  /* Backslashes are not sufficient to make a name weird, but if a name is
-   * weird because of other characters, backslahes need to be escaped too.
-   * The first time we see a backslash, we set maybe_weird, and mw_pos points
-   * to the backslash.  Then if the name turns out to be weird, we re-process
-   * everything starting from mw_pos.
-   * We could instead make backslashes always weird.  This is not necessary
-   * to ensure that the output is (read)-able, but it would make this code
-   * simpler and faster. */
-  int maybe_weird = 0;
-  size_t mw_pos = 0;
-  size_t len = scm_i_symbol_length (str);
-  scm_t_wchar str0 = scm_i_symbol_ref (str, 0);
 
-  if (len == 0 || str0 == '\'' || str0 == '`' || str0 == ','
+#define SUBSEQUENT_IDENTIFIER_MASK                                      \
-      || quote_keywordish_symbol (str) 
+  (INITIAL_IDENTIFIER_MASK                                              \
-      || (str0 == '.' && len == 1)
+   | UC_CATEGORY_MASK_Nd | UC_CATEGORY_MASK_Mc | UC_CATEGORY_MASK_Me)
-      || scm_is_true (scm_i_string_to_number (scm_symbol_to_string (str), 10)))
+
+static int
+symbol_has_extended_read_syntax (SCM sym)
+{
+  size_t pos, len = scm_i_symbol_length (sym);
+  scm_t_wchar c;
+
+  /* The empty symbol.  */
+  if (len == 0)
+    return 1;
+
+  c = scm_i_symbol_ref (sym, 0);
+
+  /* Single dot; conflicts with dotted-pair notation.  */
+  if (len == 1 && c == '.')
+    return 1;
+
+  /* Other initial-character constraints.  */
+  if (c == '\'' || c == '`' || c == ',' || c == '"' || c == ';' || c == '#')
+    return 1;
+  
+  /* Keywords can be identified by trailing colons too.  */
+  if (c == ':' || scm_i_symbol_ref (sym, len - 1) == ':')
+    return quote_keywordish_symbols ();
+  
+  /* Number-ish symbols.  */
+  if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10)))
+    return 1;
+  
+  /* Other disallowed first characters.  */
+  if (!uc_is_general_category_withtable (c, INITIAL_IDENTIFIER_MASK))
+    return 1;
+
+  /* Otherwise, any character that's in the identifier category mask is
+     fine to pass through as-is, provided it's not one of the ASCII
+     delimiters like `;'.  */
+  for (pos = 1; pos < len; pos++)
     {
-      scm_lfwrite ("#{", 2, port);
+      c = scm_i_symbol_ref (sym, pos);
-      weird = 1;
+      if (!uc_is_general_category_withtable (c, SUBSEQUENT_IDENTIFIER_MASK))
+        return 1;
+      else if (c == '"' || c == ';' || c == '#')
+        return 1;
     }
 
-  for (end = pos; end < len; ++end)
+  return 0;
-    switch (scm_i_symbol_ref (str, end))
+}
-      {
+
-#ifdef BRACKETS_AS_PARENS
+static void
-      case '[':
+print_normal_symbol (SCM sym, SCM port)
-      case ']':
+{
-#endif
+  scm_display (scm_symbol_to_string (sym), port);
-      case '(':
+}
-      case ')':
+
-      case '"':
+static void
-      case ';':
+print_extended_symbol (SCM sym, SCM port)
-      case '#':
+{
-      case SCM_WHITE_SPACES:
+  size_t pos, len;
-      case SCM_LINE_INCREMENTORS:
+  scm_t_string_failed_conversion_handler strategy;
-      weird_handler:
+
-	if (maybe_weird)
+  len = scm_i_symbol_length (sym);
-	  {
+  strategy = scm_i_get_conversion_strategy (port);
-	    end = mw_pos;
+
-	    maybe_weird = 0;
+  scm_lfwrite ("#{", 2, port);
-	  }
+
-	if (!weird)
+  for (pos = 0; pos < len; pos++)
-	  {
+    {
-	    scm_lfwrite ("#{", 2, port);
+      scm_t_wchar c = scm_i_symbol_ref (sym, pos);
-	    weird = 1;
+      
-	  }
+      if (uc_is_general_category_withtable (c,
-	if (pos < end)
+                                            SUBSEQUENT_IDENTIFIER_MASK
-	  scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port);
+                                            | UC_CATEGORY_MASK_Zs))
-	{
+        {
-	  char buf[2];
+          if (!display_character (c, port, strategy))
-	  buf[0] = '\\';
+            scm_encoding_error ("print_extended_symbol", errno,
-	  buf[1] = (char) (unsigned char) scm_i_symbol_ref (str, end);
+                                "cannot convert to output locale",
-	  scm_lfwrite (buf, 2, port);
+                                port, SCM_MAKE_CHAR (c));
-	}
+        }
-	pos = end + 1;
+      else
-	break;
+        {
-      case '\\':
+          display_string ("\\x", 1, 2, port, iconveh_question_mark);
-	if (weird)
+          scm_intprint (c, 16, port);
-	  goto weird_handler;
+          display_character (';', port, iconveh_question_mark);
-	if (!maybe_weird)
+        }
-	  {
+    }
-	    maybe_weird = 1;
+
-	    mw_pos = pos;
+  scm_lfwrite ("}#", 2, port);
-	  }
+}
-	break;
+
-      default:
+/* FIXME: allow R6RS hex escapes instead of #{...}#.  */
-	break;
+void
-      }
+scm_i_print_symbol_name (SCM sym, SCM port)
-  if (pos < end)
+{
-    scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port);
+  if (symbol_has_extended_read_syntax (sym))
-  if (weird)
+    print_extended_symbol (sym, port);
-    scm_lfwrite ("}#", 2, port);
+  else
+    print_normal_symbol (sym, port);
 }
 
 void
@@ -862,6 +880,8 @@ display_string (const void *str, int narrow_p,
 
       if (SCM_UNLIKELY (done == (size_t) -1))
 	{
+          int errno_save = errno;
+
 	  /* Reset the `iconv' state.  */
 	  iconv (pt->output_cd, NULL, NULL, NULL, NULL);
 
@@ -873,7 +893,7 @@ display_string (const void *str, int narrow_p,
 	  codepoints_read = offsets[input - utf8_buf] - printed;
 	  printed += codepoints_read;
 
-	  if (errno == EILSEQ &&
+	  if (errno_save == EILSEQ &&
 	      strategy != SCM_FAILED_CONVERSION_ERROR)
 	    {
 	      /* Conversion failed somewhere in INPUT and we want to
@@ -1282,8 +1302,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
   else if (scm_is_false (destination))
     {
       fReturnString = 1;
-      port = scm_mkstrport (SCM_INUM0, 
+      port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
-			    scm_make_string (SCM_INUM0, SCM_UNDEFINED),
 			    SCM_OPN | SCM_WRTNG,
 			    FUNC_NAME);
       destination = port;

libguile/procs.c

@@ -149,7 +149,8 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
   SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
   if (SCM_STRUCT_SETTER_P (proc))
     return SCM_STRUCT_SETTER (proc);
-  if (SCM_PUREGENERICP (proc))
+  if (SCM_PUREGENERICP (proc)
+      && SCM_IS_A_P (proc, scm_class_generic_with_setter))
     /* FIXME: might not be an accessor */
     return SCM_GENERIC_SETTER (proc);
   SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);

libguile/pthread-threads.h

@@ -3,7 +3,7 @@
 #ifndef SCM_PTHREADS_THREADS_H
 #define SCM_PTHREADS_THREADS_H
 
-/* Copyright (C) 2002, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2005, 2006, 2011 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 License
@@ -29,24 +29,39 @@
 #include <pthread.h>
 #include <sched.h>
 
-/* `libgc' intercepts pthread calls by defining wrapping macros.  */
+/* `libgc' defines wrapper procedures for pthread calls.  */
 #include "libguile/bdw-gc.h"
 
 /* Threads 
 */
 #define scm_i_pthread_t                     pthread_t
 #define scm_i_pthread_self                  pthread_self
-#define scm_i_pthread_create                pthread_create
+#define scm_i_pthread_create                GC_pthread_create
-#define scm_i_pthread_detach                pthread_detach
+#define scm_i_pthread_detach                GC_pthread_detach
+
+#if SCM_HAVE_GC_PTHREAD_EXIT
+#define scm_i_pthread_exit                  GC_pthread_exit
+#else
 #define scm_i_pthread_exit                  pthread_exit
+#endif
+
+#if SCM_HAVE_GC_PTHREAD_CANCEL
+#define scm_i_pthread_cancel                GC_pthread_cancel
+#else
 #define scm_i_pthread_cancel                pthread_cancel
+#endif
+
 #define scm_i_pthread_cleanup_push          pthread_cleanup_push
 #define scm_i_pthread_cleanup_pop           pthread_cleanup_pop
 #define scm_i_sched_yield                   sched_yield
 
 /* Signals
  */
+#if SCM_HAVE_GC_PTHREAD_SIGMASK
+#define scm_i_pthread_sigmask               GC_pthread_sigmask
+#else
 #define scm_i_pthread_sigmask               pthread_sigmask
+#endif
 
 /* Mutexes
  */

libguile/r6rs-ports.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011 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 License
@@ -136,7 +136,7 @@ bip_seek (SCM port, scm_t_off offset, int whence)
       /* Fall through.  */
 
     case SEEK_SET:
-      if (c_port->read_buf + offset < c_port->read_end)
+      if (c_port->read_buf + offset <= c_port->read_end)
 	{
 	  c_port->read_pos = c_port->read_buf + offset;
 	  c_result = offset;
@@ -1221,6 +1221,46 @@ SCM_DEFINE (scm_i_make_transcoded_port,
 }
 #undef FUNC_NAME
 
+
+/* Textual I/O */
+
+SCM_DEFINE (scm_get_string_n_x,
+            "get-string-n!", 4, 0, 0,
+            (SCM port, SCM str, SCM start, SCM count),
+            "Read up to @var{count} characters from @var{port} into "
+            "@var{str}, starting at @var{start}.  If no characters "
+            "can be read before the end of file is encountered, the end "
+            "of file object is returned.  Otherwise, the number of "
+            "characters read is returned.")
+#define FUNC_NAME s_scm_get_string_n_x
+{
+  size_t c_start, c_count, c_len, c_end, j;
+  scm_t_wchar c;
+
+  SCM_VALIDATE_OPINPORT (1, port);
+  SCM_VALIDATE_STRING (2, str);
+  c_len = scm_c_string_length (str);
+  c_start = scm_to_size_t (start);
+  c_count = scm_to_size_t (count);
+  c_end = c_start + c_count;
+
+  if (SCM_UNLIKELY (c_end > c_len))
+    scm_out_of_range (FUNC_NAME, count);
+
+  for (j = c_start; j < c_end; j++)
+    {
+      c = scm_getc (port);
+      if (c == EOF)
+        {
+          size_t chars_read = j - c_start;
+          return chars_read == 0 ? SCM_EOF_VAL : scm_from_size_t (chars_read);
+        }
+      scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c));
+    }
+  return count;
+}
+#undef FUNC_NAME
+
 
 /* Initialization.  */
 

libguile/r6rs-ports.h

@@ -1,7 +1,7 @@
 #ifndef SCM_R6RS_PORTS_H
 #define SCM_R6RS_PORTS_H
 
-/* Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011 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 License
@@ -38,6 +38,7 @@ SCM_API SCM scm_put_u8 (SCM, SCM);
 SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM);
 SCM_API SCM scm_open_bytevector_output_port (SCM);
 SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM);
 
 SCM_API void scm_init_r6rs_ports (void);
 SCM_INTERNAL void scm_register_r6rs_ports (void);

libguile/read.c

@@ -516,7 +516,7 @@ scm_read_string (int chr, SCM port)
   unsigned c_str_len = 0;
   scm_t_wchar c;
 
-  str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
+  str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
   while ('"' != (c = scm_getc (port)))
     {
       if (c == EOF)
@@ -528,7 +528,7 @@ scm_read_string (int chr, SCM port)
 
       if (c_str_len + 1 >= scm_i_string_length (str))
         {
-          SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
+          SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
 
           str = scm_string_append (scm_list_2 (str, addy));
         }
@@ -1116,13 +1116,9 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
 {
   int bang_seen = 0;
 
-  /* We can use the get_byte here because there is no need to get the
-     locale correct when reading comments. This presumes that 
-     hash and exclamation points always represent themselves no
-     matter what the source encoding is.*/
   for (;;)
     {
-      int c = scm_get_byte_or_eof (port);
+      int c = scm_getc (port);
 
       if (c == EOF)
 	scm_i_input_error ("skip_block_comment", port,
@@ -1234,9 +1230,9 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port)
        #{This is all a symbol name}#
 
      So here, CHR is expected to be `{'.  */
-  int saw_brace = 0, finished = 0;
+  int saw_brace = 0;
   size_t len = 0;
-  SCM buf = scm_i_make_string (1024, NULL);
+  SCM buf = scm_i_make_string (1024, NULL, 0);
 
   buf = scm_i_string_start_writing (buf);
 
@@ -1246,36 +1242,75 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port)
 	{
 	  if (chr == '#')
 	    {
-	      finished = 1;
 	      break;
 	    }
 	  else
 	    {
 	      saw_brace = 0;
 	      scm_i_string_set_x (buf, len++, '}');
-	      scm_i_string_set_x (buf, len++, chr);
 	    }
 	}
-      else if (chr == '}')
+
+      if (chr == '}')
 	saw_brace = 1;
+      else if (chr == '\\')
+        {
+          /* It used to be that print.c would print extended-read-syntax
+             symbols with backslashes before "non-standard" chars, but
+             this routine wouldn't do anything with those escapes.
+             Bummer.  What we've done is to change print.c to output
+             R6RS hex escapes for those characters, relying on the fact
+             that the extended read syntax would never put a `\' before
+             an `x'.  For now, we just ignore other instances of
+             backslash in the string.  */
+          switch ((chr = scm_getc (port)))
+            {
+            case EOF:
+              goto done;
+            case 'x':
+              {
+                scm_t_wchar c;
+                
+                SCM_READ_HEX_ESCAPE (10, ';');
+                scm_i_string_set_x (buf, len++, c);
+                break;
+
+              str_eof:
+                chr = EOF;
+                goto done;
+
+              bad_escaped:
+                scm_i_string_stop_writing ();
+                scm_i_input_error ("scm_read_extended_symbol", port,
+                                   "illegal character in escape sequence: ~S",
+                                   scm_list_1 (SCM_MAKE_CHAR (c)));
+                break;
+              }
+            default:
+	      scm_i_string_set_x (buf, len++, chr);
+              break;
+            }
+        }
       else
-	scm_i_string_set_x (buf, len++, chr);
+        scm_i_string_set_x (buf, len++, chr);
 
       if (len >= scm_i_string_length (buf) - 2)
 	{
 	  SCM addy;
 
 	  scm_i_string_stop_writing ();
-	  addy = scm_i_make_string (1024, NULL);
+	  addy = scm_i_make_string (1024, NULL, 0);
 	  buf = scm_string_append (scm_list_2 (buf, addy));
 	  len = 0;
 	  buf = scm_i_string_start_writing (buf);
 	}
-
-      if (finished)
-	break;
     }
+
+ done:
   scm_i_string_stop_writing ();
+  if (chr == EOF)
+    scm_i_input_error ("scm_read_extended_symbol", port,
+                       "end of file while reading symbol", SCM_EOL);
 
   return (scm_string_to_symbol (scm_c_substring (buf, 0, len)));
 }
@@ -1333,6 +1368,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
     case 's':
     case 'u':
     case 'f':
+    case 'c':
       /* This one may return either a boolean or an SRFI-4 vector.  */
       return (scm_read_srfi4_vector (chr, port));
     case 'v':
@@ -1352,7 +1388,6 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
 #if SCM_ENABLE_DEPRECATED
       /* See below for 'i' and 'e'. */
     case 'a':
-    case 'c':
     case 'y':
     case 'h':
     case 'l':
@@ -1654,6 +1689,7 @@ scm_get_hash_procedure (int c)
 char *
 scm_i_scan_for_encoding (SCM port)
 {
+  scm_t_port *pt;
   char header[SCM_ENCODING_SEARCH_SIZE+1];
   size_t bytes_read, encoding_length, i;
   char *encoding = NULL;
@@ -1661,15 +1697,46 @@ scm_i_scan_for_encoding (SCM port)
   char *pos, *encoding_start;
   int in_comment;
 
-  if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port)))
+  pt = SCM_PTAB_ENTRY (port);
-    /* PORT is a non-seekable file port (e.g., as created by Bash when using
-       "guile <(echo '(display "hello")')") so bail out.  */
-    return NULL;
 
-  bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
+  if (pt->rw_active == SCM_PORT_WRITE)
-  header[bytes_read] = '\0';
+    scm_flush (port);
 
-  scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
+  if (pt->rw_random)
+    pt->rw_active = SCM_PORT_READ;
+
+  if (pt->read_pos == pt->read_end)
+    {
+      /* We can use the read buffer, and thus avoid a seek. */
+      if (scm_fill_input (port) == EOF)
+        return NULL;
+
+      bytes_read = pt->read_end - pt->read_pos;
+      if (bytes_read > SCM_ENCODING_SEARCH_SIZE)
+        bytes_read = SCM_ENCODING_SEARCH_SIZE;
+
+      if (bytes_read <= 1)
+        /* An unbuffered port -- don't scan.  */
+        return NULL;
+
+      memcpy (header, pt->read_pos, bytes_read);
+      header[bytes_read] = '\0';
+    }
+  else
+    {
+      /* Try to read some bytes and then seek back.  Not all ports
+         support seeking back; and indeed some file ports (like
+         /dev/urandom) will succeed on an lseek (fd, 0, SEEK_CUR)---the
+         check performed by SCM_FPORT_FDES---but fail to seek
+         backwards.  Hence this block comes second.  We prefer to use
+         the read buffer in-place.  */
+      if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port)))
+        return NULL;
+
+      bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
+      header[bytes_read] = '\0';
+      scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
+    }
 
   if (bytes_read > 3 
       && header[0] == '\xef' && header[1] == '\xbb' && header[2] == '\xbf')
@@ -1718,22 +1785,26 @@ scm_i_scan_for_encoding (SCM port)
   pos = encoding_start;
   while (pos >= header)
     {
-      if (*pos == '\n')
-	{
-	  /* This wasn't in a semicolon comment. Check for a
-	   hash-bang comment. */
-	  char *beg = strstr (header, "#!");
-	  char *end = strstr (header, "!#");
-	  if (beg < encoding_start && encoding_start + encoding_length < end)
-	    in_comment = 1;
-	  break;
-	}
       if (*pos == ';')
 	{
 	  in_comment = 1;
 	  break;
 	}
-      pos --;
+      else if (*pos == '\n' || pos == header)
+	{
+	  /* This wasn't in a semicolon comment. Check for a
+	   hash-bang comment. */
+	  char *beg = strstr (header, "#!");
+	  char *end = strstr (header, "!#");
+	  if (beg < encoding_start && encoding_start + encoding_length <= end)
+	    in_comment = 1;
+	  break;
+	}
+      else
+        {
+          pos --;
+          continue;
+        }
     }
   if (!in_comment)
     /* This wasn't in a comment */
@@ -1761,6 +1832,8 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
   char *enc;
   SCM s_enc;
 
+  SCM_VALIDATE_OPINPORT (SCM_ARG1, port);
+
   enc = scm_i_scan_for_encoding (port);
   if (enc == NULL)
     return SCM_BOOL_F;

libguile/snarf.h

@@ -53,11 +53,17 @@
  * The SCM_SNARF_INIT text goes into the corresponding .x file
  * up through the first occurrence of SCM_SNARF_DOC_START on that
  * line, if any.
+ *
+ * Some debugging options can cause the preprocessor to echo #define
+ * directives to its output. Keeping the snarfing markers on separate
+ * lines prevents guile-snarf from inadvertently snarfing the definition
+ * of SCM_SNARF_INIT if those options are in effect.
  */
 
 #ifdef SCM_MAGIC_SNARF_INITS
 # define SCM_SNARF_HERE(X)
-# define SCM_SNARF_INIT(X) ^^ X ^:^
+# define SCM_SNARF_INIT_PREFIX ^^
+# define SCM_SNARF_INIT(X) SCM_SNARF_INIT_PREFIX X ^:^
 # define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
 #else
 # ifdef SCM_MAGIC_SNARF_DOCS

libguile/socket.c

@@ -1426,7 +1426,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
 	 "use a bytevector instead.");
 
       len = scm_i_string_length (buf);
-      msg = scm_i_make_string (len, &dest);
+      msg = scm_i_make_string (len, &dest, 0);
       SCM_SYSCALL (rv = recv (fd, dest, len, flg));
       scm_string_copy_x (buf, scm_from_int (0),
 			 msg, scm_from_int (0), scm_from_size_t (len));

libguile/srfi-13.c

@@ -251,14 +251,14 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
     if (wide)
       {
         scm_t_wchar *wbuf = NULL;
-        res = scm_i_make_wide_string (clen, &wbuf);
+        res = scm_i_make_wide_string (clen, &wbuf, 0);
         memcpy (wbuf, buf, clen * sizeof (scm_t_wchar));
         free (buf);
       }
     else
       {
         char *nbuf = NULL;
-        res = scm_i_make_string (clen, &nbuf);
+        res = scm_i_make_string (clen, &nbuf, 0);
         for (i = 0; i < clen; i ++)
           nbuf[i] = (unsigned char) buf[i];
         free (buf);
@@ -336,7 +336,7 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
 
   if (i < 0)
     SCM_WRONG_TYPE_ARG (1, chrs);
-  result = scm_i_make_string (i, &data);
+  result = scm_i_make_string (i, &data, 0);
 
   {
     SCM rest;
@@ -439,7 +439,7 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
     SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
 		    SCM_EOL);
 
-  result = scm_i_make_string (0, NULL);
+  result = scm_i_make_string (0, NULL, 0);
 
   tmp = ls;
   switch (gram)
@@ -1181,7 +1181,9 @@ SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
       len1 = scm_i_string_length (s1);
       len2 = scm_i_string_length (s2);
 
-      if (SCM_LIKELY (len1 == len2))
+      if (len1 != len2)
+	return SCM_BOOL_F;
+      else
 	{
 	  if (!scm_i_is_narrow_string (s1))
 	    len1 *= 4;
@@ -2484,7 +2486,7 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
   MY_VALIDATE_SUBSTRING_SPEC (2, s,
 			      3, start, cstart,
 			      4, end, cend);
-  result = scm_i_make_string (cend - cstart, NULL);
+  result = scm_i_make_string (cend - cstart, NULL, 0);
   p = 0;
   while (cstart < cend)
     {
@@ -2622,7 +2624,7 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
       ans = base;
     }
   else
-    ans = scm_i_make_string (0, NULL);
+    ans = scm_i_make_string (0, NULL, 0);
   if (!SCM_UNBNDP (make_final))
     SCM_VALIDATE_PROC (6, make_final);
 
@@ -2634,7 +2636,7 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
       SCM ch = scm_call_1 (f, seed);
       if (!SCM_CHARP (ch))
 	SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
-      str = scm_i_make_string (1, NULL);
+      str = scm_i_make_string (1, NULL, 0);
       str = scm_i_string_start_writing (str);
       scm_i_string_set_x (str, i, SCM_CHAR (ch));
       scm_i_string_stop_writing ();
@@ -2688,7 +2690,7 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
       ans = base;
     }
   else
-    ans = scm_i_make_string (0, NULL);
+    ans = scm_i_make_string (0, NULL, 0);
   if (!SCM_UNBNDP (make_final))
     SCM_VALIDATE_PROC (6, make_final);
 
@@ -2700,7 +2702,7 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
       SCM ch = scm_call_1 (f, seed);
       if (!SCM_CHARP (ch))
 	SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
-      str = scm_i_make_string (1, NULL);
+      str = scm_i_make_string (1, NULL, 0);
       str = scm_i_string_start_writing (str);
       scm_i_string_set_x (str, i, SCM_CHAR (ch));
       scm_i_string_stop_writing ();
@@ -2815,7 +2817,7 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
   if (cstart == cend && cfrom != cto)
     SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
 
-  result = scm_i_make_string (cto - cfrom, NULL);
+  result = scm_i_make_string (cto - cfrom, NULL, 0);
   result = scm_i_string_start_writing (result);
 
   p = 0;
@@ -3127,7 +3129,7 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
       else
         {
           size_t dst = 0;
-          result = scm_i_make_string (count, NULL);
+          result = scm_i_make_string (count, NULL, 0);
 	  result = scm_i_string_start_writing (result);
 
           /* decrement "count" in this loop as well as using idx, so that if
@@ -3237,7 +3239,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
         {
 	  int i = 0;
           /* new string for retained portion */
-          result = scm_i_make_string (count, NULL); 
+          result = scm_i_make_string (count, NULL, 0); 
           result = scm_i_string_start_writing (result);
           /* decrement "count" in this loop as well as using idx, so that if
              another thread is simultaneously changing "s" there's no chance
@@ -3279,7 +3281,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
         {
 	  size_t i = 0;
           /* new string for retained portion */
-          result = scm_i_make_string (count, NULL);
+          result = scm_i_make_string (count, NULL, 0);
 	  result = scm_i_string_start_writing (result);
 
           /* decrement "count" in this loop as well as using idx, so that if

libguile/srfi-14.c

@@ -1515,9 +1515,9 @@ SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
 
   count = scm_to_int (scm_char_set_size (cs));
   if (wide)
-    result = scm_i_make_wide_string (count, &wbuf);
+    result = scm_i_make_wide_string (count, &wbuf, 0);
   else
-    result = scm_i_make_string (count, &buf);
+    result = scm_i_make_string (count, &buf, 0);
 
   for (k = 0; k < cs_data->len; k++)
     for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)

libguile/stacks.c

@@ -247,7 +247,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
 #define FUNC_NAME s_scm_make_stack
 {
   long n;
-  int maxp;
   SCM frame;
   SCM stack;
   SCM inner_cut, outer_cut;
@@ -289,7 +288,6 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   /* Count number of frames.  Also get stack id tag and check whether
      there are more stackframes than we want to record
      (SCM_BACKTRACE_MAXDEPTH). */
-  maxp = 0;
   n = stack_depth (frame);
 
   /* Make the stack object. */

libguile/strings.c

@@ -262,30 +262,34 @@ SCM scm_nullstr;
 
 /* Create a scheme string with space for LEN 8-bit Latin-1-encoded
    characters.  CHARSP, if not NULL, will be set to location of the
-   char array.  */
+   char array.  If READ_ONLY_P, the returned string is read-only;
+   otherwise it is writable.  */
 SCM
-scm_i_make_string (size_t len, char **charsp)
+scm_i_make_string (size_t len, char **charsp, int read_only_p)
 {
   SCM buf = make_stringbuf (len);
   SCM res;
   if (charsp)
     *charsp = (char *) STRINGBUF_CHARS (buf);
-  res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
+  res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG,
-			 (scm_t_bits)0, (scm_t_bits) len);
+			 SCM_UNPACK (buf),
+			 (scm_t_bits) 0, (scm_t_bits) len);
   return res;
 }
 
 /* Create a scheme string with space for LEN 32-bit UCS-4-encoded
    characters.  CHARSP, if not NULL, will be set to location of the
-   character array.  */
+   character array.  If READ_ONLY_P, the returned string is read-only;
+   otherwise it is writable.  */
 SCM
-scm_i_make_wide_string (size_t len, scm_t_wchar **charsp)
+scm_i_make_wide_string (size_t len, scm_t_wchar **charsp, int read_only_p)
 {
   SCM buf = make_wide_stringbuf (len);
   SCM res;
   if (charsp)
     *charsp = STRINGBUF_WIDE_CHARS (buf);
-  res = scm_double_cell (STRING_TAG, SCM_UNPACK (buf),
+  res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG,
+			 SCM_UNPACK (buf),
                          (scm_t_bits) 0, (scm_t_bits) len);
   return res;
 }
@@ -889,7 +893,7 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str),
     {
       size_t len = STRINGBUF_LENGTH (buf);
       char *cbuf;
-      SCM sbc = scm_i_make_string (len, &cbuf);
+      SCM sbc = scm_i_make_string (len, &cbuf, 0);
       memcpy (cbuf, STRINGBUF_CHARS (buf), len);
       e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
                      sbc);
@@ -898,7 +902,7 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str),
     {
       size_t len = STRINGBUF_LENGTH (buf);
       scm_t_wchar *cbuf;
-      SCM sbc = scm_i_make_wide_string (len, &cbuf);
+      SCM sbc = scm_i_make_wide_string (len, &cbuf, 0);
       u32_cpy ((scm_t_uint32 *) cbuf, 
                (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
       e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
@@ -962,7 +966,7 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym),
     {
       size_t len = STRINGBUF_LENGTH (buf);
       char *cbuf;
-      SCM sbc = scm_i_make_string (len, &cbuf);
+      SCM sbc = scm_i_make_string (len, &cbuf, 0);
       memcpy (cbuf, STRINGBUF_CHARS (buf), len);
       e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
                      sbc);
@@ -971,7 +975,7 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym),
     {
       size_t len = STRINGBUF_LENGTH (buf);
       scm_t_wchar *cbuf;
-      SCM sbc = scm_i_make_wide_string (len, &cbuf);
+      SCM sbc = scm_i_make_wide_string (len, &cbuf, 0);
       u32_cpy ((scm_t_uint32 *) cbuf, 
                (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
       e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
@@ -1066,7 +1070,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
     {
       char *buf;
 
-      result = scm_i_make_string (len, NULL);
+      result = scm_i_make_string (len, NULL, 0);
       result = scm_i_string_start_writing (result);
       buf = scm_i_string_writable_chars (result);
       while (len > 0 && scm_is_pair (rest))
@@ -1083,7 +1087,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
     {
       scm_t_wchar *buf;
 
-      result = scm_i_make_wide_string (len, NULL);
+      result = scm_i_make_wide_string (len, NULL, 0);
       result = scm_i_string_start_writing (result);
       buf = scm_i_string_writable_wide_chars (result);
       while (len > 0 && scm_is_pair (rest))
@@ -1125,7 +1129,7 @@ scm_c_make_string (size_t len, SCM chr)
 {
   size_t p;
   char *contents = NULL;
-  SCM res = scm_i_make_string (len, &contents);
+  SCM res = scm_i_make_string (len, &contents, 0);
 
   /* If no char is given, initialize string contents to NULL.  */
   if (SCM_UNBNDP (chr))
@@ -1372,9 +1376,9 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
     }
   data.narrow = NULL;
   if (!wide)
-    res = scm_i_make_string (len, &data.narrow);
+    res = scm_i_make_string (len, &data.narrow, 0);
   else
-    res = scm_i_make_wide_string (len, &data.wide);
+    res = scm_i_make_wide_string (len, &data.wide, 0);
 
   for (l = args; !scm_is_null (l); l = SCM_CDR (l))
     {
@@ -1419,8 +1423,8 @@ scm_encoding_error (const char *subr, int err, const char *message,
 		    SCM port, SCM chr)
 {
   scm_throw (scm_encoding_error_key,
-	     scm_list_n (scm_from_locale_string (subr),
+	     scm_list_n (scm_from_latin1_string (subr),
-			 scm_from_locale_string (message),
+			 scm_from_latin1_string (message),
 			 scm_from_int (err),
 			 port, chr,
 			 SCM_UNDEFINED));
@@ -1432,8 +1436,8 @@ void
 scm_decoding_error (const char *subr, int err, const char *message, SCM port)
 {
   scm_throw (scm_decoding_error_key,
-	     scm_list_n (scm_from_locale_string (subr),
+	     scm_list_n (scm_from_latin1_string (subr),
-			 scm_from_locale_string (message),
+			 scm_from_latin1_string (message),
 			 scm_from_int (err),
 			 port,
 			 SCM_UNDEFINED));
@@ -1463,7 +1467,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
     {
       /* If encoding is null, use Latin-1.  */
       char *buf;
-      res = scm_i_make_string (len, &buf);
+      res = scm_i_make_string (len, &buf, 0);
       memcpy (buf, str, len);
       return res;
     }
@@ -1502,7 +1506,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
   if (!wide)
     {
       char *dst;
-      res = scm_i_make_string (u32len, &dst);
+      res = scm_i_make_string (u32len, &dst, 0);
       for (i = 0; i < u32len; i ++)
         dst[i] = (unsigned char) u32[i];
       dst[u32len] = '\0';
@@ -1510,7 +1514,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
   else
     {
       scm_t_wchar *wdst;
-      res = scm_i_make_wide_string (u32len, &wdst);
+      res = scm_i_make_wide_string (u32len, &wdst, 0);
       u32_cpy ((scm_t_uint32 *) wdst, (scm_t_uint32 *) u32, u32len);
       wdst[u32len] = 0;
     }
@@ -1528,25 +1532,8 @@ scm_from_locale_string (const char *str)
 SCM
 scm_from_locale_stringn (const char *str, size_t len)
 {
-  const char *enc;
+  return scm_from_stringn (str, len, locale_charset (),
-  scm_t_string_failed_conversion_handler hndl;
+                           scm_i_get_conversion_strategy (SCM_BOOL_F));
-  SCM inport;
-  scm_t_port *pt;
-
-  inport = scm_current_input_port ();
-  if (!SCM_UNBNDP (inport) && SCM_OPINPORTP (inport))
-    {
-      pt = SCM_PTAB_ENTRY (inport);
-      enc = pt->encoding;
-      hndl = pt->ilseq_handler;
-    }
-  else
-    {
-      enc = NULL;
-      hndl = SCM_FAILED_CONVERSION_ERROR;
-    }
-
-  return scm_from_stringn (str, len, enc, hndl);
 }
 
 SCM
@@ -1565,7 +1552,7 @@ scm_from_latin1_stringn (const char *str, size_t len)
     len = strlen (str);
 
   /* Make a narrow string and copy STR as is.  */
-  result = scm_i_make_string (len, &buf);
+  result = scm_i_make_string (len, &buf, 0);
   memcpy (buf, str, len);
 
   return result;
@@ -1598,7 +1585,7 @@ scm_from_utf32_stringn (const scm_t_wchar *str, size_t len)
   if (len == (size_t) -1)
     len = u32_strlen ((uint32_t *) str);
 
-  result = scm_i_make_wide_string (len, &buf);
+  result = scm_i_make_wide_string (len, &buf, 0);
   memcpy (buf, str, len * sizeof (scm_t_wchar));
   scm_i_try_narrow_string (result);
 
@@ -1771,21 +1758,8 @@ scm_to_locale_string (SCM str)
 char *
 scm_to_locale_stringn (SCM str, size_t *lenp)
 {
-  SCM outport;
-  scm_t_port *pt;
-  const char *enc;
-
-  outport = scm_current_output_port ();
-  if (!SCM_UNBNDP (outport) && SCM_OPOUTPORTP (outport))
-    {
-      pt = SCM_PTAB_ENTRY (outport);
-      enc = pt->encoding;
-    }
-  else
-    enc = NULL;
-
   return scm_to_stringn (str, lenp, 
-                         enc,
+                         locale_charset (),
                          scm_i_get_conversion_strategy (SCM_BOOL_F));
 }
 
@@ -2029,7 +2003,7 @@ normalize_str (SCM string, uninorm_t form)
 
   w_str = u32_normalize (form, w_str, len, NULL, &rlen);  
   
-  ret = scm_i_make_wide_string (rlen, &cbuf);
+  ret = scm_i_make_wide_string (rlen, &cbuf, 0);
   u32_cpy ((scm_t_uint32 *) cbuf, w_str, rlen);
   free (w_str);
 
@@ -2241,7 +2215,7 @@ SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string)
 void
 scm_init_strings ()
 {
-  scm_nullstr = scm_i_make_string (0, NULL);
+  scm_nullstr = scm_i_make_string (0, NULL, 1);
 
 #include "libguile/strings.x"
 }

libguile/strings.h

@@ -177,8 +177,11 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv);
 
 /* internal accessor functions.  Arguments must be valid. */
 
-SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap);
+SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap,
-SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap);
+				    int read_only_p);
+SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap,
+					 int read_only_p);
+SCM_INTERNAL SCM scm_i_set_string_read_only_x (SCM str);
 SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end);
 SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end);
 SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end);

libguile/strports.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010, 2011 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 License
@@ -30,7 +30,7 @@
 #include <unistd.h>
 #endif
 
-#include "libguile/arrays.h"
+#include "libguile/bytevectors.h"
 #include "libguile/eval.h"
 #include "libguile/ports.h"
 #include "libguile/read.h"
@@ -55,15 +55,8 @@
 
 /* NOTES:
 
-   We break the rules set forth by strings.h about accessing the
+   write_buf/write_end point to the ends of the allocated bytevector.
-   internals of strings here.  We can do this since we can guarantee
+   read_buf/read_end in principle point to the part of the bytevector which
-   that the string used as pt->stream is not in use by anyone else.
-   Thus, it's representation will not change asynchronously.
-
-   (Ports aren't thread-safe yet anyway...)
-
-   write_buf/write_end point to the ends of the allocated string.
-   read_buf/read_end in principle point to the part of the string which
    has been written to, but this is only updated after a flush.
    read_pos and write_pos in principle should be equal, but this is only true
    when rw_active is SCM_PORT_NEITHER.
@@ -106,25 +99,23 @@ stfill_buffer (SCM port)
     return scm_return_first_int (*pt->read_pos, port);
 }
 
-/* change the size of a port's string to new_size.  this doesn't
+/* Change the size of a port's bytevector to NEW_SIZE.  This doesn't
-   change read_buf_size.  */
+   change `read_buf_size'.  */
-static void 
+static void
 st_resize_port (scm_t_port *pt, scm_t_off new_size)
 {
   SCM old_stream = SCM_PACK (pt->stream);
-  const char *src = scm_i_string_chars (old_stream);
+  const signed char *src = SCM_BYTEVECTOR_CONTENTS (old_stream);
-  char *dst;
+  SCM new_stream = scm_c_make_bytevector (new_size);
-  SCM new_stream = scm_i_make_string (new_size, &dst);
+  signed char *dst = SCM_BYTEVECTOR_CONTENTS (new_stream);
-  unsigned long int old_size = scm_i_string_length (old_stream);
+  unsigned long int old_size = SCM_BYTEVECTOR_LENGTH (old_stream);
   unsigned long int min_size = min (old_size, new_size);
-  unsigned long int i;
 
   scm_t_off index = pt->write_pos - pt->write_buf;
 
   pt->write_buf_size = new_size;
 
-  for (i = 0; i != min_size; ++i)
+  memcpy (dst, src, min_size);
-    dst[i] = src[i];
 
   scm_remember_upto_here_1 (old_stream);
 
@@ -138,27 +129,17 @@ st_resize_port (scm_t_port *pt, scm_t_off new_size)
   }
 }
 
-/* amount by which write_buf is expanded.  */
+/* Ensure that `write_pos' < `write_end' by enlarging the buffer when
-#define SCM_WRITE_BLOCK 80
+   necessary.  Update `read_buf' to account for written chars.  The
-
+   buffer is enlarged geometrically.  */
-/* ensure that write_pos < write_end by enlarging the buffer when
-   necessary.  update read_buf to account for written chars.
-
-   The buffer is enlarged by 1.5 times, plus SCM_WRITE_BLOCK.  Adding just a
-   fixed amount is no good, because there's a block copy for each increment,
-   and that copying would take quadratic time.  In the past it was found to
-   be very slow just adding 80 bytes each time (eg. about 10 seconds for
-   writing a 100kbyte string).  */
-
 static void
 st_flush (SCM port)
 {
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 
   if (pt->write_pos == pt->write_end)
-    {
+    st_resize_port (pt, pt->write_buf_size * 2);
-      st_resize_port (pt, pt->write_buf_size * 3 / 2 + SCM_WRITE_BLOCK);
+
-    }
   pt->read_pos = pt->write_pos;
   if (pt->read_pos > pt->read_end)
     {
@@ -255,12 +236,8 @@ st_seek (SCM port, scm_t_off offset, int whence)
 				  SCM_EOL);
 		}
 	    }
-	  else
+	  else if (target == pt->write_buf_size)
-	    {
+	    st_resize_port (pt, target * 2);
-	      st_resize_port (pt, target + (target == pt->write_buf_size
-					    ? SCM_WRITE_BLOCK
-					    : 0));
-	    }
 	}
       pt->read_pos = pt->write_pos = pt->read_buf + target;
       if (pt->read_pos > pt->read_end)
@@ -289,16 +266,19 @@ st_truncate (SCM port, scm_t_off length)
     pt->write_pos = pt->read_end;
 }
 
+/* The initial size in bytes of a string port's buffer.  */
+#define INITIAL_BUFFER_SIZE 128
+
+/* Return a new string port with MODES.  If STR is #f, a new backing
+   buffer is allocated; otherwise STR must be a string and a copy of it
+   serves as the buffer for the new port.  */
 SCM
 scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
 {
-  SCM z;
+  SCM z, buf;
   scm_t_port *pt;
   size_t str_len, c_pos;
-  char *buf, *c_str;
+  char *c_buf;
-
-  SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
-  c_pos = scm_to_unsigned_integer (pos, 0, scm_i_string_length (str));
 
   if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
     scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
@@ -308,19 +288,44 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
 
   z = scm_new_port_table_entry (scm_tc16_strport);
   pt = SCM_PTAB_ENTRY(z);
-  SCM_SETSTREAM (z, SCM_UNPACK (str));
+
+  if (scm_is_false (str))
+    {
+      /* Allocate a new buffer to write to.  */
+      str_len = INITIAL_BUFFER_SIZE;
+      buf = scm_c_make_bytevector (str_len);
+      c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
+
+      /* Reset `read_buf_size'.  It will contain the actual number of
+	 bytes written to PT.  */
+      pt->read_buf_size = 0;
+      c_pos = 0;
+    }
+  else
+    {
+      /* STR is a string.  */
+      char *copy;
+
+      SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
+
+      /* Create a copy of STR in the encoding of PT.  */
+      copy = scm_to_stringn (str, &str_len, pt->encoding,
+			     SCM_FAILED_CONVERSION_ERROR);
+      buf = scm_c_make_bytevector (str_len);
+      c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
+      memcpy (c_buf, copy, str_len);
+      free (copy);
+
+      c_pos = scm_to_unsigned_integer (pos, 0, str_len);
+      pt->read_buf_size = str_len;
+    }
+
+  SCM_SETSTREAM (z, SCM_UNPACK (buf));
   SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes);
 
-  /* Create a copy of STR in the encoding of Z.  */
+  pt->write_buf = pt->read_buf = (unsigned char *) c_buf;
-  buf = scm_to_stringn (str, &str_len, pt->encoding,
-			SCM_FAILED_CONVERSION_ERROR);
-  c_str = scm_gc_malloc (str_len, "strport");
-  memcpy (c_str, buf, str_len);
-  free (buf);
-
-  pt->write_buf = pt->read_buf = (unsigned char *) c_str;
   pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
-  pt->write_buf_size = pt->read_buf_size = str_len;
+  pt->write_buf_size = str_len;
   pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
 
   pt->rw_random = 1;
@@ -352,7 +357,7 @@ scm_strport_to_string (SCM port)
   if (pt->encoding == NULL)
     {
       char *buf;
-      str = scm_i_make_string (pt->read_buf_size, &buf);
+      str = scm_i_make_string (pt->read_buf_size, &buf, 0);
       memcpy (buf, pt->read_buf, pt->read_buf_size);
     }
   else
@@ -369,20 +374,30 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
 	    "argument @var{printer} (default: @code{write}).")
 #define FUNC_NAME s_scm_object_to_string
 {
-  SCM str, port;
+  SCM port, result;
 
   if (!SCM_UNBNDP (printer))
     SCM_VALIDATE_PROC (2, printer);
 
-  str = scm_c_make_string (0, SCM_UNDEFINED);
+  port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
-  port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME);
+			SCM_OPN | SCM_WRTNG, FUNC_NAME);
 
   if (SCM_UNBNDP (printer))
     scm_write (obj, port);
   else
     scm_call_2 (printer, obj, port);
 
-  return scm_strport_to_string (port);
+  result = scm_strport_to_string (port);
+
+  /* Explicitly close PORT so that the iconv CDs associated with it are
+     deallocated right away.  This is important because CDs use a lot of
+     memory that's not visible to the GC, so not freeing them can lead
+     to almost large heap usage.  See
+     <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter>
+     for details.  */
+  scm_close_port (port);
+
+  return result;
 }
 #undef FUNC_NAME
 
@@ -395,8 +410,7 @@ SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0,
 {
   SCM p;
 
-  p = scm_mkstrport (SCM_INUM0, 
+  p = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
-		     scm_make_string (SCM_INUM0, SCM_UNDEFINED),
 		     SCM_OPN | SCM_WRTNG,
                      FUNC_NAME);
   scm_call_1 (proc, p);
@@ -441,8 +455,7 @@ SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0,
 {
   SCM p;
 
-  p = scm_mkstrport (SCM_INUM0, 
+  p = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
-		     scm_make_string (SCM_INUM0, SCM_UNDEFINED),
 		     SCM_OPN | SCM_WRTNG,
                      FUNC_NAME);
   return p;
@@ -467,15 +480,12 @@ SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0,
 SCM
 scm_c_read_string (const char *expr)
 {
-  /* FIXME: the c string gets packed into a string, only to get
-     immediately unpacked in scm_mkstrport.  */
   SCM port = scm_mkstrport (SCM_INUM0,
 			    scm_from_locale_string (expr),
 			    SCM_OPN | SCM_RDNG,
 			    "scm_c_read_string");
   SCM form;
 
-  /* Read expressions from that port; ignore the values.  */
   form = scm_read (port);
 
   scm_close_port (port);
@@ -497,25 +507,6 @@ scm_c_eval_string_in_module (const char *expr, SCM module)
 }
 
 
-static SCM
-inner_eval_string (void *data)
-{
-  SCM port = (SCM)data;
-  SCM form;
-  SCM ans = SCM_UNSPECIFIED;
-
-  /* Read expressions from that port; ignore the values.  */
-  while (!SCM_EOF_OBJECT_P (form = scm_read (port)))
-    ans = scm_primitive_eval_x (form);
-
-  /* Don't close the port here; if we re-enter this function via a
-     continuation, then the next time we enter it, we'll get an error.
-     It's a string port anyway, so there's no advantage to closing it
-     early.  */
-
-  return ans;
-}
-
 SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0, 
             (SCM string, SCM module),
 	    "Evaluate @var{string} as the text representation of a Scheme\n"
@@ -527,14 +518,20 @@ SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0,
             "procedure returns.")
 #define FUNC_NAME s_scm_eval_string_in_module
 {
-  SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG,
+  static SCM eval_string = SCM_BOOL_F, k_module = SCM_BOOL_F;
-			    FUNC_NAME);
+
+  if (scm_is_false (eval_string))
+    {
+      eval_string = scm_c_public_lookup ("ice-9 eval-string", "eval-string");
+      k_module = scm_from_locale_keyword ("module");
+    }
+  
   if (SCM_UNBNDP (module))
     module = scm_current_module ();
   else
     SCM_VALIDATE_MODULE (2, module);
-  return scm_c_call_with_current_module (module,
+
-					 inner_eval_string, (void *)port);
+  return scm_call_3 (scm_variable_ref (eval_string), string, k_module, module);
 }
 #undef FUNC_NAME
 

libguile/symbols.c

@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004,
- * 
+ *   2006, 2009, 2011 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 License
  * as published by the Free Software Foundation; either version 3 of
@@ -341,6 +342,9 @@ SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+/* The default prefix for `gensym'd symbols.  */
+static SCM default_gensym_prefix;
+
 #define MAX_PREFIX_LENGTH 30
 
 SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
@@ -359,15 +363,15 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
   char buf[SCM_INTBUFLEN];
 
   if (SCM_UNBNDP (prefix))
-    prefix = scm_from_locale_string (" g");
+    prefix = default_gensym_prefix;
-  
+
   /* mutex in case another thread looks and incs at the exact same moment */
   scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
   n = gensym_counter++;
   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
 
   n_digits = scm_iint2str (n, 10, buf);
-  suffix = scm_from_locale_stringn (buf, n_digits);
+  suffix = scm_from_latin1_stringn (buf, n_digits);
   name = scm_string_append (scm_list_2 (prefix, suffix));
   return scm_string_to_symbol (name);
 }
@@ -506,6 +510,8 @@ void
 scm_init_symbols ()
 {
 #include "libguile/symbols.x"
+
+  default_gensym_prefix = scm_from_latin1_string (" g");
 }
 
 /*

libguile/threads.c

@@ -79,6 +79,122 @@ typedef void * (* GC_fn_type) (void *);
 #endif
 
 
+#ifndef GC_SUCCESS
+#define GC_SUCCESS 0
+#endif
+
+#ifndef GC_UNIMPLEMENTED
+#define GC_UNIMPLEMENTED 3
+#endif
+
+/* Likewise struct GC_stack_base is missing before 7.1.  */
+#ifndef HAVE_GC_STACK_BASE
+struct GC_stack_base {
+  void * mem_base; /* Base of memory stack. */
+#ifdef __ia64__
+  void * reg_base; /* Base of separate register stack. */
+#endif
+};
+
+static int
+GC_register_my_thread (struct GC_stack_base *stack_base)
+{
+  return GC_UNIMPLEMENTED;
+}
+
+static void
+GC_unregister_my_thread ()
+{
+}
+
+#if !SCM_USE_PTHREAD_THREADS
+/* No threads; we can just use GC_stackbottom.  */
+static void *
+get_thread_stack_base ()
+{
+  return GC_stackbottom;
+}
+
+#elif defined HAVE_PTHREAD_ATTR_GETSTACK && defined HAVE_PTHREAD_GETATTR_NP \
+  && defined PTHREAD_ATTR_GETSTACK_WORKS
+/* This method for GNU/Linux and perhaps some other systems.
+   It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
+   available on them.  */
+static void *
+get_thread_stack_base ()
+{
+  pthread_attr_t attr;
+  void *start, *end;
+  size_t size;
+
+  pthread_getattr_np (pthread_self (), &attr);
+  pthread_attr_getstack (&attr, &start, &size);
+  end = (char *)start + size;
+
+#if SCM_STACK_GROWS_UP
+  return start;
+#else
+  return end;
+#endif
+}
+
+#elif defined HAVE_PTHREAD_GET_STACKADDR_NP
+/* This method for MacOS X.
+   It'd be nice if there was some documentation on pthread_get_stackaddr_np,
+   but as of 2006 there's nothing obvious at apple.com.  */
+static void *
+get_thread_stack_base ()
+{
+  return pthread_get_stackaddr_np (pthread_self ());
+}
+
+#else 
+#error Threads enabled with old BDW-GC, but missing get_thread_stack_base impl.  Please upgrade to libgc >= 7.1.
+#endif
+
+static int
+GC_get_stack_base (struct GC_stack_base *stack_base)
+{
+  stack_base->mem_base = get_thread_stack_base ();
+#ifdef __ia64__
+  /* Calculate and store off the base of this thread's register
+     backing store (RBS).  Unfortunately our implementation(s) of
+     scm_ia64_register_backing_store_base are only reliable for the
+     main thread.  For other threads, therefore, find out the current
+     top of the RBS, and use that as a maximum. */
+  stack_base->reg_base = scm_ia64_register_backing_store_base ();
+  {
+    ucontext_t ctx;
+    void *bsp;
+    getcontext (&ctx);
+    bsp = scm_ia64_ar_bsp (&ctx);
+    if (stack_base->reg_base > bsp)
+      stack_base->reg_base = bsp;
+  }
+#endif
+  return GC_SUCCESS;
+}
+
+static void *
+GC_call_with_stack_base(void * (*fn) (struct GC_stack_base*, void*), void *arg)
+{
+  struct GC_stack_base stack_base;
+
+  stack_base.mem_base = (void*)&stack_base;
+#ifdef __ia64__
+  /* FIXME: Untested.  */
+  {
+    ucontext_t ctx;
+    getcontext (&ctx);
+    stack_base.reg_base = scm_ia64_ar_bsp (&ctx);
+  }
+#endif
+
+  return fn (&stack_base, arg);
+}
+#endif /* HAVE_GC_STACK_BASE */
+
+
 /* Now define with_gc_active and with_gc_inactive.  */
 
 #if (defined(HAVE_GC_DO_BLOCKING) && defined (HAVE_DECL_GC_DO_BLOCKING) && defined (HAVE_GC_CALL_WITH_GC_ACTIVE))
@@ -343,6 +459,12 @@ unblock_from_queue (SCM queue)
 /* Getting into and out of guile mode.
  */
 
+/* Key used to attach a cleanup handler to a given thread.  Also, if
+   thread-local storage is unavailable, this key is used to retrieve the
+   current thread with `pthread_getspecific ()'.  */
+scm_i_pthread_key_t scm_i_thread_key;
+
+
 #ifdef SCM_HAVE_THREAD_STORAGE_CLASS
 
 /* When thread-local storage (TLS) is available, a pointer to the
@@ -352,17 +474,7 @@ unblock_from_queue (SCM queue)
    represent.  */
 SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread = NULL;
 
-# define SET_CURRENT_THREAD(_t)  scm_i_current_thread = (_t)
+#endif /* SCM_HAVE_THREAD_STORAGE_CLASS */
-
-#else /* !SCM_HAVE_THREAD_STORAGE_CLASS */
-
-/* Key used to retrieve the current thread with `pthread_getspecific ()'.  */
-scm_i_pthread_key_t scm_i_thread_key;
-
-# define SET_CURRENT_THREAD(_t)				\
-  scm_i_pthread_setspecific (scm_i_thread_key, (_t))
-
-#endif /* !SCM_HAVE_THREAD_STORAGE_CLASS */
 
 
 static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
@@ -374,67 +486,75 @@ static SCM scm_i_default_dynamic_state;
 /* Perform first stage of thread initialisation, in non-guile mode.
  */
 static void
-guilify_self_1 (SCM_STACKITEM *base)
+guilify_self_1 (struct GC_stack_base *base)
 {
-  scm_i_thread *t = scm_gc_malloc (sizeof (scm_i_thread), "thread");
+  scm_i_thread t;
 
-  t->pthread = scm_i_pthread_self ();
+  /* We must arrange for SCM_I_CURRENT_THREAD to point to a valid value
-  t->handle = SCM_BOOL_F;
+     before allocating anything in this thread, because allocation could
-  t->result = SCM_BOOL_F;
+     cause GC to run, and GC could cause finalizers, which could invoke
-  t->cleanup_handler = SCM_BOOL_F;
+     Scheme functions, which need the current thread to be set.  */
-  t->mutexes = SCM_EOL;
+
-  t->held_mutex = NULL;
+  t.pthread = scm_i_pthread_self ();
-  t->join_queue = SCM_EOL;
+  t.handle = SCM_BOOL_F;
-  t->dynamic_state = SCM_BOOL_F;
+  t.result = SCM_BOOL_F;
-  t->dynwinds = SCM_EOL;
+  t.cleanup_handler = SCM_BOOL_F;
-  t->active_asyncs = SCM_EOL;
+  t.mutexes = SCM_EOL;
-  t->block_asyncs = 1;
+  t.held_mutex = NULL;
-  t->pending_asyncs = 1;
+  t.join_queue = SCM_EOL;
-  t->critical_section_level = 0;
+  t.dynamic_state = SCM_BOOL_F;
-  t->base = base;
+  t.dynwinds = SCM_EOL;
+  t.active_asyncs = SCM_EOL;
+  t.block_asyncs = 1;
+  t.pending_asyncs = 1;
+  t.critical_section_level = 0;
+  t.base = base->mem_base;
 #ifdef __ia64__
-  /* Calculate and store off the base of this thread's register
+  t.register_backing_store_base = base->reg-base;
-     backing store (RBS).  Unfortunately our implementation(s) of
-     scm_ia64_register_backing_store_base are only reliable for the
-     main thread.  For other threads, therefore, find out the current
-     top of the RBS, and use that as a maximum. */
-  t->register_backing_store_base = scm_ia64_register_backing_store_base ();
-  {
-    ucontext_t ctx;
-    void *bsp;
-    getcontext (&ctx);
-    bsp = scm_ia64_ar_bsp (&ctx);
-    if (t->register_backing_store_base > bsp)
-      t->register_backing_store_base = bsp;
-  }
 #endif
-  t->continuation_root = SCM_EOL;
+  t.continuation_root = SCM_EOL;
-  t->continuation_base = base;
+  t.continuation_base = t.base;
-  scm_i_pthread_cond_init (&t->sleep_cond, NULL);
+  scm_i_pthread_cond_init (&t.sleep_cond, NULL);
-  t->sleep_mutex = NULL;
+  t.sleep_mutex = NULL;
-  t->sleep_object = SCM_BOOL_F;
+  t.sleep_object = SCM_BOOL_F;
-  t->sleep_fd = -1;
+  t.sleep_fd = -1;
 
-  if (pipe (t->sleep_pipe) != 0)
+  if (pipe (t.sleep_pipe) != 0)
     /* FIXME: Error conditions during the initialization phase are handled
        gracelessly since public functions such as `scm_init_guile ()'
        currently have type `void'.  */
     abort ();
 
-  scm_i_pthread_mutex_init (&t->admin_mutex, NULL);
+  scm_i_pthread_mutex_init (&t.admin_mutex, NULL);
-  t->current_mark_stack_ptr = NULL;
+  t.current_mark_stack_ptr = NULL;
-  t->current_mark_stack_limit = NULL;
+  t.current_mark_stack_limit = NULL;
-  t->canceled = 0;
+  t.canceled = 0;
-  t->exited = 0;
+  t.exited = 0;
-  t->guile_mode = 0;
+  t.guile_mode = 0;
 
-  SET_CURRENT_THREAD (t);
+  /* The switcheroo.  */
+  {
+    scm_i_thread *t_ptr = &t;
+    
+    GC_disable ();
+    t_ptr = GC_malloc (sizeof (scm_i_thread));
+    memcpy (t_ptr, &t, sizeof t);
 
-  scm_i_pthread_mutex_lock (&thread_admin_mutex);
+    scm_i_pthread_setspecific (scm_i_thread_key, t_ptr);
-  t->next_thread = all_threads;
+
-  all_threads = t;
+#ifdef SCM_HAVE_THREAD_STORAGE_CLASS
-  thread_count++;
+    /* Cache the current thread in TLS for faster lookup.  */
-  scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+    scm_i_current_thread = t_ptr;
+#endif
+
+    scm_i_pthread_mutex_lock (&thread_admin_mutex);
+    t_ptr->next_thread = all_threads;
+    all_threads = t_ptr;
+    thread_count++;
+    scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+
+    GC_enable ();
+  }
 }
 
 /* Perform second stage of thread initialisation, in guile mode.
@@ -537,6 +657,15 @@ do_thread_exit (void *v)
   return NULL;
 }
 
+static void *
+do_thread_exit_trampoline (struct GC_stack_base *sb, void *v)
+{
+  /* Won't hurt if we are already registered.  */
+  GC_register_my_thread (sb);
+
+  return scm_with_guile (do_thread_exit, v);
+}
+
 static void
 on_thread_exit (void *v)
 {
@@ -551,19 +680,18 @@ on_thread_exit (void *v)
       t->held_mutex = NULL;
     }
 
-  SET_CURRENT_THREAD (v);
+  /* Reinstate the current thread for purposes of scm_with_guile
+     guile-mode cleanup handlers.  Only really needed in the non-TLS
+     case but it doesn't hurt to be consistent.  */
+  scm_i_pthread_setspecific (scm_i_thread_key, t);
 
   /* Ensure the signal handling thread has been launched, because we might be
      shutting it down.  */
   scm_i_ensure_signal_delivery_thread ();
 
-  /* Unblocking the joining threads needs to happen in guile mode
+  /* Scheme-level thread finalizers and other cleanup needs to happen in
-     since the queue is a SCM data structure.  */
+     guile mode.  */
-
+  GC_call_with_stack_base (do_thread_exit_trampoline, t);
-  /* Note: Since `do_thread_exit ()' uses allocates memory via `libgc', we
-     assume the GC is usable at this point, and notably that thread-local
-     storage (TLS) hasn't been deallocated yet.  */
-  do_thread_exit (v);
 
   /* Removing ourself from the list of all threads needs to happen in
      non-guile mode since all SCM values on our stack become
@@ -590,21 +718,21 @@ on_thread_exit (void *v)
 
   scm_i_pthread_mutex_unlock (&thread_admin_mutex);
 
-  SET_CURRENT_THREAD (NULL);
+  scm_i_pthread_setspecific (scm_i_thread_key, NULL);
-}
 
-#ifndef SCM_HAVE_THREAD_STORAGE_CLASS
+#if !SCM_USE_NULL_THREADS
+  GC_unregister_my_thread ();
+#endif
+}
 
 static scm_i_pthread_once_t init_thread_key_once = SCM_I_PTHREAD_ONCE_INIT;
 
 static void
 init_thread_key (void)
 {
-  scm_i_pthread_key_create (&scm_i_thread_key, NULL);
+  scm_i_pthread_key_create (&scm_i_thread_key, on_thread_exit);
 }
 
-#endif
-
 /* Perform any initializations necessary to make the current thread
    known to Guile (via SCM_I_CURRENT_THREAD), initializing Guile itself,
    if necessary.
@@ -623,11 +751,9 @@ init_thread_key (void)
    be sure.  New threads are put into guile mode implicitly.  */
 
 static int
-scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
+scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent)
 {
-#ifndef SCM_HAVE_THREAD_STORAGE_CLASS
   scm_i_pthread_once (&init_thread_key_once, init_thread_key);
-#endif
 
   if (SCM_I_CURRENT_THREAD)
     {
@@ -647,6 +773,12 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
 	     initialization.
 	  */
 	  scm_i_init_guile (base);
+
+#ifdef HAVE_GC_ALLOW_REGISTER_THREADS
+          /* Allow other threads to come in later.  */
+          GC_allow_register_threads ();
+#endif
+
 	  scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
 	}
       else
@@ -655,6 +787,10 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
 	     the first time.  Only initialize this thread.
 	  */
 	  scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
+
+          /* Register this thread with libgc.  */
+          GC_register_my_thread (base);
+
 	  guilify_self_1 (base);
 	  guilify_self_2 (parent);
 	}
@@ -662,97 +798,19 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
     }
 }
 
-#if SCM_USE_PTHREAD_THREADS
-
-#if defined HAVE_PTHREAD_ATTR_GETSTACK && defined HAVE_PTHREAD_GETATTR_NP
-/* This method for GNU/Linux and perhaps some other systems.
-   It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
-   available on them.  */
-#define HAVE_GET_THREAD_STACK_BASE
-
-static SCM_STACKITEM *
-get_thread_stack_base ()
-{
-  pthread_attr_t attr;
-  void *start, *end;
-  size_t size;
-
-  pthread_getattr_np (pthread_self (), &attr);
-  pthread_attr_getstack (&attr, &start, &size);
-  end = (char *)start + size;
-
-  /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
-     for the main thread, but we can use scm_get_stack_base in that
-     case.
-  */
-
-#ifndef PTHREAD_ATTR_GETSTACK_WORKS
-  if ((void *)&attr < start || (void *)&attr >= end)
-    return (SCM_STACKITEM *) GC_stackbottom;
-  else
-#endif
-    {
-#if SCM_STACK_GROWS_UP
-      return start;
-#else
-      return end;
-#endif
-    }
-}
-
-#elif defined HAVE_PTHREAD_GET_STACKADDR_NP
-/* This method for MacOS X.
-   It'd be nice if there was some documentation on pthread_get_stackaddr_np,
-   but as of 2006 there's nothing obvious at apple.com.  */
-#define HAVE_GET_THREAD_STACK_BASE
-static SCM_STACKITEM *
-get_thread_stack_base ()
-{
-  return pthread_get_stackaddr_np (pthread_self ());
-}
-
-#elif defined (__MINGW32__)
-/* This method for mingw.  In mingw the basic scm_get_stack_base can be used
-   in any thread.  We don't like hard-coding the name of a system, but there
-   doesn't seem to be a cleaner way of knowing scm_get_stack_base can
-   work.  */
-#define HAVE_GET_THREAD_STACK_BASE
-static SCM_STACKITEM *
-get_thread_stack_base ()
-{
-  return (SCM_STACKITEM *) GC_stackbottom;
-}
-
-#endif /* pthread methods of get_thread_stack_base */
-
-#else /* !SCM_USE_PTHREAD_THREADS */
-
-#define HAVE_GET_THREAD_STACK_BASE
-
-static SCM_STACKITEM *
-get_thread_stack_base ()
-{
-  return (SCM_STACKITEM *) GC_stackbottom;
-}
-
-#endif /* !SCM_USE_PTHREAD_THREADS */
-
-#ifdef HAVE_GET_THREAD_STACK_BASE
-
 void
 scm_init_guile ()
 {
-  scm_i_init_thread_for_guile (get_thread_stack_base (),
+  struct GC_stack_base stack_base;
-			       scm_i_default_dynamic_state);
+  
-}
+  if (GC_get_stack_base (&stack_base) == GC_SUCCESS)
-
+    scm_i_init_thread_for_guile (&stack_base,
-#endif
+                                 scm_i_default_dynamic_state);
-
+  else
-void *
+    {
-scm_with_guile (void *(*func)(void *), void *data)
+      fprintf (stderr, "Failed to get stack base for current thread.\n");
-{
+      exit (1);
-  return scm_i_with_guile_and_parent (func, data,
+    }
-				      scm_i_default_dynamic_state);
 }
 
 SCM_UNUSED static void
@@ -761,38 +819,37 @@ scm_leave_guile_cleanup (void *x)
   on_thread_exit (SCM_I_CURRENT_THREAD);
 }
 
-struct with_guile_trampoline_args
+struct with_guile_args
 {
   GC_fn_type func;
   void *data;
+  SCM parent;
 };
 
 static void *
 with_guile_trampoline (void *data)
 {
-  struct with_guile_trampoline_args *args = data;
+  struct with_guile_args *args = data;
 
   return scm_c_with_continuation_barrier (args->func, args->data);
 }
   
-void *
+static void *
-scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent)
+with_guile_and_parent (struct GC_stack_base *base, void *data)
 {
   void *res;
   int new_thread;
   scm_i_thread *t;
-  SCM_STACKITEM base_item;
+  struct with_guile_args *args = data;
 
-  new_thread = scm_i_init_thread_for_guile (&base_item, parent);
+  new_thread = scm_i_init_thread_for_guile (base, args->parent);
   t = SCM_I_CURRENT_THREAD;
   if (new_thread)
     {
       /* We are in Guile mode.  */
       assert (t->guile_mode);
 
-      scm_i_pthread_cleanup_push (scm_leave_guile_cleanup, NULL);
+      res = scm_c_with_continuation_barrier (args->func, args->data);
-      res = scm_c_with_continuation_barrier (func, data);
-      scm_i_pthread_cleanup_pop (0);
 
       /* Leave Guile mode.  */
       t->guile_mode = 0;
@@ -800,14 +857,10 @@ scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent)
   else if (t->guile_mode)
     {
       /* Already in Guile mode.  */
-      res = scm_c_with_continuation_barrier (func, data);
+      res = scm_c_with_continuation_barrier (args->func, args->data);
     }
   else
     {
-      struct with_guile_trampoline_args args;
-      args.func = func;
-      args.data = data;
-
       /* We are not in Guile mode, either because we are not within a
          scm_with_guile, or because we are within a scm_without_guile.
 
@@ -816,20 +869,39 @@ scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent)
          when this thread was first guilified.  Thus, `base' must be
          updated.  */
 #if SCM_STACK_GROWS_UP
-      if (SCM_STACK_PTR (&base_item) < t->base)
+      if (SCM_STACK_PTR (base->mem_base) < t->base)
-        t->base = SCM_STACK_PTR (&base_item);
+        t->base = SCM_STACK_PTR (base->mem_base);
 #else
-      if (SCM_STACK_PTR (&base_item) > t->base)
+      if (SCM_STACK_PTR (base->mem_base) > t->base)
-        t->base = SCM_STACK_PTR (&base_item);
+        t->base = SCM_STACK_PTR (base->mem_base);
 #endif
 
       t->guile_mode = 1;
-      res = with_gc_active (with_guile_trampoline, &args);
+      res = with_gc_active (with_guile_trampoline, args);
       t->guile_mode = 0;
     }
   return res;
 }
 
+static void *
+scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent)
+{
+  struct with_guile_args args;
+
+  args.func = func;
+  args.data = data;
+  args.parent = parent;
+  
+  return GC_call_with_stack_base (with_guile_and_parent, &args);
+}
+
+void *
+scm_with_guile (void *(*func)(void *), void *data)
+{
+  return scm_i_with_guile_and_parent (func, data,
+				      scm_i_default_dynamic_state);
+}
+
 void *
 scm_without_guile (void *(*func)(void *), void *data)
 {
@@ -880,9 +952,6 @@ really_launch (void *d)
   else
     t->result = scm_catch (SCM_BOOL_T, thunk, handler);
 
-  /* Trigger a call to `on_thread_exit ()'.  */
-  pthread_exit (NULL);
-
   return 0;
 }
 
@@ -1965,7 +2034,7 @@ pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];
 #endif
 
 void
-scm_threads_prehistory (SCM_STACKITEM *base)
+scm_threads_prehistory (void *base)
 {
 #if SCM_USE_PTHREAD_THREADS
   pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive);
@@ -1978,7 +2047,7 @@ scm_threads_prehistory (SCM_STACKITEM *base)
   scm_i_pthread_mutex_init (&scm_i_misc_mutex, NULL);
   scm_i_pthread_cond_init (&wake_up_cond, NULL);
 
-  guilify_self_1 (base);
+  guilify_self_1 ((struct GC_stack_base *) base);
 }
 
 scm_t_bits scm_tc16_thread;