[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.7-289-g45c08
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.7-289-g45c0878 |
|
Date: |
Thu, 04 Apr 2013 21:51:49 +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=45c0878b8665182f06a917e391169031c1dc7db6
The branch, stable-2.0 has been updated
via 45c0878b8665182f06a917e391169031c1dc7db6 (commit)
via 0426b3f8f8036364aca13c24ef769283937faa3d (commit)
from 71539c1cd3bf16dfdb87dc6c0c5f4238ebf8dcd9 (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 45c0878b8665182f06a917e391169031c1dc7db6
Author: Mark H Weaver <address@hidden>
Date: Sun Mar 31 19:06:51 2013 -0400
Peeks do not consume EOFs.
Fixes <http://bugs.gnu.org/12216>.
* libguile/ports-internal.h (struct scm_port_internal): Add
'pending_eof' flag.
* libguile/ports.c (scm_i_set_pending_eof, scm_i_clear_pending_eof): New
static functions.
(scm_new_port_table_entry): Initialize 'pending_eof'.
(scm_i_fill_input): Check for 'pending_eof'.
(scm_i_peek_byte_or_eof): Set 'pending_eof' flag before returning EOF.
(scm_end_input, scm_unget_byte, scm_seek, scm_truncate): Clear
'pending_eof'.
(scm_peek_char): Set 'pending_eof' flag before returning EOF.
* test-suite/tests/ports.test ("pending EOF behavior"): Add tests.
commit 0426b3f8f8036364aca13c24ef769283937faa3d
Author: Mark H Weaver <address@hidden>
Date: Thu Apr 4 15:22:18 2013 -0400
Nicer docstring syntax for case-lambda.
* module/ice-9/psyntax.scm (case-lambda, case-lambda*): Allow a
docstring to be placed immediately after the 'case-lambda' or
'case-lambda*'.
* module/ice-9/psyntax-pp.scm: Regenerate.
* doc/ref/api-procedures.texi (Case-lambda): Update docs.
* test-suite/tests/optargs.test ("case-lambda", "case-lambda*"):
Add tests.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-procedures.texi | 4 +-
libguile/ports-internal.h | 1 +
libguile/ports.c | 50 +++++++++++++++++---
module/ice-9/psyntax-pp.scm | 102 +++++++++++++++++++++++++----------------
module/ice-9/psyntax.scm | 42 +++++++++++------
test-suite/tests/optargs.test | 18 +++++++-
test-suite/tests/ports.test | 84 +++++++++++++++++++++++++++++++++
7 files changed, 238 insertions(+), 63 deletions(-)
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 8ff240a..e11479d 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -575,7 +575,8 @@ with @code{lambda} (@pxref{Lambda}).
@example
@group
<case-lambda>
- --> (case-lambda <case-lambda-clause>)
+ --> (case-lambda <case-lambda-clause>*)
+ --> (case-lambda <docstring> <case-lambda-clause>*)
<case-lambda-clause>
--> (<formals> <definition-or-command>*)
<formals>
@@ -590,6 +591,7 @@ Rest lists can be useful with @code{case-lambda}:
@lisp
(define plus
(case-lambda
+ "Return the sum of all arguments."
(() 0)
((a) a)
((a b) (+ a b))
diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h
index 73a788f..333d4fb 100644
--- a/libguile/ports-internal.h
+++ b/libguile/ports-internal.h
@@ -48,6 +48,7 @@ struct scm_port_internal
{
scm_t_port_encoding_mode encoding_mode;
scm_t_iconv_descriptors *iconv_descriptors;
+ int pending_eof;
SCM alist;
};
diff --git a/libguile/ports.c b/libguile/ports.c
index eaa2047..f210cda 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -241,6 +241,18 @@ scm_set_port_input_waiting (scm_t_bits tc, int
(*input_waiting) (SCM))
scm_ptobs[SCM_TC2PTOBNUM (tc)].input_waiting = input_waiting;
}
+static void
+scm_i_set_pending_eof (SCM port)
+{
+ SCM_PORT_GET_INTERNAL (port)->pending_eof = 1;
+}
+
+static void
+scm_i_clear_pending_eof (SCM port)
+{
+ SCM_PORT_GET_INTERNAL (port)->pending_eof = 0;
+}
+
SCM
scm_i_port_alist (SCM port)
{
@@ -645,6 +657,7 @@ scm_new_port_table_entry (scm_t_bits tag)
entry->input_cd = pti; /* XXX pointer to the internal port structure */
entry->output_cd = NULL; /* XXX unused */
+ pti->pending_eof = 0;
pti->alist = SCM_EOL;
SCM_SET_CELL_TYPE (z, tag);
@@ -1326,8 +1339,11 @@ get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
return 0;
}
else
- /* EOF found in the middle of a multibyte character. */
- return EILSEQ;
+ {
+ /* EOF found in the middle of a multibyte character. */
+ scm_i_set_pending_eof (port);
+ return EILSEQ;
+ }
}
buf[input_size++] = byte_read;
@@ -1431,9 +1447,16 @@ static int
scm_i_fill_input (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
assert (pt->read_pos == pt->read_end);
+ if (pti->pending_eof)
+ {
+ pti->pending_eof = 0;
+ return EOF;
+ }
+
if (pt->read_buf == pt->putback_buf)
{
/* finished reading put-back chars. */
@@ -1489,7 +1512,10 @@ scm_slow_peek_byte_or_eof (SCM port)
if (pt->read_pos >= pt->read_end)
{
if (SCM_UNLIKELY (scm_i_fill_input (port) == EOF))
- return EOF;
+ {
+ scm_i_set_pending_eof (port);
+ return EOF;
+ }
}
return *pt->read_pos;
@@ -1721,6 +1747,7 @@ scm_end_input (SCM port)
long offset;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_i_clear_pending_eof (port);
if (pt->read_buf == pt->putback_buf)
{
offset = pt->read_end - pt->read_pos;
@@ -1744,6 +1771,7 @@ scm_unget_byte (int c, SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_i_clear_pending_eof (port);
if (pt->read_buf == pt->putback_buf)
/* already using the put-back buffer. */
{
@@ -1915,7 +1943,10 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
result = SCM_BOOL_F;
}
else if (c == EOF)
- result = SCM_EOF_VAL;
+ {
+ scm_i_set_pending_eof (port);
+ result = SCM_EOF_VAL;
+ }
else
result = SCM_MAKE_CHAR (c);
@@ -2014,7 +2045,10 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
SCM_MISC_ERROR ("port is not seekable",
scm_cons (fd_port, SCM_EOL));
else
- rv = ptob->seek (fd_port, off, how);
+ {
+ scm_i_clear_pending_eof (fd_port);
+ rv = ptob->seek (fd_port, off, how);
+ }
return scm_from_off_t_or_off64_t (rv);
}
else /* file descriptor?. */
@@ -2103,14 +2137,16 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
scm_t_port *pt = SCM_PTAB_ENTRY (object);
scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
-
+
if (!ptob->truncate)
SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
+
+ scm_i_clear_pending_eof (object);
if (pt->rw_active == SCM_PORT_READ)
scm_end_input (object);
else if (pt->rw_active == SCM_PORT_WRITE)
ptob->flush (object);
-
+
ptob->truncate (object, c_length);
rv = 0;
}
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 7b565db..8619d78 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1742,50 +1742,72 @@
'core
'case-lambda
(lambda (e r w s mod)
- (let* ((tmp e)
- (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
- (if tmp
- (apply (lambda (args e1 e2)
- (call-with-values
- (lambda ()
- (expand-lambda-case
- e
- r
- w
- s
- mod
- lambda-formals
- (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1
tmp-2)))
- e2
- e1
- args)))
- (lambda (meta lcase) (build-case-lambda s meta lcase))))
- tmp)
- (syntax-violation 'case-lambda "bad case-lambda" e)))))
+ (letrec*
+ ((build-it
+ (lambda (meta clauses)
+ (call-with-values
+ (lambda () (expand-lambda-case e r w s mod lambda-formals
clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))))
+ (let* ((tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
+ (if tmp
+ (apply (lambda (args e1 e2)
+ (build-it
+ '()
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1
tmp-2)))
+ e2
+ e1
+ args)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any .
each-any))))))
+ (if (and tmp
+ (apply (lambda (docstring args e1 e2) (string?
(syntax->datum docstring)))
+ tmp))
+ (apply (lambda (docstring args e1 e2)
+ (build-it
+ (list (cons 'documentation (syntax->datum
docstring)))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons
tmp-1 tmp-2)))
+ e2
+ e1
+ args)))
+ tmp)
+ (syntax-violation 'case-lambda "bad case-lambda" e))))))))
(global-extend
'core
'case-lambda*
(lambda (e r w s mod)
- (let* ((tmp e)
- (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
- (if tmp
- (apply (lambda (args e1 e2)
- (call-with-values
- (lambda ()
- (expand-lambda-case
- e
- r
- w
- s
- mod
- lambda*-formals
- (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1
tmp-2)))
- e2
- e1
- args)))
- (lambda (meta lcase) (build-case-lambda s meta lcase))))
- tmp)
- (syntax-violation 'case-lambda "bad case-lambda*" e)))))
+ (letrec*
+ ((build-it
+ (lambda (meta clauses)
+ (call-with-values
+ (lambda () (expand-lambda-case e r w s mod lambda*-formals
clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))))
+ (let* ((tmp-1 e)
+ (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
+ (if tmp
+ (apply (lambda (args e1 e2)
+ (build-it
+ '()
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1
tmp-2)))
+ e2
+ e1
+ args)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any .
each-any))))))
+ (if (and tmp
+ (apply (lambda (docstring args e1 e2) (string?
(syntax->datum docstring)))
+ tmp))
+ (apply (lambda (docstring args e1 e2)
+ (build-it
+ (list (cons 'documentation (syntax->datum
docstring)))
+ (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons
tmp-1 tmp-2)))
+ e2
+ e1
+ args)))
+ tmp)
+ (syntax-violation 'case-lambda "bad case-lambda*" e))))))))
(global-extend
'core
'let
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 228d8e3..b359fc1 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2075,28 +2075,42 @@
(global-extend 'core 'case-lambda
(lambda (e r w s mod)
+ (define (build-it meta clauses)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case e r w s mod
+ lambda-formals
+ clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))
(syntax-case e ()
((_ (args e1 e2 ...) ...)
- (call-with-values
- (lambda ()
- (expand-lambda-case e r w s mod
- lambda-formals
- #'((args e1 e2 ...) ...)))
- (lambda (meta lcase)
- (build-case-lambda s meta lcase))))
+ (build-it '() #'((args e1 e2 ...) ...)))
+ ((_ docstring (args e1 e2 ...) ...)
+ (string? (syntax->datum #'docstring))
+ (build-it `((documentation
+ . ,(syntax->datum #'docstring)))
+ #'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda"
e)))))
(global-extend 'core 'case-lambda*
(lambda (e r w s mod)
+ (define (build-it meta clauses)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case e r w s mod
+ lambda*-formals
+ clauses))
+ (lambda (meta* lcase)
+ (build-case-lambda s (append meta meta*) lcase))))
(syntax-case e ()
((_ (args e1 e2 ...) ...)
- (call-with-values
- (lambda ()
- (expand-lambda-case e r w s mod
- lambda*-formals
- #'((args e1 e2 ...) ...)))
- (lambda (meta lcase)
- (build-case-lambda s meta lcase))))
+ (build-it '() #'((args e1 e2 ...) ...)))
+ ((_ docstring (args e1 e2 ...) ...)
+ (string? (syntax->datum #'docstring))
+ (build-it `((documentation
+ . ,(syntax->datum #'docstring)))
+ #'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda*"
e)))))
(global-extend 'core 'let
diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test
index 0be1a54..16a4533 100644
--- a/test-suite/tests/optargs.test
+++ b/test-suite/tests/optargs.test
@@ -226,7 +226,15 @@
((case-lambda)))
(pass-if-exception "no clauses, args" exception:wrong-num-args
- ((case-lambda) 1)))
+ ((case-lambda) 1))
+
+ (pass-if "docstring"
+ (equal? "docstring test"
+ (procedure-documentation
+ (case-lambda
+ "docstring test"
+ (() 0)
+ ((x) 1))))))
(with-test-prefix/c&e "case-lambda*"
(pass-if-exception "no clauses, no args" exception:wrong-num-args
@@ -235,6 +243,14 @@
(pass-if-exception "no clauses, args" exception:wrong-num-args
((case-lambda*) 1))
+ (pass-if "docstring"
+ (equal? "docstring test"
+ (procedure-documentation
+ (case-lambda*
+ "docstring test"
+ (() 0)
+ ((x) 1)))))
+
(pass-if "unambiguous"
((case-lambda*
((a b) #t)
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 886ab24..7b6ee22 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -1110,6 +1110,90 @@
(char-ready?))))))
+;;;; pending-eof behavior
+
+(with-test-prefix "pending EOF behavior"
+ ;; Make a test port that will produce the given sequence. Each
+ ;; element of 'lst' may be either a character or #f (which means EOF).
+ (define (test-soft-port . lst)
+ (make-soft-port
+ (vector (lambda (c) #f) ; write char
+ (lambda (s) #f) ; write string
+ (lambda () #f) ; flush
+ (lambda () ; read char
+ (let ((c (car lst)))
+ (set! lst (cdr lst))
+ c))
+ (lambda () #f)) ; close
+ "rw"))
+
+ (define (call-with-port p proc)
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () (proc p))
+ (lambda () (close-port p))))
+
+ (define (call-with-test-file str proc)
+ (let ((filename (test-file)))
+ (dynamic-wind
+ (lambda () (call-with-output-file filename
+ (lambda (p) (display str p))))
+ (lambda () (call-with-input-file filename proc))
+ (lambda () (delete-file (test-file))))))
+
+ (pass-if "peek-char does not swallow EOF (soft port)"
+ (call-with-port (test-soft-port #\a #f #\b)
+ (lambda (p)
+ (and (char=? #\a (peek-char p))
+ (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (eof-object? (read-char p))
+ (char=? #\b (peek-char p))
+ (char=? #\b (read-char p))))))
+
+ (pass-if "unread clears pending EOF (soft port)"
+ (call-with-port (test-soft-port #\a #f #\b)
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (unread-char #\u p)
+ (char=? #\u (read-char p)))))))
+
+ (pass-if "unread clears pending EOF (string port)"
+ (call-with-input-string "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (unread-char #\u p)
+ (char=? #\u (read-char p)))))))
+
+ (pass-if "unread clears pending EOF (file port)"
+ (call-with-test-file
+ "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (unread-char #\u p)
+ (char=? #\u (read-char p)))))))
+
+ (pass-if "seek clears pending EOF (string port)"
+ (call-with-input-string "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (seek p 0 SEEK_SET)
+ (char=? #\a (read-char p)))))))
+
+ (pass-if "seek clears pending EOF (file port)"
+ (call-with-test-file
+ "a"
+ (lambda (p)
+ (and (char=? #\a (read-char p))
+ (eof-object? (peek-char p))
+ (begin (seek p 0 SEEK_SET)
+ (char=? #\a (read-char p))))))))
+
+
;;;; Close current-input-port, and make sure everyone can handle it.
(with-test-prefix "closing current-input-port"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.7-289-g45c0878,
Mark H Weaver <=