[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-178-g7
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-178-g7cd6d77 |
|
Date: |
Fri, 08 Oct 2010 14:26:47 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=7cd6d77c640115d64768ac2e6d81b82e272a706f
The branch, master has been updated
via 7cd6d77c640115d64768ac2e6d81b82e272a706f (commit)
via 75365375dd72b9c5c213955ad866756727e72e19 (commit)
via 7390e4bd11418371bc4a744e2eee1ca40b9c9531 (commit)
via 7f593bc7f9ab9ebf4e64ce7e28f85bdcbbe8906f (commit)
via 58ee1beabec22eaad41eecf6fdd4c0032b6608e3 (commit)
via a6505cb49c0971671bcdc87eb6abbc3204d94d97 (commit)
via 07076c1e61ab05b62979ee01a5220edb308b0750 (commit)
via c00623281b8272388b673996d94f6e4b9146f909 (commit)
via 8a954f3df579eae483d1df718e7ec3e745962aa1 (commit)
from aee24bac50ae0851264b3382d2bce0c23fd9eff7 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 7cd6d77c640115d64768ac2e6d81b82e272a706f
Author: Ludovic Courtès <address@hidden>
Date: Fri Oct 8 15:24:15 2010 +0200
Improve pretty-printing of tree-il objects.
* module/language/tree-il.scm (print-tree-il): Print the AST with ~S
instead of ~A.
commit 75365375dd72b9c5c213955ad866756727e72e19
Author: Ludovic Courtès <address@hidden>
Date: Fri Oct 8 16:25:32 2010 +0200
Add `-Wformat'.
* module/language/tree-il/analyze.scm (format-string-argument-count):
New procedure.
(format-analysis): New tree analysis.
* module/language/tree-il/compile-glil.scm (%warning-passes): Add
`format'.
* module/system/base/message.scm (%warning-types): Add `format'.
* test-suite/tests/tree-il.test (%opts-w-format): New variable.
("warnings")["format"]: New test prefix.
* doc/ref/api-evaluation.texi (Compilation): Mention `format' warnings.
commit 7390e4bd11418371bc4a744e2eee1ca40b9c9531
Author: Ludovic Courtès <address@hidden>
Date: Fri Oct 8 13:50:24 2010 +0200
Fixlets for REPL error handling.
* module/system/repl/error-handling.scm (error-string): Don't call
`display-error' when STACK is empty.
(call-with-error-handling): Display ERROR-MSG instead of using
`format', since ERROR-MSG may contain `format' escapes.
* module/system/repl/repl.scm (run-repl): Add missing argument to
`format'.
commit 7f593bc7f9ab9ebf4e64ce7e28f85bdcbbe8906f
Author: Ludovic Courtès <address@hidden>
Date: Fri Oct 8 13:48:02 2010 +0200
SRFI-1: Rewrite `split-at' and `split-at!' in Scheme.
This partially reverts commit bb560b9c16893f762699ba5a3109c8367fff8dfc
(Tue Mar 15 2005).
* module/srfi/srfi-1.scm (out-of-range, split-at, split-at!): New
procedures.
* libguile/srfi-1.c (scm_srfi1_split_at, scm_srfi1_split_at_x): Remove.
* libguile/srfi-1.h (scm_srfi1_split_at, scm_srfi1_split_at_x): Ditto.
commit 58ee1beabec22eaad41eecf6fdd4c0032b6608e3
Author: Ludovic Courtès <address@hidden>
Date: Fri Oct 8 11:03:51 2010 +0200
SRFI-1: Rewrite `filter-map' in Scheme.
This partially reverts commit c16359466bcc3f2ebf6d750c069f787f629fc625
(Thu Mar 17 2005).
* libguile/srfi-1.c (scm_srfi1_filter_map): Remove.
* libguile/srfi-1.h (scm_srfi1_filter_map): Ditto.
* module/srfi/srfi-1.scm (filter-map): New procedure.
commit a6505cb49c0971671bcdc87eb6abbc3204d94d97
Author: Ludovic Courtès <address@hidden>
Date: Fri Oct 8 10:43:59 2010 +0200
SRFI-1: Make `fold-right' tail-recursive.
* module/srfi/srfi-1.scm (fold-right): Make tail-recursive.
* test-suite/tests/srfi-1.test ("fold-right"): New test prefix.
commit 07076c1e61ab05b62979ee01a5220edb308b0750
Author: Ludovic Courtès <address@hidden>
Date: Fri Oct 8 10:23:52 2010 +0200
SRFI-1: Make `unfold' tail-recursive (fix bug #30071).
* module/srfi/srfi-1.scm (unfold): Make tail-recursive, following a
suggestion by Szavai Gyula.
* test-suite/tests/srfi-1.test ("unfold"): New test prefix.
commit c00623281b8272388b673996d94f6e4b9146f909
Author: Ludovic Courtès <address@hidden>
Date: Fri Oct 8 09:49:12 2010 +0200
Register `scm_init_r6rs_ports' as an extension.
* libguile/r6rs-ports.c (scm_register_r6rs_ports): New function.
* libguile/r6rs-ports.h (scm_register_r6rs_ports): New declaration.
* libguile/init.c (scm_i_init_guile): Call it.
commit 8a954f3df579eae483d1df718e7ec3e745962aa1
Author: Ludovic Courtès <address@hidden>
Date: Fri Oct 8 09:46:39 2010 +0200
Always run at least the ASCII regexp tests.
* test-suite/tests/regexp.test (with-ascii-or-latin1-locale): New macro.
("regexp-quote"): Use it instead of `with-latin1-locale'.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-evaluation.texi | 8 +-
libguile/init.c | 1 +
libguile/r6rs-ports.c | 9 ++
libguile/r6rs-ports.h | 3 +-
libguile/srfi-1.c | 160 ------------------------------
libguile/srfi-1.h | 3 -
module/language/tree-il.scm | 2 +-
module/language/tree-il/analyze.scm | 75 ++++++++++++++-
module/language/tree-il/compile-glil.scm | 3 +-
module/srfi/srfi-1.scm | 87 ++++++++++++++---
module/system/base/message.scm | 9 ++-
module/system/repl/error-handling.scm | 3 +-
module/system/repl/repl.scm | 2 +-
test-suite/tests/regexp.test | 11 ++-
test-suite/tests/srfi-1.test | 50 +++++++++
test-suite/tests/tree-il.test | 97 ++++++++++++++++++-
16 files changed, 334 insertions(+), 189 deletions(-)
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 4087598..022bc48 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -570,10 +570,10 @@ in @code{.go}.
@item -W @var{warning}
@itemx address@hidden
-Emit warnings of type @var{warning}; use @code{--warn=help} for a list of
-available warnings. Currently recognized warnings include
address@hidden, @code{unused-toplevel}, @code{unbound-variable}, and
address@hidden
+Emit warnings of type @var{warning}; use @code{--warn=help} for a list
+of available warnings and their description. Currently recognized
+warnings include @code{unused-variable}, @code{unused-toplevel},
address@hidden, @code{arity-mismatch}, and @code{format}.
@item -f @var{lang}
@itemx address@hidden
diff --git a/libguile/init.c b/libguile/init.c
index f64258f..bb916dc 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -455,6 +455,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_bootstrap_objcodes ();
scm_bootstrap_programs ();
scm_bootstrap_vm ();
+ scm_register_r6rs_ports ();
scm_register_foreign ();
scm_register_srfi_1 ();
scm_register_srfi_60 ();
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 9576db8..968b329 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1065,6 +1065,15 @@ initialize_custom_binary_output_ports (void)
/* Initialization. */
void
+scm_register_r6rs_ports (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_r6rs_ports",
+ (scm_t_extension_init_func) scm_init_r6rs_ports,
+ NULL);
+}
+
+void
scm_init_r6rs_ports (void)
{
#include "libguile/r6rs-ports.x"
diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h
index 5e1707a..edde005 100644
--- a/libguile/r6rs-ports.h
+++ b/libguile/r6rs-ports.h
@@ -1,7 +1,7 @@
#ifndef SCM_R6RS_PORTS_H
#define SCM_R6RS_PORTS_H
-/* Copyright (C) 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -40,5 +40,6 @@ SCM_API SCM scm_open_bytevector_output_port (SCM);
SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM);
SCM_API void scm_init_r6rs_ports (void);
+SCM_INTERNAL void scm_register_r6rs_ports (void);
#endif /* SCM_R6RS_PORTS_H */
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c
index 2fb677a..e2a9c93 100644
--- a/libguile/srfi-1.c
+++ b/libguile/srfi-1.c
@@ -616,115 +616,6 @@ SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_srfi1_filter_map, "filter-map", 2, 0, 1,
- (SCM proc, SCM list1, SCM rest),
- "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
- "return a list of the results as per SRFI-1 @code{map}, except\n"
- "that any @code{#f} results are omitted from the list returned.")
-#define FUNC_NAME s_scm_srfi1_filter_map
-{
- SCM ret, *loc, elem, newcell, lst;
- int argnum;
-
- SCM_VALIDATE_REST_ARGUMENT (rest);
-
- ret = SCM_EOL;
- loc = &ret;
-
- if (scm_is_null (rest))
- {
- /* one list */
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
- for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
- {
- elem = scm_call_1 (proc, SCM_CAR (list1));
- if (scm_is_true (elem))
- {
- newcell = scm_cons (elem, SCM_EOL);
- *loc = newcell;
- loc = SCM_CDRLOC (newcell);
- }
- }
-
- /* check below that list1 is a proper list, and done */
- end_list1:
- lst = list1;
- argnum = 2;
- }
- else if (scm_is_null (SCM_CDR (rest)))
- {
- /* two lists */
- SCM list2 = SCM_CAR (rest);
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
-
- for (;;)
- {
- if (! scm_is_pair (list1))
- goto end_list1;
- if (! scm_is_pair (list2))
- {
- lst = list2;
- argnum = 3;
- goto check_lst_and_done;
- }
- elem = scm_call_2 (proc, SCM_CAR (list1), SCM_CAR (list2));
- if (scm_is_true (elem))
- {
- newcell = scm_cons (elem, SCM_EOL);
- *loc = newcell;
- loc = SCM_CDRLOC (newcell);
- }
- list1 = SCM_CDR (list1);
- list2 = SCM_CDR (list2);
- }
- }
- else
- {
- /* three or more lists */
- SCM vec, args, a;
- size_t len, i;
-
- /* vec is the list arguments */
- vec = scm_vector (scm_cons (list1, rest));
- len = SCM_SIMPLE_VECTOR_LENGTH (vec);
-
- /* args is the argument list to pass to proc, same length as vec,
- re-used for each call */
- args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
-
- for (;;)
- {
- /* first elem of each list in vec into args, and step those
- vec entries onto their next element */
- for (i = 0, a = args, argnum = 2;
- i < len;
- i++, a = SCM_CDR (a), argnum++)
- {
- lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
- if (! scm_is_pair (lst))
- goto check_lst_and_done;
- SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */
- SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
- }
-
- elem = scm_apply (proc, args, SCM_EOL);
- if (scm_is_true (elem))
- {
- newcell = scm_cons (elem, SCM_EOL);
- *loc = newcell;
- loc = SCM_CDRLOC (newcell);
- }
- }
- }
-
- check_lst_and_done:
- SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, 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"
@@ -1292,57 +1183,6 @@ SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_srfi1_split_at, "split-at", 2, 0, 0,
- (SCM lst, SCM n),
- "Return two values (multiple values), being a list of the\n"
- "elements before index @var{n} in @var{lst}, and a list of those\n"
- "after.")
-#define FUNC_NAME s_scm_srfi1_split_at
-{
- size_t nn;
- /* pre is a list of elements before the i split point, loc is the CDRLOC
- of the last cell, ie. where to store to append to it */
- SCM pre = SCM_EOL;
- SCM *loc = ⪯
-
- for (nn = scm_to_size_t (n); nn != 0; nn--)
- {
- SCM_VALIDATE_CONS (SCM_ARG1, lst);
-
- *loc = scm_cons (SCM_CAR (lst), SCM_EOL);
- loc = SCM_CDRLOC (*loc);
- lst = SCM_CDR(lst);
- }
- return scm_values (scm_list_2 (pre, lst));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_srfi1_split_at_x, "split-at!", 2, 0, 0,
- (SCM lst, SCM n),
- "Return two values (multiple values), being a list of the\n"
- "elements before index @var{n} in @var{lst}, and a list of those\n"
- "after. @var{lst} is modified to form those values.")
-#define FUNC_NAME s_scm_srfi1_split_at
-{
- size_t nn;
- SCM upto = lst;
- SCM *loc = &lst;
-
- for (nn = scm_to_size_t (n); nn != 0; nn--)
- {
- SCM_VALIDATE_CONS (SCM_ARG1, upto);
-
- loc = SCM_CDRLOC (upto);
- upto = SCM_CDR (upto);
- }
-
- *loc = SCM_EOL;
- return scm_values (scm_list_2 (lst, upto));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
(SCM lst, SCM n),
"Return the a list containing the @var{n} last elements of\n"
diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h
index ddc8d0a..593d9bb 100644
--- a/libguile/srfi-1.h
+++ b/libguile/srfi-1.h
@@ -34,7 +34,6 @@ 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_filter_map (SCM proc, SCM list1, SCM rest);
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);
@@ -48,8 +47,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_split_at (SCM lst, SCM n);
-SCM_INTERNAL SCM scm_srfi1_split_at_x (SCM lst, SCM n);
SCM_INTERNAL SCM scm_srfi1_take_right (SCM lst, SCM n);
SCM_INTERNAL void scm_register_srfi_1 (void);
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 27fc3ba..5fd4c12 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -62,7 +62,7 @@
pre-order!))
(define (print-tree-il exp port)
- (format port "#<tree-il ~a>" (unparse-tree-il exp)))
+ (format port "#<tree-il ~S>" (unparse-tree-il exp)))
(define-syntax borrow-core-vtables
(lambda (x)
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index f5ddd32..0595793 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -33,7 +33,8 @@
unused-variable-analysis
unused-toplevel-analysis
unbound-variable-analysis
- arity-analysis))
+ arity-analysis
+ format-analysis))
;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage
@@ -1194,3 +1195,75 @@ accurate information is missing from a given `tree-il'
element."
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
+
+
+;;;
+;;; `format' argument analysis.
+;;;
+
+(define (format-string-argument-count fmt)
+ ;; Return the number of arguments that should follow format string
+ ;; FMT, or at least a good estimate thereof.
+
+ ;; FIXME: Implement ~[ conditionals. Check
+ ;; `language/assembly/disassemble.scm' for an example.
+ (let loop ((chars (string->list fmt))
+ (tilde? #f)
+ (count 0))
+ (if (null? chars)
+ count
+ (if tilde?
+ (case (car chars)
+ ((#\~ #\%) (loop (cdr chars) #f count))
+ (else (loop (cdr chars) #f (+ 1 count))))
+ (case (car chars)
+ ((#\~) (loop (cdr chars) #t count))
+ (else (loop (cdr chars) #f count)))))))
+
+(define format-analysis
+ ;; Report arity mismatches in the given tree.
+ (make-tree-analysis
+ (lambda (x _ env locs)
+ ;; X is a leaf.
+ #t)
+
+ (lambda (x _ env locs)
+ ;; Down into X.
+ (define (check-format-args args loc)
+ (pmatch args
+ ((,port ,fmt . ,rest)
+ (guard (and (const? fmt) (string? (const-exp fmt))))
+ (let* ((fmt (const-exp fmt))
+ (expected (format-string-argument-count fmt))
+ (actual (length rest)))
+ (or (= expected actual)
+ (warning 'format loc fmt expected actual))))
+ (else #t)))
+
+ (define (resolve-toplevel name)
+ (and (module? env)
+ (false-if-exception (module-ref env name))))
+
+ (record-case x
+ ((<application> proc args src)
+ (let ((loc src))
+ (record-case proc
+ ((<toplevel-ref> name src)
+ (let ((proc (resolve-toplevel name)))
+ (and (or (eq? proc format)
+ (eq? proc (@ (ice-9 format) format)))
+ (check-format-args args (or src (find pair? locs))))))
+ (else #t)))
+ #t)
+ (else #t))
+ #t)
+
+ (lambda (x _ env locs)
+ ;; Up from X.
+ #t)
+
+ (lambda (_ env)
+ ;; Post-processing.
+ #t)
+
+ #t))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 831eab0..b588802 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -47,7 +47,8 @@
`((unused-variable . ,unused-variable-analysis)
(unused-toplevel . ,unused-toplevel-analysis)
(unbound-variable . ,unbound-variable-analysis)
- (arity-mismatch . ,arity-analysis)))
+ (arity-mismatch . ,arity-analysis)
+ (format . ,format-analysis)))
(define (compile-glil x e opts)
(define warnings
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index d7ef6bb..8ddf271 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -238,6 +238,10 @@ higher-order procedures."
(scm-error 'wrong-type-arg caller
"Wrong type argument: ~S" (list arg) '())))
+(define (out-of-range proc arg)
+ (scm-error 'out-of-range proc
+ "Value out of range: ~A" (list arg) (list arg)))
+
;; the srfi spec doesn't seem to forbid inexact integers.
(define (non-negative-integer? x) (and (integer? x) (>= x 0)))
@@ -375,6 +379,30 @@ end-of-list checking in contexts where dotted lists are
allowed."
(loop (cdr prev)
(cdr tail)))))))
+(define (split-at lst i)
+ "Return two values, a list of the elements before index I in LST, and
+a list of those after."
+ (if (< i 0)
+ (out-of-range 'split-at i)
+ (let lp ((l lst) (n i) (acc '()))
+ (if (<= n 0)
+ (values (reverse! acc) l)
+ (lp (cdr l) (- n 1) (cons (car l) acc))))))
+
+(define (split-at! lst i)
+ "Linear-update variant of `split-at'."
+ (cond ((< i 0)
+ (out-of-range 'split-at! i))
+ ((= i 0)
+ (values '() lst))
+ (else
+ (let lp ((l lst) (n (- i 1)))
+ (if (<= n 0)
+ (let ((tmp (cdr l)))
+ (set-cdr! l '())
+ (values lst tmp))
+ (lp (cdr l) (- n 1)))))))
+
(define (last pair)
"Return the last element of the non-empty, finite list PAIR."
(car (last-pair pair)))
@@ -419,14 +447,18 @@ that result. See the manual for details."
(define (fold-right kons knil clist1 . rest)
(if (null? rest)
- (let f ((list1 clist1))
- (if (null? list1)
- knil
- (kons (car list1) (f (cdr list1)))))
- (let f ((lists (cons clist1 rest)))
- (if (any null? lists)
- knil
- (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
+ (let loop ((lst (reverse clist1))
+ (result knil))
+ (if (null? lst)
+ result
+ (loop (cdr lst)
+ (kons (car lst) result))))
+ (let loop ((lists (map1 reverse (cons clist1 rest)))
+ (result knil))
+ (if (any1 null? lists)
+ result
+ (loop (map1 cdr lists)
+ (apply kons (append! (map1 car lists) (list result))))))))
(define (pair-fold kons knil clist1 . rest)
(if (null? rest)
@@ -454,11 +486,20 @@ that result. See the manual for details."
(apply kons (append! lists (list (f (map1 cdr lists)))))))))
(define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
- (let uf ((seed seed))
+ (define (reverse+tail lst seed)
+ (let loop ((lst lst)
+ (result (tail-gen seed)))
+ (if (null? lst)
+ result
+ (loop (cdr lst)
+ (cons (car lst) result)))))
+
+ (let loop ((seed seed)
+ (result '()))
(if (p seed)
- (tail-gen seed)
- (cons (f seed)
- (uf (g seed))))))
+ (reverse+tail result seed)
+ (loop (g seed)
+ (cons (f seed) result)))))
(define* (unfold-right p f g seed #:optional (tail '()))
(let uf ((seed seed) (lis tail))
@@ -498,6 +539,28 @@ has just one element then that's the return value."
;; OPTIMIZE-ME: Re-use cons cells of list1
(define map! map)
+(define (filter-map proc list1 . rest)
+ "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."
+ (if (null? rest)
+ (let lp ((l list1)
+ (rl '()))
+ (if (null? l)
+ (reverse! rl)
+ (let ((res (proc (car l))))
+ (if res
+ (lp (cdr l) (cons res rl))
+ (lp (cdr l) rl)))))
+ (let lp ((l (cons list1 rest))
+ (rl '()))
+ (if (any1 null? l)
+ (reverse! rl)
+ (let ((res (apply proc (map1 car l))))
+ (if res
+ (lp (map1 cdr l) (cons res rl))
+ (lp (map1 cdr l) rl)))))))
+
(define (pair-for-each f clist1 . rest)
(if (null? rest)
(let lp ((l clist1))
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 98bf5cf..0486adc 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -102,7 +102,14 @@
loc name)
(format port
"~A: warning: possibly wrong number of arguments to
`~A'~%"
- loc name)))))))
+ loc name))))
+
+ (format
+ "report wrong number of arguments to `format'"
+ ,(lambda (port loc fmt expected actual)
+ (format port
+ "~A: warning: ~S: wrong number of `format' arguments:
expected ~A, got ~A~%"
+ loc fmt expected actual))))))
(define (lookup-warning-type name)
"Return the warning type NAME or `#f' if not found."
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index 34a158f..609d9c3 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -38,6 +38,7 @@
(lambda ()
(pmatch args
((,subr ,msg ,args . ,rest)
+ (guard (> (vector-length stack) 0))
(display-error (vector-ref stack 0) (current-output-port)
subr msg args rest))
(else
@@ -147,7 +148,7 @@
(debug (make-debug stack 0 error-msg)))
(with-saved-ports
(lambda ()
- (format #t error-msg)
+ (display error-msg)
(format #t "Entering a new prompt. ")
(format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
((@ (system repl repl) start-repl) #:debug debug))))))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 8275f8f..9691dfb 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -129,7 +129,7 @@
(if (eq? k 'quit)
(abort args)
(begin
- (format #t "While executing meta-command:~%" string)
+ (format #t "While executing meta-command `~A'~%" string)
(pmatch args
((,subr ,msg ,args . ,rest)
(display-error #f (current-output-port) subr msg
args rest))
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index a6844ca..efa0e7e 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -138,6 +138,13 @@
;;; regexp-quote
;;;
+(define-syntax with-ascii-or-latin1-locale
+ (syntax-rules ()
+ ((_ chr body ...)
+ (if (> chr 127)
+ (with-latin1-locale body ...)
+ (begin body ...)))))
+
(with-test-prefix "regexp-quote"
(pass-if-exception "no args" exception:wrong-num-args
@@ -165,7 +172,7 @@
(let* ((c (integer->char i))
(s (string c)))
(pass-if (list "char" i (format #f "~s ~s" c s))
- (with-latin1-locale
+ (with-ascii-or-latin1-locale i
(let* ((q (regexp-quote s))
(m (regexp-exec (make-regexp q flag) s)))
(and (= 0 (match:start m))
@@ -180,7 +187,7 @@
(s (string #\a c))
(q (regexp-quote s)))
(pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q))
- (with-latin1-locale
+ (with-ascii-or-latin1-locale i
(let* ((m (regexp-exec (make-regexp q flag) s)))
(and (= 0 (match:start m))
(= 2 (match:end m))))))))
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index ca34e8f..eaad8c9 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1266,6 +1266,56 @@
(equal? '((1 2) (3 4) (5 6)) lst))))))
;;
+;; fold-right
+;;
+
+(with-test-prefix "fold-right"
+
+ (pass-if "one list"
+ (equal? (iota 10)
+ (fold-right cons '() (iota 10))))
+
+ (pass-if "two lists"
+ (equal? (zip (iota 10) (map integer->char (iota 10)))
+ (fold-right (lambda (x y z)
+ (cons (list x y) z))
+ '()
+ (iota 10)
+ (map integer->char (iota 10)))))
+
+ (pass-if "tail-recursive"
+ (= 1e6 (fold-right (lambda (x y) (+ 1 y))
+ 0
+ (iota 1e6)))))
+;;
+;; unfold
+;;
+
+(with-test-prefix "unfold"
+
+ (pass-if "basic"
+ (equal? (iota 10)
+ (unfold (lambda (x) (>= x 10))
+ identity
+ 1+
+ 0)))
+
+ (pass-if "tail-gen"
+ (equal? (append (iota 10) '(tail 10))
+ (unfold (lambda (x) (>= x 10))
+ identity
+ 1+
+ 0
+ (lambda (seed) (list 'tail seed)))))
+
+ (pass-if "tail-recursive"
+ ;; Bug #30071.
+ (pair? (unfold (lambda (x) (>= x 1e6))
+ identity
+ 1+
+ 0))))
+
+;;
;; length+
;;
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 54bfd37..2455c17 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -609,6 +609,9 @@
(define %opts-w-arity
'(#:warnings (arity-mismatch)))
+(define %opts-w-format
+ '(#:warnings (format)))
+
(with-test-prefix "warnings"
@@ -1076,4 +1079,96 @@
y)))
(f 2 #:Z 3))
#:opts %opts-w-arity
- #:to 'assembly)))))))
+ #:to 'assembly))))))
+
+ (with-test-prefix "format"
+
+ (pass-if "quiet (no args)"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t "hey!")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "quiet (1 arg)"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t "hey ~A!" "you")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "quiet (2 args)"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format #t "~A ~A!" "hello" "world")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "~% and ~~"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(format some-port "~~ hey~%")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+
+ (pass-if "one missing argument"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(format some-port "foo ~A~%")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected 1, got 0")))))
+
+ (pass-if "two missing arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(format #f "foo ~10,2f and bar ~S~%")
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected 2, got 0")))))
+
+ (pass-if "one given, one missing argument"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(format #t "foo ~A and ~S~%" hey)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected 2, got 1")))))
+
+ (pass-if "too many arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(format #t "foo ~A~%" 1 2)
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected 1, got 2")))))
+
+ (pass-if "ice-9 format"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (let ((in (open-input-string
+ "(use-modules ((ice-9 format)
+ #:renamer (symbol-prefix-proc 'i9-)))
+ (i9-format #t \"yo! ~A\" 1 2)")))
+ (read-and-compile in
+ #:opts %opts-w-format
+ #:to 'assembly))))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected 1, got 2")))))
+
+ (pass-if "not format"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(let ((format chbouib))
+ (format #t "not ~A a format string"))
+ #:opts %opts-w-format
+ #:to 'assembly)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-12-178-g7cd6d77,
Ludovic Courtès <=