[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
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0 |
|
Date: |
Wed, 31 Aug 2011 07:58:22 +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=8b66aa8f5496a515ca133d6d2c37a06f6ec1720d
The branch, master has been updated
via 8b66aa8f5496a515ca133d6d2c37a06f6ec1720d (commit)
via 0b4f77192da214690aa811d13bb6a7f6dd576445 (commit)
via 406524ea980e50e8f28f3144cc40dd253116ef8c (commit)
via 35c0f0672e76ee8cb0007f57b85a0d666365d5d1 (commit)
via 31d5976931adf4bd7cd4b0b0cbcbf3b84335f4a1 (commit)
via b8287e882316bce594c0be0c9db7c5be12c27b96 (commit)
via 6b1c5d9d67acd35a2b0c6e994dea21c3b5d8d39a (commit)
via fb031aba42d3b0d22538c50ef92a666496a8e326 (commit)
via 5261e74281b1150e3b2594c92e571d8887a4900d (commit)
via 81bda963e969db7e2ecc878982286daa5b0aacff (commit)
via b8f191964e519807bb6d05ea0f2296a46d2144bd (commit)
via 6ffb5f9765866ea7037a4acdab8378c470f7931b (commit)
via 2844ab856427936aff535103195b3553cfa0d393 (commit)
via 8761623524d767e6e355f0de4c3be426ed3c8b09 (commit)
via 42f9581238b011d15114bfd31606cbda10574d17 (commit)
via e7a81c7acdc0501b3fca6cdd51eb05d4fe39d317 (commit)
via 335c8a89a2e1dfb362b7a52010da4a81ab9cffc9 (commit)
via 2b582a285af7c30dbe7a3ee167728277a745f9b7 (commit)
via abab34ce4d561cbb2a2311e571578a5e331c7aa4 (commit)
via a6e1e050941a39821f1022ce7a655ac511879b7a (commit)
via e4f6e855b6f96cd58f6643949438384be5470a39 (commit)
via 0f75cc78096578f85cc66bba054044116e2ca413 (commit)
via 89f886122a37a051087fbfbbab5400a29a661b06 (commit)
via 3b08b1c24df6d89645e0d1633dac0c4a7b160e6b (commit)
via 2700aa43f21d927fb208b6779a07c8f63d91c27e (commit)
via 7c888dfa6e67e13dd89c459df3ee28f13ab681ec (commit)
via eff3dd99f757410d6ab8d7e3da0a4120d1111192 (commit)
via 2b14df4bc7c317cb25a0bf7cb0bc35c18bb01898 (commit)
via bd61f2e64f745851ff6f0b477ade14a8c2880565 (commit)
via 74ec8d786fd0abd8e2818b373ef8bc7d36fee8ad (commit)
from 02620dd9a628ec40ec4324adca9b82cd0442d1d2 (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 8b66aa8f5496a515ca133d6d2c37a06f6ec1720d
Merge: 02620dd 0b4f771
Author: Andy Wingo <address@hidden>
Date: Wed Aug 31 09:34:54 2011 +0200
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/bytevectors.c
libguile/bytevectors.h
libguile/objcodes.c
libguile/r6rs-ports.c
libguile/strings.c
libguile/vm.c
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-io.texi | 44 ++--
libguile/arrays.c | 34 ++--
libguile/bytevectors.c | 4 +-
libguile/bytevectors.h | 2 +-
libguile/control.c | 3 +-
libguile/gc.c | 13 +-
libguile/hashtab.c | 2 +-
libguile/i18n.c | 13 +-
libguile/load.c | 253 +++++++++++---------
libguile/numbers.c | 2 -
libguile/objcodes.c | 4 +-
libguile/posix.c | 12 +-
libguile/r6rs-ports.c | 14 +-
libguile/read.c | 2 +-
libguile/script.c | 2 +
libguile/srfi-1.c | 39 ---
libguile/srfi-1.h | 2 -
libguile/stacks.c | 9 +-
libguile/strings.c | 2 +-
libguile/vm.c | 9 +-
module/ice-9/boot-9.scm | 19 +-
module/language/tree-il.scm | 2 +-
module/rnrs/base.scm | 72 ++++++-
module/scripts/help.scm | 82 +++++--
module/srfi/srfi-1.scm | 93 +++++++-
module/srfi/srfi-19.scm | 522 ++++++++++++++++++++---------------------
module/srfi/srfi-9.scm | 32 ++-
module/texinfo.scm | 10 +-
module/texinfo/reflection.scm | 9 +-
module/web/http.scm | 181 +++++++++++++-
test-suite/tests/srfi-1.test | 16 +-
test-suite/tests/texinfo.test | 5 +-
test-suite/tests/tree-il.test | 17 ++
33 files changed, 947 insertions(+), 578 deletions(-)
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 19c0665..afcde57 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -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.
-
-(For reference, Guile leaves text versus binary up to the C library,
address@hidden here just adds @code{O_BINARY} to the underlying @code{open}
-call, when that flag is available.)
-
-Also, open the file using the 8-bit character encoding "ISO-8859-1",
-ignoring any coding declaration or port encoding.
-
-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}).
+Use binary mode, ensuring that each byte in the file will be read as one
+Scheme character.
+
+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.
+
+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
address@hidden Binary Output}, for more.
+
+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
address@hidden
In theory we could create read/write ports which were buffered
in one direction only. However this isn't included in the
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 6724d00..d99081c 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -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,13 +895,22 @@ 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.
*/
if (c == '@' || c == ':')
@@ -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);
}
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 99ac176..8fc0252 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -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;
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 4b775f2..f22a3dd 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -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 *);
diff --git a/libguile/control.c b/libguile/control.c
index 9121d17..661de8f 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -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);
diff --git a/libguile/gc.c b/libguile/gc.c
index 3ae978f..c68f295 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -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;
}
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 6141e4f..c4f2b5e 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -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];
diff --git a/libguile/i18n.c b/libguile/i18n.c
index f9ec723..c0deb98 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -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;
}
diff --git a/libguile/load.c b/libguile/load.c
index de6bf7c..21008cb 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -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)
+ 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
{
- 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 ());
- }
+ 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 ());
}
- else
- /* At least one of the files isn't accessible. */
- compiled_is_newer = 0;
-
- free (source);
- free (compiled);
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 */
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 24ae2bc..235bbbb 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -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;
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index a4657be..f026783 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -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
diff --git a/libguile/posix.c b/libguile/posix.c
index 2923dc6..ea406ae 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -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
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index bf146ef..7ee56af 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -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;
diff --git a/libguile/read.c b/libguile/read.c
index c95db5c..0b7144c 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -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)
diff --git a/libguile/script.c b/libguile/script.c
index 83dcdd5..5e0685a 100644
--- a/libguile/script.c
+++ b/libguile/script.c
@@ -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 *))))
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 37441f7..ed6d3d9 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -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)
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index 13ab067..47607bc 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -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);
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 86188f4..d0e82f7 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -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);
diff --git a/libguile/strings.c b/libguile/strings.c
index b43ccab..dd859c4 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -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);
diff --git a/libguile/vm.c b/libguile/vm.c
index 8d1c375..940dd60 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -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);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 3bf4922..b233a00 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -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)
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index d919f9a..1264f32 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -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)))
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 4cfd1d1..499a224 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -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)
diff --git a/module/scripts/help.scm b/module/scripts/help.scm
index 107d394..4e0f47c 100644
--- a/module/scripts/help.scm
+++ b/module/scripts/help.scm
@@ -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))))
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index c60f625..765bd50 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -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
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index dcc2533..d8f7643 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -1,6 +1,6 @@
;;; srfi-19.scm --- Time/Date Library
-;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010 Free
Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 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
@@ -33,7 +33,7 @@
;;
;; FIXME: mkoeppe: Time zones are treated a little simplistic in
;; SRFI-19; they are only a numeric offset. Thus, printing time zones
-;; (PRIV:LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly. The
+;; (LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly. The
;; functions taking an optional TZ-OFFSET should be extended to take a
;; symbolic time-zone (like "CET"); this string should be stored in
;; the DATE structure.
@@ -147,27 +147,23 @@
;;-- LOCALE dependent constants
-(define priv:locale-number-separator locale-decimal-point)
-(define priv:locale-pm locale-pm-string)
-(define priv:locale-am locale-am-string)
-
;; See date->string
-(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
-(define priv:locale-short-date-format "~m/~d/~y")
-(define priv:locale-time-format "~H:~M:~S")
-(define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")
+(define locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
+(define locale-short-date-format "~m/~d/~y")
+(define locale-time-format "~H:~M:~S")
+(define iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")
;;-- Miscellaneous Constants.
-;;-- only the priv:tai-epoch-in-jd might need changing if
+;;-- only the tai-epoch-in-jd might need changing if
;; a different epoch is used.
-(define priv:nano 1000000000) ; nanoseconds in a second
-(define priv:sid 86400) ; seconds in a day
-(define priv:sihd 43200) ; seconds in a half day
-(define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
+(define nano 1000000000) ; nanoseconds in a second
+(define sid 86400) ; seconds in a day
+(define sihd 43200) ; seconds in a half day
+(define tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
;; FIXME: should this be something other than misc-error?
-(define (priv:time-error caller type value)
+(define (time-error caller type value)
(if value
(throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f)
(throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f)))
@@ -179,11 +175,11 @@
;; format and creates the leap second table
;; it also calls the almost standard, but not R5 procedures read-line
;; & open-input-string
-;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat"))
+;; ie (set! leap-second-table (read-tai-utc-date "tai-utc.dat"))
-(define (priv:read-tai-utc-data filename)
+(define (read-tai-utc-data filename)
(define (convert-jd jd)
- (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid))
+ (* (- (inexact->exact jd) tai-epoch-in-jd) sid))
(define (convert-sec sec)
(inexact->exact sec))
(let ((port (open-input-file filename))
@@ -205,7 +201,7 @@
;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
;; note they go higher to lower, and end in 1972.
-(define priv:leap-second-table
+(define leap-second-table
'((1136073600 . 33)
(915148800 . 32)
(867715200 . 31)
@@ -232,16 +228,16 @@
(63072000 . 10)))
(define (read-leap-second-table filename)
- (set! priv:leap-second-table (priv:read-tai-utc-data filename)))
+ (set! leap-second-table (read-tai-utc-data filename)))
-(define (priv:leap-second-delta utc-seconds)
+(define (leap-second-delta utc-seconds)
(letrec ((lsd (lambda (table)
(cond ((>= utc-seconds (caar table))
(cdar table))
(else (lsd (cdr table)))))))
- (if (< utc-seconds (* (- 1972 1970) 365 priv:sid)) 0
- (lsd priv:leap-second-table))))
+ (if (< utc-seconds (* (- 1972 1970) 365 sid)) 0
+ (lsd leap-second-table))))
;;; the TIME structure; creates the accessors, too.
@@ -256,16 +252,16 @@
(define (copy-time time)
(make-time (time-type time) (time-nanosecond time) (time-second time)))
-(define (priv:split-real r)
+(define (split-real r)
(if (integer? r)
(values (inexact->exact r) 0)
(let ((l (truncate r)))
(values (inexact->exact l) (- r l)))))
-(define (priv:time-normalize! t)
+(define (time-normalize! t)
(if (>= (abs (time-nanosecond t)) 1000000000)
(receive (int frac)
- (priv:split-real (time-nanosecond t))
+ (split-real (time-nanosecond t))
(set-time-second! t (+ (time-second t)
(quotient int 1000000000)))
(set-time-nanosecond! t (+ (remainder int 1000000000)
@@ -283,7 +279,7 @@
t)
(define (make-time type nanosecond second)
- (priv:time-normalize! (make-time-unnormalized type nanosecond second)))
+ (time-normalize! (make-time-unnormalized type nanosecond second)))
;; Helpers
;; FIXME: finish this and publish it?
@@ -307,21 +303,21 @@
;;; specific time getters.
-(define (priv:current-time-utc)
+(define (current-time-utc)
;; Resolution is microseconds.
(let ((tod (gettimeofday)))
(make-time time-utc (* (cdr tod) 1000) (car tod))))
-(define (priv:current-time-tai)
+(define (current-time-tai)
;; Resolution is microseconds.
(let* ((tod (gettimeofday))
(sec (car tod))
(usec (cdr tod)))
(make-time time-tai
(* usec 1000)
- (+ (car tod) (priv:leap-second-delta sec)))))
+ (+ (car tod) (leap-second-delta sec)))))
-;;(define (priv:current-time-ms-time time-type proc)
+;;(define (current-time-ms-time time-type proc)
;; (let ((current-ms (proc)))
;; (make-time time-type
;; (quotient current-ms 10000)
@@ -332,36 +328,36 @@
;; will require rewriting all of the time-monotonic converters,
;; of course.
-(define (priv:current-time-monotonic)
+(define (current-time-monotonic)
;; Resolution is microseconds.
- (priv:current-time-tai))
+ (current-time-tai))
-(define (priv:current-time-thread)
- (priv:time-error 'current-time 'unsupported-clock-type 'time-thread))
+(define (current-time-thread)
+ (time-error 'current-time 'unsupported-clock-type 'time-thread))
-(define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))
+(define ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))
-(define (priv:current-time-process)
+(define (current-time-process)
(let ((run-time (get-internal-run-time)))
(make-time
time-process
(* (remainder run-time internal-time-units-per-second)
- priv:ns-per-guile-tick)
+ ns-per-guile-tick)
(quotient run-time internal-time-units-per-second))))
-;;(define (priv:current-time-gc)
-;; (priv:current-time-ms-time time-gc current-gc-milliseconds))
+;;(define (current-time-gc)
+;; (current-time-ms-time time-gc current-gc-milliseconds))
(define (current-time . clock-type)
(let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
(cond
- ((eq? clock-type time-tai) (priv:current-time-tai))
- ((eq? clock-type time-utc) (priv:current-time-utc))
- ((eq? clock-type time-monotonic) (priv:current-time-monotonic))
- ((eq? clock-type time-thread) (priv:current-time-thread))
- ((eq? clock-type time-process) (priv:current-time-process))
- ;; ((eq? clock-type time-gc) (priv:current-time-gc))
- (else (priv:time-error 'current-time 'invalid-clock-type clock-type)))))
+ ((eq? clock-type time-tai) (current-time-tai))
+ ((eq? clock-type time-utc) (current-time-utc))
+ ((eq? clock-type time-monotonic) (current-time-monotonic))
+ ((eq? clock-type time-thread) (current-time-thread))
+ ((eq? clock-type time-process) (current-time-process))
+ ;; ((eq? clock-type time-gc) (current-time-gc))
+ (else (time-error 'current-time 'invalid-clock-type clock-type)))))
;; -- Time Resolution
;; This is the resolution of the clock in nanoseconds.
@@ -373,10 +369,10 @@
((time-tai) 1000)
((time-utc) 1000)
((time-monotonic) 1000)
- ((time-process) priv:ns-per-guile-tick)
+ ((time-process) ns-per-guile-tick)
;; ((eq? clock-type time-thread) 1000)
;; ((eq? clock-type time-gc) 10000)
- (else (priv:time-error 'time-resolution 'invalid-clock-type
clock-type)))))
+ (else (time-error 'time-resolution 'invalid-clock-type clock-type)))))
;; -- Time comparisons
@@ -415,7 +411,7 @@
(set-time-type! time1 time-duration)
(set-time-second! time1 sec-diff)
(set-time-nanosecond! time1 nsec-diff)
- (priv:time-normalize! time1)))
+ (time-normalize! time1)))
(define (time-difference time1 time2)
(let ((result (copy-time time1)))
@@ -423,12 +419,12 @@
(define (add-duration! t duration)
(if (not (eq? (time-type duration) time-duration))
- (priv:time-error 'add-duration 'not-duration duration)
+ (time-error 'add-duration 'not-duration duration)
(let ((sec-plus (+ (time-second t) (time-second duration)))
(nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
(set-time-second! t sec-plus)
(set-time-nanosecond! t nsec-plus)
- (priv:time-normalize! t))))
+ (time-normalize! t))))
(define (add-duration t duration)
(let ((result (copy-time t)))
@@ -436,12 +432,12 @@
(define (subtract-duration! t duration)
(if (not (eq? (time-type duration) time-duration))
- (priv:time-error 'add-duration 'not-duration duration)
+ (time-error 'add-duration 'not-duration duration)
(let ((sec-minus (- (time-second t) (time-second duration)))
(nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
(set-time-second! t sec-minus)
(set-time-nanosecond! t nsec-minus)
- (priv:time-normalize! t))))
+ (time-normalize! t))))
(define (subtract-duration time1 duration)
(let ((result (copy-time time1)))
@@ -451,11 +447,11 @@
(define (priv:time-tai->time-utc! time-in time-out caller)
(if (not (eq? (time-type time-in) time-tai))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (time-error caller 'incompatible-time-types time-in))
(set-time-type! time-out time-utc)
(set-time-nanosecond! time-out (time-nanosecond time-in))
(set-time-second! time-out (- (time-second time-in)
- (priv:leap-second-delta
+ (leap-second-delta
(time-second time-in))))
time-out)
@@ -468,11 +464,11 @@
(define (priv:time-utc->time-tai! time-in time-out caller)
(if (not (eq? (time-type time-in) time-utc))
- (priv:time-error caller 'incompatible-time-types time-in))
+ (time-error caller 'incompatible-time-types time-in))
(set-time-type! time-out time-tai)
(set-time-nanosecond! time-out (time-nanosecond time-in))
(set-time-second! time-out (+ (time-second time-in)
- (priv:leap-second-delta
+ (leap-second-delta
(time-second time-in))))
time-out)
@@ -485,7 +481,7 @@
;; -- these depend on time-monotonic having the same definition as time-tai!
(define (time-monotonic->time-utc time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error 'time-monotonic->time-utc
+ (time-error 'time-monotonic->time-utc
'incompatible-time-types time-in))
(let ((ntime (copy-time time-in)))
(set-time-type! ntime time-tai)
@@ -493,14 +489,14 @@
(define (time-monotonic->time-utc! time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error 'time-monotonic->time-utc!
+ (time-error 'time-monotonic->time-utc!
'incompatible-time-types time-in))
(set-time-type! time-in time-tai)
(priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
(define (time-monotonic->time-tai time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error 'time-monotonic->time-tai
+ (time-error 'time-monotonic->time-tai
'incompatible-time-types time-in))
(let ((ntime (copy-time time-in)))
(set-time-type! ntime time-tai)
@@ -508,14 +504,14 @@
(define (time-monotonic->time-tai! time-in)
(if (not (eq? (time-type time-in) time-monotonic))
- (priv:time-error 'time-monotonic->time-tai!
+ (time-error 'time-monotonic->time-tai!
'incompatible-time-types time-in))
(set-time-type! time-in time-tai)
time-in)
(define (time-utc->time-monotonic time-in)
(if (not (eq? (time-type time-in) time-utc))
- (priv:time-error 'time-utc->time-monotonic
+ (time-error 'time-utc->time-monotonic
'incompatible-time-types time-in))
(let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f
#f)
'time-utc->time-monotonic)))
@@ -524,7 +520,7 @@
(define (time-utc->time-monotonic! time-in)
(if (not (eq? (time-type time-in) time-utc))
- (priv:time-error 'time-utc->time-monotonic!
+ (time-error 'time-utc->time-monotonic!
'incompatible-time-types time-in))
(let ((ntime (priv:time-utc->time-tai! time-in time-in
'time-utc->time-monotonic!)))
@@ -533,7 +529,7 @@
(define (time-tai->time-monotonic time-in)
(if (not (eq? (time-type time-in) time-tai))
- (priv:time-error 'time-tai->time-monotonic
+ (time-error 'time-tai->time-monotonic
'incompatible-time-types time-in))
(let ((ntime (copy-time time-in)))
(set-time-type! ntime time-monotonic)
@@ -541,7 +537,7 @@
(define (time-tai->time-monotonic! time-in)
(if (not (eq? (time-type time-in) time-tai))
- (priv:time-error 'time-tai->time-monotonic!
+ (time-error 'time-tai->time-monotonic!
'incompatible-time-types time-in))
(set-time-type! time-in time-monotonic)
time-in)
@@ -567,7 +563,7 @@
(zone-offset date-zone-offset set-date-zone-offset!))
;; gives the julian day which starts at noon.
-(define (priv:encode-julian-day-number day month year)
+(define (encode-julian-day-number day month year)
(let* ((a (quotient (- 14 month) 12))
(y (- (+ year 4800) a (if (negative? year) -1 0)))
(m (- (+ month (* 12 a)) 3)))
@@ -580,7 +576,7 @@
-32045)))
;; gives the seconds/date/month/year
-(define (priv:decode-julian-day-number jdn)
+(define (decode-julian-day-number jdn)
(let* ((days (inexact->exact (truncate jdn)))
(a (+ days 32044))
(b (quotient (+ (* 4 a) 3) 146097))
@@ -590,7 +586,7 @@
(m (quotient (+ (* 5 e) 2) 153))
(y (+ (* 100 b) d -4800 (quotient m 10))))
(values ; seconds date month year
- (* (- jdn days) priv:sid)
+ (* (- jdn days) sid)
(+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
(+ m 3 (* -12 (quotient m 10)))
(if (>= 0 y) (- y 1) y))))
@@ -599,32 +595,32 @@
;; differently from MzScheme's....
;; This should be written to be OS specific.
-(define (priv:local-tz-offset utc-time)
+(define (local-tz-offset utc-time)
;; SRFI uses seconds West, but guile (and libc) use seconds East.
(- (tm:gmtoff (localtime (time-second utc-time)))))
;; special thing -- ignores nanos
-(define (priv:time->julian-day-number seconds tz-offset)
- (+ (/ (+ seconds tz-offset priv:sihd)
- priv:sid)
- priv:tai-epoch-in-jd))
+(define (time->julian-day-number seconds tz-offset)
+ (+ (/ (+ seconds tz-offset sihd)
+ sid)
+ tai-epoch-in-jd))
-(define (priv:leap-second? second)
- (and (assoc second priv:leap-second-table) #t))
+(define (leap-second? second)
+ (and (assoc second leap-second-table) #t))
(define (time-utc->date time . tz-offset)
(if (not (eq? (time-type time) time-utc))
- (priv:time-error 'time->date 'incompatible-time-types time))
+ (time-error 'time->date 'incompatible-time-types time))
(let* ((offset (if (null? tz-offset)
- (priv:local-tz-offset time)
+ (local-tz-offset time)
(car tz-offset)))
- (leap-second? (priv:leap-second? (+ offset (time-second time))))
- (jdn (priv:time->julian-day-number (if leap-second?
+ (leap-second? (leap-second? (+ offset (time-second time))))
+ (jdn (time->julian-day-number (if leap-second?
(- (time-second time) 1)
(time-second time))
offset)))
- (call-with-values (lambda () (priv:decode-julian-day-number jdn))
+ (call-with-values (lambda () (decode-julian-day-number jdn))
(lambda (secs date month year)
;; secs is a real because jdn is a real in Guile;
;; but it is conceptionally an integer.
@@ -644,18 +640,18 @@
(define (time-tai->date time . tz-offset)
(if (not (eq? (time-type time) time-tai))
- (priv:time-error 'time->date 'incompatible-time-types time))
+ (time-error 'time->date 'incompatible-time-types time))
(let* ((offset (if (null? tz-offset)
- (priv:local-tz-offset (time-tai->time-utc time))
+ (local-tz-offset (time-tai->time-utc time))
(car tz-offset)))
(seconds (- (time-second time)
- (priv:leap-second-delta (time-second time))))
- (leap-second? (priv:leap-second? (+ offset seconds)))
- (jdn (priv:time->julian-day-number (if leap-second?
+ (leap-second-delta (time-second time))))
+ (leap-second? (leap-second? (+ offset seconds)))
+ (jdn (time->julian-day-number (if leap-second?
(- seconds 1)
seconds)
offset)))
- (call-with-values (lambda () (priv:decode-julian-day-number jdn))
+ (call-with-values (lambda () (decode-julian-day-number jdn))
(lambda (secs date month year)
;; secs is a real because jdn is a real in Guile;
;; but it is conceptionally an integer.
@@ -677,18 +673,18 @@
;; this is the same as time-tai->date.
(define (time-monotonic->date time . tz-offset)
(if (not (eq? (time-type time) time-monotonic))
- (priv:time-error 'time->date 'incompatible-time-types time))
+ (time-error 'time->date 'incompatible-time-types time))
(let* ((offset (if (null? tz-offset)
- (priv:local-tz-offset (time-monotonic->time-utc time))
+ (local-tz-offset (time-monotonic->time-utc time))
(car tz-offset)))
(seconds (- (time-second time)
- (priv:leap-second-delta (time-second time))))
- (leap-second? (priv:leap-second? (+ offset seconds)))
- (jdn (priv:time->julian-day-number (if leap-second?
+ (leap-second-delta (time-second time))))
+ (leap-second? (leap-second? (+ offset seconds)))
+ (jdn (time->julian-day-number (if leap-second?
(- seconds 1)
seconds)
offset)))
- (call-with-values (lambda () (priv:decode-julian-day-number jdn))
+ (call-with-values (lambda () (decode-julian-day-number jdn))
(lambda (secs date month year)
;; secs is a real because jdn is a real in Guile;
;; but it is conceptionally an integer.
@@ -708,10 +704,10 @@
offset))))))
(define (date->time-utc date)
- (let* ((jdays (- (priv:encode-julian-day-number (date-day date)
+ (let* ((jdays (- (encode-julian-day-number (date-day date)
(date-month date)
(date-year date))
- priv:tai-epoch-in-jd))
+ tai-epoch-in-jd))
;; jdays is an integer plus 1/2,
(jdays-1/2 (inexact->exact (- jdays 1/2))))
(make-time
@@ -729,29 +725,29 @@
(define (date->time-monotonic date)
(time-utc->time-monotonic! (date->time-utc date)))
-(define (priv:leap-year? year)
+(define (leap-year? year)
(or (= (modulo year 400) 0)
(and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
;; Map 1-based month number M to number of days in the year before the
;; start of month M (in a non-leap year).
-(define priv:month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90)
+(define month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90)
(5 . 120) (6 . 151) (7 . 181) (8 . 212)
(9 . 243) (10 . 273) (11 . 304) (12 . 334)))
-(define (priv:year-day day month year)
- (let ((days-pr (assoc month priv:month-assoc)))
+(define (year-day day month year)
+ (let ((days-pr (assoc month month-assoc)))
(if (not days-pr)
- (priv:time-error 'date-year-day 'invalid-month-specification month))
- (if (and (priv:leap-year? year) (> month 2))
+ (time-error 'date-year-day 'invalid-month-specification month))
+ (if (and (leap-year? year) (> month 2))
(+ day (cdr days-pr) 1)
(+ day (cdr days-pr)))))
(define (date-year-day date)
- (priv:year-day (date-day date) (date-month date) (date-year date)))
+ (year-day (date-day date) (date-month date) (date-year date)))
;; from calendar faq
-(define (priv:week-day day month year)
+(define (week-day day month year)
(let* ((a (quotient (- 14 month) 12))
(y (- year a))
(m (+ month (* 12 a) -2)))
@@ -764,9 +760,9 @@
7)))
(define (date-week-day date)
- (priv:week-day (date-day date) (date-month date) (date-year date)))
+ (week-day (date-day date) (date-month date) (date-year date)))
-(define (priv:days-before-first-week date day-of-week-starting-week)
+(define (days-before-first-week date day-of-week-starting-week)
(let* ((first-day (make-date 0 0 0 0
1
1
@@ -783,7 +779,7 @@
(define (date-week-number date day-of-week-starting-week)
(quotient (- (date-year-day date)
1
- (priv:days-before-first-week date day-of-week-starting-week))
+ (days-before-first-week date day-of-week-starting-week))
7))
(define (current-date . tz-offset)
@@ -791,11 +787,11 @@
(time-utc->date
time
(if (null? tz-offset)
- (priv:local-tz-offset time)
+ (local-tz-offset time)
(car tz-offset)))))
;; given a 'two digit' number, find the year within 50 years +/-
-(define (priv:natural-year n)
+(define (natural-year n)
(let* ((current-year (date-year (current-date)))
(current-century (* (quotient current-year 100) 100)))
(cond
@@ -813,14 +809,14 @@
(month (date-month date))
(year (date-year date))
(offset (date-zone-offset date)))
- (+ (priv:encode-julian-day-number day month year)
+ (+ (encode-julian-day-number day month year)
(- 1/2)
(+ (/ (+ (- offset)
(* hour 60 60)
(* minute 60)
second
- (/ nanosecond priv:nano))
- priv:sid)))))
+ (/ nanosecond nano))
+ sid)))))
(define (date->modified-julian-day date)
(- (date->julian-day date)
@@ -828,10 +824,10 @@
(define (time-utc->julian-day time)
(if (not (eq? (time-type time) time-utc))
- (priv:time-error 'time->date 'incompatible-time-types time))
- (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano))
- priv:sid)
- priv:tai-epoch-in-jd))
+ (time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (time-second time) (/ (time-nanosecond time) nano))
+ sid)
+ tai-epoch-in-jd))
(define (time-utc->modified-julian-day time)
(- (time-utc->julian-day time)
@@ -839,12 +835,12 @@
(define (time-tai->julian-day time)
(if (not (eq? (time-type time) time-tai))
- (priv:time-error 'time->date 'incompatible-time-types time))
+ (time-error 'time->date 'incompatible-time-types time))
(+ (/ (+ (- (time-second time)
- (priv:leap-second-delta (time-second time)))
- (/ (time-nanosecond time) priv:nano))
- priv:sid)
- priv:tai-epoch-in-jd))
+ (leap-second-delta (time-second time)))
+ (/ (time-nanosecond time) nano))
+ sid)
+ tai-epoch-in-jd))
(define (time-tai->modified-julian-day time)
(- (time-tai->julian-day time)
@@ -853,23 +849,23 @@
;; this is the same as time-tai->julian-day
(define (time-monotonic->julian-day time)
(if (not (eq? (time-type time) time-monotonic))
- (priv:time-error 'time->date 'incompatible-time-types time))
+ (time-error 'time->date 'incompatible-time-types time))
(+ (/ (+ (- (time-second time)
- (priv:leap-second-delta (time-second time)))
- (/ (time-nanosecond time) priv:nano))
- priv:sid)
- priv:tai-epoch-in-jd))
+ (leap-second-delta (time-second time)))
+ (/ (time-nanosecond time) nano))
+ sid)
+ tai-epoch-in-jd))
(define (time-monotonic->modified-julian-day time)
(- (time-monotonic->julian-day time)
4800001/2))
(define (julian-day->time-utc jdn)
- (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd))))
+ (let ((secs (* sid (- jdn tai-epoch-in-jd))))
(receive (seconds parts)
- (priv:split-real secs)
+ (split-real secs)
(make-time time-utc
- (* parts priv:nano)
+ (* parts nano)
seconds))))
(define (julian-day->time-tai jdn)
@@ -881,7 +877,7 @@
(define (julian-day->date jdn . tz-offset)
(let* ((time (julian-day->time-utc jdn))
(offset (if (null? tz-offset)
- (priv:local-tz-offset time)
+ (local-tz-offset time)
(car tz-offset))))
(time-utc->date time offset)))
@@ -909,7 +905,7 @@
;; as if number->string was used. if string is longer than or equal
;; in length to LENGTH, it's as if number->string was used.
-(define (priv:padding n pad-with length)
+(define (padding n pad-with length)
(let* ((str (number->string n))
(str-len (string-length str)))
(if (or (>= str-len length)
@@ -917,15 +913,15 @@
str
(string-append (make-string (- length str-len) pad-with) str))))
-(define (priv:last-n-digits i n)
+(define (last-n-digits i n)
(abs (remainder i (expt 10 n))))
-(define (priv:locale-abbr-weekday n) (locale-day-short (+ 1 n)))
-(define (priv:locale-long-weekday n) (locale-day (+ 1 n)))
-(define priv:locale-abbr-month locale-month-short)
-(define priv:locale-long-month locale-month)
+(define (locale-abbr-weekday n) (locale-day-short (+ 1 n)))
+(define (locale-long-weekday n) (locale-day (+ 1 n)))
+(define locale-abbr-month locale-month-short)
+(define locale-long-month locale-month)
-(define (priv:date-reverse-lookup needle haystack-ref haystack-len
+(define (date-reverse-lookup needle haystack-ref haystack-len
same?)
;; Lookup NEEDLE (a string) using HAYSTACK-REF (a one argument procedure
;; that returns a string corresponding to the given index) by passing it
@@ -936,28 +932,28 @@
index)
(else (loop (+ index 1))))))
-(define (priv:locale-abbr-weekday->index string)
- (priv:date-reverse-lookup string locale-day-short 7 string=?))
+(define (locale-abbr-weekday->index string)
+ (date-reverse-lookup string locale-day-short 7 string=?))
-(define (priv:locale-long-weekday->index string)
- (priv:date-reverse-lookup string locale-day 7 string=?))
+(define (locale-long-weekday->index string)
+ (date-reverse-lookup string locale-day 7 string=?))
-(define (priv:locale-abbr-month->index string)
- (priv:date-reverse-lookup string priv:locale-abbr-month 12 string=?))
+(define (locale-abbr-month->index string)
+ (date-reverse-lookup string locale-abbr-month 12 string=?))
-(define (priv:locale-long-month->index string)
- (priv:date-reverse-lookup string priv:locale-long-month 12 string=?))
+(define (locale-long-month->index string)
+ (date-reverse-lookup string locale-long-month 12 string=?))
;; FIXME: mkoeppe: Put a symbolic time zone in the date structs.
;; Print it here instead of the numerical offset if available.
-(define (priv:locale-print-time-zone date port)
- (priv:tz-printer (date-zone-offset date) port))
+(define (locale-print-time-zone date port)
+ (tz-printer (date-zone-offset date) port))
-(define (priv:locale-am/pm hr)
- (if (> hr 11) (priv:locale-pm) (priv:locale-am)))
+(define (locale-am-string/pm hr)
+ (if (> hr 11) (locale-pm-string) (locale-am-string)))
-(define (priv:tz-printer offset port)
+(define (tz-printer offset port)
(cond
((= offset 0) (display "Z" port))
((negative? offset) (display "-" port))
@@ -965,116 +961,116 @@
(if (not (= offset 0))
(let ((hours (abs (quotient offset (* 60 60))))
(minutes (abs (quotient (remainder offset (* 60 60)) 60))))
- (display (priv:padding hours #\0 2) port)
- (display (priv:padding minutes #\0 2) port))))
+ (display (padding hours #\0 2) port)
+ (display (padding minutes #\0 2) port))))
;; A table of output formatting directives.
;; the first time is the format char.
;; the second is a procedure that takes the date, a padding character
;; (which might be #f), and the output port.
;;
-(define priv:directives
+(define directives
(list
(cons #\~ (lambda (date pad-with port)
(display #\~ port)))
(cons #\a (lambda (date pad-with port)
- (display (priv:locale-abbr-weekday (date-week-day date))
+ (display (locale-abbr-weekday (date-week-day date))
port)))
(cons #\A (lambda (date pad-with port)
- (display (priv:locale-long-weekday (date-week-day date))
+ (display (locale-long-weekday (date-week-day date))
port)))
(cons #\b (lambda (date pad-with port)
- (display (priv:locale-abbr-month (date-month date))
+ (display (locale-abbr-month (date-month date))
port)))
(cons #\B (lambda (date pad-with port)
- (display (priv:locale-long-month (date-month date))
+ (display (locale-long-month (date-month date))
port)))
(cons #\c (lambda (date pad-with port)
- (display (date->string date priv:locale-date-time-format)
port)))
+ (display (date->string date locale-date-time-format) port)))
(cons #\d (lambda (date pad-with port)
- (display (priv:padding (date-day date)
+ (display (padding (date-day date)
#\0 2)
port)))
(cons #\D (lambda (date pad-with port)
(display (date->string date "~m/~d/~y") port)))
(cons #\e (lambda (date pad-with port)
- (display (priv:padding (date-day date)
+ (display (padding (date-day date)
#\Space 2)
port)))
(cons #\f (lambda (date pad-with port)
(if (> (date-nanosecond date)
- priv:nano)
- (display (priv:padding (+ (date-second date) 1)
+ nano)
+ (display (padding (+ (date-second date) 1)
pad-with 2)
port)
- (display (priv:padding (date-second date)
+ (display (padding (date-second date)
pad-with 2)
port))
(receive (i f)
- (priv:split-real (/
+ (split-real (/
(date-nanosecond date)
- priv:nano 1.0))
+ nano 1.0))
(let* ((ns (number->string f))
(le (string-length ns)))
(if (> le 2)
(begin
- (display (priv:locale-number-separator) port)
+ (display (locale-decimal-point) port)
(display (substring ns 2 le) port)))))))
(cons #\h (lambda (date pad-with port)
(display (date->string date "~b") port)))
(cons #\H (lambda (date pad-with port)
- (display (priv:padding (date-hour date)
+ (display (padding (date-hour date)
pad-with 2)
port)))
(cons #\I (lambda (date pad-with port)
(let ((hr (date-hour date)))
(if (> hr 12)
- (display (priv:padding (- hr 12)
+ (display (padding (- hr 12)
pad-with 2)
port)
- (display (priv:padding hr
+ (display (padding hr
pad-with 2)
port)))))
(cons #\j (lambda (date pad-with port)
- (display (priv:padding (date-year-day date)
+ (display (padding (date-year-day date)
pad-with 3)
port)))
(cons #\k (lambda (date pad-with port)
- (display (priv:padding (date-hour date)
+ (display (padding (date-hour date)
#\Space 2)
port)))
(cons #\l (lambda (date pad-with port)
(let ((hr (if (> (date-hour date) 12)
(- (date-hour date) 12) (date-hour date))))
- (display (priv:padding hr #\Space 2)
+ (display (padding hr #\Space 2)
port))))
(cons #\m (lambda (date pad-with port)
- (display (priv:padding (date-month date)
+ (display (padding (date-month date)
pad-with 2)
port)))
(cons #\M (lambda (date pad-with port)
- (display (priv:padding (date-minute date)
+ (display (padding (date-minute date)
pad-with 2)
port)))
(cons #\n (lambda (date pad-with port)
(newline port)))
(cons #\N (lambda (date pad-with port)
- (display (priv:padding (date-nanosecond date)
+ (display (padding (date-nanosecond date)
pad-with 7)
port)))
(cons #\p (lambda (date pad-with port)
- (display (priv:locale-am/pm (date-hour date)) port)))
+ (display (locale-am-string/pm (date-hour date)) port)))
(cons #\r (lambda (date pad-with port)
(display (date->string date "~I:~M:~S ~p") port)))
(cons #\s (lambda (date pad-with port)
(display (time-second (date->time-utc date)) port)))
(cons #\S (lambda (date pad-with port)
(if (> (date-nanosecond date)
- priv:nano)
- (display (priv:padding (+ (date-second date) 1)
+ nano)
+ (display (padding (+ (date-second date) 1)
pad-with 2)
port)
- (display (priv:padding (date-second date)
+ (display (padding (date-second date)
pad-with 2)
port))))
(cons #\t (lambda (date pad-with port)
@@ -1082,28 +1078,28 @@
(cons #\T (lambda (date pad-with port)
(display (date->string date "~H:~M:~S") port)))
(cons #\U (lambda (date pad-with port)
- (if (> (priv:days-before-first-week date 0) 0)
- (display (priv:padding (+ (date-week-number date 0) 1)
+ (if (> (days-before-first-week date 0) 0)
+ (display (padding (+ (date-week-number date 0) 1)
#\0 2) port)
- (display (priv:padding (date-week-number date 0)
+ (display (padding (date-week-number date 0)
#\0 2) port))))
(cons #\V (lambda (date pad-with port)
- (display (priv:padding (date-week-number date 1)
+ (display (padding (date-week-number date 1)
#\0 2) port)))
(cons #\w (lambda (date pad-with port)
(display (date-week-day date) port)))
(cons #\x (lambda (date pad-with port)
- (display (date->string date priv:locale-short-date-format)
port)))
+ (display (date->string date locale-short-date-format) port)))
(cons #\X (lambda (date pad-with port)
- (display (date->string date priv:locale-time-format) port)))
+ (display (date->string date locale-time-format) port)))
(cons #\W (lambda (date pad-with port)
- (if (> (priv:days-before-first-week date 1) 0)
- (display (priv:padding (+ (date-week-number date 1) 1)
+ (if (> (days-before-first-week date 1) 0)
+ (display (padding (+ (date-week-number date 1) 1)
#\0 2) port)
- (display (priv:padding (date-week-number date 1)
+ (display (padding (date-week-number date 1)
#\0 2) port))))
(cons #\y (lambda (date pad-with port)
- (display (priv:padding (priv:last-n-digits
+ (display (padding (last-n-digits
(date-year date) 2)
pad-with
2)
@@ -1111,9 +1107,9 @@
(cons #\Y (lambda (date pad-with port)
(display (date-year date) port)))
(cons #\z (lambda (date pad-with port)
- (priv:tz-printer (date-zone-offset date) port)))
+ (tz-printer (date-zone-offset date) port)))
(cons #\Z (lambda (date pad-with port)
- (priv:locale-print-time-zone date port)))
+ (locale-print-time-zone date port)))
(cons #\1 (lambda (date pad-with port)
(display (date->string date "~Y-~m-~d") port)))
(cons #\2 (lambda (date pad-with port)
@@ -1126,37 +1122,37 @@
(display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
-(define (priv:get-formatter char)
- (let ((associated (assoc char priv:directives)))
+(define (get-formatter char)
+ (let ((associated (assoc char directives)))
(if associated (cdr associated) #f)))
-(define (priv:date-printer date index format-string str-len port)
+(define (date-printer date index format-string str-len port)
(if (< index str-len)
(let ((current-char (string-ref format-string index)))
(if (not (char=? current-char #\~))
(begin
(display current-char port)
- (priv:date-printer date (+ index 1) format-string str-len port))
+ (date-printer date (+ index 1) format-string str-len port))
(if (= (+ index 1) str-len) ; bad format string.
- (priv:time-error 'priv:date-printer 'bad-date-format-string
+ (time-error 'date-printer 'bad-date-format-string
format-string)
(let ((pad-char? (string-ref format-string (+ index 1))))
(cond
((char=? pad-char? #\-)
(if (= (+ index 2) str-len) ; bad format string.
- (priv:time-error 'priv:date-printer
+ (time-error 'date-printer
'bad-date-format-string
format-string)
- (let ((formatter (priv:get-formatter
+ (let ((formatter (get-formatter
(string-ref format-string
(+ index 2)))))
(if (not formatter)
- (priv:time-error 'priv:date-printer
+ (time-error 'date-printer
'bad-date-format-string
format-string)
(begin
(formatter date #f port)
- (priv:date-printer date
+ (date-printer date
(+ index 3)
format-string
str-len
@@ -1164,34 +1160,34 @@
((char=? pad-char? #\_)
(if (= (+ index 2) str-len) ; bad format string.
- (priv:time-error 'priv:date-printer
+ (time-error 'date-printer
'bad-date-format-string
format-string)
- (let ((formatter (priv:get-formatter
+ (let ((formatter (get-formatter
(string-ref format-string
(+ index 2)))))
(if (not formatter)
- (priv:time-error 'priv:date-printer
+ (time-error 'date-printer
'bad-date-format-string
format-string)
(begin
(formatter date #\Space port)
- (priv:date-printer date
+ (date-printer date
(+ index 3)
format-string
str-len
port))))))
(else
- (let ((formatter (priv:get-formatter
+ (let ((formatter (get-formatter
(string-ref format-string
(+ index 1)))))
(if (not formatter)
- (priv:time-error 'priv:date-printer
+ (time-error 'date-printer
'bad-date-format-string
format-string)
(begin
(formatter date #\0 port)
- (priv:date-printer date
+ (date-printer date
(+ index 2)
format-string
str-len
@@ -1201,10 +1197,10 @@
(define (date->string date . format-string)
(let ((str-port (open-output-string))
(fmt-str (if (null? format-string) "~c" (car format-string))))
- (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port)
+ (date-printer date 0 fmt-str (string-length fmt-str) str-port)
(get-output-string str-port)))
-(define (priv:char->int ch)
+(define (char->int ch)
(case ch
((#\0) 0)
((#\1) 1)
@@ -1216,58 +1212,58 @@
((#\7) 7)
((#\8) 8)
((#\9) 9)
- (else (priv:time-error 'priv:char->int 'bad-date-template-string
+ (else (time-error 'char->int 'bad-date-template-string
(list "Non-integer character" ch)))))
;; read an integer upto n characters long on port; upto -> #f is any length
-(define (priv:integer-reader upto port)
+(define (integer-reader upto port)
(let loop ((accum 0) (nchars 0))
(let ((ch (peek-char port)))
(if (or (eof-object? ch)
(not (char-numeric? ch))
(and upto (>= nchars upto)))
accum
- (loop (+ (* accum 10) (priv:char->int (read-char port)))
+ (loop (+ (* accum 10) (char->int (read-char port)))
(+ nchars 1))))))
-(define (priv:make-integer-reader upto)
+(define (make-integer-reader upto)
(lambda (port)
- (priv:integer-reader upto port)))
+ (integer-reader upto port)))
;; read *exactly* n characters and convert to integer; could be padded
-(define (priv:integer-reader-exact n port)
+(define (integer-reader-exact n port)
(let ((padding-ok #t))
(define (accum-int port accum nchars)
(let ((ch (peek-char port)))
(cond
((>= nchars n) accum)
((eof-object? ch)
- (priv:time-error 'string->date 'bad-date-template-string
+ (time-error 'string->date 'bad-date-template-string
"Premature ending to integer read."))
((char-numeric? ch)
(set! padding-ok #f)
(accum-int port
- (+ (* accum 10) (priv:char->int (read-char port)))
+ (+ (* accum 10) (char->int (read-char port)))
(+ nchars 1)))
(padding-ok
(read-char port) ; consume padding
(accum-int port accum (+ nchars 1)))
(else ; padding where it shouldn't be
- (priv:time-error 'string->date 'bad-date-template-string
+ (time-error 'string->date 'bad-date-template-string
"Non-numeric characters in integer read.")))))
(accum-int port 0 0)))
-(define (priv:make-integer-exact-reader n)
+(define (make-integer-exact-reader n)
(lambda (port)
- (priv:integer-reader-exact n port)))
+ (integer-reader-exact n port)))
-(define (priv:zone-reader port)
+(define (zone-reader port)
(let ((offset 0)
(positive? #f))
(let ((ch (read-char port)))
(if (eof-object? ch)
- (priv:time-error 'string->date 'bad-date-template-string
+ (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone +/-" ch)))
(if (or (char=? ch #\Z) (char=? ch #\z))
0
@@ -1276,36 +1272,36 @@
((char=? ch #\+) (set! positive? #t))
((char=? ch #\-) (set! positive? #f))
(else
- (priv:time-error 'string->date 'bad-date-template-string
+ (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone +/-" ch))))
(let ((ch (read-char port)))
(if (eof-object? ch)
- (priv:time-error 'string->date 'bad-date-template-string
+ (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone number" ch)))
- (set! offset (* (priv:char->int ch)
+ (set! offset (* (char->int ch)
10 60 60)))
(let ((ch (read-char port)))
(if (eof-object? ch)
- (priv:time-error 'string->date 'bad-date-template-string
+ (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone number" ch)))
- (set! offset (+ offset (* (priv:char->int ch)
+ (set! offset (+ offset (* (char->int ch)
60 60))))
(let ((ch (read-char port)))
(if (eof-object? ch)
- (priv:time-error 'string->date 'bad-date-template-string
+ (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone number" ch)))
- (set! offset (+ offset (* (priv:char->int ch)
+ (set! offset (+ offset (* (char->int ch)
10 60))))
(let ((ch (read-char port)))
(if (eof-object? ch)
- (priv:time-error 'string->date 'bad-date-template-string
+ (time-error 'string->date 'bad-date-template-string
(list "Invalid time zone number" ch)))
- (set! offset (+ offset (* (priv:char->int ch)
+ (set! offset (+ offset (* (char->int ch)
60))))
(if positive? offset (- offset)))))))
;; looking at a char, read the char string, run thru indexer, return index
-(define (priv:locale-reader port indexer)
+(define (locale-reader port indexer)
(define (read-char-string result)
(let ((ch (peek-char port)))
@@ -1315,19 +1311,19 @@
(let* ((str (read-char-string '()))
(index (indexer str)))
- (if index index (priv:time-error 'string->date
+ (if index index (time-error 'string->date
'bad-date-template-string
(list "Invalid string for " indexer)))))
-(define (priv:make-locale-reader indexer)
+(define (make-locale-reader indexer)
(lambda (port)
- (priv:locale-reader port indexer)))
+ (locale-reader port indexer)))
-(define (priv:make-char-id-reader char)
+(define (make-char-id-reader char)
(lambda (port)
(if (char=? char (read-char port))
char
- (priv:time-error 'string->date
+ (time-error 'string->date
'bad-date-template-string
"Invalid character match."))))
@@ -1343,22 +1339,22 @@
;; some object (here, always the date) and (probably) side-effects it.
;; If no action is required, as with ~A, this element may be #f.
-(define priv:read-directives
- (let ((ireader4 (priv:make-integer-reader 4))
- (ireader2 (priv:make-integer-reader 2))
- (eireader2 (priv:make-integer-exact-reader 2))
- (locale-reader-abbr-weekday (priv:make-locale-reader
- priv:locale-abbr-weekday->index))
- (locale-reader-long-weekday (priv:make-locale-reader
- priv:locale-long-weekday->index))
- (locale-reader-abbr-month (priv:make-locale-reader
- priv:locale-abbr-month->index))
- (locale-reader-long-month (priv:make-locale-reader
- priv:locale-long-month->index))
+(define read-directives
+ (let ((ireader4 (make-integer-reader 4))
+ (ireader2 (make-integer-reader 2))
+ (eireader2 (make-integer-exact-reader 2))
+ (locale-reader-abbr-weekday (make-locale-reader
+ locale-abbr-weekday->index))
+ (locale-reader-long-weekday (make-locale-reader
+ locale-long-weekday->index))
+ (locale-reader-abbr-month (make-locale-reader
+ locale-abbr-month->index))
+ (locale-reader-long-month (make-locale-reader
+ locale-long-month->index))
(char-fail (lambda (ch) #t)))
(list
- (list #\~ char-fail (priv:make-char-id-reader #\~) #f)
+ (list #\~ char-fail (make-char-id-reader #\~) #f)
(list #\a char-alphabetic? locale-reader-abbr-weekday #f)
(list #\A char-alphabetic? locale-reader-long-weekday #f)
(list #\b char-alphabetic? locale-reader-abbr-month
@@ -1388,7 +1384,7 @@
(set-date-second! object val)))
(list #\y char-fail eireader2
(lambda (val object)
- (set-date-year! object (priv:natural-year val))))
+ (set-date-year! object (natural-year val))))
(list #\Y char-numeric? ireader4 (lambda (val object)
(set-date-year! object val)))
(list #\z (lambda (c)
@@ -1396,14 +1392,14 @@
(char=? c #\z)
(char=? c #\+)
(char=? c #\-)))
- priv:zone-reader (lambda (val object)
+ zone-reader (lambda (val object)
(set-date-zone-offset! object val))))))
(define (priv:string->date date index format-string str-len port
template-string)
(define (skip-until port skipper)
(let ((ch (peek-char port)))
(if (eof-object? ch)
- (priv:time-error 'string->date 'bad-date-format-string
template-string)
+ (time-error 'string->date 'bad-date-format-string template-string)
(if (not (skipper ch))
(begin (read-char port) (skip-until port skipper))))))
(if (< index str-len)
@@ -1412,7 +1408,7 @@
(let ((port-char (read-char port)))
(if (or (eof-object? port-char)
(not (char=? current-char port-char)))
- (priv:time-error 'string->date
+ (time-error 'string->date
'bad-date-format-string template-string))
(priv:string->date date
(+ index 1)
@@ -1422,12 +1418,12 @@
template-string))
;; otherwise, it's an escape, we hope
(if (> (+ index 1) str-len)
- (priv:time-error 'string->date
+ (time-error 'string->date
'bad-date-format-string template-string)
(let* ((format-char (string-ref format-string (+ index 1)))
- (format-info (assoc format-char priv:read-directives)))
+ (format-info (assoc format-char read-directives)))
(if (not format-info)
- (priv:time-error 'string->date
+ (time-error 'string->date
'bad-date-format-string template-string)
(begin
(let ((skipper (cadr format-info))
@@ -1436,7 +1432,7 @@
(skip-until port skipper)
(let ((val (reader port)))
(if (eof-object? val)
- (priv:time-error 'string->date
+ (time-error 'string->date
'bad-date-format-string
template-string)
(if actor (actor val date))))
@@ -1448,7 +1444,7 @@
template-string))))))))))
(define (string->date input-string template-string)
- (define (priv:date-ok? date)
+ (define (date-ok? date)
(and (date-nanosecond date)
(date-second date)
(date-minute date)
@@ -1470,14 +1466,14 @@
;; get it right (think of the double/missing hour in the
;; night when we are switching between normal time and DST).
(set-date-zone-offset! newdate
- (priv:local-tz-offset
+ (local-tz-offset
(make-time time-utc 0 0)))
(set-date-zone-offset! newdate
- (priv:local-tz-offset
+ (local-tz-offset
(date->time-utc newdate)))))
- (if (priv:date-ok? newdate)
+ (if (date-ok? newdate)
newdate
- (priv:time-error
+ (time-error
'string->date
'bad-date-format-string
(list "Incomplete date read. " newdate template-string)))))
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 6574a8d..cb8dd0a 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -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)))
diff --git a/module/texinfo.scm b/module/texinfo.scm
index 0b8285e..970895f 100644
--- a/module/texinfo.scm
+++ b/module/texinfo.scm
@@ -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))
diff --git a/module/texinfo/reflection.scm b/module/texinfo/reflection.scm
index a69436f..d85f612 100644
--- a/module/texinfo/reflection.scm
+++ b/module/texinfo/reflection.scm
@@ -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))
diff --git a/module/web/http.scm b/module/web/http.scm
index 8298505..21874ee 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -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))
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index eaad8c9..d40f8e1 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -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
diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test
index 273227b..49d1086 100644
--- a/test-suite/tests/texinfo.test
+++ b/test-suite/tests/texinfo.test
@@ -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{} }"
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 3dacb72..0f445fd 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -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)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0,
Andy Wingo <=