[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-204-g04ec290
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-204-g04ec290 |
|
Date: |
Tue, 06 Dec 2011 18:14:57 +0000 |
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=04ec290f8b3e6bd6297fb10391ea7e885a55a786
The branch, master has been updated
via 04ec290f8b3e6bd6297fb10391ea7e885a55a786 (commit)
via 679eea4f0ef7720e0ed3c9ba3fddedf35d1501d6 (commit)
via fe0c202c0ea4ec1ab502b7e26fa70c9e734e8f6c (commit)
via 2c27dd57c7ec4a8168e2668aed380594a99dda8f (commit)
via 3972de7675bf771b403eaef97f0741280649b5ed (commit)
via 13dd74c8eae595889df6f570007b5f50b78073ce (commit)
via 90de5c4c2e4fc177c18f6cdd035dad5d8b6895f9 (commit)
via 6d346bb61a2256515a969e4c4683dfa4a692c426 (commit)
via 8500b18696f5943049d769631b2abf309c98b3d2 (commit)
via 2aef6c2ba990c5829004c28cd410ba26a74c0597 (commit)
via d88f5323d10a09533a5b66bb8031a4e2b8e44313 (commit)
via 76f3ee77b07141b5ba5a199182d0e8118cd026d0 (commit)
from 8806b4c28a7919b236d10751ebcb15f4a503b08c (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 04ec290f8b3e6bd6297fb10391ea7e885a55a786
Merge: 8806b4c 679eea4
Author: Andy Wingo <address@hidden>
Date: Tue Dec 6 19:14:50 2011 +0100
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/deprecation.c
libguile/load.c
libguile/print.c
-----------------------------------------------------------------------
Summary of changes:
libguile/deprecation.c | 4 +-
libguile/gc-malloc.c | 3 +-
libguile/load.c | 20 +++++-----
libguile/numbers.c | 8 +++-
libguile/poll.c | 1 +
libguile/ports.c | 24 +++++++++++
libguile/ports.h | 2 +
libguile/print.c | 23 ++++++----
libguile/private-options.h | 5 ++-
module/ice-9/boot-9.scm | 82 +++++++++++++++++++++++++++++++++----
module/ice-9/poll.scm | 3 +
module/system/base/message.scm | 12 +++--
module/system/repl/command.scm | 1 +
module/system/repl/repl.scm | 5 ++-
module/web/client.scm | 2 +-
module/web/uri.scm | 20 ++++++----
test-suite/Makefile.am | 1 +
test-suite/tests/parameters.test | 69 ++++++++++++++++++++++++++++++++
test-suite/tests/web-uri.test | 19 ++++++++-
19 files changed, 254 insertions(+), 50 deletions(-)
create mode 100644 test-suite/tests/parameters.test
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index 1622406..5c1a246 100644
--- a/libguile/deprecation.c
+++ b/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_newline (scm_current_error_port ());
+ scm_puts_unlocked (msg, scm_current_warning_port ());
+ scm_newline (scm_current_warning_port ());
}
}
}
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index 3b64159..39e82ef 100644
--- a/libguile/gc-malloc.c
+++ b/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);
diff --git a/libguile/load.c b/libguile/load.c
index 14f411a..b28e30b 100644
--- a/libguile/load.c
+++ b/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_display (source, scm_current_error_port ());
- scm_puts_unlocked (" failed:\n", scm_current_error_port ());
+ scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_warning_port
());
+ scm_display (source, scm_current_warning_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_display (scm_car (lines), scm_current_error_port ());
- scm_newline (scm_current_error_port ());
+ scm_puts_unlocked (";;; ", scm_current_warning_port ());
+ scm_display (scm_car (lines), scm_current_warning_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_display (fallback, scm_current_error_port ());
- scm_newline (scm_current_error_port ());
+ scm_puts_unlocked (";;; found fresh local cache at ",
scm_current_warning_port ());
+ scm_display (fallback, scm_current_warning_port ());
+ scm_newline (scm_current_warning_port ());
return scm_load_compiled_with_vm (fallback);
}
}
diff --git a/libguile/numbers.c b/libguile/numbers.c
index f15c724..46a195a 100644
--- a/libguile/numbers.c
+++ b/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))
{
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/ports.c b/libguile/ports.c
index bee2c86..9eb6d3b 100644
--- a/libguile/ports.c
+++ b/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
diff --git a/libguile/ports.h b/libguile/ports.h
index 8c578a6..f4a1908 100644
--- a/libguile/ports.h
+++ b/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);
diff --git a/libguile/print.c b/libguile/print.c
index cdb9237..d8dd24c 100644
--- a/libguile/print.c
+++ b/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);
}
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 cf3f5d8..3ae933a 100644
--- a/module/ice-9/boot-9.scm
+++ b/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 ")
@@ -2825,6 +2827,68 @@ 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) (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)))
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/base/message.scm b/module/system/base/message.scm
index aed3502..75e14ea 100644
--- a/module/system/base/message.scm
+++ b/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.
- (make-fluid (current-error-port)))
-
-(fluid-set! *current-warning-port* (current-error-port))
+ ;; Can't play the identifier-syntax deprecation game in Guile 2.0, as
+ ;; other modules might depend on this being a normal binding and not a
+ ;; syntax binding.
+ (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)
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/module/web/client.scm b/module/web/client.scm
index 6a04497..b035668 100644
--- a/module/web/client.scm
+++ b/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:
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 6f9377c..67ecbae 100644
--- a/module/web/uri.scm
+++ b/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 (and m (valid-host? (match:substring m 3)))
- (values (match:substring m 2)
- (match:substring m 3)
- (let ((port (match:substring m 5)))
- (and port (not (string-null? port))
- (string->number port))))
- (fail))))
+ (if (equal? authority "//")
+ ;; Allow empty authorities: file:///etc/hosts is a synonym of
+ ;; file:/etc/hosts.
+ (values #f #f #f)
+ (let ((m (regexp-exec authority-regexp authority)))
+ (if (and m (valid-host? (match:substring m 3)))
+ (values (match:substring m 2)
+ (match:substring m 3)
+ (let ((port (match:substring m 5)))
+ (and port (not (string-null? port))
+ (string->number port))))
+ (fail)))))
;;; RFC 3986, #3.
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)))))))))
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 534380a..9118eea 100644
--- a/test-suite/tests/web-uri.test
+++ b/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:"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-204-g04ec290,
Andy Wingo <=