mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

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

Browse source 
Conflicts:
	libguile/bytevectors.c
	libguile/bytevectors.h
	libguile/objcodes.c
	libguile/r6rs-ports.c
	libguile/strings.c
	libguile/vm.c
This commit is contained in:
Andy Wingo 2011-08-31 09:34:54 +02:00
commit 8b66aa8f54
33 changed files with 945 additions and 576 deletions
Download patch file Download diff file Expand all files Collapse all files

38
doc/ref/api-io.texi
View file

@ -838,34 +838,34 @@ setvbuf}
Add line-buffering to the port. The port output buffer will be
automatically flushed whenever a newline character is written.
@item b
Use binary mode. On DOS systems the default text mode converts CR+LF
in the file to newline for the program, whereas binary mode reads and
writes all bytes unchanged. On Unix-like systems there is no such
distinction, text files already contain just newlines and no
conversion is ever made. The @code{b} flag is accepted on all
systems, but has no effect on Unix-like systems.
Use binary mode, ensuring that each byte in the file will be read as one
Scheme character.
(For reference, Guile leaves text versus binary up to the C library,
@code{b} here just adds @code{O_BINARY} to the underlying @code{open}
call, when that flag is available.)
To provide this property, the file will be opened with the 8-bit
character encoding "ISO-8859-1", ignoring any coding declaration or port
encoding. @xref{Ports}, for more information on port encodings.
Also, open the file using the 8-bit character encoding "ISO-8859-1",
ignoring any coding declaration or port encoding.
Note that while it is possible to read and write binary data as
characters or strings, it is usually better to treat bytes as octets,
and byte sequences as bytevectors. @xref{R6RS Binary Input}, and
@ref{R6RS Binary Output}, for more.
Note that, when reading or writing binary data with ports, the
bytevector ports in the @code{(rnrs io ports)} module are preferred,
as they return vectors, and not strings (@pxref{R6RS I/O Ports}).
This option had another historical meaning, for DOS compatibility: in
the default (textual) mode, DOS reads a CR-LF sequence as one LF byte.
The @code{b} flag prevents this from happening, adding @code{O_BINARY}
to the underlying @code{open} call. Still, the flag is generally useful
because of its port encoding ramifications.
@end table
If a file cannot be opened with the access
requested, @code{open-file} throws an exception.
When the file is opened, this procedure will scan for a coding
declaration (@pxref{Character Encoding of Source Files}). If present
will use that encoding for interpreting the file. Otherwise, the
port's encoding will be used. To suppress this behavior, open
the file in binary mode and then set the port encoding explicitly
using @code{set-port-encoding!}.
declaration (@pxref{Character Encoding of Source Files}). If a coding
declaration is found, it will be used to interpret the file. Otherwise,
the port's encoding will be used. To suppress this behavior, open the
file in binary mode and then set the port encoding explicitly using
@code{set-port-encoding!}.
In theory we could create read/write ports which were buffered
in one direction only. However this isn't included in the

32
libguile/arrays.c
View file

@ -822,15 +822,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
C is the first character read after the '#'.
*/
static SCM
tag_to_type (const char *tag, SCM port)
{
if (*tag == '\0')
return SCM_BOOL_T;
else
return scm_from_locale_symbol (tag);
}
static int
read_decimal_integer (SCM port, int c, ssize_t *resp)
{
@ -860,10 +851,10 @@ SCM
scm_i_read_array (SCM port, int c)
{
ssize_t rank;
char tag[80];
scm_t_wchar tag_buf[8];
int tag_len;
SCM shape = SCM_BOOL_F, elements;
SCM tag, shape = SCM_BOOL_F, elements;
/* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
the array code can not deal with zero-length dimensions yet, and
@ -887,7 +878,7 @@ scm_i_read_array (SCM port, int c)
return SCM_BOOL_F;
}
rank = 1;
tag[0] = 'f';
tag_buf[0] = 'f';
tag_len = 1;
goto continue_reading_tag;
}
@ -904,12 +895,21 @@ scm_i_read_array (SCM port, int c)
*/
tag_len = 0;
continue_reading_tag:
while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
while (c != EOF && c != '(' && c != '@' && c != ':'
&& tag_len < sizeof tag_buf / sizeof tag_buf[0])
{
tag[tag_len++] = c;
tag_buf[tag_len++] = c;
c = scm_getc (port);
}
tag[tag_len] = '\0';
if (tag_len == 0)
tag = SCM_BOOL_T;
else
{
tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
scm_list_1 (tag));
}
/* Read shape.
*/
@ -983,7 +983,7 @@ scm_i_read_array (SCM port, int c)
/* Construct array.
*/
return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
return scm_list_to_typed_array (tag, shape, elements);
}

4
libguile/bytevectors.c
View file

@ -178,7 +178,7 @@
/* Bytevector type. */
#define SCM_BYTEVECTOR_HEADER_BYTES \
(SCM_BYTEVECTOR_HEADER_SIZE * sizeof (SCM))
(SCM_BYTEVECTOR_HEADER_SIZE * sizeof (scm_t_bits))
#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
@ -292,7 +292,7 @@ scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
because it was allocated using `scm_gc_malloc ()', or because it is
part of PARENT. */
SCM
scm_c_take_bytevector (signed char *contents, size_t len, SCM parent)
scm_c_take_gc_bytevector (signed char *contents, size_t len, SCM parent)
{
SCM ret;

2
libguile/bytevectors.h
View file

@ -140,7 +140,7 @@ SCM_INTERNAL void scm_bootstrap_bytevectors (void);
SCM_INTERNAL void scm_init_bytevectors (void);
SCM_INTERNAL SCM scm_i_native_endianness;
SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t, SCM);
SCM_INTERNAL SCM scm_c_take_gc_bytevector (signed char *, size_t, SCM);
SCM_INTERNAL int scm_i_print_bytevector (SCM, SCM, scm_print_state *);

3
libguile/control.c
View file

@ -248,7 +248,8 @@ SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
#define FUNC_NAME s_scm_at_abort
{
SCM *argv;
size_t i, n;
size_t i;
long n;
SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
argv = alloca (sizeof (SCM)*n);

13
libguile/gc.c
View file

@ -739,13 +739,7 @@ accumulate_gc_timer (void * hook_data SCM_UNUSED,
char const *
scm_i_tag_name (scm_t_bits tag)
{
if (tag >= 255)
{
int k = 0xff & (tag >> 8);
return (scm_smobs[k].name);
}
switch (tag) /* 7 bits */
switch (tag & 0x7f) /* 7 bits */
{
case scm_tcs_struct:
return "struct";
@ -806,7 +800,10 @@ scm_i_tag_name (scm_t_bits tag)
return "port";
break;
case scm_tc7_smob:
return "smob"; /* should not occur. */
{
int k = 0xff & (tag >> 8);
return (scm_smobs[k].name);
}
break;
}

2
libguile/hashtab.c
View file

@ -274,7 +274,7 @@ make_hash_table (int flags, unsigned long k, const char *func_name)
SCM vector;
scm_t_hashtable *t;
int i = 0, n = k ? k : 31;
while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
++i;
n = hashtable_size[i];

13
libguile/i18n.c
View file

@ -501,7 +501,6 @@ get_current_locale (SCM *result)
c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
lock_locale_mutex ();
c_locale->category_mask = LC_ALL_MASK;
@ -509,20 +508,16 @@ get_current_locale (SCM *result)
current_locale = setlocale (LC_ALL, NULL);
if (current_locale != NULL)
{
c_locale->locale_name = strdup (current_locale);
if (c_locale->locale_name == NULL)
err = ENOMEM;
}
c_locale->locale_name = scm_gc_strdup (current_locale, "locale");
else
err = EINVAL;
unlock_locale_mutex ();
if (err)
scm_gc_free (c_locale, sizeof (* c_locale), "locale");
else
if (err == 0)
SCM_NEWSMOB (*result, scm_tc16_locale_smob_type, c_locale);
else
*result = SCM_BOOL_F;
return err;
}

255
libguile/load.c
View file

@ -419,63 +419,21 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM extensions)
If FILENAME is absolute, return it unchanged.
If given, EXTENSIONS is a list of strings; for each directory
in PATH, we search for FILENAME concatenated with each EXTENSION. */
SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
(SCM path, SCM filename, SCM rest),
"Search @var{path} for a directory containing a file named\n"
"@var{filename}. The file must be readable, and not a directory.\n"
"If we find one, return its full filename; otherwise, return\n"
"@code{#f}. If @var{filename} is absolute, return it unchanged.\n"
"If given, @var{extensions} is a list of strings; for each\n"
"directory in @var{path}, we search for @var{filename}\n"
"concatenated with each @var{extension}.")
#define FUNC_NAME s_scm_search_path
static SCM
search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
struct stat *stat_buf)
{
struct stringbuf buf;
char *filename_chars;
size_t filename_len;
SCM extensions, require_exts;
SCM result = SCM_BOOL_F;
if (SCM_UNBNDP (rest) || scm_is_null (rest))
{
/* Called either by Scheme code that didn't provide the optional
arguments, or C code that used the Guile 1.8 signature (2 required,
1 optional arg) and passed '() or nothing as the EXTENSIONS
argument. */
extensions = SCM_EOL;
require_exts = SCM_UNDEFINED;
}
else
{
if (scm_is_null (SCM_CAR (rest)) || scm_is_pair (SCM_CAR (rest)))
{
/* Called by Scheme code written for 1.9. */
extensions = SCM_CAR (rest);
if (scm_is_null (SCM_CDR (rest)))
require_exts = SCM_UNDEFINED;
else
{
require_exts = SCM_CADR (rest);
if (SCM_UNLIKELY (!scm_is_null (SCM_CDDR (rest))))
scm_wrong_num_args (scm_from_locale_string (FUNC_NAME));
}
}
else
{
/* Called by C code that uses the 1.8 signature, i.e., which
expects the 3rd argument to be EXTENSIONS. */
extensions = rest;
require_exts = SCM_UNDEFINED;
}
}
if (SCM_UNBNDP (extensions))
extensions = SCM_EOL;
SCM_VALIDATE_LIST (3, extensions);
if (SCM_UNBNDP (require_exts))
require_exts = SCM_BOOL_F;
if (scm_ilength (path) < 0)
scm_misc_error ("%search-path", "path is not a proper list: ~a",
scm_list_1 (path));
if (scm_ilength (extensions) < 0)
scm_misc_error ("%search-path", "bad extensions list: ~a",
scm_list_1 (extensions));
scm_dynwind_begin (0);
@ -576,7 +534,6 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
for (exts = extensions; scm_is_pair (exts); exts = SCM_CDR (exts))
{
SCM ext = SCM_CAR (exts);
struct stat mode;
buf.ptr = buf.buf + sans_ext_len;
stringbuf_cat_locale_string (&buf, ext);
@ -584,8 +541,8 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
/* If the file exists at all, we should return it. If the
file is inaccessible, then that's an error. */
if (stat (buf.buf, &mode) == 0
&& ! (mode.st_mode & S_IFDIR))
if (stat (buf.buf, stat_buf) == 0
&& ! (stat_buf->st_mode & S_IFDIR))
{
result = scm_from_locale_string (buf.buf);
goto end;
@ -603,6 +560,62 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
scm_dynwind_end ();
return result;
}
SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1,
(SCM path, SCM filename, SCM rest),
"Search @var{path} for a directory containing a file named\n"
"@var{filename}. The file must be readable, and not a directory.\n"
"If we find one, return its full filename; otherwise, return\n"
"@code{#f}. If @var{filename} is absolute, return it unchanged.\n"
"If given, @var{extensions} is a list of strings; for each\n"
"directory in @var{path}, we search for @var{filename}\n"
"concatenated with each @var{extension}.")
#define FUNC_NAME s_scm_search_path
{
SCM extensions, require_exts;
struct stat stat_buf;
if (SCM_UNBNDP (rest) || scm_is_null (rest))
{
/* Called either by Scheme code that didn't provide the optional
arguments, or C code that used the Guile 1.8 signature (2 required,
1 optional arg) and passed '() or nothing as the EXTENSIONS
argument. */
extensions = SCM_EOL;
require_exts = SCM_UNDEFINED;
}
else
{
if (scm_is_null (SCM_CAR (rest)) || scm_is_pair (SCM_CAR (rest)))
{
/* Called by Scheme code written for 1.9. */
extensions = SCM_CAR (rest);
if (scm_is_null (SCM_CDR (rest)))
require_exts = SCM_UNDEFINED;
else
{
require_exts = SCM_CADR (rest);
if (SCM_UNLIKELY (!scm_is_null (SCM_CDDR (rest))))
scm_wrong_num_args (scm_from_locale_string (FUNC_NAME));
}
}
else
{
/* Called by C code that uses the 1.8 signature, i.e., which
expects the 3rd argument to be EXTENSIONS. */
extensions = rest;
require_exts = SCM_UNDEFINED;
}
}
if (SCM_UNBNDP (extensions))
extensions = SCM_EOL;
if (SCM_UNBNDP (require_exts))
require_exts = SCM_BOOL_F;
return search_path (path, filename, extensions, require_exts, &stat_buf);
}
#undef FUNC_NAME
@ -621,60 +634,41 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
"will try each extension automatically.")
#define FUNC_NAME s_scm_sys_search_load_path
{
SCM path = *scm_loc_load_path;
SCM exts = *scm_loc_load_extensions;
struct stat stat_buf;
SCM_VALIDATE_STRING (1, filename);
if (scm_ilength (path) < 0)
SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL);
if (scm_ilength (exts) < 0)
SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL);
return scm_search_path (path, filename, exts);
return search_path (*scm_loc_load_path, filename, *scm_loc_load_extensions,
SCM_BOOL_F, &stat_buf);
}
#undef FUNC_NAME
/* Return true if COMPILED_FILENAME is newer than source file
FULL_FILENAME, false otherwise. Also return false if one of the
files cannot be stat'd. */
FULL_FILENAME, false otherwise. */
static int
compiled_is_fresh (SCM full_filename, SCM compiled_filename)
compiled_is_fresh (SCM full_filename, SCM compiled_filename,
struct stat *stat_source, struct stat *stat_compiled)
{
char *source, *compiled;
struct stat stat_source, stat_compiled;
int compiled_is_newer;
struct timespec source_mtime, compiled_mtime;
source = scm_to_locale_string (full_filename);
compiled = scm_to_locale_string (compiled_filename);
source_mtime = get_stat_mtime (stat_source);
compiled_mtime = get_stat_mtime (stat_compiled);
if (stat (source, &stat_source) == 0
&& stat (compiled, &stat_compiled) == 0)
{
struct timespec source_mtime, compiled_mtime;
source_mtime = get_stat_mtime (&stat_source);
compiled_mtime = get_stat_mtime (&stat_compiled);
if (source_mtime.tv_sec < compiled_mtime.tv_sec
|| (source_mtime.tv_sec == compiled_mtime.tv_sec
&& source_mtime.tv_nsec <= compiled_mtime.tv_nsec))
compiled_is_newer = 1;
else
{
compiled_is_newer = 0;
scm_puts (";;; note: source file ", scm_current_error_port ());
scm_puts (source, scm_current_error_port ());
scm_puts ("\n;;; newer than compiled ", scm_current_error_port ());
scm_puts (compiled, scm_current_error_port ());
scm_puts ("\n", scm_current_error_port ());
}
}
if (source_mtime.tv_sec < compiled_mtime.tv_sec
|| (source_mtime.tv_sec == compiled_mtime.tv_sec
&& source_mtime.tv_nsec <= compiled_mtime.tv_nsec))
compiled_is_newer = 1;
else
/* At least one of the files isn't accessible. */
compiled_is_newer = 0;
free (source);
free (compiled);
{
compiled_is_newer = 0;
scm_puts (";;; note: source file ", scm_current_error_port ());
scm_display (full_filename, scm_current_error_port ());
scm_puts ("\n;;; newer than compiled ", scm_current_error_port ());
scm_display (compiled_filename, scm_current_error_port ());
scm_puts ("\n", scm_current_error_port ());
}
return compiled_is_newer;
}
@ -798,9 +792,13 @@ scm_try_auto_compile (SCM source)
/* See also (system base compile):compiled-file-name. */
static SCM
canonical_to_suffix (SCM canon)
canonical_suffix (SCM fname)
{
size_t len = scm_c_string_length (canon);
SCM canon;
size_t len;
canon = scm_canonicalize_path (fname);
len = scm_c_string_length (canon);
if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/')))
return canon;
@ -826,6 +824,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
SCM full_filename, compiled_filename;
int compiled_is_fallback = 0;
SCM hook = *scm_loc_load_hook;
struct stat stat_source, stat_compiled;
if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
@ -857,15 +856,14 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
if (SCM_UNBNDP (exception_on_not_found))
exception_on_not_found = SCM_BOOL_T;
full_filename = scm_sys_search_load_path (filename);
if (scm_is_string (full_filename))
full_filename = scm_canonicalize_path (full_filename);
full_filename = search_path (*scm_loc_load_path, filename,
*scm_loc_load_extensions, SCM_BOOL_F,
&stat_source);
compiled_filename =
scm_search_path (*scm_loc_load_compiled_path,
filename,
scm_list_2 (*scm_loc_load_compiled_extensions,
SCM_BOOL_T));
search_path (*scm_loc_load_compiled_path, filename,
*scm_loc_load_compiled_extensions, SCM_BOOL_T,
&stat_compiled);
if (scm_is_false (compiled_filename)
&& scm_is_true (full_filename)
@ -874,15 +872,21 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
&& scm_is_pair (*scm_loc_load_compiled_extensions)
&& scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
{
SCM fallback = scm_string_append
SCM fallback;
char *fallback_chars;
fallback = scm_string_append
(scm_list_3 (*scm_loc_compile_fallback_path,
canonical_to_suffix (full_filename),
canonical_suffix (full_filename),
scm_car (*scm_loc_load_compiled_extensions)));
if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
fallback_chars = scm_to_locale_string (fallback);
if (stat (fallback_chars, &stat_compiled) == 0)
{
compiled_filename = fallback;
compiled_is_fallback = 1;
}
free (fallback_chars);
}
if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
@ -900,7 +904,8 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
if (scm_is_false (full_filename)
|| (scm_is_true (compiled_filename)
&& compiled_is_fresh (full_filename, compiled_filename)))
&& compiled_is_fresh (full_filename, compiled_filename,
&stat_source, &stat_compiled)))
return scm_load_compiled_with_vm (compiled_filename);
/* Perhaps there was the installed .go that was stale, but our fallback is
@ -912,12 +917,21 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
&& scm_is_pair (*scm_loc_load_compiled_extensions)
&& scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
{
SCM fallback = scm_string_append
SCM fallback;
char *fallback_chars;
int stat_ret;
fallback = scm_string_append
(scm_list_3 (*scm_loc_compile_fallback_path,
canonical_to_suffix (full_filename),
canonical_suffix (full_filename),
scm_car (*scm_loc_load_compiled_extensions)));
if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))
&& compiled_is_fresh (full_filename, fallback))
fallback_chars = scm_to_locale_string (fallback);
stat_ret = stat (fallback_chars, &stat_compiled);
free (fallback_chars);
if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
&stat_source, &stat_compiled))
{
scm_puts (";;; found fresh local cache at ", scm_current_error_port ());
scm_display (fallback, scm_current_error_port ());
@ -948,15 +962,18 @@ void
scm_init_eval_in_scheme (void)
{
SCM eval_scm, eval_go;
eval_scm = scm_search_path (*scm_loc_load_path,
scm_from_locale_string ("ice-9/eval.scm"),
SCM_EOL);
eval_go = scm_search_path (*scm_loc_load_compiled_path,
scm_from_locale_string ("ice-9/eval.go"),
SCM_EOL);
struct stat stat_source, stat_compiled;
eval_scm = search_path (*scm_loc_load_path,
scm_from_locale_string ("ice-9/eval.scm"),
SCM_EOL, SCM_BOOL_F, &stat_source);
eval_go = search_path (*scm_loc_load_compiled_path,
scm_from_locale_string ("ice-9/eval.go"),
SCM_EOL, SCM_BOOL_F, &stat_compiled);
if (scm_is_true (eval_scm) && scm_is_true (eval_go)
&& compiled_is_fresh (eval_scm, eval_go))
&& compiled_is_fresh (eval_scm, eval_go,
&stat_source, &stat_compiled))
scm_load_compiled_with_vm (eval_go);
else
/* if we have no eval.go, we shouldn't load any compiled code at all */

2
libguile/numbers.c
View file

@ -1499,8 +1499,6 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
if (SCM_LIKELY (xx >= 0))
xx1 = xx + yy - 1;
}
else if (SCM_UNLIKELY (yy == 0))
scm_num_overflow (s_scm_ceiling_quotient);
else if (xx < 0)
xx1 = xx + yy + 1;
qq = xx1 / yy;

4
libguile/objcodes.c
View file

@ -314,8 +314,8 @@ SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
return scm_c_take_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode),
len, objcode);
return scm_c_take_gc_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode),
len, objcode);
}
#undef FUNC_NAME

12
libguile/posix.c
View file

@ -1338,10 +1338,20 @@ SCM_DEFINE (scm_tmpfile, "tmpfile", 0, 0, 0,
#define FUNC_NAME s_scm_tmpfile
{
FILE *rv;
int fd;
if (! (rv = tmpfile ()))
SCM_SYSERROR;
return scm_fdes_to_port (fileno (rv), "w+", SCM_BOOL_F);
#ifndef __MINGW32__
fd = dup (fileno (rv));
fclose (rv);
#else
fd = fileno (rv);
/* FIXME: leaking the file, it will never be closed! */
#endif
return scm_fdes_to_port (fd, "w+", SCM_BOOL_F);
}
#undef FUNC_NAME

14
libguile/r6rs-ports.c
View file

@ -618,8 +618,8 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
c_len = (unsigned) c_total;
}
result = scm_c_take_bytevector ((signed char *) c_bv, c_len,
SCM_BOOL_F);
result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
SCM_BOOL_F);
}
return result;
@ -678,8 +678,8 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
c_len = (unsigned) c_total;
}
result = scm_c_take_bytevector ((signed char *) c_bv, c_len,
SCM_BOOL_F);
result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
SCM_BOOL_F);
}
return result;
@ -921,7 +921,7 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure,
bop_buffer_init (buf);
if (result_buf.len == 0)
bv = scm_c_take_bytevector (NULL, 0, SCM_BOOL_F);
bv = scm_c_take_gc_bytevector (NULL, 0, SCM_BOOL_F);
else
{
if (result_buf.total_len > result_buf.len)
@ -931,8 +931,8 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure,
result_buf.len,
SCM_GC_BOP);
bv = scm_c_take_bytevector ((signed char *) result_buf.buffer,
result_buf.len, SCM_BOOL_F);
bv = scm_c_take_gc_bytevector ((signed char *) result_buf.buffer,
result_buf.len, SCM_BOOL_F);
}
return bv;

2
libguile/read.c
View file

@ -408,7 +408,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
/* See above note about scm_sym_dot. */
if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
{
SCM_SETCDR (tl, tmp = scm_read_expression (port));
SCM_SETCDR (tl, scm_read_expression (port));
c = flush_ws (port, FUNC_NAME);
if (terminating_char != c)

2
libguile/script.c
View file

@ -317,6 +317,7 @@ scm_get_meta_args (int argc, char **argv)
switch (getc (f))
{
case EOF:
free (nargv);
return 0L;
default:
continue;
@ -324,6 +325,7 @@ scm_get_meta_args (int argc, char **argv)
goto found_args;
}
found_args:
/* FIXME: we leak the result of calling script_read_arg. */
while ((narg = script_read_arg (f)))
if (!(nargv = (char **) realloc (nargv,
(1 + ++nargc) * sizeof (char *))))

39
libguile/srfi-1.c
View file

@ -568,28 +568,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
(SCM lst, SCM n),
"Return a new list containing all except the last @var{n}\n"
"elements of @var{lst}.")
#define FUNC_NAME s_scm_srfi1_drop_right
{
SCM tail = scm_list_tail (lst, n);
SCM ret = SCM_EOL;
SCM *rend = &ret;
while (scm_is_pair (tail))
{
*rend = scm_cons (SCM_CAR (lst), SCM_EOL);
rend = SCM_CDRLOC (*rend);
lst = SCM_CDR (lst);
tail = SCM_CDR (tail);
}
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
return ret;
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
(SCM pred, SCM lst),
"Return the first element of @var{lst} which satisfies the\n"
@ -924,23 +902,6 @@ SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
(SCM lst, SCM n),
"Return a list containing the @var{n} last elements of\n"
"@var{lst}.")
#define FUNC_NAME s_scm_srfi1_take_right
{
SCM tail = scm_list_tail (lst, n);
while (scm_is_pair (tail))
{
lst = SCM_CDR (lst);
tail = SCM_CDR (tail);
}
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
return lst;
}
#undef FUNC_NAME
void
scm_register_srfi_1 (void)

2
libguile/srfi-1.h
View file

@ -33,7 +33,6 @@ SCM_INTERNAL SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred);
SCM_INTERNAL SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
SCM_INTERNAL SCM scm_srfi1_drop_right (SCM lst, SCM n);
SCM_INTERNAL SCM scm_srfi1_find (SCM pred, SCM lst);
SCM_INTERNAL SCM scm_srfi1_find_tail (SCM pred, SCM lst);
SCM_INTERNAL SCM scm_srfi1_length_plus (SCM lst);
@ -44,7 +43,6 @@ SCM_INTERNAL SCM scm_srfi1_partition (SCM pred, SCM list);
SCM_INTERNAL SCM scm_srfi1_partition_x (SCM pred, SCM list);
SCM_INTERNAL SCM scm_srfi1_remove (SCM pred, SCM list);
SCM_INTERNAL SCM scm_srfi1_remove_x (SCM pred, SCM list);
SCM_INTERNAL SCM scm_srfi1_take_right (SCM lst, SCM n);
SCM_INTERNAL void scm_register_srfi_1 (void);
SCM_INTERNAL void scm_init_srfi_1 (void);

9
libguile/stacks.c
View file

@ -184,11 +184,10 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
else
{
/* Cut specified number of frames. */
for (; outer && len ; --outer)
{
frame = scm_stack_ref (stack, scm_from_long (len - 1));
len--;
}
if (outer < len)
len -= outer;
else
len = 0;
}
SCM_SET_STACK_LENGTH (stack, len);

2
libguile/strings.c
View file

@ -1489,7 +1489,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
buf = scm_gc_malloc_pointerless (len, "bytevector");
memcpy (buf, str, len);
bv = scm_c_take_bytevector (buf, len, SCM_BOOL_F);
bv = scm_c_take_gc_bytevector (buf, len, SCM_BOOL_F);
scm_decoding_error (__func__, errno,
"input locale conversion error", bv);

9
libguile/vm.c
View file

@ -384,14 +384,15 @@ really_make_boot_program (long nargs)
text[1] = (scm_t_uint8)nargs;
bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text));
bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text),
"boot-program");
memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
bp->len = sizeof(text);
bp->metalen = 0;
u8vec = scm_c_take_bytevector ((scm_t_int8*)bp,
sizeof (struct scm_objcode) + sizeof (text),
SCM_BOOL_F);
u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
sizeof (struct scm_objcode) + sizeof (text),
SCM_BOOL_F);
ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
SCM_BOOL_F, SCM_BOOL_F);
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);

19
module/ice-9/boot-9.scm
View file

@ -2629,10 +2629,6 @@ VALUE."
(error "expected list of integers for version"))
(set-module-version! module version)
(set-module-version! (module-public-interface module) version)))
(if (pair? duplicates)
(let ((handlers (lookup-duplicates-handlers duplicates)))
(set-module-duplicates-handlers! module handlers)))
(let ((imports (resolve-imports imports)))
(call-with-deferred-observers
(lambda ()
@ -2652,7 +2648,12 @@ VALUE."
(error "expected re-exports to be a list of symbols or symbol pairs"))
;; FIXME
(if (not (null? autoloads))
(apply module-autoload! module autoloads)))))
(apply module-autoload! module autoloads))
;; Wait until modules have been loaded to resolve duplicates
;; handlers.
(if (pair? duplicates)
(let ((handlers (lookup-duplicates-handlers duplicates)))
(set-module-duplicates-handlers! module handlers))))))
(if transformer
(if (and (pair? transformer) (list-of symbol? transformer))
@ -3692,13 +3693,15 @@ module '(ice-9 q) '(make-q q-length))}."
((args ...) (generate-temporaries #'(formals ...))))
#`(begin
(define (proc-name formals ...)
body ...)
(fluid-let-syntax ((name (identifier-syntax proc-name)))
body ...))
(define-syntax name
(lambda (x)
(syntax-case x ()
((_ args ...)
#'((lambda (formals ...)
body ...)
#'((fluid-let-syntax ((name (identifier-syntax proc-name)))
(lambda (formals ...)
body ...))
args ...))
(_
(identifier? x)

2
module/language/tree-il.scm
View file

@ -408,7 +408,7 @@
(case (car alt-expansion)
((lambda)
`(case-lambda (,formals ,(tree-il->scheme body))
,@(cdr alt-expansion)))
,(cdr alt-expansion)))
((lambda*)
`(case-lambda* (,formals ,(tree-il->scheme body))
,(cdr alt-expansion)))

72
module/rnrs/base.scm
View file

@ -73,7 +73,7 @@
let-syntax letrec-syntax
syntax-rules identifier-syntax)
(import (rename (except (guile) error raise)
(import (rename (except (guile) error raise map)
(log log-internal)
(euclidean-quotient div)
(euclidean-remainder mod)
@ -86,6 +86,76 @@
(inexact->exact exact))
(srfi srfi-11))
(define map
(case-lambda
((f l)
(let map1 ((hare l) (tortoise l) (move? #f) (out '()))
(if (pair? hare)
(if move?
(if (eq? tortoise hare)
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
(list l) #f)
(map1 (cdr hare) (cdr tortoise) #f
(cons (f (car hare)) out)))
(map1 (cdr hare) tortoise #t
(cons (f (car hare)) out)))
(if (null? hare)
(reverse out)
(scm-error 'wrong-type-arg "map" "Not a list: ~S"
(list l) #f)))))
((f l1 l2)
(let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
(cond
((pair? h1)
(cond
((not (pair? h2))
(scm-error 'wrong-type-arg "map"
(if (list? h2)
"List of wrong length: ~S"
"Not a list: ~S")
(list l2) #f))
((not move?)
(map2 (cdr h1) (cdr h2) t1 t2 #t
(cons (f (car h1) (car h2)) out)))
((eq? t1 h1)
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
(list l1) #f))
((eq? t2 h2)
(scm-error 'wrong-type-arg "map" "Circular list: ~S"
(list l2) #f))
(else
(map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
(cons (f (car h1) (car h2)) out)))))
((and (null? h1) (null? h2))
(reverse out))
((null? h1)
(scm-error 'wrong-type-arg "map"
(if (list? h2)
"List of wrong length: ~S"
"Not a list: ~S")
(list l2) #f))
(else
(scm-error 'wrong-type-arg "map"
"Not a list: ~S"
(list l1) #f)))))
((f l1 . rest)
(let ((len (length l1)))
(let mapn ((rest rest))
(or (null? rest)
(if (= (length (car rest)) len)
(mapn (cdr rest))
(scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
(list (car rest)) #f)))))
(let mapn ((l1 l1) (rest rest) (out '()))
(if (null? l1)
(reverse out)
(mapn (cdr l1) (map cdr rest)
(cons (apply f (car l1) (map car rest)) out)))))))
(define log
(case-lambda
((n)

82
module/scripts/help.scm
View file

@ -29,9 +29,14 @@
#:use-module (ice-9 format)
#:use-module (ice-9 documentation)
#:use-module ((srfi srfi-1) #:select (fold append-map))
#:export (main))
#:export (show-help show-summary show-usage main))
(define %summary "Show a brief help message.")
(define %synopsis "help\nhelp --all\nhelp COMMAND")
(define %help "
Show help on guild commands. With --all, show arcane incantations as
well. With COMMAND, show more detailed help for a particular command.
")
(define (directory-files dir)
@ -117,32 +122,67 @@ For complete documentation, run: info guile 'Using Guile Tools'
(file-commentary
(%search-load-path (module-filename mod))))
(define (module-command-name mod)
(symbol->string (car (last-pair (module-name mod)))))
(define* (show-usage mod #:optional (port (current-output-port)))
(let ((usages (string-split
(let ((var (module-variable mod '%synopsis)))
(if var
(variable-ref var)
(string-append (module-command-name mod)
" OPTION...")))
#\newline)))
(display "Usage: guild " port)
(display (car usages))
(newline port)
(for-each (lambda (u)
(display " guild " port)
(display u port)
(newline port))
(cdr usages))))
(define* (show-summary mod #:optional (port (current-output-port)))
(let ((var (module-variable mod '%summary)))
(if var
(begin
(display (variable-ref var) port)
(newline port)))))
(define* (show-help mod #:optional (port (current-output-port)))
(show-usage mod port)
(show-summary mod port)
(cond
((module-variable mod '%help)
=> (lambda (var)
(display (variable-ref var) port)
(newline port)))
((module-commentary mod)
=> (lambda (commentary)
(newline port)
(display commentary port)))
(else
(format #t "No documentation found for command \"~a\".\n"
(module-command-name mod)))))
(define %mod (current-module))
(define (main . args)
(cond
((null? args)
(list-commands #f))
((or (equal? args '("--all")) (equal? args '("-a")))
(list-commands #t))
((not (string-prefix? "-" (car args)))
((and (null? (cdr args)) (not (string-prefix? "-" (car args))))
;; help for particular command
(let* ((name (car args))
(mod (resolve-module `(scripts ,(string->symbol name))
#:ensure #f)))
(if mod
(let ((commentary (module-commentary mod)))
(if commentary
(display commentary)
(format #t "No documentation found for command \"~a\".\n"
name)))
(begin
(format #t "No command named \"~a\".\n" name)
(exit 1)))))
(let ((name (car args)))
(cond
((resolve-module `(scripts ,(string->symbol name)) #:ensure #f)
=> (lambda (mod)
(show-help mod)
(exit 0)))
(else
(format #t "No command named \"~a\".\n" name)
(exit 1)))))
(else
(display "Usage: guild help
guild help --all
guild help COMMAND
Show a help on guild commands. With --all, show arcane incantations as
well. With COMMAND, show more detailed help for a particular command.
")
(show-help %mod (current-error-port))
(exit 1))))

93
module/srfi/srfi-1.scm
View file

@ -236,12 +236,15 @@
higher-order procedures."
(cons a d))
;; internal helper, similar to (scsh utilities) check-arg.
(define (check-arg-type pred arg caller)
(if (pred arg)
arg
(scm-error 'wrong-type-arg caller
"Wrong type argument: ~S" (list arg) '())))
(define (wrong-type-arg caller arg)
(scm-error 'wrong-type-arg (symbol->string caller)
"Wrong type argument: ~S" (list arg) '()))
(define-syntax check-arg
(syntax-rules ()
((_ pred arg caller)
(if (not (pred arg))
(wrong-type-arg 'caller arg)))))
(define (out-of-range proc arg)
(scm-error 'out-of-range proc
@ -254,7 +257,7 @@ higher-order procedures."
"Return an N-element list, where each list element is produced by applying the
procedure INIT-PROC to the corresponding list index. The order in which
INIT-PROC is applied to the indices is not specified."
(check-arg-type non-negative-integer? n "list-tabulate")
(check-arg non-negative-integer? n list-tabulate)
(let lp ((n n) (acc '()))
(if (<= n 0)
acc
@ -266,7 +269,7 @@ INIT-PROC is applied to the indices is not specified."
elts)
(define* (iota count #:optional (start 0) (step 1))
(check-arg-type non-negative-integer? count "iota")
(check-arg non-negative-integer? count iota)
(let lp ((n 0) (acc '()))
(if (= n count)
(reverse! acc)
@ -334,6 +337,8 @@ end-of-list checking in contexts where dotted lists are allowed."
(else
(and (elt= (car a) (car b))
(lp (cdr a) (cdr b)))))))
(check-arg procedure? elt= list=)
(or (null? rest)
(let lp ((lists rest))
(or (null? (cdr lists))
@ -360,6 +365,22 @@ end-of-list checking in contexts where dotted lists are allowed."
(define take list-head)
(define drop list-tail)
;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
;;; off by K, then chasing down the list until the lead pointer falls off
;;; the end. Note that they diverge for circular lists.
(define (take-right lis k)
(let lp ((lag lis) (lead (drop lis k)))
(if (pair? lead)
(lp (cdr lag) (cdr lead))
lag)))
(define (drop-right lis k)
(let recur ((lag lis) (lead (drop lis k)))
(if (pair? lead)
(cons (car lag) (recur (cdr lag) (cdr lead)))
'())))
(define (take! lst i)
"Linear-update variant of `take'."
(if (= i 0)
@ -438,6 +459,7 @@ a list of those after."
(define (fold kons knil list1 . rest)
"Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
that result. See the manual for details."
(check-arg procedure? kons fold)
(if (null? rest)
(let f ((knil knil) (list1 list1))
(if (null? list1)
@ -451,6 +473,7 @@ that result. See the manual for details."
(f (apply kons (append! cars (list knil))) cdrs))))))
(define (fold-right kons knil clist1 . rest)
(check-arg procedure? kons fold-right)
(if (null? rest)
(let loop ((lst (reverse clist1))
(result knil))
@ -466,6 +489,7 @@ that result. See the manual for details."
(apply kons (append! (map car lists) (list result))))))))
(define (pair-fold kons knil clist1 . rest)
(check-arg procedure? kons pair-fold)
(if (null? rest)
(let f ((knil knil) (list1 clist1))
(if (null? list1)
@ -480,6 +504,7 @@ that result. See the manual for details."
(define (pair-fold-right kons knil clist1 . rest)
(check-arg procedure? kons pair-fold-right)
(if (null? rest)
(let f ((list1 clist1))
(if (null? list1)
@ -499,6 +524,10 @@ that result. See the manual for details."
(loop (cdr lst)
(cons (car lst) result)))))
(check-arg procedure? p unfold)
(check-arg procedure? f unfold)
(check-arg procedure? g unfold)
(check-arg procedure? tail-gen unfold)
(let loop ((seed seed)
(result '()))
(if (p seed)
@ -507,6 +536,9 @@ that result. See the manual for details."
(cons (f seed) result)))))
(define* (unfold-right p f g seed #:optional (tail '()))
(check-arg procedure? p unfold-right)
(check-arg procedure? f unfold-right)
(check-arg procedure? g unfold-right)
(let uf ((seed seed) (lis tail))
(if (p seed)
lis
@ -517,6 +549,7 @@ that result. See the manual for details."
elements from LST, rather than one element and a given initial value.
If LST is empty, RIDENTITY is returned. If LST has just one element
then that's the return value."
(check-arg procedure? f reduce)
(if (null? lst)
ridentity
(fold f (car lst) (cdr lst))))
@ -526,6 +559,7 @@ then that's the return value."
F is on two elements from LST, rather than one element and a given
initial value. If LST is empty, RIDENTITY is returned. If LST
has just one element then that's the return value."
(check-arg procedure? f reduce)
(if (null? lst)
ridentity
(fold-right f (last lst) (drop-right lst 1))))
@ -533,6 +567,7 @@ has just one element then that's the return value."
(define map
(case-lambda
((f l)
(check-arg procedure? f map)
(let map1 ((hare l) (tortoise l) (move? #f) (out '()))
(if (pair? hare)
(if move?
@ -549,6 +584,7 @@ has just one element then that's the return value."
(list l) #f)))))
((f l1 . rest)
(check-arg procedure? f map)
(let ((len (fold (lambda (ls len)
(let ((ls-len (length+ ls)))
(if len
@ -571,6 +607,7 @@ has just one element then that's the return value."
(define for-each
(case-lambda
((f l)
(check-arg procedure? f for-each)
(let for-each1 ((hare l) (tortoise l) (move? #f))
(if (pair? hare)
(if move?
@ -589,6 +626,7 @@ has just one element then that's the return value."
(list l) #f)))))
((f l1 . rest)
(check-arg procedure? f for-each)
(let ((len (fold (lambda (ls len)
(let ((ls-len (length+ ls)))
(if len
@ -619,6 +657,7 @@ has just one element then that's the return value."
"Apply PROC to to the elements of LIST1... and return a list of the
results as per SRFI-1 `map', except that any #f results are omitted from
the list returned."
(check-arg procedure? proc filter-map)
(if (null? rest)
(let lp ((l list1)
(rl '()))
@ -638,6 +677,7 @@ the list returned."
(lp (map cdr l) rl)))))))
(define (pair-for-each f clist1 . rest)
(check-arg procedure? f pair-for-each)
(if (null? rest)
(let lp ((l clist1))
(if (null? l)
@ -658,6 +698,7 @@ the list returned."
(define (take-while pred ls)
"Return a new list which is the longest initial prefix of LS whose
elements all satisfy the predicate PRED."
(check-arg procedure? pred take-while)
(cond ((null? ls) '())
((not (pred (car ls))) '())
(else
@ -671,6 +712,7 @@ elements all satisfy the predicate PRED."
(define (take-while! pred lst)
"Linear-update variant of `take-while'."
(check-arg procedure? pred take-while!)
(let loop ((prev #f)
(rest lst))
(cond ((null? rest)
@ -687,6 +729,7 @@ elements all satisfy the predicate PRED."
(define (drop-while pred lst)
"Drop the longest initial prefix of LST whose elements all satisfy the
predicate PRED."
(check-arg procedure? pred drop-while)
(let loop ((lst lst))
(cond ((null? lst)
'())
@ -697,6 +740,7 @@ predicate PRED."
(define (span pred lst)
"Return two values, the longest initial prefix of LST whose elements
all satisfy the predicate PRED, and the remainder of LST."
(check-arg procedure? pred span)
(let lp ((lst lst) (rl '()))
(if (and (not (null? lst))
(pred (car lst)))
@ -705,6 +749,7 @@ all satisfy the predicate PRED, and the remainder of LST."
(define (span! pred list)
"Linear-update variant of `span'."
(check-arg procedure? pred span!)
(let loop ((prev #f)
(rest list))
(cond ((null? rest)
@ -721,6 +766,7 @@ all satisfy the predicate PRED, and the remainder of LST."
(define (break pred clist)
"Return two values, the longest initial prefix of LST whose elements
all fail the predicate PRED, and the remainder of LST."
(check-arg procedure? pred break)
(let lp ((clist clist) (rl '()))
(if (or (null? clist)
(pred (car clist)))
@ -729,6 +775,7 @@ all fail the predicate PRED, and the remainder of LST."
(define (break! pred list)
"Linear-update variant of `break'."
(check-arg procedure? pred break!)
(let loop ((l list)
(prev #f))
(cond ((null? l)
@ -743,6 +790,7 @@ all fail the predicate PRED, and the remainder of LST."
(loop (cdr l) l)))))
(define (any pred ls . lists)
(check-arg procedure? pred any)
(if (null? lists)
(any1 pred ls)
(let lp ((lists (cons ls lists)))
@ -763,6 +811,7 @@ all fail the predicate PRED, and the remainder of LST."
(or (pred (car ls)) (lp (cdr ls)))))))
(define (every pred ls . lists)
(check-arg procedure? pred every)
(if (null? lists)
(every1 pred ls)
(let lp ((lists (cons ls lists)))
@ -785,6 +834,7 @@ all fail the predicate PRED, and the remainder of LST."
(define (list-index pred clist1 . rest)
"Return the index of the first set of elements, one from each of
CLIST1 ... CLISTN, that satisfies PRED."
(check-arg procedure? pred list-index)
(if (null? rest)
(let lp ((l clist1) (i 0))
(if (null? l)
@ -813,6 +863,7 @@ and those making the associations."
(lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))
(define* (alist-delete key alist #:optional (k= equal?))
(check-arg procedure? k= alist-delete)
(let lp ((a alist) (rl '()))
(if (null? a)
(reverse! rl)
@ -827,13 +878,18 @@ and those making the associations."
(define* (member x ls #:optional (= equal?))
(cond
((eq? = eq?) (memq x ls))
;; This might be performance-sensitive, so punt on the check here,
;; relying on memq/memv to check that = is a procedure.
((eq? = eq?) (memq x ls))
((eq? = eqv?) (memv x ls))
(else (find-tail (lambda (y) (= x y)) ls))))
(else
(check-arg procedure? = member)
(find-tail (lambda (y) (= x y)) ls))))
;;; Set operations on lists
(define (lset<= = . rest)
(check-arg procedure? = lset<=)
(if (null? rest)
#t
(let lp ((f (car rest)) (r (cdr rest)))
@ -842,6 +898,7 @@ and those making the associations."
(lp (car r) (cdr r)))))))
(define (lset= = . rest)
(check-arg procedure? = lset<=)
(if (null? rest)
#t
(let lp ((f (car rest)) (r (cdr rest)))
@ -870,7 +927,9 @@ given REST parameters."
(define pred
(if (or (eq? = eq?) (eq? = eqv?))
=
(lambda (x y) (= y x))))
(begin
(check-arg procedure? = lset-adjoin)
(lambda (x y) (= y x)))))
(let lp ((ans list) (rest rest))
(if (null? rest)
@ -885,7 +944,9 @@ given REST parameters."
(define pred
(if (or (eq? = eq?) (eq? = eqv?))
=
(lambda (x y) (= y x))))
(begin
(check-arg procedure? = lset-union)
(lambda (x y) (= y x)))))
(fold (lambda (lis ans) ; Compute ANS + LIS.
(cond ((null? lis) ans) ; Don't copy any lists
@ -901,6 +962,7 @@ given REST parameters."
rest))
(define (lset-intersection = list1 . rest)
(check-arg procedure? = lset-intersection)
(let lp ((l list1) (acc '()))
(if (null? l)
(reverse! acc)
@ -909,6 +971,7 @@ given REST parameters."
(lp (cdr l) acc)))))
(define (lset-difference = list1 . rest)
(check-arg procedure? = lset-difference)
(if (null? rest)
list1
(let lp ((l list1) (acc '()))
@ -921,6 +984,7 @@ given REST parameters."
;(define (fold kons knil list1 . rest)
(define (lset-xor = . rest)
(check-arg procedure? = lset-xor)
(fold (lambda (lst res)
(let lp ((l lst) (acc '()))
(if (null? l)
@ -937,6 +1001,7 @@ given REST parameters."
rest))
(define (lset-diff+intersection = list1 . rest)
(check-arg procedure? = lset-diff+intersection)
(let lp ((l list1) (accd '()) (acci '()))
(if (null? l)
(values (reverse! accd) (reverse! acci))
@ -947,15 +1012,19 @@ given REST parameters."
(define (lset-union! = . rest)
(check-arg procedure? = lset-union!)
(apply lset-union = rest)) ; XXX:optimize
(define (lset-intersection! = list1 . rest)
(check-arg procedure? = lset-intersection!)
(apply lset-intersection = list1 rest)) ; XXX:optimize
(define (lset-xor! = . rest)
(check-arg procedure? = lset-xor!)
(apply lset-xor = rest)) ; XXX:optimize
(define (lset-diff+intersection! = list1 . rest)
(check-arg procedure? = lset-diff+intersection!)
(apply lset-diff+intersection = list1 rest)) ; XXX:optimize
;;; srfi-1.scm ends here

522
module/srfi/srfi-19.scm
View file

File diff suppressed because it is too large Load diff

32
module/srfi/srfi-9.scm
View file

@ -95,6 +95,20 @@
(identifier? x)
#'proc-name))))))))))
(define (default-record-printer s p)
(display "#<" p)
(display (record-type-name (record-type-descriptor s)) p)
(let loop ((fields (record-type-fields (record-type-descriptor s)))
(off 0))
(cond
((not (null? fields))
(display " " p)
(display (car fields) p)
(display ": " p)
(write (struct-ref s off) p)
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
(define-syntax define-record-type
(lambda (x)
(define (field-identifiers field-specs)
@ -177,16 +191,14 @@
(indices (field-indices (map syntax->datum fields))))
#`(begin
(define type-name
(make-vtable #,layout
(lambda (obj port)
(format port "#<~A" 'type-name)
#,@(map (lambda (field)
(let* ((f (syntax->datum field))
(i (assoc-ref indices f)))
#`(format port " ~A: ~S" '#,field
(struct-ref obj #,i))))
fields)
(format port ">"))))
(let ((rtd (make-struct/no-tail
record-type-vtable
'#,(datum->syntax #'here (make-struct-layout layout))
default-record-printer
'type-name
'#,fields)))
(set-struct-vtable-name! rtd 'type-name)
rtd))
(define-inlinable (predicate-name obj)
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))

10
module/texinfo.scm
View file

@ -1,6 +1,6 @@
;;;; (texinfo) -- parsing of texinfo into SXML
;;;;
;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
;;;;
@ -168,6 +168,9 @@ line, received through their attribute list, and parsed text until the
@code{EOF-TEXT-ARGS} receives its arguments in its attribute list, as in
@code{ENVIRON}.
In addition, @code{ALIAS} can alias one command to another. The alias
will never be seen in parsed stexinfo.
There are four @@-commands that are treated specially. @code{@@include}
is a low-level token that will not be seen by higher-level parsers, so
it has no content-model. @code{@@para} is the paragraph command, which
@ -210,7 +213,6 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
(dfn INLINE-TEXT)
(cite INLINE-TEXT)
(acro INLINE-TEXT)
(url INLINE-TEXT)
(email INLINE-TEXT)
(emph INLINE-TEXT)
(strong INLINE-TEXT)
@ -230,6 +232,7 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
(ref INLINE-ARGS . (node #:opt name section info-file manual))
(xref INLINE-ARGS . (node #:opt name section info-file manual))
(pxref INLINE-ARGS . (node #:opt name section info-file manual))
(url ALIAS . uref)
(uref INLINE-ARGS . (url #:opt title replacement))
(anchor INLINE-ARGS . (name))
(dots INLINE-ARGS . ())
@ -255,6 +258,7 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS},
(dircategory EOL-ARGS . (category))
(top EOL-ARGS . (title))
(printindex EOL-ARGS . (type))
(paragraphindent EOL-ARGS . (indent))
;; EOL text commands
(*ENVIRON-ARGS* EOL-TEXT)
@ -654,6 +658,8 @@ Examples:
(type (cadr spec))
(arg-names (cddr spec)))
(case type
((ALIAS)
(complete-start-command arg-names port))
((INLINE-TEXT)
(assert-curr-char '(#\{) "Inline element lacks {" port)
(values command '() type))

9
module/texinfo/reflection.scm
View file

@ -288,11 +288,16 @@
(else (lp (cdr forms))))))
(define* (module-stexi-documentation sym-name
#:optional (docs-resolver
(lambda (name def) def)))
#:optional %docs-resolver
#:key (docs-resolver
(or %docs-resolver
(lambda (name def) def))))
"Return documentation for the module named @var{sym-name}. The
documentation will be formatted as @code{stexi}
(@pxref{texinfo,texinfo})."
(if %docs-resolver
(issue-deprecation-warning
"module-stexi-documentation: use #:docs-resolver instead of a positional argument."))
(let* ((commentary (and=> (module-commentary sym-name)
(lambda (x) (string-trim-both x #\newline))))
(stexi (string->stexi commentary))

181
module/web/http.scm
View file

@ -33,7 +33,6 @@
#:use-module ((srfi srfi-1) #:select (append-map! map!))
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (web uri)
#:export (string->header
@ -622,19 +621,179 @@ ordered alist."
(write-key-value-list item port val-writer ";"))
","))
(define-syntax string-match?
(lambda (x)
(syntax-case x ()
((_ str pat) (string? (syntax->datum #'pat))
(let ((p (syntax->datum #'pat)))
#`(let ((s str))
(and
(= (string-length s) #,(string-length p))
#,@(let lp ((i 0) (tests '()))
(if (< i (string-length p))
(let ((c (string-ref p i)))
(lp (1+ i)
(case c
((#\.) ; Whatever.
tests)
((#\d) ; Digit.
(cons #`(char-numeric? (string-ref s #,i))
tests))
((#\a) ; Alphabetic.
(cons #`(char-alphabetic? (string-ref s #,i))
tests))
(else ; Literal.
(cons #`(eqv? (string-ref s #,i) #,c)
tests)))))
tests)))))))))
;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun"
;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"
(define (parse-month str start end)
(define (bad)
(bad-header-component 'month (substring str start end)))
(if (not (= (- end start) 3))
(bad)
(let ((a (string-ref str (+ start 0)))
(b (string-ref str (+ start 1)))
(c (string-ref str (+ start 2))))
(case a
((#\J)
(case b
((#\a) (case c ((#\n) 1) (else (bad))))
((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad))))
(else (bad))))
((#\F)
(case b
((#\e) (case c ((#\b) 2) (else (bad))))
(else (bad))))
((#\M)
(case b
((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad))))
(else (bad))))
((#\A)
(case b
((#\p) (case c ((#\r) 4) (else (bad))))
((#\u) (case c ((#\g) 8) (else (bad))))
(else (bad))))
((#\S)
(case b
((#\e) (case c ((#\p) 9) (else (bad))))
(else (bad))))
((#\O)
(case b
((#\c) (case c ((#\t) 10) (else (bad))))
(else (bad))))
((#\N)
(case b
((#\o) (case c ((#\v) 11) (else (bad))))
(else (bad))))
((#\D)
(case b
((#\e) (case c ((#\c) 12) (else (bad))))
(else (bad))))
(else (bad))))))
;; RFC 822, updated by RFC 1123
;;
;; Sun, 06 Nov 1994 08:49:37 GMT
;; 01234567890123456789012345678
;; 0 1 2
(define (parse-rfc-822-date str)
;; We could verify the day of the week but we don't.
(if (not (string-match? str "aaa, dd aaa dddd dd:dd:dd GMT"))
(bad-header 'date str))
(let ((date (parse-non-negative-integer str 5 7))
(month (parse-month str 8 11))
(year (parse-non-negative-integer str 12 16))
(hour (parse-non-negative-integer str 17 19))
(minute (parse-non-negative-integer str 20 22))
(second (parse-non-negative-integer str 23 25)))
(make-date 0 second minute hour date month year 0)))
;; RFC 850, updated by RFC 1036
;; Sunday, 06-Nov-94 08:49:37 GMT
;; 0123456789012345678901
;; 0 1 2
(define (parse-rfc-850-date str comma)
;; We could verify the day of the week but we don't.
(let ((tail (substring str (1+ comma))))
(if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT"))
(bad-header 'date str))
(let ((date (parse-non-negative-integer tail 1 3))
(month (parse-month tail 4 7))
(year (parse-non-negative-integer tail 8 10))
(hour (parse-non-negative-integer tail 11 13))
(minute (parse-non-negative-integer tail 14 16))
(second (parse-non-negative-integer tail 17 19)))
(make-date 0 second minute hour date month
(let* ((now (date-year (current-date)))
(then (+ now year (- (modulo now 100)))))
(cond ((< (+ then 50) now) (+ then 100))
((< (+ now 50) then) (- then 100))
(else then)))
0))))
;; ANSI C's asctime() format
;; Sun Nov 6 08:49:37 1994
;; 012345678901234567890123
;; 0 1 2
(define (parse-asctime-date str)
(if (not (string-match? str "aaa aaa .d dd:dd:dd dddd"))
(bad-header 'date str))
(let ((date (parse-non-negative-integer
str
(if (eqv? (string-ref str 8) #\space) 9 8)
10))
(month (parse-month str 4 7))
(year (parse-non-negative-integer str 20 24))
(hour (parse-non-negative-integer str 11 13))
(minute (parse-non-negative-integer str 14 16))
(second (parse-non-negative-integer str 17 19)))
(make-date 0 second minute hour date month year 0)))
(define (parse-date str)
;; Unfortunately, there is no way to make string->date parse out the
;; "GMT" bit, so we play string games to append a format it will
;; understand (the +0000 bit).
(string->date
(if (string-suffix? " GMT" str)
(string-append (substring str 0 (- (string-length str) 4))
" +0000")
(bad-header-component 'date str))
"~a, ~d ~b ~Y ~H:~M:~S ~z"))
(if (string-suffix? " GMT" str)
(let ((comma (string-index str #\,)))
(cond ((not comma) (bad-header 'date str))
((= comma 3) (parse-rfc-822-date str))
(else (parse-rfc-850-date str comma))))
(parse-asctime-date str)))
(define (write-date date port)
(display (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT") port))
(define (display-digits n digits port)
(define zero (char->integer #\0))
(let lp ((tens (expt 10 (1- digits))))
(if (> tens 0)
(begin
(display (integer->char (+ zero (modulo (truncate/ n tens) 10)))
port)
(lp (floor/ tens 10))))))
(let ((date (if (zero? (date-zone-offset date))
date
(time-tai->date (date->time-tai date) 0))))
(display (case (date-week-day date)
((0) "Sun, ") ((2) "Mon, ") ((2) "Tue, ")
((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ")
((6) "Sat, ") (else (error "bad date" date)))
port)
(display-digits (date-day date) 2 port)
(display (case (date-month date)
((1) " Jan ") ((2) " Feb ") ((3) " Ma ")
((4) " Apr ") ((5) " May ") ((6) " Jun ")
((7) " Jul ") ((8) " Aug ") ((9) " Sep ")
((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
(else (error "bad date" date)))
port)
(display-digits (date-year date) 4 port)
(display #\space port)
(display-digits (date-hour date) 2 port)
(display #\: port)
(display-digits (date-minute date) 2 port)
(display #\: port)
(display-digits (date-second date) 2 port)
(display " GMT" port)))
(define (write-uri uri port)
(display (uri->string uri) port))

16
test-suite/tests/srfi-1.test
View file

@ -1,6 +1,6 @@
;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
;;;;
;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 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
@ -902,7 +902,12 @@
(pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
(pass-if (equal? '() (drop-right '(4 5 6) 3)))
(pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
(drop-right '(4 5 6) 4)))
(drop-right '(4 5 6) 4))
(pass-if "(a b . c) 0"
(equal? (drop-right '(a b . c) 0) '(a b)))
(pass-if "(a b . c) 1"
(equal? (drop-right '(a b . c) 1) '(a))))
;;
;; drop-right!
@ -2621,7 +2626,12 @@
(pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
(pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
(pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
(take-right '(4 5 6) 4)))
(take-right '(4 5 6) 4))
(pass-if "(a b . c) 0"
(equal? (take-right '(a b . c) 0) 'c))
(pass-if "(a b . c) 1"
(equal? (take-right '(a b . c) 1) '(b . c))))
;;
;; tenth

5
test-suite/tests/texinfo.test
View file

@ -1,6 +1,6 @@
;;;; texinfo.test -*- scheme -*-
;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@ -207,6 +207,9 @@
(test-body "@code{arg}"
'((para (code "arg"))))
;; FIXME: Why no enclosing para here? Probably a bug.
(test-body "@url{arg}"
'((uref (% (url "arg")))))
(test-body "@code{ }"
'((para (code))))
(test-body "@code{ @code{} }"

17
test-suite/tests/tree-il.test
View file

@ -55,6 +55,23 @@
(pat (guard test ...) #t)
(else #f))))))))
(define-syntax pass-if-tree-il->scheme
(syntax-rules ()
((_ in pat)
(assert-scheme->tree-il->scheme in pat #t))
((_ in pat guard-exp)
(pass-if 'in
(pmatch (tree-il->scheme
(compile 'in #:from 'scheme #:to 'tree-il))
(pat (guard guard-exp) #t)
(_ #f))))))
(with-test-prefix "tree-il->scheme"
(pass-if-tree-il->scheme
(case-lambda ((a) a) ((b c) (list b c)))
(case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
(and (eq? a a1) (eq? b b1) (eq? c c1))))
(with-test-prefix "void"
(assert-tree-il->glil
(void)