[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-54-g90de5c4

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=90de5c4c2e4fc177c18f6cdd035dad5d8b6895f9

The branch, stable-2.0 has been updated
       via  90de5c4c2e4fc177c18f6cdd035dad5d8b6895f9 (commit)
       via  6d346bb61a2256515a969e4c4683dfa4a692c426 (commit)
       via  8500b18696f5943049d769631b2abf309c98b3d2 (commit)
       via  2aef6c2ba990c5829004c28cd410ba26a74c0597 (commit)
      from  d88f5323d10a09533a5b66bb8031a4e2b8e44313 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 90de5c4c2e4fc177c18f6cdd035dad5d8b6895f9
Author: Andy Wingo <address@hidden>
Date:   Mon Dec 5 14:20:09 2011 +0100

    add srfi-39 parameters to boot-9
    
    * module/ice-9/boot-9.scm (<parameter>, make-parameter, parameter?)
      (parameter-fluid, parameter-converter, parameterize): New top-level
      bindings, implementing SRFI-39 parameters.  Currently,
      current-input-port and similar procedures are not yet parameters.
    
    * test-suite/Makefile.am:
    * test-suite/tests/parameters.test: Add tests, taken from srfi-39
      tests.

commit 6d346bb61a2256515a969e4c4683dfa4a692c426
Author: Andy Wingo <address@hidden>
Date:   Sun Dec 4 22:45:03 2011 +0100

    ice-9/poll: verify sizeof(struct pollfd)
    
    * libguile/poll.c (scm_init_poll): Define %sizeof-struct-pollfd.
    * module/ice-9/poll.scm: Check %sizeof-struct-pollfd.

commit 8500b18696f5943049d769631b2abf309c98b3d2
Author: Andy Wingo <address@hidden>
Date:   Sun Dec 4 22:37:27 2011 +0100

    new print option escape-newlines, defaults to #t
    
    * libguile/private-options.h (SCM_PRINT_ESCAPE_NEWLINES_P):
    * libguile/print.c: Add new escape-newlines print option, defaulting to
      on.
      (write_character): For newlines, if SCM_PRINT_ESCAPE_NEWLINES_P, then
      print them as \n.
      (scm_init_print): Refactor print options initialization.

commit 2aef6c2ba990c5829004c28cd410ba26a74c0597
Author: Andy Wingo <address@hidden>
Date:   Sun Dec 4 21:56:13 2011 +0100

    ,language at REPL sets current-language
    
    * module/system/repl/command.scm (language): Set the
      *current-language*.
    * module/system/repl/repl.scm (start-repl): Create a new dynamic scope
      for *current-language*.

-----------------------------------------------------------------------

Summary of changes:
 libguile/poll.c                  |    1 +
 libguile/print.c                 |   23 ++++++++-----
 libguile/private-options.h       |    5 ++-
 module/ice-9/boot-9.scm          |   47 ++++++++++++++++++++++++++
 module/ice-9/poll.scm            |    3 ++
 module/system/repl/command.scm   |    1 +
 module/system/repl/repl.scm      |    5 ++-
 test-suite/Makefile.am           |    1 +
 test-suite/tests/parameters.test |   69 ++++++++++++++++++++++++++++++++++++++
 9 files changed, 144 insertions(+), 11 deletions(-)
 create mode 100644 test-suite/tests/parameters.test

diff --git a/libguile/poll.c b/libguile/poll.c
index d61d519..1bb7572 100644
--- a/libguile/poll.c
+++ b/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
diff --git a/libguile/print.c b/libguile/print.c
index 4afd12c..2551bdf 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -107,8 +107,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 },
 };
 
@@ -1119,6 +1120,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);
@@ -1529,13 +1536,6 @@ scm_init_print ()
 {
   SCM vtable, layout, 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 ("}")));
-
   scm_gc_register_root (&print_state_pool);
   scm_gc_register_root (&scm_print_state_vtable);
   vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
@@ -1551,6 +1551,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);
 }
 
diff --git a/libguile/private-options.h b/libguile/private-options.h
index c095688..9d2d43c 100644
--- a/libguile/private-options.h
+++ b/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
 
 
 /*
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 5ac01b8..73d897c 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2859,6 +2859,53 @@ module '(ice-9 q) '(make-q q-length))}."
 
 
 
+;;; {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) (fluid-set! fluid (conv x))))
+                 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* ...)))))))
+
+
+
 ;;; {Running Repls}
 ;;;
 
diff --git a/module/ice-9/poll.scm b/module/ice-9/poll.scm
index cf61294..2ba8687 100644
--- a/module/ice-9/poll.scm
+++ b/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))
 
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 3fead7c..a709c8d 100644
--- a/module/system/repl/command.scm
+++ b/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)))
 
 
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 1cffa71..f7b0229 100644
--- a/module/system/repl/repl.scm
+++ b/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)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 05aee78..f825cc7 100644
--- a/test-suite/Makefile.am
+++ b/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                    \
diff --git a/test-suite/tests/parameters.test b/test-suite/tests/parameters.test
new file mode 100644
index 0000000..9d0a092
--- /dev/null
+++ b/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)))))))))


hooks/post-receive
-- 
GNU Guile