diff options
33 files changed, 947 insertions, 578 deletions
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 19c066530..afcde579d 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, -@code{b} 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 +@ref{R6RS 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 +@code{set-port-encoding!}. In theory we could create read/write ports which were buffered in one direction only. However this isn't included in the diff --git a/libguile/arrays.c b/libguile/arrays.c index 6724d0071..d99081caf 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 99ac1761d..8fc025285 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 4b775f244..f22a3dd86 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 9121d1791..661de8f4f 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 3ae978fc0..c68f295b1 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 6141e4fd2..c4f2b5eb0 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 f9ec723a0..c0deb98d4 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 de6bf7c60..21008cbef 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 24ae2bc31..235bbbb83 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 a4657befb..f026783df 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 2923dc6f8..ea406aee1 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 bf146ef15..7ee56af71 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 c95db5c25..0b7144c58 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 83dcdd5b9..5e0685a56 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 37441f788..ed6d3d9d1 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 13ab067bd..47607bc55 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 86188f416..d0e82f7bd 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 b43ccaba2..dd859c4d3 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 8d1c37570..940dd6031 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 3bf492280..b233a00a3 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 d919f9ae7..1264f3209 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 4cfd1d1cc..499a22444 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 107d39485..4e0f47c32 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 c60f6257f..765bd50e9 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 dcc253334..d8f764335 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 6574a8da7..cb8dd0a19 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 0b8285e0f..970895ff6 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 a69436f89..d85f61239 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 8298505d0..21874ee16 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 eaad8c961..d40f8e1c2 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 273227b5f..49d108698 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 3dacb7277..0f445fdd2 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) |