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

Conflicts:
	configure.ac
	libguile/finalizers.c
	libguile/finalizers.h
	libguile/gc.c
	libguile/gc.h
	libguile/inline.c
	libguile/inline.h
	libguile/ports.c
	libguile/smob.c
	libguile/smob.h
	module/ice-9/deprecated.scm
	module/ice-9/r4rs.scm

benchmark-suite/benchmarks/ports.bm

@@ -1,6 +1,6 @@
 ;;; ports.bm --- Port I/O.         -*- mode: scheme; coding: utf-8; -*-
 ;;;
-;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 2012 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
@@ -21,68 +21,72 @@
   #:use-module (ice-9 rdelim)
   #:use-module (benchmark-suite lib))
 
+(define-syntax sequence
+  (lambda (s)
+    ;; Create a sequence `(begin EXPR ...)' with COUNT occurrences of EXPR.
+    (syntax-case s ()
+      ((_ expr count)
+       (number? (syntax->datum #'count))
+       (cons #'begin
+             (make-list (syntax->datum #'count) #'expr))))))
+
+(define (large-string s)
+  (string-concatenate (make-list (* iteration-factor 10000) s)))
+
 (define %latin1-port
   (with-fluids ((%default-port-encoding #f))
-    (open-input-string "hello, world")))
+    (open-input-string (large-string "hello, world"))))
 
 (define %utf8/ascii-port
   (with-fluids ((%default-port-encoding "UTF-8"))
-    (open-input-string "hello, world")))
+    (open-input-string (large-string "hello, world"))))
 
 (define %utf8/wide-port
   (with-fluids ((%default-port-encoding "UTF-8"))
-    (open-input-string "안녕하세요")))
+    (open-input-string (large-string "안녕하세요"))))
 
 
 (with-benchmark-prefix "peek-char"
 
-  (benchmark "latin-1 port" 700000
+  (benchmark "latin-1 port" 700
-    (peek-char %latin1-port))
+    (sequence (peek-char %latin1-port) 1000))
 
-  (benchmark "utf-8 port, ascii character" 700000
+  (benchmark "utf-8 port, ascii character" 700
-    (peek-char %utf8/ascii-port))
+    (sequence (peek-char %utf8/ascii-port) 1000))
 
-  (benchmark "utf-8 port, Korean character" 700000
+  (benchmark "utf-8 port, Korean character" 700
-    (peek-char %utf8/wide-port)))
+    (sequence (peek-char %utf8/wide-port) 1000)))
-
-(with-benchmark-prefix "read-char"
-
-  (benchmark "latin-1 port" 10000000
-    (read-char %latin1-port))
-
-  (benchmark "utf-8 port, ascii character" 10000000
-    (read-char %utf8/ascii-port))
-
-  (benchmark "utf-8 port, Korean character" 10000000
-    (read-char %utf8/wide-port)))
 
 (with-benchmark-prefix "char-ready?"
 
-  (benchmark "latin-1 port" 10000000
+  (benchmark "latin-1 port" 10000
-    (char-ready? %latin1-port))
+    (sequence (char-ready? %latin1-port) 1000))
 
-  (benchmark "utf-8 port, ascii character" 10000000
+  (benchmark "utf-8 port, ascii character" 10000
-    (char-ready? %utf8/ascii-port))
+    (sequence (char-ready? %utf8/ascii-port) 1000))
 
-  (benchmark "utf-8 port, Korean character" 10000000
+  (benchmark "utf-8 port, Korean character" 10000
-    (char-ready? %utf8/wide-port)))
+    (sequence (char-ready? %utf8/wide-port) 1000)))
+
+;; Keep the `read-char' benchmarks last as they consume input from the
+;; ports.
+
+(with-benchmark-prefix "read-char"
+
+  (benchmark "latin-1 port" 10000
+    (sequence (read-char %latin1-port) 1000))
+
+  (benchmark "utf-8 port, ascii character" 10000
+    (sequence (read-char %utf8/ascii-port) 1000))
+
+  (benchmark "utf-8 port, Korean character" 10000
+    (sequence (read-char %utf8/wide-port) 1000)))
 
 
 (with-benchmark-prefix "rdelim"
 
-  (let-syntax ((sequence (lambda (s)
+  (let ((str (string-concatenate (make-list 1000 "one line\n"))))
-                           ;; Create a sequence `(begin EXPR ...)' with
+    (benchmark "read-line" 1000
-                           ;; COUNT occurrences of EXPR.
+               (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
-                           (syntax-case s ()
+                             (open-input-string str))))
-                             ((_ expr count)
+                 (sequence (read-line port) 1000)))))
-                              (number? (syntax->datum #'count))
-                              (cons #'begin
-                                    (make-list
-                                     (syntax->datum #'count)
-                                     #'expr)))))))
-    (let ((str (string-concatenate
-                (make-list 1000 "one line\n"))))
-      (benchmark "read-line" 1000
-        (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
-                      (open-input-string str))))
-          (sequence (read-line port) 1000))))))

configure.ac

@@ -1232,7 +1232,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 GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes])
+AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes GC_set_finalizer_notifier])
 
 # 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

doc/ref/api-data.texi

@@ -3405,7 +3405,6 @@ i18n)} module}, for locale-dependent string comparison.
 
 @rnindex string=?
 @deffn {Scheme Procedure} string=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_equal_p (s1, s2, rest)
 Lexicographic equality predicate; return @code{#t} if all strings are
 the same length and contain the same characters in the same positions,
 otherwise return @code{#f}.
@@ -3418,7 +3417,6 @@ characters.
 
 @rnindex string<?
 @deffn {Scheme Procedure} string<? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_less_p (s1, s2, rest)
 Lexicographic ordering predicate; return @code{#t} if, for every pair of
 consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
 lexicographically less than @var{str_i+1}.
@@ -3426,7 +3424,6 @@ lexicographically less than @var{str_i+1}.
 
 @rnindex string<=?
 @deffn {Scheme Procedure} string<=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_leq_p (s1, s2, rest)
 Lexicographic ordering predicate; return @code{#t} if, for every pair of
 consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
 lexicographically less than or equal to @var{str_i+1}.
@@ -3434,7 +3431,6 @@ lexicographically less than or equal to @var{str_i+1}.
 
 @rnindex string>?
 @deffn {Scheme Procedure} string>? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_gr_p (s1, s2, rest)
 Lexicographic ordering predicate; return @code{#t} if, for every pair of
 consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
 lexicographically greater than @var{str_i+1}.
@@ -3442,7 +3438,6 @@ lexicographically greater than @var{str_i+1}.
 
 @rnindex string>=?
 @deffn {Scheme Procedure} string>=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_geq_p (s1, s2, rest)
 Lexicographic ordering predicate; return @code{#t} if, for every pair of
 consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
 lexicographically greater than or equal to @var{str_i+1}.
@@ -3450,7 +3445,6 @@ lexicographically greater than or equal to @var{str_i+1}.
 
 @rnindex string-ci=?
 @deffn {Scheme Procedure} string-ci=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_equal_p (s1, s2, rest)
 Case-insensitive string equality predicate; return @code{#t} if
 all strings are the same length and their component
 characters match (ignoring case) at each position; otherwise
@@ -3459,7 +3453,6 @@ return @code{#f}.
 
 @rnindex string-ci<?
 @deffn {Scheme Procedure} string-ci<? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_less_p (s1, s2, rest)
 Case insensitive lexicographic ordering predicate; return @code{#t} if,
 for every pair of consecutive string arguments @var{str_i} and
 @var{str_i+1}, @var{str_i} is lexicographically less than @var{str_i+1}
@@ -3468,7 +3461,6 @@ regardless of case.
 
 @rnindex string<=?
 @deffn {Scheme Procedure} string-ci<=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_leq_p (s1, s2, rest)
 Case insensitive lexicographic ordering predicate; return @code{#t} if,
 for every pair of consecutive string arguments @var{str_i} and
 @var{str_i+1}, @var{str_i} is lexicographically less than or equal to
@@ -3477,7 +3469,6 @@ for every pair of consecutive string arguments @var{str_i} and
 
 @rnindex string-ci>?
 @deffn {Scheme Procedure} string-ci>? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_gr_p (s1, s2, rest)
 Case insensitive lexicographic ordering predicate; return @code{#t} if,
 for every pair of consecutive string arguments @var{str_i} and
 @var{str_i+1}, @var{str_i} is lexicographically greater than
@@ -3486,7 +3477,6 @@ for every pair of consecutive string arguments @var{str_i} and
 
 @rnindex string-ci>=?
 @deffn {Scheme Procedure} string-ci>=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_geq_p (s1, s2, rest)
 Case insensitive lexicographic ordering predicate; return @code{#t} if,
 for every pair of consecutive string arguments @var{str_i} and
 @var{str_i+1}, @var{str_i} is lexicographically greater than or equal to

libguile/finalizers.c

@@ -41,6 +41,17 @@
 static size_t finalization_count;
 
 
+
+
+#ifndef HAVE_GC_SET_FINALIZER_NOTIFIER
+static void
+GC_set_finalizer_notifier (void (*notifier) (void))
+{
+  GC_finalizer_notifier = notifier;
+}
+#endif
+
+
 
 
 void
@@ -142,10 +153,9 @@ run_finalizers_async_thunk (void)
 }
 
 
-/* The function queue_after_gc_hook is run by the scm_before_gc_c_hook
+/* The function queue_finalizer_async is run by the GC when there are
- * at the end of the garbage collection.  The only purpose of this
+ * objects to finalize.  It will enqueue an asynchronous call to
- * function is to mark the after_gc_async (which will eventually lead to
+ * GC_invoke_finalizers() at the next SCM_TICK in this thread.
- * the execution of the after_gc_async_thunk).
  */
 static void
 queue_finalizer_async (void)
@@ -154,7 +164,10 @@ queue_finalizer_async (void)
   static scm_i_pthread_mutex_t lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
   scm_i_pthread_mutex_lock (&lock);
-  if (scm_is_false (SCM_CDR (finalizer_async_cell)))
+  /* If t is NULL, that could be because we're allocating in
+     threads.c:guilify_self_1.  In that case, rely on the
+     GC_invoke_finalizers call there after the thread spins up.  */
+  if (t && scm_is_false (SCM_CDR (finalizer_async_cell)))
     {
       SCM_SETCDR (finalizer_async_cell, t->active_asyncs);
       t->active_asyncs = finalizer_async_cell;

libguile/gc.c

@@ -384,6 +384,8 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
 #define FUNC_NAME s_scm_gc
 {
   scm_i_gc ("call");
+  /* If you're calling scm_gc(), you probably want synchronous
+     finalization.  */
   GC_invoke_finalizers ();
   return SCM_UNSPECIFIED;
 }

libguile/init.c

@@ -444,7 +444,8 @@ scm_i_init_guile (void *base)
   scm_init_ioext ();
   scm_init_keywords ();    /* Requires smob_prehistory */
   scm_init_list ();
-  scm_init_macros ();      /* Requires smob_prehistory */
+  scm_init_random ();      /* Requires smob_prehistory */
+  scm_init_macros ();      /* Requires smob_prehistory and random */
   scm_init_mallocs ();     /* Requires smob_prehistory */
   scm_init_modules ();     /* Requires smob_prehistory */
   scm_init_numbers ();
@@ -502,7 +503,6 @@ scm_i_init_guile (void *base)
   scm_init_eval_in_scheme ();
   scm_init_evalext ();
   scm_init_debug ();	/* Requires macro smobs */
-  scm_init_random ();   /* Requires smob_prehistory */
   scm_init_simpos ();
 #if HAVE_MODULES
   scm_init_dynamic_linking (); /* Requires smob_prehistory */

libguile/strings.c

@@ -748,7 +748,7 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
       name = SH_STRING_STRING (name);
       start += STRING_START (name);
     }
-  buf = SYMBOL_STRINGBUF (name);
+  buf = STRING_STRINGBUF (name);
 
   if (start == 0 && length == STRINGBUF_LENGTH (buf))
     {

libguile/threads.c

@@ -625,6 +625,9 @@ guilify_self_2 (SCM parent)
 
   t->join_queue = make_queue ();
   t->block_asyncs = 0;
+
+  /* See note in finalizers.c:queue_finalizer_async().  */
+  GC_invoke_finalizers ();
 }
 
 

libguile/vports.c

@@ -56,21 +56,11 @@ sf_flush (SCM port)
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
   SCM stream = SCM_PACK (pt->stream);
 
-  if (pt->write_pos > pt->write_buf)
+  SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
-    {
-      /* write the byte. */
-      scm_call_1 (SCM_SIMPLE_VECTOR_REF (stream, 0),
-		  SCM_MAKE_CHAR (*pt->write_buf));
-      pt->write_pos = pt->write_buf;
 
-      /* flush the output.  */
+  if (scm_is_true (f))
-      {
+    scm_call_0 (f);
-	SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
 
-	if (scm_is_true (f))
-	  scm_call_0 (f);
-      }
-    }
 }
 
 static void

module/ice-9/psyntax-pp.scm

@@ -2682,83 +2682,6 @@
               "source expression failed to match any pattern"
               tmp-1)))))))
 
-(define do
-  (make-syntax-transformer
-    'do
-    'macro
-    (lambda (orig-x)
-      (let ((tmp-1 orig-x))
-        (let ((tmp ($sc-dispatch
-                     tmp-1
-                     '(_ #(each (any any . any)) (any . each-any) . each-any))))
-          (if tmp
-            (apply (lambda (var init step e0 e1 c)
-                     (let ((tmp-1 (map (lambda (v s)
-                                         (let ((tmp-1 s))
-                                           (let ((tmp ($sc-dispatch tmp-1 '())))
-                                             (if tmp
-                                               (apply (lambda () v) tmp)
-                                               (let ((tmp ($sc-dispatch tmp-1 '(any))))
-                                                 (if tmp
-                                                   (apply (lambda (e) e) tmp)
-                                                   (syntax-violation 'do "bad step expression" orig-x s)))))))
-                                       var
-                                       step)))
-                       (let ((tmp ($sc-dispatch tmp-1 'each-any)))
-                         (if tmp
-                           (apply (lambda (step)
-                                    (let ((tmp e1))
-                                      (let ((tmp-1 ($sc-dispatch tmp '())))
-                                        (if tmp-1
-                                          (apply (lambda ()
-                                                   (list '#(syntax-object let ((top)) (hygiene guile))
-                                                         '#(syntax-object doloop ((top)) (hygiene guile))
-                                                         (map list var init)
-                                                         (list '#(syntax-object if ((top)) (hygiene guile))
-                                                               (list '#(syntax-object not ((top)) (hygiene guile)) e0)
-                                                               (cons '#(syntax-object begin ((top)) (hygiene guile))
-                                                                     (append
-                                                                       c
-                                                                       (list (cons '#(syntax-object
-                                                                                      doloop
-                                                                                      ((top))
-                                                                                      (hygiene guile))
-                                                                                   step)))))))
-                                                 tmp-1)
-                                          (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
-                                            (if tmp-1
-                                              (apply (lambda (e1 e2)
-                                                       (list '#(syntax-object let ((top)) (hygiene guile))
-                                                             '#(syntax-object doloop ((top)) (hygiene guile))
-                                                             (map list var init)
-                                                             (list '#(syntax-object if ((top)) (hygiene guile))
-                                                                   e0
-                                                                   (cons '#(syntax-object begin ((top)) (hygiene guile))
-                                                                         (cons e1 e2))
-                                                                   (cons '#(syntax-object begin ((top)) (hygiene guile))
-                                                                         (append
-                                                                           c
-                                                                           (list (cons '#(syntax-object
-                                                                                          doloop
-                                                                                          ((top))
-                                                                                          (hygiene guile))
-                                                                                       step)))))))
-                                                     tmp-1)
-                                              (syntax-violation
-                                                #f
-                                                "source expression failed to match any pattern"
-                                                tmp)))))))
-                                  tmp)
-                           (syntax-violation
-                             #f
-                             "source expression failed to match any pattern"
-                             tmp-1)))))
-                   tmp)
-            (syntax-violation
-              #f
-              "source expression failed to match any pattern"
-              tmp-1)))))))
-
 (define quasiquote
   (make-syntax-transformer
     'quasiquote
@@ -3163,66 +3086,6 @@
         "expression not valid outside of quasiquote"
         x))))
 
-(define case
-  (make-syntax-transformer
-    'case
-    'macro
-    (lambda (x)
-      (let ((tmp-1 x))
-        (let ((tmp ($sc-dispatch tmp-1 '(_ any any . each-any))))
-          (if tmp
-            (apply (lambda (e m1 m2)
-                     (let ((tmp (let f ((clause m1) (clauses m2))
-                                  (if (null? clauses)
-                                    (let ((tmp-1 clause))
-                                      (let ((tmp ($sc-dispatch
-                                                   tmp-1
-                                                   '(#(free-id #(syntax-object else ((top)) (hygiene guile)))
-                                                     any
-                                                     .
-                                                     each-any))))
-                                        (if tmp
-                                          (apply (lambda (e1 e2)
-                                                   (cons '#(syntax-object begin ((top)) (hygiene guile)) (cons e1 e2)))
-                                                 tmp)
-                                          (let ((tmp ($sc-dispatch tmp-1 '(each-any any . each-any))))
-                                            (if tmp
-                                              (apply (lambda (k e1 e2)
-                                                       (list '#(syntax-object if ((top)) (hygiene guile))
-                                                             (list '#(syntax-object memv ((top)) (hygiene guile))
-                                                                   '#(syntax-object t ((top)) (hygiene guile))
-                                                                   (list '#(syntax-object quote ((top)) (hygiene guile))
-                                                                         k))
-                                                             (cons '#(syntax-object begin ((top)) (hygiene guile))
-                                                                   (cons e1 e2))))
-                                                     tmp)
-                                              (syntax-violation 'case "bad clause" x clause))))))
-                                    (let ((tmp (f (car clauses) (cdr clauses))))
-                                      (let ((rest tmp))
-                                        (let ((tmp clause))
-                                          (let ((tmp ($sc-dispatch tmp '(each-any any . each-any))))
-                                            (if tmp
-                                              (apply (lambda (k e1 e2)
-                                                       (list '#(syntax-object if ((top)) (hygiene guile))
-                                                             (list '#(syntax-object memv ((top)) (hygiene guile))
-                                                                   '#(syntax-object t ((top)) (hygiene guile))
-                                                                   (list '#(syntax-object quote ((top)) (hygiene guile))
-                                                                         k))
-                                                             (cons '#(syntax-object begin ((top)) (hygiene guile))
-                                                                   (cons e1 e2))
-                                                             rest))
-                                                     tmp)
-                                              (syntax-violation 'case "bad clause" x clause))))))))))
-                       (let ((body tmp))
-                         (list '#(syntax-object let ((top)) (hygiene guile))
-                               (list (list '#(syntax-object t ((top)) (hygiene guile)) e))
-                               body))))
-                   tmp)
-            (syntax-violation
-              #f
-              "source expression failed to match any pattern"
-              tmp-1)))))))
-
 (define make-variable-transformer
   (lambda (proc)
     (if (procedure? proc)

module/ice-9/psyntax.scm

@@ -608,22 +608,15 @@
 
     ;; syntax object wraps
 
-    ;;         <wrap> ::= ((<mark> ...) . (<subst> ...))
+    ;;      <wrap> ::= ((<mark> ...) . (<subst> ...))
-    ;;        <subst> ::= <shift> | <subs>
+    ;;     <subst> ::= shift | <subs>
-    ;;         <subs> ::= #(<old name> <label> (<mark> ...))
+    ;;      <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
-    ;;        <shift> ::= positive fixnum
+    ;;                 | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
 
     (define-syntax make-wrap (identifier-syntax cons))
     (define-syntax wrap-marks (identifier-syntax car))
     (define-syntax wrap-subst (identifier-syntax cdr))
 
-    (define-syntax subst-rename? (identifier-syntax vector?))
-    (define-syntax-rule (rename-old x) (vector-ref x 0))
-    (define-syntax-rule (rename-new x) (vector-ref x 1))
-    (define-syntax-rule (rename-marks x) (vector-ref x 2))
-    (define-syntax-rule (make-rename old new marks)
-      (vector old new marks))
-
     ;; labels must be comparable with "eq?", have read-write invariance,
     ;; and distinct from symbols.
     (define (gen-label)
@@ -2903,6 +2896,9 @@
                            (binding (car bindings)))
                #'(let (binding) body))))))))
 
+;; This definition of 'do' is never used, as it is immediately
+;; replaced by the definition in boot-9.scm.
+#;
 (define-syntax do
    (lambda (orig-x)
       (syntax-case orig-x ()
@@ -3076,6 +3072,10 @@
                       "expression not valid outside of quasiquote"
                       x)))
 
+;; This definition of 'case' is never used, as it is immediately
+;; replaced by the definition in boot-9.scm.  This version lacks
+;; R7RS-mandated support for '=>'.
+#;
 (define-syntax case
   (lambda (x)
     (syntax-case x ()