mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-09 10:50:27 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/deprecation.c libguile/load.c libguile/print.c
This commit is contained in:
commit
04ec290f8b
19 changed files with 254 additions and 50 deletions
|
@ -89,8 +89,8 @@ scm_c_issue_deprecation_warning (const char *msg)
|
||||||
fprintf (stderr, "%s\n", msg);
|
fprintf (stderr, "%s\n", msg);
|
||||||
else
|
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 ());
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -153,7 +153,8 @@ scm_strdup (const char *str)
|
||||||
void
|
void
|
||||||
scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
|
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
|
#ifdef GUILE_DEBUG_MALLOC
|
||||||
if (mem)
|
if (mem)
|
||||||
scm_malloc_register (mem, what);
|
scm_malloc_register (mem, what);
|
||||||
|
|
|
@ -738,18 +738,18 @@ auto_compile_catch_handler (void *data, SCM tag, SCM throw_args)
|
||||||
oport = scm_open_output_string ();
|
oport = scm_open_output_string ();
|
||||||
scm_print_exception (oport, SCM_BOOL_F, tag, throw_args);
|
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),
|
lines = scm_string_split (scm_get_output_string (oport),
|
||||||
SCM_MAKE_CHAR ('\n'));
|
SCM_MAKE_CHAR ('\n'));
|
||||||
for (; scm_is_pair (lines); lines = scm_cdr (lines))
|
for (; scm_is_pair (lines); lines = scm_cdr (lines))
|
||||||
if (scm_c_string_length (scm_car (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);
|
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"
|
scm_puts_unlocked (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n"
|
||||||
";;; or pass the --no-auto-compile argument to disable.\n",
|
";;; or pass the --no-auto-compile argument to disable.\n",
|
||||||
scm_current_error_port ());
|
scm_current_warning_port ());
|
||||||
message_shown = 1;
|
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,
|
if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
|
||||||
&stat_source, &stat_compiled))
|
&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);
|
return scm_load_compiled_with_vm (fallback);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -5321,8 +5321,14 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
|
||||||
else if (SCM_BIGP (n))
|
else if (SCM_BIGP (n))
|
||||||
{
|
{
|
||||||
char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (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);
|
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))
|
else if (SCM_FRACTIONP (n))
|
||||||
{
|
{
|
||||||
|
|
|
@ -184,6 +184,7 @@ scm_init_poll (void)
|
||||||
{
|
{
|
||||||
#if HAVE_POLL
|
#if HAVE_POLL
|
||||||
scm_c_define_gsubr ("primitive-poll", 4, 0, 0, scm_primitive_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
|
#else
|
||||||
scm_misc_error ("%init-poll", "`poll' unavailable on this platform", SCM_EOL);
|
scm_misc_error ("%init-poll", "`poll' unavailable on this platform", SCM_EOL);
|
||||||
#endif
|
#endif
|
||||||
|
|
|
@ -328,6 +328,17 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
|
||||||
}
|
}
|
||||||
#undef FUNC_NAME
|
#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,
|
SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
|
||||||
(),
|
(),
|
||||||
"Return the current-load-port.\n"
|
"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
|
#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
|
void
|
||||||
scm_dynwind_current_input_port (SCM port)
|
scm_dynwind_current_input_port (SCM port)
|
||||||
#define FUNC_NAME NULL
|
#define FUNC_NAME NULL
|
||||||
|
|
|
@ -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_input_port (void);
|
||||||
SCM_API SCM scm_current_output_port (void);
|
SCM_API SCM scm_current_output_port (void);
|
||||||
SCM_API SCM scm_current_error_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_current_load_port (void);
|
||||||
SCM_API SCM scm_set_current_input_port (SCM port);
|
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_output_port (SCM port);
|
||||||
SCM_API SCM scm_set_current_error_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_input_port (SCM port);
|
||||||
SCM_API void scm_dynwind_current_output_port (SCM port);
|
SCM_API void scm_dynwind_current_output_port (SCM port);
|
||||||
SCM_API void scm_dynwind_current_error_port (SCM port);
|
SCM_API void scm_dynwind_current_error_port (SCM port);
|
||||||
|
|
|
@ -106,8 +106,9 @@ scm_t_option scm_print_opts[] = {
|
||||||
{ SCM_OPTION_SCM, "quote-keywordish-symbols", (scm_t_bits)SCM_BOOL_F_BITS,
|
{ 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. "
|
"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; "
|
"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 },
|
{ 0 },
|
||||||
};
|
};
|
||||||
|
|
||||||
|
@ -1104,6 +1105,12 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p)
|
||||||
display_character (ch, port, strategy);
|
display_character (ch, port, strategy);
|
||||||
printed = 1;
|
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')
|
else if (ch == ' ' || ch == '\n')
|
||||||
{
|
{
|
||||||
display_character (ch, port, strategy);
|
display_character (ch, port, strategy);
|
||||||
|
@ -1522,13 +1529,6 @@ scm_init_print ()
|
||||||
{
|
{
|
||||||
SCM type;
|
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),
|
type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
|
||||||
SCM_BOOL_F);
|
SCM_BOOL_F);
|
||||||
scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
|
scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
|
||||||
|
@ -1540,6 +1540,11 @@ scm_init_print ()
|
||||||
|
|
||||||
#include "libguile/print.x"
|
#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);
|
scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -45,11 +45,14 @@ SCM_INTERNAL scm_t_option scm_debug_opts[];
|
||||||
*/
|
*/
|
||||||
SCM_INTERNAL scm_t_option scm_print_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_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_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[1].val))
|
||||||
#define SCM_PRINT_KEYWORD_STYLE_I 2
|
#define SCM_PRINT_KEYWORD_STYLE_I 2
|
||||||
#define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[2].val))
|
#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
|
||||||
|
|
||||||
|
|
||||||
/*
|
/*
|
||||||
|
|
|
@ -213,9 +213,11 @@ If there is no handler at all, Guile prints an error and then exits."
|
||||||
|
|
||||||
(define pk peek)
|
(define pk peek)
|
||||||
|
|
||||||
|
;; Temporary definition; replaced later.
|
||||||
|
(define current-warning-port current-error-port)
|
||||||
|
|
||||||
(define (warn . stuff)
|
(define (warn . stuff)
|
||||||
(with-output-to-port (current-error-port)
|
(with-output-to-port (current-warning-port)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(newline)
|
(newline)
|
||||||
(display ";;; WARNING ")
|
(display ";;; WARNING ")
|
||||||
|
@ -1373,7 +1375,7 @@ VALUE."
|
||||||
|
|
||||||
(define (%load-announce file)
|
(define (%load-announce file)
|
||||||
(if %load-verbosely
|
(if %load-verbosely
|
||||||
(with-output-to-port (current-error-port)
|
(with-output-to-port (current-warning-port)
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(display ";;; ")
|
(display ";;; ")
|
||||||
(display "loading ")
|
(display "loading ")
|
||||||
|
@ -2823,6 +2825,68 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
(define (unspecified? v) (eq? v *unspecified*))
|
(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}
|
;;; {Running Repls}
|
||||||
|
@ -3288,7 +3352,7 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
#f))
|
#f))
|
||||||
|
|
||||||
(define (warn module name int1 val1 int2 val2 var val)
|
(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"
|
"WARNING: ~A: `~A' imported from both ~A and ~A\n"
|
||||||
(module-name module)
|
(module-name module)
|
||||||
name
|
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)
|
(define (warn-override-core module name int1 val1 int2 val2 var val)
|
||||||
(and (eq? int1 the-scm-module)
|
(and (eq? int1 the-scm-module)
|
||||||
(begin
|
(begin
|
||||||
(format (current-error-port)
|
(format (current-warning-port)
|
||||||
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
|
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
|
||||||
(module-name module)
|
(module-name module)
|
||||||
(module-name int2)
|
(module-name int2)
|
||||||
|
@ -3432,13 +3496,13 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
go-path
|
go-path
|
||||||
(begin
|
(begin
|
||||||
(if gostat
|
(if gostat
|
||||||
(format (current-error-port)
|
(format (current-warning-port)
|
||||||
";;; note: source file ~a\n;;; newer than compiled ~a\n"
|
";;; note: source file ~a\n;;; newer than compiled ~a\n"
|
||||||
name go-path))
|
name go-path))
|
||||||
(cond
|
(cond
|
||||||
(%load-should-auto-compile
|
(%load-should-auto-compile
|
||||||
(%warn-auto-compilation-enabled)
|
(%warn-auto-compilation-enabled)
|
||||||
(format (current-error-port) ";;; compiling ~a\n" name)
|
(format (current-warning-port) ";;; compiling ~a\n" name)
|
||||||
(let ((cfn
|
(let ((cfn
|
||||||
((module-ref
|
((module-ref
|
||||||
(resolve-interface '(system base compile))
|
(resolve-interface '(system base compile))
|
||||||
|
@ -3446,15 +3510,15 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
name
|
name
|
||||||
#:opts %auto-compilation-options
|
#:opts %auto-compilation-options
|
||||||
#:env (current-module))))
|
#:env (current-module))))
|
||||||
(format (current-error-port) ";;; compiled ~a\n" cfn)
|
(format (current-warning-port) ";;; compiled ~a\n" cfn)
|
||||||
cfn))
|
cfn))
|
||||||
(else #f))))))
|
(else #f))))))
|
||||||
(lambda (k . args)
|
(lambda (k . args)
|
||||||
(format (current-error-port)
|
(format (current-warning-port)
|
||||||
";;; WARNING: compilation of ~a failed:\n" name)
|
";;; WARNING: compilation of ~a failed:\n" name)
|
||||||
(for-each (lambda (s)
|
(for-each (lambda (s)
|
||||||
(if (not (string-null? s))
|
(if (not (string-null? s))
|
||||||
(format (current-error-port) ";;; ~a\n" s)))
|
(format (current-warning-port) ";;; ~a\n" s)))
|
||||||
(string-split
|
(string-split
|
||||||
(call-with-output-string
|
(call-with-output-string
|
||||||
(lambda (port) (print-exception port #f k args)))
|
(lambda (port) (print-exception port #f k args)))
|
||||||
|
|
|
@ -38,6 +38,9 @@
|
||||||
(load-extension (string-append "libguile-" (effective-version))
|
(load-extension (string-append "libguile-" (effective-version))
|
||||||
"scm_init_poll"))
|
"scm_init_poll"))
|
||||||
|
|
||||||
|
(if (not (= %sizeof-struct-pollfd 8))
|
||||||
|
(error "Unexpected struct pollfd size" %sizeof-struct-pollfd))
|
||||||
|
|
||||||
(if (defined? 'POLLIN)
|
(if (defined? 'POLLIN)
|
||||||
(export POLLIN))
|
(export POLLIN))
|
||||||
|
|
||||||
|
|
|
@ -54,11 +54,13 @@
|
||||||
;;; Warnings
|
;;; Warnings
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
|
;; This name existed before %current-warning-port was introduced, but
|
||||||
|
;; otherwise it is a deprecated binding.
|
||||||
(define *current-warning-port*
|
(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*
|
(define *current-warning-prefix*
|
||||||
;; Prefix string when emitting a warning.
|
;; Prefix string when emitting a warning.
|
||||||
|
@ -194,7 +196,7 @@
|
||||||
"Emit a warning of type TYPE for source location LOCATION (a source
|
"Emit a warning of type TYPE for source location LOCATION (a source
|
||||||
property alist) using the data in ARGS."
|
property alist) using the data in ARGS."
|
||||||
(let ((wt (lookup-warning-type type))
|
(let ((wt (lookup-warning-type type))
|
||||||
(port (fluid-ref *current-warning-port*)))
|
(port (current-warning-port)))
|
||||||
(if (warning-type? wt)
|
(if (warning-type? wt)
|
||||||
(apply (warning-type-printer wt)
|
(apply (warning-type-printer wt)
|
||||||
port (location-string location)
|
port (location-string location)
|
||||||
|
|
|
@ -441,6 +441,7 @@ Change languages."
|
||||||
(cur (repl-language repl)))
|
(cur (repl-language repl)))
|
||||||
(format #t "Happy hacking with ~a! To switch back, type `,L ~a'.\n"
|
(format #t "Happy hacking with ~a! To switch back, type `,L ~a'.\n"
|
||||||
(language-title lang) (language-name cur))
|
(language-title lang) (language-name cur))
|
||||||
|
(fluid-set! *current-language* lang)
|
||||||
(set! (repl-language repl) lang)))
|
(set! (repl-language repl) lang)))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -132,7 +132,10 @@
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define* (start-repl #:optional (lang (current-language)) #:key debug)
|
(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)
|
;; (put 'abort-on-error 'scheme-indent-function 1)
|
||||||
(define-syntax-rule (abort-on-error string exp)
|
(define-syntax-rule (abort-on-error string exp)
|
||||||
|
|
|
@ -27,7 +27,7 @@
|
||||||
;;; the web server.
|
;;; the web server.
|
||||||
;;;
|
;;;
|
||||||
;;; Another option, good but not as performant, would be to use threads,
|
;;; Another option, good but not as performant, would be to use threads,
|
||||||
;;; possibly via par-map or futures.
|
;;; possibly via a thread pool.
|
||||||
;;;
|
;;;
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
|
|
|
@ -125,14 +125,18 @@ consistency checks to make sure that the constructed URI is valid."
|
||||||
userinfo-pat host-pat port-pat)))
|
userinfo-pat host-pat port-pat)))
|
||||||
|
|
||||||
(define (parse-authority authority fail)
|
(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.
|
;;; RFC 3986, #3.
|
||||||
|
|
|
@ -74,6 +74,7 @@ SCM_TESTS = tests/00-initial-env.test \
|
||||||
tests/numbers.test \
|
tests/numbers.test \
|
||||||
tests/optargs.test \
|
tests/optargs.test \
|
||||||
tests/options.test \
|
tests/options.test \
|
||||||
|
tests/parameters.test \
|
||||||
tests/print.test \
|
tests/print.test \
|
||||||
tests/procprop.test \
|
tests/procprop.test \
|
||||||
tests/procs.test \
|
tests/procs.test \
|
||||||
|
|
69
test-suite/tests/parameters.test
Normal file
69
test-suite/tests/parameters.test
Normal file
|
@ -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)))))))))
|
|
@ -1,6 +1,6 @@
|
||||||
;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
|
;;;; 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
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
@ -150,7 +150,22 @@
|
||||||
(not (string->uri "http://:10")))
|
(not (string->uri "http://:10")))
|
||||||
|
|
||||||
(pass-if "http://foo@"
|
(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"
|
(with-test-prefix "uri->string"
|
||||||
(pass-if "ftp:"
|
(pass-if "ftp:"
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue