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

Conflicts:
	libguile/deprecation.c
	libguile/load.c
	libguile/print.c

libguile/deprecation.c

@@ -89,8 +89,8 @@ scm_c_issue_deprecation_warning (const char *msg)
             fprintf (stderr, "%s\n", msg);
           else
             {
-              scm_puts_unlocked (msg, scm_current_error_port ());
+              scm_puts_unlocked (msg, scm_current_warning_port ());
-              scm_newline (scm_current_error_port ());
+              scm_newline (scm_current_warning_port ());
             }
         }
     }

libguile/gc-malloc.c

@@ -153,7 +153,8 @@ scm_strdup (const char *str)
 void
 scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
 {
-  /* Nothing to do.  */
+  scm_gc_register_allocation (size);
+
 #ifdef GUILE_DEBUG_MALLOC
   if (mem)
     scm_malloc_register (mem, what);

libguile/load.c

@@ -738,18 +738,18 @@ auto_compile_catch_handler (void *data, SCM tag, SCM throw_args)
   oport = scm_open_output_string ();
   scm_print_exception (oport, SCM_BOOL_F, tag, throw_args);
 
-  scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_error_port ());
+  scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_warning_port ());
-  scm_display (source, scm_current_error_port ());
+  scm_display (source, scm_current_warning_port ());
-  scm_puts_unlocked (" failed:\n", scm_current_error_port ());
+  scm_puts_unlocked (" failed:\n", scm_current_warning_port ());
 
   lines = scm_string_split (scm_get_output_string (oport),
                             SCM_MAKE_CHAR ('\n'));
   for (; scm_is_pair (lines); lines = scm_cdr (lines))
     if (scm_c_string_length (scm_car (lines)))
       {
-        scm_puts_unlocked (";;; ", scm_current_error_port ());
+        scm_puts_unlocked (";;; ", scm_current_warning_port ());
-        scm_display (scm_car (lines), scm_current_error_port ());
+        scm_display (scm_car (lines), scm_current_warning_port ());
-        scm_newline (scm_current_error_port ());
+        scm_newline (scm_current_warning_port ());
       }
 
   scm_close_port (oport);
@@ -767,7 +767,7 @@ SCM_DEFINE (scm_sys_warn_auto_compilation_enabled, "%warn-auto-compilation-enabl
     {
       scm_puts_unlocked (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n"
                 ";;;       or pass the --no-auto-compile argument to disable.\n",
-                scm_current_error_port ());
+                scm_current_warning_port ());
       message_shown = 1;
     }
 
@@ -933,9 +933,9 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
       if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
                                               &stat_source, &stat_compiled))
         {
-          scm_puts_unlocked (";;; found fresh local cache at ", scm_current_error_port ());
+          scm_puts_unlocked (";;; found fresh local cache at ", scm_current_warning_port ());
-          scm_display (fallback, scm_current_error_port ());
+          scm_display (fallback, scm_current_warning_port ());
-          scm_newline (scm_current_error_port ());
+          scm_newline (scm_current_warning_port ());
           return scm_load_compiled_with_vm (fallback);
         }
     }

libguile/numbers.c

@@ -5321,8 +5321,14 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
   else if (SCM_BIGP (n))
     {
       char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
+      size_t len = strlen (str);
+      void (*freefunc) (void *, size_t);
+      SCM ret;
+      mp_get_memory_functions (NULL, NULL, &freefunc);
       scm_remember_upto_here_1 (n);
-      return scm_take_locale_string (str);
+      ret = scm_from_latin1_stringn (str, len);
+      freefunc (str, len + 1);
+      return ret;
     }
   else if (SCM_FRACTIONP (n))
     {

libguile/poll.c

@@ -184,6 +184,7 @@ scm_init_poll (void)
 {
 #if HAVE_POLL
   scm_c_define_gsubr ("primitive-poll", 4, 0, 0, scm_primitive_poll);
+  scm_c_define ("%sizeof-struct-pollfd", scm_from_size_t (sizeof (struct pollfd)));
 #else
   scm_misc_error ("%init-poll", "`poll' unavailable on this platform", SCM_EOL);
 #endif

libguile/ports.c

@@ -328,6 +328,17 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM
+scm_current_warning_port (void)
+{
+  static SCM cwp_var = SCM_BOOL_F;
+
+  if (scm_is_false (cwp_var))
+    cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
+  
+  return scm_call_0 (scm_variable_ref (cwp_var));
+}
+
 SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
 	    (),
 	    "Return the current-load-port.\n"
@@ -382,6 +393,19 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+
+SCM
+scm_set_current_warning_port (SCM port)
+{
+  static SCM cwp_var = SCM_BOOL_F;
+
+  if (scm_is_false (cwp_var))
+    cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
+  
+  return scm_call_1 (scm_variable_ref (cwp_var), port);
+}
+
+
 void
 scm_dynwind_current_input_port (SCM port)
 #define FUNC_NAME NULL

libguile/ports.h

@@ -241,10 +241,12 @@ SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SC
 SCM_API SCM scm_current_input_port (void);
 SCM_API SCM scm_current_output_port (void);
 SCM_API SCM scm_current_error_port (void);
+SCM_API SCM scm_current_warning_port (void);
 SCM_API SCM scm_current_load_port (void);
 SCM_API SCM scm_set_current_input_port (SCM port);
 SCM_API SCM scm_set_current_output_port (SCM port);
 SCM_API SCM scm_set_current_error_port (SCM port);
+SCM_API SCM scm_set_current_warning_port (SCM port);
 SCM_API void scm_dynwind_current_input_port (SCM port);
 SCM_API void scm_dynwind_current_output_port (SCM port);
 SCM_API void scm_dynwind_current_error_port (SCM port);

libguile/print.c

@@ -106,8 +106,9 @@ scm_t_option scm_print_opts[] = {
   { SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F_BITS,
     "How to print symbols that have a colon as their first or last character. "
     "The value '#f' does not quote the colons; '#t' quotes them; "
-    "'reader' quotes them when the reader option 'keywords' is not '#f'." 
+    "'reader' quotes them when the reader option 'keywords' is not '#f'." },
-  },
+  { SCM_OPTION_BOOLEAN, "escape-newlines", 1,
+    "Render newlines as \\n when printing using `write'." },
   { 0 },
 };
 
@@ -1104,6 +1105,12 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
 	  display_character (ch, port, strategy);
 	  printed = 1;
 	}
+      else if (ch == '\n' && SCM_PRINT_ESCAPE_NEWLINES_P)
+        {
+	  display_character ('\\', port, iconveh_question_mark);
+	  display_character ('n', port, strategy);
+	  printed = 1;
+        }
       else if (ch == ' ' || ch == '\n')
 	{
 	  display_character (ch, port, strategy);
@@ -1522,13 +1529,6 @@ scm_init_print ()
 {
   SCM type;
 
-  scm_init_opts (scm_print_options, scm_print_opts);
-
-  scm_print_options (scm_list_4 (scm_from_latin1_symbol ("highlight-prefix"),
-				 scm_from_locale_string ("{"),
-				 scm_from_latin1_symbol ("highlight-suffix"),
-				 scm_from_locale_string ("}")));
-
   type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
                           SCM_BOOL_F);
   scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
@@ -1540,6 +1540,11 @@ scm_init_print ()
 
 #include "libguile/print.x"
 
+  scm_init_opts (scm_print_options, scm_print_opts);
+  scm_print_opts[SCM_PRINT_HIGHLIGHT_PREFIX_I].val =
+    SCM_UNPACK (scm_from_locale_string ("{"));
+  scm_print_opts[SCM_PRINT_HIGHLIGHT_SUFFIX_I].val =
+    SCM_UNPACK (scm_from_locale_string ("}"));
   scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
 }
 

libguile/private-options.h

@@ -45,11 +45,14 @@ SCM_INTERNAL scm_t_option scm_debug_opts[];
 */
 SCM_INTERNAL scm_t_option scm_print_opts[];
 
+#define SCM_PRINT_HIGHLIGHT_PREFIX_I 0
 #define SCM_PRINT_HIGHLIGHT_PREFIX  (SCM_PACK (scm_print_opts[0].val))
+#define SCM_PRINT_HIGHLIGHT_SUFFIX_I 1
 #define SCM_PRINT_HIGHLIGHT_SUFFIX  (SCM_PACK (scm_print_opts[1].val))
 #define SCM_PRINT_KEYWORD_STYLE_I   2
 #define SCM_PRINT_KEYWORD_STYLE     (SCM_PACK (scm_print_opts[2].val))
-#define SCM_N_PRINT_OPTIONS 3
+#define SCM_PRINT_ESCAPE_NEWLINES_P scm_print_opts[3].val
+#define SCM_N_PRINT_OPTIONS 4
 
 
 /*

module/ice-9/boot-9.scm

@@ -213,9 +213,11 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (define pk peek)
 
+;; Temporary definition; replaced later.
+(define current-warning-port current-error-port)
 
 (define (warn . stuff)
-  (with-output-to-port (current-error-port)
+  (with-output-to-port (current-warning-port)
     (lambda ()
       (newline)
       (display ";;; WARNING ")
@@ -1373,7 +1375,7 @@ VALUE."
 
 (define (%load-announce file)
   (if %load-verbosely
-      (with-output-to-port (current-error-port)
+      (with-output-to-port (current-warning-port)
         (lambda ()
           (display ";;; ")
           (display "loading ")
@@ -2823,6 +2825,68 @@ module '(ice-9 q) '(make-q q-length))}."
 (define (unspecified? v) (eq? v *unspecified*))
 
 
+
+
+;;; {Parameters}
+;;;
+
+(define <parameter>
+  ;; Three fields: the procedure itself, the fluid, and the converter.
+  (make-struct <applicable-struct-vtable> 0 'pwprpr))
+(set-struct-vtable-name! <parameter> '<parameter>)
+
+(define* (make-parameter init #:optional (conv (lambda (x) x)))
+  (let ((fluid (make-fluid (conv init))))
+    (make-struct <parameter> 0
+                 (case-lambda
+                   (() (fluid-ref fluid))
+                   ((x) (let ((prev (fluid-ref fluid)))
+                          (fluid-set! fluid (conv x))
+                          prev)))
+                 fluid conv)))
+
+(define (parameter? x)
+  (and (struct? x) (eq? (struct-vtable x) <parameter>)))
+
+(define (parameter-fluid p)
+  (if (parameter? p)
+      (struct-ref p 1)
+      (scm-error 'wrong-type-arg "parameter-fluid"
+                 "Not a parameter: ~S" (list p) #f)))
+
+(define (parameter-converter p)
+  (if (parameter? p)
+      (struct-ref p 2)
+      (scm-error 'wrong-type-arg "parameter-fluid"
+                 "Not a parameter: ~S" (list p) #f)))
+
+(define-syntax parameterize
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((param value) ...) body body* ...)
+       (with-syntax (((p ...) (generate-temporaries #'(param ...))))
+         #'(let ((p param) ...)
+             (if (not (parameter? p))
+                        (scm-error 'wrong-type-arg "parameterize"
+                                   "Not a parameter: ~S" (list p) #f))
+             ...
+             (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
+                           ...)
+               body body* ...)))))))
+
+
+;;;
+;;; Warnings.
+;;;
+
+(define current-warning-port
+  (make-parameter (current-error-port)
+                  (lambda (x)
+                    (if (output-port? x)
+                        x
+                        (error "expected an output port" x)))))
+
+
 
 
 ;;; {Running Repls}
@@ -3288,7 +3352,7 @@ module '(ice-9 q) '(make-q q-length))}."
                  #f))
     
     (define (warn module name int1 val1 int2 val2 var val)
-      (format (current-error-port)
+      (format (current-warning-port)
               "WARNING: ~A: `~A' imported from both ~A and ~A\n"
               (module-name module)
               name
@@ -3310,7 +3374,7 @@ module '(ice-9 q) '(make-q q-length))}."
     (define (warn-override-core module name int1 val1 int2 val2 var val)
       (and (eq? int1 the-scm-module)
            (begin
-             (format (current-error-port)
+             (format (current-warning-port)
                      "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
                      (module-name module)
                      (module-name int2)
@@ -3432,13 +3496,13 @@ module '(ice-9 q) '(make-q q-length))}."
               go-path
               (begin
                 (if gostat
-                    (format (current-error-port)
+                    (format (current-warning-port)
                             ";;; note: source file ~a\n;;;       newer than compiled ~a\n"
                             name go-path))
                 (cond
                  (%load-should-auto-compile
                   (%warn-auto-compilation-enabled)
-                  (format (current-error-port) ";;; compiling ~a\n" name)
+                  (format (current-warning-port) ";;; compiling ~a\n" name)
                   (let ((cfn
                          ((module-ref
                                (resolve-interface '(system base compile))
@@ -3446,15 +3510,15 @@ module '(ice-9 q) '(make-q q-length))}."
                               name
                               #:opts %auto-compilation-options
                               #:env (current-module))))
-                    (format (current-error-port) ";;; compiled ~a\n" cfn)
+                    (format (current-warning-port) ";;; compiled ~a\n" cfn)
                     cfn))
                  (else #f))))))
       (lambda (k . args)
-        (format (current-error-port)
+        (format (current-warning-port)
                 ";;; WARNING: compilation of ~a failed:\n" name)
         (for-each (lambda (s)
                     (if (not (string-null? s))
-                        (format (current-error-port) ";;; ~a\n" s)))
+                        (format (current-warning-port) ";;; ~a\n" s)))
                   (string-split
                    (call-with-output-string
                     (lambda (port) (print-exception port #f k args)))

module/ice-9/poll.scm

@@ -38,6 +38,9 @@
   (load-extension (string-append "libguile-" (effective-version))
                   "scm_init_poll"))
 
+(if (not (= %sizeof-struct-pollfd 8))
+    (error "Unexpected struct pollfd size" %sizeof-struct-pollfd))
+
 (if (defined? 'POLLIN)
     (export POLLIN))
 

module/system/base/message.scm

@@ -54,11 +54,13 @@
 ;;; Warnings
 ;;;
 
+;; This name existed before %current-warning-port was introduced, but
+;; otherwise it is a deprecated binding.
 (define *current-warning-port*
-  ;; The port where warnings are sent.
+  ;; Can't play the identifier-syntax deprecation game in Guile 2.0, as
-  (make-fluid (current-error-port)))
+  ;; other modules might depend on this being a normal binding and not a
-
+  ;; syntax binding.
-(fluid-set! *current-warning-port* (current-error-port))
+  (parameter-fluid current-warning-port))
 
 (define *current-warning-prefix*
   ;; Prefix string when emitting a warning.
@@ -194,7 +196,7 @@
   "Emit a warning of type TYPE for source location LOCATION (a source
 property alist) using the data in ARGS."
   (let ((wt   (lookup-warning-type type))
-        (port (fluid-ref *current-warning-port*)))
+        (port (current-warning-port)))
     (if (warning-type? wt)
         (apply (warning-type-printer wt)
                port (location-string location)

module/system/repl/command.scm

@@ -441,6 +441,7 @@ Change languages."
         (cur (repl-language repl)))
     (format #t "Happy hacking with ~a!  To switch back, type `,L ~a'.\n"
             (language-title lang) (language-name cur))
+    (fluid-set! *current-language* lang)
     (set! (repl-language repl) lang)))
 
 

module/system/repl/repl.scm

@@ -132,7 +132,10 @@
 ;;;
 
 (define* (start-repl #:optional (lang (current-language)) #:key debug)
-  (run-repl (make-repl lang debug)))
+  ;; ,language at the REPL will fluid-set! the *current-language*.  Make
+  ;; sure that it does so in a new scope.
+  (with-fluids ((*current-language* lang))
+    (run-repl (make-repl lang debug))))
 
 ;; (put 'abort-on-error 'scheme-indent-function 1)
 (define-syntax-rule (abort-on-error string exp)

module/web/client.scm

@@ -27,7 +27,7 @@
 ;;; the web server.
 ;;;
 ;;; Another option, good but not as performant, would be to use threads,
-;;; possibly via par-map or futures.
+;;; possibly via a thread pool.
 ;;;
 ;;; Code:
 

module/web/uri.scm

@@ -125,14 +125,18 @@ consistency checks to make sure that the constructed URI is valid."
            userinfo-pat host-pat port-pat)))
 
 (define (parse-authority authority fail)
-  (let ((m (regexp-exec authority-regexp authority)))
+  (if (equal? authority "//")
-    (if (and m (valid-host? (match:substring m 3)))
+      ;; Allow empty authorities: file:///etc/hosts is a synonym of
-        (values (match:substring m 2)
+      ;; file:/etc/hosts.
-                (match:substring m 3)
+      (values #f #f #f)
-                (let ((port (match:substring m 5)))
+      (let ((m (regexp-exec authority-regexp authority)))
-                  (and port (not (string-null? port))
+        (if (and m (valid-host? (match:substring m 3)))
-                       (string->number port))))
+            (values (match:substring m 2)
-        (fail))))
+                    (match:substring m 3)
+                    (let ((port (match:substring m 5)))
+                      (and port (not (string-null? port))
+                           (string->number port))))
+            (fail)))))
 
 
 ;;; RFC 3986, #3.

test-suite/Makefile.am

@@ -74,6 +74,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/numbers.test			\
 	    tests/optargs.test			\
 	    tests/options.test			\
+	    tests/parameters.test		\
 	    tests/print.test			\
 	    tests/procprop.test			\
 	    tests/procs.test			\

test-suite/tests/parameters.test

@@ -0,0 +1,69 @@
+;;;; srfi-39.test --- -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 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 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, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;; Testing the parameters implementation in boot-9.
+;;
+(define-module (test-parameters)
+  #:use-module (srfi srfi-34)
+  #:use-module (test-suite lib))
+
+(define a (make-parameter 3))
+(define b (make-parameter 4))
+
+(define (check a b a-val b-val)
+  (and (eqv? (a) a-val)) (eqv? (b) b-val))
+
+(define c (make-parameter 2 (lambda (x) (if (< x 10) x 10))))
+(define d (make-parameter 15 (lambda (x) (if (< x 10) x 10))))
+
+(with-test-prefix "parameters"
+
+  (pass-if "test 1"
+    (check a b 3 4))
+
+  (pass-if "test 2"
+    (parameterize ((a 2) (b 1))
+      (and (check a b 2 1)
+	   (parameterize ((b 8))
+	     (check a b 2 8)))))
+
+  (pass-if "test 3"
+    (check a b 3 4))
+
+  (pass-if "test 4"
+    (check c d 2 10))
+
+  (pass-if "test 5"
+    (parameterize ((a 0) (b 1) (c 98) (d 9))
+      (and (check a b 0 1)
+           (check c d 10 9)
+           (parameterize ((c (a)) (d (b)))
+	     (and (check a b 0 1)
+		  (check c d 0 1))))))
+
+  (pass-if "SRFI-34"
+    (let ((inside? (make-parameter #f)))
+      (call/cc (lambda (return)
+                 (with-exception-handler
+                  (lambda (c)
+                    ;; This handler should be called in the dynamic
+                    ;; environment installed by `parameterize'.
+                    (return (inside?)))
+                  (lambda ()
+                    (parameterize ((inside? #t))
+                      (raise 'some-exception)))))))))

test-suite/tests/web-uri.test

@@ -1,6 +1,6 @@
 ;;;; web-uri.test --- URI library          -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;; 	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
@@ -150,7 +150,22 @@
     (not (string->uri "http://:10")))
 
   (pass-if "http://foo@"
-    (not (string->uri "http://foo@"))))
+    (not (string->uri "http://foo@")))
+
+  (pass-if "file:/"
+    (uri=? (string->uri "file:/")
+           #:scheme 'file
+           #:path "/"))
+
+  (pass-if "file:/etc/hosts"
+    (uri=? (string->uri "file:/etc/hosts")
+           #:scheme 'file
+           #:path "/etc/hosts"))
+
+  (pass-if "file:///etc/hosts"
+    (uri=? (string->uri "file:///etc/hosts")
+           #:scheme 'file
+           #:path "/etc/hosts")))
 
 (with-test-prefix "uri->string"
   (pass-if "ftp:"