[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-13-68-gc3
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-68-gc372cd7 |
|
Date: |
Thu, 18 Nov 2010 13:30:44 +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=c372cd74fdc5de5b3ee3299b77a7881e271c649c
The branch, master has been updated
via c372cd74fdc5de5b3ee3299b77a7881e271c649c (commit)
via 9b5fcde6f9488e9836b090f8da292bf3f2642ca6 (commit)
via 96fa68966d1290a55100eedcb94f6f922f3b4cb1 (commit)
via b8b63433182674b3d7de4d52073b3243c9355146 (commit)
via 6e699fed6b549f02869d3508b5e10d5b59b1c8fd (commit)
via e92f113a5e4fa5a05a525a9d490d8de203d59e19 (commit)
via a608cad27e43e176d1a6e6d7cb4a53ba3861b308 (commit)
via 29de6ae2e8da0db797fcb808b4d35d07e2b9d5f4 (commit)
via cd28785f799d76fc242224b032b67a31346cf539 (commit)
via e75184d5d2cddfc6feea40989e23c609b17a6053 (commit)
from b98d5a5a7607b905afa54fd2768210232fa08e16 (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 c372cd74fdc5de5b3ee3299b77a7881e271c649c
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 14:32:53 2010 +0100
repl read/write using current ports, not captured ports
Fixes bug in repl meta-commands after activating readline, which changes
the current input port.
* module/system/repl/common.scm (<repl>): Remove inport and outport
fields.
(make-repl): Adapt.
(repl-read, repl-print): Just read and write to the current ports.
* module/system/repl/repl.scm (meta-reader): Meta-read from the current
input port.
* module/system/repl/command.scm (read-command, define-meta-command):
Read from the current input port.
commit 9b5fcde6f9488e9836b090f8da292bf3f2642ca6
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 13:10:45 2010 +0100
lower-case hexadecimal digits again
* libguile/numbers.c: Default to lower-case hexadecimal digits again.
commit 96fa68966d1290a55100eedcb94f6f922f3b4cb1
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 13:03:49 2010 +0100
better errors for ecmascript parser too
* module/language/ecmascript/parse.scm (syntax-error): Better errors
here too.
commit b8b63433182674b3d7de4d52073b3243c9355146
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 12:55:25 2010 +0100
ecmascript tokenization errors report source location
* module/language/ecmascript/tokenize.scm (syntax-error): Report source
locations. Adapt all callers to pass source locations.
commit 6e699fed6b549f02869d3508b5e10d5b59b1c8fd
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 12:31:28 2010 +0100
add source-location->source-properties to lalr
* module/system/base/lalr.scm (source-location->source-properties): New
public function, to produce source properties that can be given to the
compiler.
commit e92f113a5e4fa5a05a525a9d490d8de203d59e19
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 12:26:20 2010 +0100
more ecmascript testing
* test-suite/tests/ecmascript.test (eread/1, parse): Also check
read-ecmascript/1, which uses tokenize/1.
commit a608cad27e43e176d1a6e6d7cb4a53ba3861b308
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 12:24:01 2010 +0100
fix ecmascript at the repl
* module/language/ecmascript/tokenize.scm (syntax-error): Reorder args
to throw vals in the right order.
(make-tokenizer/1): Fix. Broken since the lalr refactor...
commit 29de6ae2e8da0db797fcb808b4d35d07e2b9d5f4
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 12:21:36 2010 +0100
repl.scm displays syntax errors on read as well
* module/system/repl/repl.scm (prompting-meta-read): Use
display-syntax-error as appropriate.
commit cd28785f799d76fc242224b032b67a31346cf539
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 11:15:16 2010 +0100
deprecate cuserid
* libguile/posix.c:
* libguile/posix.h:
* libguile/deprecated.h:
* libguile/deprecated.c (scm_cuserid): Deprecate cuserid, as it only
returns 8 bytes of a user's login.
* doc/ref/posix.texi: Remove cuserid from docs.
commit e75184d5d2cddfc6feea40989e23c609b17a6053
Author: Andy Wingo <address@hidden>
Date: Thu Nov 18 11:04:15 2010 +0100
adapt tests to new syntax-error form
* test-suite/tests/syntax.test (pass-if-syntax-error): Fix up for new
form of syntax errors. Adapt all tests.
* test-suite/tests/srfi-17.test: Likewise.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/posix.texi | 13 +--
libguile/deprecated.c | 29 +++
libguile/deprecated.h | 5 +
libguile/numbers.c | 2 +-
libguile/posix.c | 24 ---
libguile/posix.h | 1 -
module/language/ecmascript/parse.scm | 11 +-
module/language/ecmascript/tokenize.scm | 189 +++++++++++---------
module/system/base/lalr.scm | 6 +
module/system/repl/command.scm | 21 +--
module/system/repl/common.scm | 14 +-
module/system/repl/repl.scm | 74 +++++----
test-suite/tests/ecmascript.test | 9 +-
test-suite/tests/srfi-17.test | 28 +++-
test-suite/tests/syntax.test | 296 ++++++++++++++++---------------
15 files changed, 397 insertions(+), 325 deletions(-)
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index b237002..3499404 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -1112,18 +1112,7 @@ or getgrent respectively.
@end deffn
In addition to the accessor procedures for the user database, the
-following shortcut procedures are also available.
-
address@hidden {Scheme Procedure} cuserid
address@hidden {C Function} scm_cuserid ()
-Return a string containing a user name associated with the
-effective user id of the process. Return @code{#f} if this
-information cannot be obtained.
-
-This function has been removed from the latest POSIX specification,
-Guile provides it only if the system has it. Using @code{(getpwuid
-(geteuid))} may be a better idea.
address@hidden deffn
+following shortcut procedure is also available.
@deffn {Scheme Procedure} getlogin
@deffnx {C Function} scm_getlogin ()
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 648efe9..e11d353 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -2361,6 +2361,35 @@ int scm_internal_select (int fds,
+#ifdef HAVE_CUSERID
+
+# if !HAVE_DECL_CUSERID
+extern char *cuserid (char *);
+# endif
+
+SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
+ (void),
+ "Return a string containing a user name associated with the\n"
+ "effective user id of the process. Return @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_cuserid
+{
+ char buf[L_cuserid];
+ char * p;
+
+ scm_c_issue_deprecation_warning
+ ("`cuserid' is deprecated. Use `(passwd:name (getpwuid (geteuid)))'
instead.");
+
+ p = cuserid (buf);
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_from_locale_string (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_CUSERID */
+
+
+
void
scm_i_init_deprecated ()
{
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 893523f..84258fa 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -736,6 +736,11 @@ SCM_DEPRECATED int scm_internal_select (int fds,
SELECT_TYPE *efds,
struct timeval *timeout);
+/* Deprecated because the cuserid call is deprecated.
+ */
+SCM_API SCM scm_cuserid (void);
+
+
void scm_i_init_deprecated (void);
diff --git a/libguile/numbers.c b/libguile/numbers.c
index c9fd891..bc9cb91 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -2160,7 +2160,7 @@ void init_fx_radix(double *fx_list, int radix)
}
/* use this array as a way to generate a single digit */
-static const char*number_chars="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+static const char number_chars[] = "0123456789abcdefghijklmnopqrstuvwxyz";
static size_t
idbl2str (double f, char *a, int radix)
diff --git a/libguile/posix.c b/libguile/posix.c
index f371cb2..8301a7e 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1841,30 +1841,6 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_GETLOGIN */
-#ifdef HAVE_CUSERID
-
-# if !HAVE_DECL_CUSERID
-extern char *cuserid (char *);
-# endif
-
-SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
- (void),
- "Return a string containing a user name associated with the\n"
- "effective user id of the process. Return @code{#f} if this\n"
- "information cannot be obtained.")
-#define FUNC_NAME s_scm_cuserid
-{
- char buf[L_cuserid];
- char * p;
-
- p = cuserid (buf);
- if (!p || !*p)
- return SCM_BOOL_F;
- return scm_from_locale_string (p);
-}
-#undef FUNC_NAME
-#endif /* HAVE_CUSERID */
-
#if HAVE_GETPRIORITY
SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
(SCM which, SCM who),
diff --git a/libguile/posix.h b/libguile/posix.h
index ac774d3..da58835 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -83,7 +83,6 @@ SCM_API SCM scm_sync (void);
SCM_API SCM scm_crypt (SCM key, SCM salt);
SCM_API SCM scm_chroot (SCM path);
SCM_API SCM scm_getlogin (void);
-SCM_API SCM scm_cuserid (void);
SCM_API SCM scm_getpriority (SCM which, SCM who);
SCM_API SCM scm_setpriority (SCM which, SCM who, SCM prio);
SCM_API SCM scm_getpass (SCM prompt);
diff --git a/module/language/ecmascript/parse.scm
b/module/language/ecmascript/parse.scm
index 4c23117..b8868a3 100644
--- a/module/language/ecmascript/parse.scm
+++ b/module/language/ecmascript/parse.scm
@@ -23,8 +23,15 @@
#:use-module (language ecmascript tokenize)
#:export (read-ecmascript read-ecmascript/1 make-parser))
-(define (syntax-error message . args)
- (throw 'syntax-error 'tokenize #f message #f #f args))
+(define* (syntax-error message #:optional token)
+ (if (lexical-token? token)
+ (throw 'syntax-error #f message
+ (and=> (lexical-token-source token)
+ source-location->source-properties)
+ (or (lexical-token-value token)
+ (lexical-token-category token))
+ #f)
+ (throw 'syntax-error #f message #f token #f)))
(define (read-ecmascript port)
(let ((parse (make-parser)))
diff --git a/module/language/ecmascript/tokenize.scm
b/module/language/ecmascript/tokenize.scm
index 270a472..f721445 100644
--- a/module/language/ecmascript/tokenize.scm
+++ b/module/language/ecmascript/tokenize.scm
@@ -24,16 +24,25 @@
#:use-module (system base lalr)
#:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))
-(define (syntax-error message . args)
- (throw 'syntax-error 'tokenize #f message #f #f args))
+(define (syntax-error what loc form . args)
+ (throw 'syntax-error #f what
+ (and=> loc source-location->source-properties)
+ form #f args))
+
+(define (port-source-location port)
+ (make-source-location (port-filename port)
+ (port-line port)
+ (port-column port)
+ (false-if-exception (ftell port))
+ #f))
;; taken from SSAX, sorta
-(define (read-until delims port)
+(define (read-until delims port loc)
(if (eof-object? (peek-char port))
- (syntax-error "EOF while reading a token")
+ (syntax-error "EOF while reading a token" loc #f)
(let ((token (read-delimited delims port 'peek)))
(if (eof-object? (peek-char port))
- (syntax-error "EOF while reading a token")
+ (syntax-error "EOF while reading a token" loc token)
token))))
(define (char-hex? c)
@@ -50,14 +59,14 @@
(digit->number c)
(+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
-(define (read-slash port div?)
+(define (read-slash port loc div?)
(let ((c1 (begin
(read-char port)
(peek-char port))))
(cond
((eof-object? c1)
;; hmm. error if we're not looking for a div? ?
- '(/ . #f))
+ (make-lexical-token '/ loc #f))
((char=? c1 #\/)
(read-line port)
(next-token port div?))
@@ -65,7 +74,8 @@
(read-char port)
(let lp ((c (read-char port)))
(cond
- ((eof-object? c) (syntax-error "EOF while in multi-line comment"))
+ ((eof-object? c)
+ (syntax-error "EOF while in multi-line comment" loc #f))
((char=? c #\*)
(if (eqv? (peek-char port) #\/)
(begin
@@ -76,15 +86,15 @@
(lp (read-char port))))))
(div?
(case c1
- ((#\=) (read-char port) (make-lexical-token '/= #f #f))
- (else (make-lexical-token '/ #f #f))))
+ ((#\=) (read-char port) (make-lexical-token '/= loc #f))
+ (else (make-lexical-token '/ loc #f))))
(else
- (read-regexp port)))))
+ (read-regexp port loc)))))
-(define (read-regexp port)
+(define (read-regexp port loc)
;; first slash already read
(let ((terms (string #\/ #\\ #\nl #\cr)))
- (let lp ((str (read-until terms port)) (head ""))
+ (let lp ((str (read-until terms port loc)) (head ""))
(let ((terminator (peek-char port)))
(cond
((char=? terminator #\/)
@@ -96,7 +106,7 @@
(char-numeric? c)
(char=? c #\$)
(char=? c #\_))))
- (make-lexical-token 'RegexpLiteral #f
+ (make-lexical-token 'RegexpLiteral loc
(cons (string-append head str)
(reverse flags)))
(begin (read-char port)
@@ -104,12 +114,13 @@
((char=? terminator #\\)
(read-char port)
(let ((echar (read-char port)))
- (lp (read-until terms port)
+ (lp (read-until terms port loc)
(string-append head str (string #\\ echar)))))
(else
- (syntax-error "regexp literals may not contain newlines" str)))))))
+ (syntax-error "regexp literals may not contain newlines"
+ loc str)))))))
-(define (read-string port)
+(define (read-string port loc)
(let ((c (read-char port)))
(let ((terms (string c #\\ #\nl #\cr)))
(define (read-escape port)
@@ -124,10 +135,12 @@
((#\v) #\vt)
((#\0)
(let ((next (peek-char port)))
- (cond ((eof-object? next) #\nul)
- ((char-numeric? next)
- (syntax-error "octal escape sequences are not
supported"))
- (else #\nul))))
+ (cond
+ ((eof-object? next) #\nul)
+ ((char-numeric? next)
+ (syntax-error "octal escape sequences are not supported"
+ loc #f))
+ (else #\nul))))
((#\x)
(let* ((a (read-char port))
(b (read-char port)))
@@ -135,24 +148,25 @@
((and (char-hex? a) (char-hex? b))
(integer->char (+ (* 16 (hex->number a)) (hex->number b))))
(else
- (syntax-error "bad hex character escape" a b)))))
+ (syntax-error "bad hex character escape" loc (string a b))))))
((#\u)
- (syntax-error "unicode not supported"))
+ (syntax-error "unicode not supported" loc #f))
(else
c))))
- (let lp ((str (read-until terms port)))
+ (let lp ((str (read-until terms port loc)))
(let ((terminator (peek-char port)))
(cond
((char=? terminator c)
(read-char port)
- str)
+ (make-lexical-token 'StringLiteral loc str))
((char=? terminator #\\)
(read-char port)
(let ((echar (read-escape port)))
(lp (string-append str (string echar)
- (read-until terms port)))))
+ (read-until terms port loc)))))
(else
- (syntax-error "string literals may not contain newlines"
str))))))))
+ (syntax-error "string literals may not contain newlines"
+ loc str))))))))
(define *keywords*
'(("break" . break)
@@ -230,13 +244,14 @@
(cond ((assoc-ref *keywords* word)
=> (lambda (x) (make-lexical-token x loc #f)))
((assoc-ref *future-reserved-words* word)
- (syntax-error "word is reserved for the future, dude." word))
+ (syntax-error "word is reserved for the future, dude."
+ loc word))
(else (make-lexical-token 'Identifier loc
(string->symbol word)))))
(begin (read-char port)
(lp (peek-char port) (cons c chars))))))
-(define (read-numeric port)
+(define (read-numeric port loc)
(let* ((c0 (if (char=? (peek-char port) #\.)
#\0
(read-char port)))
@@ -247,7 +262,8 @@
(read-char port)
(let ((c (peek-char port)))
(if (not (char-hex? c))
- (syntax-error "bad digit reading hexadecimal number" c))
+ (syntax-error "bad digit reading hexadecimal number"
+ loc c))
(let lp ((c c) (acc 0))
(cond ((char-hex? c)
(read-char port)
@@ -260,7 +276,8 @@
(cond ((eof-object? c) acc)
((char-numeric? c)
(if (or (char=? c #\8) (char=? c #\9))
- (syntax-error "invalid digit in octal sequence" c))
+ (syntax-error "invalid digit in octal sequence"
+ loc c))
(read-char port)
(lp (peek-char port)
(+ (* 8 acc) (digit->number c))))
@@ -277,12 +294,15 @@
((or (char=? c1 #\e) (char=? c1 #\E))
(read-char port)
(let ((add (let ((c (peek-char port)))
- (cond ((eof-object? c) (syntax-error "error reading
exponent: EOF"))
+ (cond ((eof-object? c)
+ (syntax-error "error reading exponent: EOF"
+ loc #f))
((char=? c #\+) (read-char port) +)
((char=? c #\-) (read-char port) -)
((char-numeric? c) +)
- (else (syntax-error "error reading exponent:
non-digit"
- c))))))
+ (else
+ (syntax-error "error reading exponent: non-digit"
+ loc c))))))
(let lp ((c (peek-char port)) (e 0))
(cond ((and (not (eof-object? c)) (char-numeric? c))
(read-char port)
@@ -382,54 +402,48 @@
(candidate
(make-lexical-token candidate loc #f))
(else
- (syntax-error "bad syntax: character not allowed" c)))))))
+ (syntax-error "bad syntax: character not allowed" loc c)))))))
(define (next-token port div?)
(let ((c (peek-char port))
- (loc (make-source-location (port-filename port)
- (port-line port)
- (port-column port)
- (false-if-exception (seek port 0 SEEK_CUR))
- #f)))
- (let ((tok
- (case c
- ((#\ht #\vt #\np #\space)
- ; whitespace
- (read-char port)
- (next-token port div?))
- ((#\newline #\cr)
- ; line break
- (read-char port)
- (next-token port div?))
- ((#\/)
- ;; division, single comment, double comment, or regexp
- (read-slash port div?))
- ((#\" #\')
- ; string literal
- (make-lexical-token 'StringLiteral loc (read-string port)))
- (else
- (cond
- ((eof-object? c)
- '*eoi*)
- ((or (char-alphabetic? c)
- (char=? c #\$)
- (char=? c #\_))
- ;; reserved word or identifier
- (read-identifier port loc))
- ((char-numeric? c)
- ;; numeric -- also accept . FIXME, requires lookahead
- (make-lexical-token 'NumericLiteral loc (read-numeric port)))
- (else
- ;; punctuation
- (read-punctuation port loc)))))))
-
- tok)))
+ (loc (port-source-location port)))
+ (case c
+ ((#\ht #\vt #\np #\space) ; whitespace
+ (read-char port)
+ (next-token port div?))
+ ((#\newline #\cr) ; line break
+ (read-char port)
+ (next-token port div?))
+ ((#\/)
+ ;; division, single comment, double comment, or regexp
+ (read-slash port loc div?))
+ ((#\" #\') ; string literal
+ (read-string port loc))
+ (else
+ (cond
+ ((eof-object? c)
+ '*eoi*)
+ ((or (char-alphabetic? c)
+ (char=? c #\$)
+ (char=? c #\_))
+ ;; reserved word or identifier
+ (read-identifier port loc))
+ ((char-numeric? c)
+ ;; numeric -- also accept . FIXME, requires lookahead
+ (make-lexical-token 'NumericLiteral loc (read-numeric port loc)))
+ (else
+ ;; punctuation
+ (read-punctuation port loc)))))))
(define (make-tokenizer port)
(let ((div? #f))
(lambda ()
(let ((tok (next-token port div?)))
- (set! div? (and (pair? tok) (eq? (car tok) 'identifier)))
+ (set! div? (and (lexical-token? tok)
+ (let ((cat (lexical-token-category tok)))
+ (or (eq? cat 'Identifier)
+ (eq? cat 'NumericLiteral)
+ (eq? cat 'StringLiteral)))))
tok))))
(define (make-tokenizer/1 port)
@@ -442,23 +456,32 @@
(let ((tok (next-token port div?)))
(case (if (lexical-token? tok) (lexical-token-category tok) tok)
((lparen)
- (set! stack (make-lexical-token 'lparen #f stack)))
+ (set! stack (cons tok stack)))
((rparen)
- (if (and (pair? stack) (eq? (car stack) 'lparen))
+ (if (and (pair? stack)
+ (eq? (lexical-token-category (car stack)) 'lparen))
(set! stack (cdr stack))
- (syntax-error "unexpected right parenthesis")))
+ (syntax-error "unexpected right parenthesis"
+ (lexical-token-source tok)
+ #f)))
((lbracket)
- (set! stack (make-lexical-token 'lbracket #f stack)))
+ (set! stack (cons tok stack)))
((rbracket)
- (if (and (pair? stack) (eq? (car stack) 'lbracket))
+ (if (and (pair? stack)
+ (eq? (lexical-token-category (car stack)) 'lbracket))
(set! stack (cdr stack))
- (syntax-error "unexpected right bracket" stack)))
+ (syntax-error "unexpected right bracket"
+ (lexical-token-source tok)
+ #f)))
((lbrace)
- (set! stack (make-lexical-token 'lbrace #f stack)))
+ (set! stack (cons tok stack)))
((rbrace)
- (if (and (pair? stack) (eq? (car stack) 'lbrace))
+ (if (and (pair? stack)
+ (eq? (lexical-token-category (car stack)) 'lbrace))
(set! stack (cdr stack))
- (syntax-error "unexpected right brace" stack)))
+ (syntax-error "unexpected right brace"
+ (lexical-token-source tok)
+ #f)))
((semicolon)
(set! eoi? (null? stack))))
(set! div? (and (lexical-token? tok)
diff --git a/module/system/base/lalr.scm b/module/system/base/lalr.scm
index 8383a6f..49e7e8d 100644
--- a/module/system/base/lalr.scm
+++ b/module/system/base/lalr.scm
@@ -35,6 +35,7 @@
source-location-column
source-location-offset
source-location-length
+ source-location->source-properties
;; `lalr-parser' is a defmacro, which produces code that refers to
;; these drivers.
@@ -43,3 +44,8 @@
;; The LALR parser generator was written by Dominique Boucher. It's available
;; from http://code.google.com/p/lalr-scm/ and released under the LGPLv3+.
(include-from-path "system/base/lalr.upstream.scm")
+
+(define (source-location->source-properties loc)
+ `((filename . ,(source-location-input loc))
+ (line . ,(source-location-line loc))
+ (column . ,(source-location-column loc))))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 4fc2038..94bb863 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -136,7 +136,7 @@
(define (read-command repl)
(catch #t
- (lambda () (read (repl-inport repl)))
+ (lambda () (read))
(lambda (key . args)
(pmatch args
((,subr ,msg ,args . ,rest)
@@ -148,11 +148,6 @@
(force-output)
*unspecified*)))
-(define read-line
- (let ((orig-read-line read-line))
- (lambda (repl)
- (orig-read-line (repl-inport repl)))))
-
(define (meta-command repl)
(let ((command (read-command repl)))
(cond
@@ -183,19 +178,19 @@
(% (let* ((expression0
(catch #t
(lambda ()
- (repl-reader ""
- (lambda* (#:optional (port (repl-inport
repl)))
- ((language-reader (repl-language repl))
- port (current-module)))))
+ (repl-reader
+ ""
+ (lambda* (#:optional (port (current-input-port)))
+ ((language-reader (repl-language repl))
+ port (current-module)))))
(lambda (k . args)
(handle-read-error 'expression0 k args))))
...)
(apply (lambda* datums
- (with-output-to-port (repl-outport repl)
- (lambda () b0 b1 ...)))
+ b0 b1 ...)
(catch #t
(lambda ()
- (let ((port (open-input-string (read-line repl))))
+ (let ((port (open-input-string (read-line))))
(let lp ((out '()))
(let ((x (read port)))
(if (eof-object? x)
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 4fc8697..e03bf93 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -26,7 +26,7 @@
#:use-module (ice-9 control)
#:use-module (ice-9 history)
#:export (<repl> make-repl repl-language repl-options
- repl-tm-stats repl-gc-stats repl-inport repl-outport repl-debug
+ repl-tm-stats repl-gc-stats repl-debug
repl-welcome repl-prompt
repl-read repl-compile repl-prepare-eval-thunk repl-eval
repl-parse repl-print repl-option-ref repl-option-set!
@@ -102,7 +102,7 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
;;;
(define-record/keywords <repl>
- language options tm-stats gc-stats inport outport debug)
+ language options tm-stats gc-stats debug)
(define repl-default-options
(copy-tree
@@ -128,8 +128,6 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
#:options (copy-tree repl-default-options)
#:tm-stats (times)
#:gc-stats (gc-stats)
- #:inport (current-input-port)
- #:outport (current-output-port)
#:debug debug))
(define (repl-welcome repl)
@@ -151,8 +149,8 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
(if (zero? level) "" (format #f " [~a]" level)))))))
(define (repl-read repl)
- ((language-reader (repl-language repl)) (repl-inport repl)
- (current-module)))
+ (let ((reader (language-reader (repl-language repl))))
+ (reader (current-input-port) (current-module))))
(define (repl-compile-options repl)
(repl-option-ref repl 'compile-options))
@@ -187,8 +185,8 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more
details.")
;; should be printed with the generic printer, `write'. The
;; language-printer is something else: it prints expressions of
;; a given language, not the result of evaluation.
- (write val (repl-outport repl))
- (newline (repl-outport repl)))))
+ (write val)
+ (newline))))
(define (repl-option-ref repl key)
(cadr (or (assq key (repl-options repl))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 237919e..b135dbb 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -34,26 +34,48 @@
;;;
+;;; Syntax errors
+;;;
+
+(define (display-syntax-error port who what where form subform extra)
+ (format port "Syntax error:~%")
+ (if where
+ (let ((file (or (assq-ref where 'filename) "unknown file"))
+ (line (and=> (assq-ref where 'line) 1+))
+ (col (assq-ref where 'column)))
+ (format port "~a:~a:~a: " file line col))
+ (format port "unknown location: "))
+ (if who
+ (format port "~a: " who))
+ (format port "~a" what)
+ (if subform
+ (format port " in subform ~s of ~s" subform form)
+ (if form
+ (format port " in form ~s" form)))
+ (newline port))
+
+
+
+;;;
;;; Meta commands
;;;
(define meta-command-token (cons 'meta 'command))
(define (meta-reader read env)
- (lambda read-args
- (let ((port (if (pair? read-args) (car read-args) (current-input-port))))
- (with-input-from-port port
- (lambda ()
- (let ((ch (next-char #t)))
- (cond ((eof-object? ch)
- ;; EOF objects are not buffered. It's quite possible
- ;; to peek an EOF then read something else. It's
- ;; strange but it's how it works.
- ch)
- ((eqv? ch #\,)
- (read-char port)
- meta-command-token)
- (else (read port env)))))))))
+ (lambda* (#:optional (port (current-input-port)))
+ (with-input-from-port port
+ (lambda ()
+ (let ((ch (next-char #t)))
+ (cond ((eof-object? ch)
+ ;; EOF objects are not buffered. It's quite possible
+ ;; to peek an EOF then read something else. It's
+ ;; strange but it's how it works.
+ ch)
+ ((eqv? ch #\,)
+ (read-char port)
+ meta-command-token)
+ (else (read port env))))))))
;; repl-reader is a function defined in boot-9.scm, and is replaced by
;; something else if readline has been activated. much of this hoopla is
@@ -71,8 +93,11 @@
((quit)
(apply throw key args))
(else
- (pmatch args
- ((,subr ,msg ,args . ,rest)
+ (pmatch (cons key args)
+ ((syntax-error ,who ,message ,where ,form ,subform . ,rest)
+ (display-syntax-error (current-output-port)
+ who message where form subform rest))
+ ((_ ,subr ,msg ,args . ,rest)
(format #t "Throw to key `~a' while reading expression:\n" key)
(display-error #f (current-output-port) subr msg args rest))
(else
@@ -90,23 +115,6 @@
(define* (start-repl #:optional (lang (current-language)) #:key debug)
(run-repl (make-repl lang debug)))
-(define (display-syntax-error port who what where form subform extra)
- (format port "Syntax error:~%")
- (if where
- (let ((file (or (assq-ref where 'filename) "unknown file"))
- (line (assq-ref where 'line))
- (col (assq-ref where 'column)))
- (format port "~a:~a:~a: " file line col))
- (format port "unknown location: "))
- (if who
- (format port "~a: " who))
- (format port "~a" what)
- (if subform
- (format port " in subform ~s of ~s" subform form)
- (if form
- (format port " in form ~s" form)))
- (newline port))
-
;; (put 'abort-on-error 'scheme-indent-function 1)
(define-syntax abort-on-error
(syntax-rules ()
diff --git a/test-suite/tests/ecmascript.test b/test-suite/tests/ecmascript.test
index c5ef344..955296d 100644
--- a/test-suite/tests/ecmascript.test
+++ b/test-suite/tests/ecmascript.test
@@ -24,12 +24,17 @@
(define (eread str)
(call-with-input-string str read-ecmascript))
+(define (eread/1 str)
+ (call-with-input-string str read-ecmascript/1))
(define-syntax parse
(syntax-rules ()
((_ expression expected)
- (pass-if expression
- (equal? expected (eread expression))))))
+ (begin
+ (pass-if expression
+ (equal? expected (eread expression)))
+ (pass-if expression
+ (equal? expected (eread/1 expression)))))))
(with-test-prefix "parser"
diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test
index d9e0054..8c4f0fc 100644
--- a/test-suite/tests/srfi-17.test
+++ b/test-suite/tests/srfi-17.test
@@ -1,6 +1,6 @@
;;;; srfi-17.test --- test suite for Guile's SRFI-17 functions. -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2003, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003, 2005, 2006, 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
@@ -17,8 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-srfi-17)
- :use-module (test-suite lib)
- :use-module (srfi srfi-17))
+ #:use-module (ice-9 regex)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-17))
(pass-if "cond-expand srfi-17"
@@ -50,7 +51,22 @@
(define %some-variable #f)
(define exception:bad-quote
- '(syntax-error . "quote: bad syntax"))
+ '(quote . "bad syntax"))
+
+;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
+(define-syntax pass-if-syntax-error
+ (syntax-rules ()
+ ((_ name pat exp)
+ (pass-if name
+ (catch 'syntax-error
+ (lambda () exp (error "expected uri-error exception"))
+ (lambda (k who what where form . maybe-subform)
+ (if (if (pair? pat)
+ (and (eq? who (car pat))
+ (string-match (cdr pat) what))
+ (string-match pat what))
+ #t
+ (error "unexpected syntax-error exception" what pat))))))))
(with-test-prefix "set!"
@@ -60,7 +76,7 @@
exception:wrong-type-arg
(set! (symbol->string 'x) 1))
- (pass-if-exception "(set! '#f 1)"
+ (pass-if-syntax-error "(set! '#f 1)"
exception:bad-quote
(eval '(set! '#f 1) (interaction-environment))))
@@ -73,7 +89,7 @@
;; The `(quote x)' below used to be memoized as an infinite list before
;; Guile 1.8.3.
- (pass-if-exception "(set! 'x 1)"
+ (pass-if-syntax-error "(set! 'x 1)"
exception:bad-quote
(eval '(set! 'x 1) (interaction-environment)))))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 5813e4d..b6fd39f 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -17,81 +17,97 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-suite test-syntax)
- :use-module (test-suite lib))
+ #:use-module (ice-9 regex)
+ #:use-module (test-suite lib))
(define exception:generic-syncase-error
- (cons 'syntax-error "source expression failed to match"))
+ "source expression failed to match")
(define exception:unexpected-syntax
- (cons 'syntax-error "unexpected syntax"))
+ "unexpected syntax")
(define exception:bad-expression
- (cons 'syntax-error "Bad expression"))
+ "Bad expression")
(define exception:missing/extra-expr
- (cons 'syntax-error "Missing or extra expression"))
+ "Missing or extra expression")
(define exception:missing-expr
- (cons 'syntax-error "Missing expression"))
+ "Missing expression")
(define exception:missing-body-expr
- (cons 'syntax-error "no expressions in body"))
+ "no expressions in body")
(define exception:extra-expr
- (cons 'syntax-error "Extra expression"))
+ "Extra expression")
(define exception:illegal-empty-combination
- (cons 'syntax-error "Illegal empty combination"))
+ "Illegal empty combination")
(define exception:bad-lambda
- '(syntax-error . "bad lambda"))
+ "bad lambda")
(define exception:bad-let
- '(syntax-error . "bad let "))
+ "bad let$")
(define exception:bad-letrec
- '(syntax-error . "bad letrec "))
+ "bad letrec$")
(define exception:bad-letrec*
- '(syntax-error . "bad letrec\\* "))
+ "bad letrec\\*$")
(define exception:bad-set!
- '(syntax-error . "bad set!"))
+ "bad set!")
(define exception:bad-quote
- '(syntax-error . "quote: bad syntax"))
+ '(quote . "bad syntax"))
(define exception:bad-bindings
- (cons 'syntax-error "Bad bindings"))
+ "Bad bindings")
(define exception:bad-binding
- (cons 'syntax-error "Bad binding"))
+ "Bad binding")
(define exception:duplicate-binding
- (cons 'syntax-error "duplicate bound variable"))
+ "duplicate bound variable")
(define exception:bad-body
- (cons 'misc-error "^bad body"))
+ "^bad body")
(define exception:bad-formals
- '(syntax-error . "invalid argument list"))
+ "invalid argument list")
(define exception:bad-formal
- (cons 'syntax-error "Bad formal"))
+ "Bad formal")
(define exception:duplicate-formals
- (cons 'syntax-error "duplicate identifier in argument list"))
+ "duplicate identifier in argument list")
(define exception:missing-clauses
- (cons 'syntax-error "Missing clauses"))
+ "Missing clauses")
(define exception:misplaced-else-clause
- (cons 'syntax-error "Misplaced else clause"))
+ "Misplaced else clause")
(define exception:bad-case-clause
- (cons 'syntax-error "Bad case clause"))
+ "Bad case clause")
(define exception:bad-case-labels
- (cons 'syntax-error "Bad case labels"))
+ "Bad case labels")
(define exception:bad-cond-clause
- (cons 'syntax-error "Bad cond clause"))
+ "Bad cond clause")
(define exception:too-many-args
- (cons 'syntax-error "too many arguments"))
-
+ "too many arguments")
+
+
+;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
+(define-syntax pass-if-syntax-error
+ (syntax-rules ()
+ ((_ name pat exp)
+ (pass-if name
+ (catch 'syntax-error
+ (lambda () exp (error "expected uri-error exception"))
+ (lambda (k who what where form . maybe-subform)
+ (if (if (pair? pat)
+ (and (eq? who (car pat))
+ (string-match (cdr pat) what))
+ (string-match pat what))
+ #t
+ (error "unexpected syntax-error exception" what pat))))))))
(with-test-prefix "expressions"
(with-test-prefix "Bad argument list"
- (pass-if-exception "improper argument list of length 1"
+ (pass-if-syntax-error "improper argument list of length 1"
exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo . 1))
(interaction-environment)))
- (pass-if-exception "improper argument list of length 2"
+ (pass-if-syntax-error "improper argument list of length 2"
exception:generic-syncase-error
(eval '(let ((foo (lambda (x y) #t)))
(foo 1 . 2))
@@ -106,7 +122,7 @@
;; valid expression.
;; Fixed on 2001-3-3
- (pass-if-exception "empty parentheses \"()\""
+ (pass-if-syntax-error "empty parentheses \"()\""
exception:unexpected-syntax
(eval '()
(interaction-environment)))))
@@ -124,8 +140,8 @@
(with-test-prefix "unquote-splicing"
- (pass-if-exception "extra arguments"
- '(syntax-error . "unquote-splicing takes exactly one argument")
+ (pass-if-syntax-error "extra arguments"
+ "unquote-splicing takes exactly one argument"
(eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4))))
(interaction-environment)))))
@@ -134,7 +150,7 @@
(pass-if "legal (begin)"
(eval '(begin (begin) #t) (interaction-environment)))
- (pass-if-exception "illegal (begin)"
+ (pass-if-syntax-error "illegal (begin)"
exception:generic-syncase-error
(eval '(begin (if #t (begin)) #t) (interaction-environment))))
@@ -153,42 +169,42 @@
(with-test-prefix "bad formals"
- (pass-if-exception "(lambda)"
+ (pass-if-syntax-error "(lambda)"
exception:bad-lambda
(eval '(lambda)
(interaction-environment)))
- (pass-if-exception "(lambda . \"foo\")"
+ (pass-if-syntax-error "(lambda . \"foo\")"
exception:bad-lambda
(eval '(lambda . "foo")
(interaction-environment)))
- (pass-if-exception "(lambda \"foo\")"
+ (pass-if-syntax-error "(lambda \"foo\")"
exception:bad-lambda
(eval '(lambda "foo")
(interaction-environment)))
- (pass-if-exception "(lambda \"foo\" #f)"
+ (pass-if-syntax-error "(lambda \"foo\" #f)"
exception:bad-formals
(eval '(lambda "foo" #f)
(interaction-environment)))
- (pass-if-exception "(lambda (x 1) 2)"
+ (pass-if-syntax-error "(lambda (x 1) 2)"
exception:bad-formals
(eval '(lambda (x 1) 2)
(interaction-environment)))
- (pass-if-exception "(lambda (1 x) 2)"
+ (pass-if-syntax-error "(lambda (1 x) 2)"
exception:bad-formals
(eval '(lambda (1 x) 2)
(interaction-environment)))
- (pass-if-exception "(lambda (x \"a\") 2)"
+ (pass-if-syntax-error "(lambda (x \"a\") 2)"
exception:bad-formals
(eval '(lambda (x "a") 2)
(interaction-environment)))
- (pass-if-exception "(lambda (\"a\" x) 2)"
+ (pass-if-syntax-error "(lambda (\"a\" x) 2)"
exception:bad-formals
(eval '(lambda ("a" x) 2)
(interaction-environment))))
@@ -196,20 +212,20 @@
(with-test-prefix "duplicate formals"
;; Fixed on 2001-3-3
- (pass-if-exception "(lambda (x x) 1)"
+ (pass-if-syntax-error "(lambda (x x) 1)"
exception:duplicate-formals
(eval '(lambda (x x) 1)
(interaction-environment)))
;; Fixed on 2001-3-3
- (pass-if-exception "(lambda (x x x) 1)"
+ (pass-if-syntax-error "(lambda (x x x) 1)"
exception:duplicate-formals
(eval '(lambda (x x x) 1)
(interaction-environment))))
(with-test-prefix "bad body"
- (pass-if-exception "(lambda ())"
+ (pass-if-syntax-error "(lambda ())"
exception:bad-lambda
(eval '(lambda ())
(interaction-environment)))))
@@ -224,61 +240,61 @@
(with-test-prefix "bad bindings"
- (pass-if-exception "(let)"
+ (pass-if-syntax-error "(let)"
exception:bad-let
(eval '(let)
(interaction-environment)))
- (pass-if-exception "(let 1)"
+ (pass-if-syntax-error "(let 1)"
exception:bad-let
(eval '(let 1)
(interaction-environment)))
- (pass-if-exception "(let (x))"
+ (pass-if-syntax-error "(let (x))"
exception:bad-let
(eval '(let (x))
(interaction-environment)))
- (pass-if-exception "(let ((x)))"
+ (pass-if-syntax-error "(let ((x)))"
exception:bad-let
(eval '(let ((x)))
(interaction-environment)))
- (pass-if-exception "(let (x) 1)"
+ (pass-if-syntax-error "(let (x) 1)"
exception:bad-let
(eval '(let (x) 1)
(interaction-environment)))
- (pass-if-exception "(let ((x)) 3)"
+ (pass-if-syntax-error "(let ((x)) 3)"
exception:bad-let
(eval '(let ((x)) 3)
(interaction-environment)))
- (pass-if-exception "(let ((x 1) y) x)"
+ (pass-if-syntax-error "(let ((x 1) y) x)"
exception:bad-let
(eval '(let ((x 1) y) x)
(interaction-environment)))
- (pass-if-exception "(let ((1 2)) 3)"
+ (pass-if-syntax-error "(let ((1 2)) 3)"
exception:bad-let
(eval '(let ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "duplicate bindings"
- (pass-if-exception "(let ((x 1) (x 2)) x)"
+ (pass-if-syntax-error "(let ((x 1) (x 2)) x)"
exception:duplicate-binding
(eval '(let ((x 1) (x 2)) x)
(interaction-environment))))
(with-test-prefix "bad body"
- (pass-if-exception "(let ())"
+ (pass-if-syntax-error "(let ())"
exception:bad-let
(eval '(let ())
(interaction-environment)))
- (pass-if-exception "(let ((x 1)))"
+ (pass-if-syntax-error "(let ((x 1)))"
exception:bad-let
(eval '(let ((x 1)))
(interaction-environment)))))
@@ -293,19 +309,19 @@
(with-test-prefix "bad bindings"
- (pass-if-exception "(let x (y))"
+ (pass-if-syntax-error "(let x (y))"
exception:bad-let
(eval '(let x (y))
(interaction-environment))))
(with-test-prefix "bad body"
- (pass-if-exception "(let x ())"
+ (pass-if-syntax-error "(let x ())"
exception:bad-let
(eval '(let x ())
(interaction-environment)))
- (pass-if-exception "(let x ((y 1)))"
+ (pass-if-syntax-error "(let x ((y 1)))"
exception:bad-let
(eval '(let x ((y 1)))
(interaction-environment)))))
@@ -329,59 +345,59 @@
(with-test-prefix "bad bindings"
- (pass-if-exception "(let*)"
+ (pass-if-syntax-error "(let*)"
exception:generic-syncase-error
(eval '(let*)
(interaction-environment)))
- (pass-if-exception "(let* 1)"
+ (pass-if-syntax-error "(let* 1)"
exception:generic-syncase-error
(eval '(let* 1)
(interaction-environment)))
- (pass-if-exception "(let* (x))"
+ (pass-if-syntax-error "(let* (x))"
exception:generic-syncase-error
(eval '(let* (x))
(interaction-environment)))
- (pass-if-exception "(let* (x) 1)"
+ (pass-if-syntax-error "(let* (x) 1)"
exception:generic-syncase-error
(eval '(let* (x) 1)
(interaction-environment)))
- (pass-if-exception "(let* ((x)) 3)"
+ (pass-if-syntax-error "(let* ((x)) 3)"
exception:generic-syncase-error
(eval '(let* ((x)) 3)
(interaction-environment)))
- (pass-if-exception "(let* ((x 1) y) x)"
+ (pass-if-syntax-error "(let* ((x 1) y) x)"
exception:generic-syncase-error
(eval '(let* ((x 1) y) x)
(interaction-environment)))
- (pass-if-exception "(let* x ())"
+ (pass-if-syntax-error "(let* x ())"
exception:generic-syncase-error
(eval '(let* x ())
(interaction-environment)))
- (pass-if-exception "(let* x (y))"
+ (pass-if-syntax-error "(let* x (y))"
exception:generic-syncase-error
(eval '(let* x (y))
(interaction-environment)))
- (pass-if-exception "(let* ((1 2)) 3)"
+ (pass-if-syntax-error "(let* ((1 2)) 3)"
exception:generic-syncase-error
(eval '(let* ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "bad body"
- (pass-if-exception "(let* ())"
+ (pass-if-syntax-error "(let* ())"
exception:generic-syncase-error
(eval '(let* ())
(interaction-environment)))
- (pass-if-exception "(let* ((x 1)))"
+ (pass-if-syntax-error "(let* ((x 1)))"
exception:generic-syncase-error
(eval '(let* ((x 1)))
(interaction-environment)))))
@@ -390,7 +406,7 @@
(with-test-prefix "bindings"
- (pass-if-exception "initial bindings are undefined"
+ (pass-if-syntax-error "initial bindings are undefined"
exception:used-before-defined
(let ((x 1))
;; FIXME: the memoizer does initialize the var to undefined, but
@@ -401,66 +417,66 @@
(with-test-prefix "bad bindings"
- (pass-if-exception "(letrec)"
+ (pass-if-syntax-error "(letrec)"
exception:bad-letrec
(eval '(letrec)
(interaction-environment)))
- (pass-if-exception "(letrec 1)"
+ (pass-if-syntax-error "(letrec 1)"
exception:bad-letrec
(eval '(letrec 1)
(interaction-environment)))
- (pass-if-exception "(letrec (x))"
+ (pass-if-syntax-error "(letrec (x))"
exception:bad-letrec
(eval '(letrec (x))
(interaction-environment)))
- (pass-if-exception "(letrec (x) 1)"
+ (pass-if-syntax-error "(letrec (x) 1)"
exception:bad-letrec
(eval '(letrec (x) 1)
(interaction-environment)))
- (pass-if-exception "(letrec ((x)) 3)"
+ (pass-if-syntax-error "(letrec ((x)) 3)"
exception:bad-letrec
(eval '(letrec ((x)) 3)
(interaction-environment)))
- (pass-if-exception "(letrec ((x 1) y) x)"
+ (pass-if-syntax-error "(letrec ((x 1) y) x)"
exception:bad-letrec
(eval '(letrec ((x 1) y) x)
(interaction-environment)))
- (pass-if-exception "(letrec x ())"
+ (pass-if-syntax-error "(letrec x ())"
exception:bad-letrec
(eval '(letrec x ())
(interaction-environment)))
- (pass-if-exception "(letrec x (y))"
+ (pass-if-syntax-error "(letrec x (y))"
exception:bad-letrec
(eval '(letrec x (y))
(interaction-environment)))
- (pass-if-exception "(letrec ((1 2)) 3)"
+ (pass-if-syntax-error "(letrec ((1 2)) 3)"
exception:bad-letrec
(eval '(letrec ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "duplicate bindings"
- (pass-if-exception "(letrec ((x 1) (x 2)) x)"
+ (pass-if-syntax-error "(letrec ((x 1) (x 2)) x)"
exception:duplicate-binding
(eval '(letrec ((x 1) (x 2)) x)
(interaction-environment))))
(with-test-prefix "bad body"
- (pass-if-exception "(letrec ())"
+ (pass-if-syntax-error "(letrec ())"
exception:bad-letrec
(eval '(letrec ())
(interaction-environment)))
- (pass-if-exception "(letrec ((x 1)))"
+ (pass-if-syntax-error "(letrec ((x 1)))"
exception:bad-letrec
(eval '(letrec ((x 1)))
(interaction-environment)))))
@@ -469,7 +485,7 @@
(with-test-prefix "bindings"
- (pass-if-exception "initial bindings are undefined"
+ (pass-if-syntax-error "initial bindings are undefined"
exception:used-before-defined
(begin
;; FIXME: the memoizer does initialize the var to undefined, but
@@ -480,66 +496,66 @@
(with-test-prefix "bad bindings"
- (pass-if-exception "(letrec*)"
+ (pass-if-syntax-error "(letrec*)"
exception:bad-letrec*
(eval '(letrec*)
(interaction-environment)))
- (pass-if-exception "(letrec* 1)"
+ (pass-if-syntax-error "(letrec* 1)"
exception:bad-letrec*
(eval '(letrec* 1)
(interaction-environment)))
- (pass-if-exception "(letrec* (x))"
+ (pass-if-syntax-error "(letrec* (x))"
exception:bad-letrec*
(eval '(letrec* (x))
(interaction-environment)))
- (pass-if-exception "(letrec* (x) 1)"
+ (pass-if-syntax-error "(letrec* (x) 1)"
exception:bad-letrec*
(eval '(letrec* (x) 1)
(interaction-environment)))
- (pass-if-exception "(letrec* ((x)) 3)"
+ (pass-if-syntax-error "(letrec* ((x)) 3)"
exception:bad-letrec*
(eval '(letrec* ((x)) 3)
(interaction-environment)))
- (pass-if-exception "(letrec* ((x 1) y) x)"
+ (pass-if-syntax-error "(letrec* ((x 1) y) x)"
exception:bad-letrec*
(eval '(letrec* ((x 1) y) x)
(interaction-environment)))
- (pass-if-exception "(letrec* x ())"
+ (pass-if-syntax-error "(letrec* x ())"
exception:bad-letrec*
(eval '(letrec* x ())
(interaction-environment)))
- (pass-if-exception "(letrec* x (y))"
+ (pass-if-syntax-error "(letrec* x (y))"
exception:bad-letrec*
(eval '(letrec* x (y))
(interaction-environment)))
- (pass-if-exception "(letrec* ((1 2)) 3)"
+ (pass-if-syntax-error "(letrec* ((1 2)) 3)"
exception:bad-letrec*
(eval '(letrec* ((1 2)) 3)
(interaction-environment))))
(with-test-prefix "duplicate bindings"
- (pass-if-exception "(letrec* ((x 1) (x 2)) x)"
+ (pass-if-syntax-error "(letrec* ((x 1) (x 2)) x)"
exception:duplicate-binding
(eval '(letrec* ((x 1) (x 2)) x)
(interaction-environment))))
(with-test-prefix "bad body"
- (pass-if-exception "(letrec* ())"
+ (pass-if-syntax-error "(letrec* ())"
exception:bad-letrec*
(eval '(letrec* ())
(interaction-environment)))
- (pass-if-exception "(letrec* ((x 1)))"
+ (pass-if-syntax-error "(letrec* ((x 1)))"
exception:bad-letrec*
(eval '(letrec* ((x 1)))
(interaction-environment))))
@@ -559,12 +575,12 @@
(with-test-prefix "missing or extra expressions"
- (pass-if-exception "(if)"
+ (pass-if-syntax-error "(if)"
exception:generic-syncase-error
(eval '(if)
(interaction-environment)))
- (pass-if-exception "(if 1 2 3 4)"
+ (pass-if-syntax-error "(if 1 2 3 4)"
exception:generic-syncase-error
(eval '(if 1 2 3 4)
(interaction-environment)))))
@@ -626,57 +642,57 @@
(let ((=> 'ok))
(eq? 'ok (cond (#t identity =>) (else #f)))))
- (pass-if-exception "missing recipient"
- '(syntax-error . "cond: wrong number of receiver expressions")
+ (pass-if-syntax-error "missing recipient"
+ '(cond . "wrong number of receiver expressions")
(cond (#t identity =>)))
- (pass-if-exception "extra recipient"
- '(syntax-error . "cond: wrong number of receiver expressions")
+ (pass-if-syntax-error "extra recipient"
+ '(cond . "wrong number of receiver expressions")
(cond (#t identity => identity identity))))
(with-test-prefix "bad or missing clauses"
- (pass-if-exception "(cond)"
+ (pass-if-syntax-error "(cond)"
exception:generic-syncase-error
(eval '(cond)
(interaction-environment)))
- (pass-if-exception "(cond #t)"
+ (pass-if-syntax-error "(cond #t)"
exception:generic-syncase-error
(eval '(cond #t)
(interaction-environment)))
- (pass-if-exception "(cond 1)"
+ (pass-if-syntax-error "(cond 1)"
exception:generic-syncase-error
(eval '(cond 1)
(interaction-environment)))
- (pass-if-exception "(cond 1 2)"
+ (pass-if-syntax-error "(cond 1 2)"
exception:generic-syncase-error
(eval '(cond 1 2)
(interaction-environment)))
- (pass-if-exception "(cond 1 2 3)"
+ (pass-if-syntax-error "(cond 1 2 3)"
exception:generic-syncase-error
(eval '(cond 1 2 3)
(interaction-environment)))
- (pass-if-exception "(cond 1 2 3 4)"
+ (pass-if-syntax-error "(cond 1 2 3 4)"
exception:generic-syncase-error
(eval '(cond 1 2 3 4)
(interaction-environment)))
- (pass-if-exception "(cond ())"
+ (pass-if-syntax-error "(cond ())"
exception:generic-syncase-error
(eval '(cond ())
(interaction-environment)))
- (pass-if-exception "(cond () 1)"
+ (pass-if-syntax-error "(cond () 1)"
exception:generic-syncase-error
(eval '(cond () 1)
(interaction-environment)))
- (pass-if-exception "(cond (1) 1)"
+ (pass-if-syntax-error "(cond (1) 1)"
exception:generic-syncase-error
(eval '(cond (1) 1)
(interaction-environment))))
@@ -694,69 +710,69 @@
(with-test-prefix "case is hygienic"
- (pass-if-exception "bound 'else is handled correctly"
+ (pass-if-syntax-error "bound 'else is handled correctly"
exception:generic-syncase-error
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
(with-test-prefix "bad or missing clauses"
- (pass-if-exception "(case)"
+ (pass-if-syntax-error "(case)"
exception:generic-syncase-error
(eval '(case)
(interaction-environment)))
- (pass-if-exception "(case . \"foo\")"
+ (pass-if-syntax-error "(case . \"foo\")"
exception:generic-syncase-error
(eval '(case . "foo")
(interaction-environment)))
- (pass-if-exception "(case 1)"
+ (pass-if-syntax-error "(case 1)"
exception:generic-syncase-error
(eval '(case 1)
(interaction-environment)))
- (pass-if-exception "(case 1 . \"foo\")"
+ (pass-if-syntax-error "(case 1 . \"foo\")"
exception:generic-syncase-error
(eval '(case 1 . "foo")
(interaction-environment)))
- (pass-if-exception "(case 1 \"foo\")"
+ (pass-if-syntax-error "(case 1 \"foo\")"
exception:generic-syncase-error
(eval '(case 1 "foo")
(interaction-environment)))
- (pass-if-exception "(case 1 ())"
+ (pass-if-syntax-error "(case 1 ())"
exception:generic-syncase-error
(eval '(case 1 ())
(interaction-environment)))
- (pass-if-exception "(case 1 (\"foo\"))"
+ (pass-if-syntax-error "(case 1 (\"foo\"))"
exception:generic-syncase-error
(eval '(case 1 ("foo"))
(interaction-environment)))
- (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
+ (pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))"
exception:generic-syncase-error
(eval '(case 1 ("foo" "bar"))
(interaction-environment)))
- (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
+ (pass-if-syntax-error "(case 1 ((2) \"bar\") . \"foo\")"
exception:generic-syncase-error
(eval '(case 1 ((2) "bar") . "foo")
(interaction-environment)))
- (pass-if-exception "(case 1 ((2) \"bar\") (else))"
+ (pass-if-syntax-error "(case 1 ((2) \"bar\") (else))"
exception:generic-syncase-error
(eval '(case 1 ((2) "bar") (else))
(interaction-environment)))
- (pass-if-exception "(case 1 (else #f) . \"foo\")"
+ (pass-if-syntax-error "(case 1 (else #f) . \"foo\")"
exception:generic-syncase-error
(eval '(case 1 (else #f) . "foo")
(interaction-environment)))
- (pass-if-exception "(case 1 (else #f) ((1) #t))"
+ (pass-if-syntax-error "(case 1 (else #f) ((1) #t))"
exception:generic-syncase-error
(eval '(case 1 (else #f) ((1) #t))
(interaction-environment)))))
@@ -776,7 +792,7 @@
(with-test-prefix "missing or extra expressions"
- (pass-if-exception "(define)"
+ (pass-if-syntax-error "(define)"
exception:generic-syncase-error
(eval '(define)
(interaction-environment)))))
@@ -842,7 +858,7 @@
(eq? 'c (a 2) (a 5)))))
(interaction-environment))))
- (pass-if-exception "missing body expression"
+ (pass-if-syntax-error "missing body expression"
exception:missing-body-expr
(eval '(let () (define x #t))
(interaction-environment))))
@@ -851,44 +867,44 @@
(with-test-prefix "missing or extra expressions"
- (pass-if-exception "(set!)"
+ (pass-if-syntax-error "(set!)"
exception:bad-set!
(eval '(set!)
(interaction-environment)))
- (pass-if-exception "(set! 1)"
+ (pass-if-syntax-error "(set! 1)"
exception:bad-set!
(eval '(set! 1)
(interaction-environment)))
- (pass-if-exception "(set! 1 2 3)"
+ (pass-if-syntax-error "(set! 1 2 3)"
exception:bad-set!
(eval '(set! 1 2 3)
(interaction-environment))))
(with-test-prefix "bad variable"
- (pass-if-exception "(set! \"\" #t)"
+ (pass-if-syntax-error "(set! \"\" #t)"
exception:bad-set!
(eval '(set! "" #t)
(interaction-environment)))
- (pass-if-exception "(set! 1 #t)"
+ (pass-if-syntax-error "(set! 1 #t)"
exception:bad-set!
(eval '(set! 1 #t)
(interaction-environment)))
- (pass-if-exception "(set! #t #f)"
+ (pass-if-syntax-error "(set! #t #f)"
exception:bad-set!
(eval '(set! #t #f)
(interaction-environment)))
- (pass-if-exception "(set! #f #t)"
+ (pass-if-syntax-error "(set! #f #t)"
exception:bad-set!
(eval '(set! #f #t)
(interaction-environment)))
- (pass-if-exception "(set! #\\space #f)"
+ (pass-if-syntax-error "(set! #\\space #f)"
exception:bad-set!
(eval '(set! #\space #f)
(interaction-environment)))))
@@ -897,12 +913,12 @@
(with-test-prefix "missing or extra expression"
- (pass-if-exception "(quote)"
+ (pass-if-syntax-error "(quote)"
exception:bad-quote
(eval '(quote)
(interaction-environment)))
- (pass-if-exception "(quote a b)"
+ (pass-if-syntax-error "(quote a b)"
exception:bad-quote
(eval '(quote a b)
(interaction-environment)))))
@@ -927,7 +943,7 @@
#t))))
- (pass-if-exception "too few args" exception:generic-syncase-error
+ (pass-if-syntax-error "too few args" exception:generic-syncase-error
(eval '(while) (interaction-environment)))
(with-test-prefix "empty body"
@@ -967,7 +983,7 @@
(with-test-prefix "break"
- (pass-if-exception "too many args" exception:too-many-args
+ (pass-if-syntax-error "too many args" exception:too-many-args
(eval '(while #t
(break 1))
(interaction-environment)))
@@ -1040,7 +1056,7 @@
(with-test-prefix "continue"
- (pass-if-exception "too many args" exception:too-many-args
+ (pass-if-syntax-error "too many args" exception:too-many-args
(eval '(while #t
(continue 1))
(interaction-environment)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-68-gc372cd7,
Andy Wingo <=