[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, string_abstraction2, updated. release_
|
From: |
Michael Gran |
|
Subject: |
[Guile-commits] GNU Guile branch, string_abstraction2, updated. release_1-9-1-110-g8241a7d |
|
Date: |
Tue, 04 Aug 2009 04:24:11 +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=8241a7d8d27ffcccdc2fac180f55df7f655f3773
The branch, string_abstraction2 has been updated
via 8241a7d8d27ffcccdc2fac180f55df7f655f3773 (commit)
via 675546753e26954c6e5fe01c19362ba745c4595f (commit)
via a876e7dcea78e770bedba40017fbb225cf88bff5 (commit)
via f7118e35525e1c137f2fb96619233610549fae12 (commit)
via 4c402b889eecaa7ffc61da6656f415c8c983507a (commit)
via 64bad3f5a8d7351a41a5b9ccb1df5c393a48b4a9 (commit)
via 5adcdb65192ba6e654ab2d1dd8b0840a33136a8a (commit)
via 4b856371b3e85cd82f6d637f72bc610d0158b5de (commit)
via 2e4c3227ce1374dd53abd3c7c5797cc64329de91 (commit)
via f4aa0f104b3347c21093b837046022fb7bb6a2ff (commit)
via 904a78f11d2d11a58d5df365a44c4fbbd4c96df3 (commit)
via 77332b21a01fac906ae4707426e00f01e62c0415 (commit)
via 5d61c2a1cff1a59e4a3f53a6c3ecf4acf3a3028e (commit)
via 22cee9cd73619a18bf42f1ed81dd93336a70bcf0 (commit)
via d3b9cb230a88dfebd1548392c4f8746d7d93fe55 (commit)
from 97e70c590128bc46891ebfd26c20c4cb1f2d3ab5 (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 8241a7d8d27ffcccdc2fac180f55df7f655f3773
Author: Michael Gran <address@hidden>
Date: Sun Aug 2 10:06:47 2009 -0700
Validate file-declared encodings
If a loaded file has and encoding declared by a "coding: XXXX"
statement, validate the encoding before setting the port. Also,
check a list of encoding aliases if the encoding isn't recognized.
* libguile/ports.c (find_valid_encoding): new validation func
(scm_i_set_port_encoding_x): use find_valid_encoding, add error
condition
* libguile/encodings.h: new file
(scm_t_alt_encodings): new type
(scm_i_encodings): new list of encoding aliases
commit 675546753e26954c6e5fe01c19362ba745c4595f
Merge: 5d61c2a1cff1a59e4a3f53a6c3ecf4acf3a3028e
a876e7dcea78e770bedba40017fbb225cf88bff5
Author: Michael Gran <address@hidden>
Date: Sat Aug 1 13:12:14 2009 -0700
Merge branch 'master' into string_abstraction2
Conflicts:
libguile/chars.c
libguile/chars.h
libguile/numbers.h
libguile/print.c
libguile/read.c
libguile/vm-i-system.c
commit 5d61c2a1cff1a59e4a3f53a6c3ecf4acf3a3028e
Author: Michael Gran <address@hidden>
Date: Mon Jul 27 20:07:30 2009 -0700
Optimize lookup_interned_symbol
* libguile/symbols.c (lookup_interned_symbol): optimization
commit 22cee9cd73619a18bf42f1ed81dd93336a70bcf0
Author: Michael Gran <address@hidden>
Date: Mon Jul 27 20:05:23 2009 -0700
Fix remember_upto_here for seed->random-state
* libguile/random.c (scm_seed_to_random_state): fix
scm_remember_upto_here_1 call
commit d3b9cb230a88dfebd1548392c4f8746d7d93fe55
Author: Michael Gran <address@hidden>
Date: Mon Jul 27 20:03:42 2009 -0700
Possible memory leak on error in scm_strptime
* libguile/stime.c (scm_strptime): add missing frees
-----------------------------------------------------------------------
Summary of changes:
NEWS | 15 +++
libguile/chars.c | 94 ++++++++----------
libguile/chars.h | 22 ++--
libguile/encodings.h | 42 ++++++++
libguile/numbers.h | 12 ++-
libguile/ports.c | 90 +++++++++++++----
libguile/print.c | 18 ++--
libguile/print.h | 1 +
libguile/random.c | 2 +-
libguile/stime.c | 2 +
libguile/symbols.c | 35 +++++--
libguile/vm-i-system.c | 12 ++-
module/Makefile.am | 1 +
module/language/assembly/compile-bytecode.scm | 1 +
module/language/tree-il.scm | 49 +++++++++-
module/language/tree-il/analyze.scm | 129 ++++++++++++++++++++++++-
module/language/tree-il/compile-glil.scm | 16 +++
module/scripts/compile.scm | 34 ++++++-
module/system/base/compile.scm | 11 ++
module/system/base/message.scm | 102 +++++++++++++++++++
test-suite/tests/tree-il.test | 117 ++++++++++++++++++++++-
21 files changed, 687 insertions(+), 118 deletions(-)
create mode 100644 libguile/encodings.h
create mode 100644 module/system/base/message.scm
diff --git a/NEWS b/NEWS
index 445bb1c..96c3a9b 100644
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,21 @@ Please send Guile bug reports to address@hidden
(During the 1.9 series, we will keep an incremental NEWS for the latest
prerelease, and a full NEWS corresponding to 1.8 -> 2.0.)
+Changes in 1.9.2 (since the 1.9.1 prerelease):
+
+** Global variables `scm_charnames' and `scm_charnums' are removed.
+
+These variables contained the names of control characters and were
+used when writing characters. While these were global, they were
+never intended to be public API. They have been replaced with private
+functions.
+
+** EBCDIC support is removed.
+
+There was an EBCDIC compile flag that altered some of the character
+processing. It appeared that full EBCDIC support was never completed
+and was unmaintained.
+
Changes in 1.9.1 (since the 1.9.0 prerelease):
** `scm_set_port_seek' and `scm_set_port_truncate' use the `scm_t_off' type
diff --git a/libguile/chars.c b/libguile/chars.c
index 50a033f..2103c54 100644
--- a/libguile/chars.c
+++ b/libguile/chars.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009 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
@@ -306,58 +306,51 @@ scm_c_downcase (scm_t_wchar c)
return uc_tolower (c);
}
-
/* There are a few sets of character names: R5RS, Guile
extensions for control characters, and leftover Guile extensions.
They are listed in order of precedence. */
-const char *const scm_r5rs_charnames[] =
- {
- "space", "newline"
- };
+static const char *const scm_r5rs_charnames[] = {
+ "space", "newline"
+};
-const scm_t_uint32 const scm_r5rs_charnums[] =
- {
- 0x20, 0x0A
- };
+static const scm_t_uint32 const scm_r5rs_charnums[] = {
+ 0x20, 0x0A
+};
-const int scm_n_r5rs_charnames = sizeof (scm_r5rs_charnames) / sizeof (char *);
+#define SCM_N_R5RS_CHARNAMES (sizeof (scm_r5rs_charnames) / sizeof (char *))
/* The abbreviated names for control characters. */
-const char *const scm_C0_control_charnames[] =
- {
- /* C0 controls */
- "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel",
- "bs", "ht", "lf", "vt", "ff", "cr", "so", "si",
- "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb",
- "can", "em", "sub", "esc", "fs", "gs", "rs", "us",
- "sp", "del"
- };
-
-const scm_t_uint32 const scm_C0_control_charnums[] =
- {
- 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
- 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
- 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
- 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
- 0x20, 0x7f
- };
-
-int scm_n_C0_control_charnames = sizeof (scm_C0_control_charnames) / sizeof
(char *);
-
-const char *const scm_alt_charnames[] =
- {
- "null", "backspace", "tab", "nl", "newline", "np", "page", "return",
- };
-
-const scm_t_uint32 const scm_alt_charnums[] =
- {
- 0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d
- };
-
-int scm_n_alt_charnames = sizeof (scm_alt_charnames) / sizeof (char *);
+static const char *const scm_C0_control_charnames[] = {
+ /* C0 controls */
+ "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel",
+ "bs", "ht", "lf", "vt", "ff", "cr", "so", "si",
+ "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb",
+ "can", "em", "sub", "esc", "fs", "gs", "rs", "us",
+ "sp", "del"
+};
+
+static const scm_t_uint32 const scm_C0_control_charnums[] = {
+ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
+ 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
+ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
+ 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
+ 0x20, 0x7f
+};
+
+#define SCM_N_C0_CONTROL_CHARNAMES (sizeof (scm_C0_control_charnames) / sizeof
(char *))
+
+static const char *const scm_alt_charnames[] = {
+ "null", "backspace", "tab", "nl", "newline", "np", "page", "return",
+};
+
+static const scm_t_uint32 const scm_alt_charnums[] = {
+ 0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d
+};
+
+#define SCM_N_ALT_CHARNAMES (sizeof (scm_alt_charnames) / sizeof (char *))
/* Returns the string charname for a character if it exists, or NULL
otherwise. */
@@ -367,15 +360,15 @@ scm_i_charname (SCM chr)
int c;
scm_t_uint32 i = SCM_CHAR (chr);
- for (c = 0; c < scm_n_r5rs_charnames; c++)
+ for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
if (scm_r5rs_charnums[c] == i)
return scm_r5rs_charnames[c];
- for (c = 0; c < scm_n_C0_control_charnames; c++)
+ for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
if (scm_C0_control_charnums[c] == i)
return scm_C0_control_charnames[c];
- for (c = 0; c < scm_n_alt_charnames; c++)
+ for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
if (scm_alt_charnums[c] == i)
return scm_alt_charnames[i];
@@ -390,27 +383,26 @@ scm_i_charname_to_char (const char *charname, size_t
charname_len)
/* The R5RS charnames. These are supposed to be case
insensitive. */
- for (c = 0; c < scm_n_r5rs_charnames; c++)
+ for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
if ((strlen (scm_r5rs_charnames[c]) == charname_len)
&& (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len)))
return SCM_MAKE_CHAR (scm_r5rs_charnums[c]);
/* Then come the controls. These are not case sensitive. */
- for (c = 0; c < scm_n_C0_control_charnames; c++)
+ for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
if ((strlen (scm_C0_control_charnames[c]) == charname_len)
&& (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len)))
return SCM_MAKE_CHAR (scm_C0_control_charnums[c]);
/* Lastly are some old names carried over for compatibility. */
- for (c = 0; c < scm_n_alt_charnames; c++)
+ for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
if ((strlen (scm_alt_charnames[c]) == charname_len)
&& (!strncasecmp (scm_alt_charnames[c], charname, charname_len)))
return SCM_MAKE_CHAR (scm_alt_charnums[c]);
-
+
return SCM_BOOL_F;
}
-
diff --git a/libguile/chars.h b/libguile/chars.h
index bf9ae0f..b6d36c8 100644
--- a/libguile/chars.h
+++ b/libguile/chars.h
@@ -3,7 +3,7 @@
#ifndef SCM_CHARS_H
#define SCM_CHARS_H
-/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008, 2009 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
@@ -29,23 +29,23 @@
/* Immediate Characters
*/
-#ifndef SCM_WCHAR_DEFINED
+#ifndef SCM_T_WCHAR_DEFINED
typedef scm_t_int32 scm_t_wchar;
-#define SCM_WCHAR_DEFINED
-#endif
+#define SCM_T_WCHAR_DEFINED
+#endif /* SCM_T_WCHAR_DEFINED */
#define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x))
-#define SCM_MAKE_CHAR(x) ({scm_t_int32 _x = (x); \
- _x < 0 \
- ? SCM_MAKE_ITAG8((scm_t_bits)(unsigned char)_x, scm_tc8_char) \
- : SCM_MAKE_ITAG8((scm_t_bits)_x, scm_tc8_char);})
+#define SCM_MAKE_CHAR(x) \
+ (x < 0 \
+ ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) x, scm_tc8_char) \
+ : SCM_MAKE_ITAG8 ((scm_t_bits) x, scm_tc8_char))
#define SCM_CODEPOINT_MAX (0x10ffff)
#define SCM_IS_UNICODE_CHAR(c) \
- ((scm_t_wchar)(c)<=0xd7ff || \
- ((scm_t_wchar)(c)>=0xe000 && (scm_t_wchar)(c)<=SCM_CODEPOINT_MAX))
+ ((scm_t_wchar) (c) <= 0xd7ff \
+ || ((scm_t_wchar) (c) >= 0xe000 && (scm_t_wchar) (c) <= SCM_CODEPOINT_MAX))
@@ -74,7 +74,7 @@ SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar c);
SCM_API scm_t_wchar scm_c_downcase (scm_t_wchar c);
SCM_INTERNAL const char *scm_i_charname (SCM chr);
SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname,
- size_t charname_len);
+ size_t charname_len);
SCM_INTERNAL void scm_init_chars (void);
#endif /* SCM_CHARS_H */
diff --git a/libguile/encodings.h b/libguile/encodings.h
new file mode 100644
index 0000000..dfc3808
--- /dev/null
+++ b/libguile/encodings.h
@@ -0,0 +1,42 @@
+#ifndef SCM_ENCODINGS_H
+#define SCM_ENCODINGS_H
+
+typedef struct scm_t_alt_encodings_tag {
+ const char * const alternate;
+ const char * const standard;
+
+} scm_t_alt_encodings;
+
+scm_t_alt_encodings scm_i_encodings[] = {
+ /* These are EMACS aliases for Libunistring encodings. */
+ {"CHINESE-BIG5", "BIG5"},
+ {"CN-BIG5", "BIG5"},
+ {"CYRILLIC-ISO-8BIT", "ISO-8859-5"},
+ {"CYRILLIC-KOI8", "KOI8-R"},
+ {"KOI8", "KOI8-R"},
+ {"US-ASCII", "ASCII"},
+ {"GREEK-ISO-8BIT", "ISO-8859-7"},
+ {"HEBREW-ISO-8BIT", "ISO-8859-8"},
+ {"ISO-LATIN-1", "ISO-8859-1"},
+ {"ISO-LATIN-1-UNIX", "ISO-8859-1"},
+ {"ISO-LATIN-2", "ISO-8859-2"},
+ {"ISO-LATIN-3", "ISO-8859-3"},
+ {"ISO-LATIN-4", "ISO-8859-4"},
+ {"ISO-LATIN-8", "ISO-8859-8"},
+ {"ISO-LATIN-9", "ISO-8859-15"},
+ {"JAPANESE-SHIFT-JIS", "SHIFT_JIS"},
+ {"LATIN-0", "ISO-8859-15"},
+ {"LATIN-1", "ISO-8859-1"},
+ {"LATIN-2", "ISO-8859-2"},
+ {"LATIN-3", "ISO-8859-3"},
+ {"LATIN-4", "ISO-8859-4"},
+ {"LATIN-9", "ISO-8859-15"},
+ {"MULE-UTF-8", "UTF-8"},
+ {"SJIS", "SHIFT_JIS"},
+ {"WINDOWS-1250", "CP1250"},
+ {"WINDOWS-1251", "CP1251"},
+ {"WINDOWS-1252", "CP1252"}
+};
+
+#define SCM_N_ALTERNATE_ENCODINGS (27)
+#endif
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 39c5225..6aa4b66 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -3,7 +3,7 @@
#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H
-/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008,
2009 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
@@ -28,6 +28,11 @@
#include "libguile/__scm.h"
#include "libguile/print.h"
+#ifndef SCM_T_WCHAR_DEFINED
+typedef scm_t_int32 scm_t_wchar;
+#define SCM_T_WCHAR_DEFINED
+#endif /* SCM_T_WCHAR_DEFINED */
+
#if SCM_HAVE_FLOATINGPOINT_H
# include <floatingpoint.h>
#endif
@@ -174,10 +179,7 @@ typedef struct scm_t_complex
double imag;
} scm_t_complex;
-#ifndef SCM_WCHAR_DEFINED
-typedef scm_t_int32 scm_t_wchar;
-#define SCM_WCHAR_DEFINED
-#endif
+
diff --git a/libguile/ports.c b/libguile/ports.c
index 47c6900..c3d6123 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -55,6 +55,7 @@
#include "libguile/weaks.h"
#include "libguile/fluids.h"
#include "libguile/eq.h"
+#include "libguile/encodings.h"
#ifdef HAVE_STRING_H
#include <string.h>
@@ -1856,21 +1857,64 @@ scm_i_get_port_encoding (SCM port)
}
}
+/* Returns ENC is if is a recognized encoding. If it isn't, it tries
+ to find an alias of ENC that is valid. Otherwise, it returns
+ NULL. */
+static const char *
+find_valid_encoding (const char *enc)
+{
+ int isvalid = 0;
+ const char str[] = " ";
+ scm_t_uint32 *u32;
+ size_t u32len;
+ int i;
+
+ u32 = u32_conv_from_encoding (enc, iconveh_error, str, 1,
+ NULL, NULL, &u32len);
+ isvalid = (u32 != NULL);
+ free (u32);
+
+ if (isvalid)
+ return enc;
+
+ for (i = 0; i < SCM_N_ALTERNATE_ENCODINGS; i++)
+ {
+ if (strcasecmp (enc, scm_i_encodings[i].alternate) == 0)
+ {
+ u32 = u32_conv_from_encoding (scm_i_encodings[i].standard,
+ iconveh_error,
+ str, 1, NULL, NULL, &u32len);
+ isvalid = (u32 != NULL);
+ free (u32);
+
+ if (isvalid)
+ return scm_i_encodings[i].standard;
+ }
+ }
+
+ return NULL;
+}
+
void
scm_i_set_port_encoding_x (SCM port, const char *enc)
{
- char *buf;
- SCM encoding;
+ const char *valid_enc;
scm_t_port *pt;
if (enc == NULL)
- encoding = SCM_BOOL_F;
+ valid_enc = NULL;
else
{
- encoding = scm_i_make_string (strlen (enc), &buf);
- memcpy (buf, enc, strlen(enc));
+ valid_enc = find_valid_encoding (enc);
+ if (valid_enc == NULL)
+ {
+ SCM err;
+ err = scm_from_locale_string (enc);
+ scm_misc_error (NULL, "invalid or unknown character encoding ~s",
+ scm_list_1 (err));
+ }
}
-
+
if (scm_is_false (port))
{
/* Set the default encoding for future ports. */
@@ -1878,7 +1922,12 @@ scm_i_set_port_encoding_x (SCM port, const char *enc)
|| !scm_is_fluid (SCM_VARIABLE_REF (scm_port_encoding_var)))
scm_misc_error (NULL, "tried to set port encoding fluid before it is
initialized",
SCM_EOL);
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var), encoding);
+
+ if (valid_enc == NULL)
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var), SCM_BOOL_F);
+ else
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var),
+ scm_from_locale_string (valid_enc));
}
else
{
@@ -1886,7 +1935,10 @@ scm_i_set_port_encoding_x (SCM port, const char *enc)
pt = SCM_PTAB_ENTRY (port);
if (pt->encoding)
free (pt->encoding);
- pt->encoding = strdup (enc);
+ if (valid_enc == NULL)
+ pt->encoding = NULL;
+ else
+ pt->encoding = strdup (valid_enc);
}
}
@@ -1920,30 +1972,24 @@ SCM_DEFINE (scm_set_port_encoding_x,
"set-port-encoding!", 2, 0, 0,
#define FUNC_NAME s_scm_set_port_encoding_x
{
- const char str[] = " ";
- scm_t_uint32 *u32;
- size_t u32len;
- char *new_enc;
- int isvalid;
+ char *enc_str;
+ const char *valid_enc_str;
SCM_VALIDATE_PORT (1, port);
SCM_VALIDATE_STRING (2, enc);
- new_enc = scm_to_locale_string (enc);
- u32 = u32_conv_from_encoding (new_enc, iconveh_error, str, 1,
- NULL, NULL, &u32len);
- isvalid = (u32 == NULL);
- free (u32);
-
- if (isvalid)
+ enc_str = scm_to_locale_string (enc);
+ valid_enc_str = find_valid_encoding (enc_str);
+ if (valid_enc_str == NULL)
{
- free (new_enc);
+ free (enc_str);
scm_misc_error (FUNC_NAME, "invalid or unknown character encoding ~s",
scm_list_1 (enc));
}
else
{
- scm_i_set_port_encoding_x (port, new_enc);
+ scm_i_set_port_encoding_x (port, valid_enc_str);
+ free (enc_str);
}
return SCM_UNSPECIFIED;
}
diff --git a/libguile/print.c b/libguile/print.c
index 97ef237..dac47d4 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -446,7 +446,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
if (SCM_CHARP (exp))
{
scm_t_wchar i = SCM_CHAR (exp);
- const char *name;
+ const char *name;
if (SCM_WRITINGP (pstate))
{
@@ -470,7 +470,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
buf = u32_conv_to_encoding (scm_i_get_port_encoding (port),
iconveh_error,
- (scm_t_uint32 *) wbuf
,
+ (scm_t_uint32 *) wbuf,
1 ,
NULL,
NULL, &len);
@@ -481,17 +481,13 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
free (buf);
}
else
- {
- /* Character is graphic but unrepresentable in
- this port's encoding. */
- scm_intprint (i, 8, port);
- }
+ /* Character is graphic but unrepresentable in
+ this port's encoding. */
+ scm_intprint (i, 8, port);
}
else
- {
- /* Character is a non-graphical character. */
- scm_intprint (i, 8, port);
- }
+ /* Character is a non-graphical character. */
+ scm_intprint (i, 8, port);
}
else
scm_charprint (i, port);
diff --git a/libguile/print.h b/libguile/print.h
index d21cb72..14c63fe 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -53,6 +53,7 @@ do { \
(SCM_PORT_WITH_PS_P (p) ? SCM_PORT_WITH_PS_PORT (p) : p)
#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwuwpwuwuwurprpw"
+
typedef struct scm_print_state {
SCM handle; /* Struct handle */
int revealed; /* Has the state escaped to Scheme? */
diff --git a/libguile/random.c b/libguile/random.c
index 1761f25..9ce70e0 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -388,9 +388,9 @@ SCM_DEFINE (scm_seed_to_random_state, "seed->random-state",
1, 0, 0,
seed = scm_number_to_string (seed, SCM_UNDEFINED);
SCM_VALIDATE_STRING (1, seed);
str = scm_to_locale_stringn (seed, &len);
- scm_remember_upto_here_1 (seed);
res = make_rstate (scm_c_make_rstate (str, len));
free(str);
+ scm_remember_upto_here_1 (seed);
return res;
}
diff --git a/libguile/stime.c b/libguile/stime.c
index c1ab3e9..a5169c1 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -770,6 +770,8 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
instance it doesn't. Force a sensible value for our error
message. */
errno = EINVAL;
+ free (str);
+ free (fmt);
SCM_SYSERROR;
}
diff --git a/libguile/symbols.c b/libguile/symbols.c
index aace16b..a4ef4e8 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -105,15 +105,32 @@ lookup_interned_symbol (SCM name, unsigned long raw_hash)
if (scm_i_symbol_hash (sym) == raw_hash
&& scm_i_symbol_length (sym) == len)
{
-
- size_t i = len;
-
- while (i != 0)
- {
- --i;
- if (scm_i_string_ref (name, i) != scm_i_symbol_ref (sym, i))
- goto next_symbol;
- }
+ size_t i = len;
+
+ /* Slightly faster path for comparing narrow to narrow. */
+ if (scm_i_is_narrow_string (name) && scm_i_is_narrow_symbol (sym))
+ {
+ const char *chrs = scm_i_symbol_chars (sym);
+ const char *str = scm_i_string_chars (name);
+
+ while (i != 0)
+ {
+ --i;
+ if (str[i] != chrs[i])
+ goto next_symbol;
+ }
+ }
+ else
+ {
+ /* Somewhat slower path for comparing narrow to wide or
+ wide to wide. */
+ while (i != 0)
+ {
+ --i;
+ if (scm_i_string_ref (name, i) != scm_i_symbol_ref (sym, i))
+ goto next_symbol;
+ }
+ }
return sym;
}
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 2827e72..3db92aa 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -171,11 +171,17 @@ VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8,
0, 1)
VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
{
- PUSH (SCM_MAKE_CHAR (FETCH ()));
+ scm_t_uint8 v = 0;
+ v = FETCH ();
+
+ PUSH (SCM_MAKE_CHAR (v));
+ /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The
+ contents of SCM_MAKE_CHAR may be evaluated more than once,
+ resulting in a double fetch. */
NEXT;
}
-VM_DEFINE_INSTRUCTION (17, make_char32, "make-char32", 4, 0, 1)
+VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1)
{
scm_t_wchar v = 0;
v += FETCH ();
@@ -186,7 +192,7 @@ VM_DEFINE_INSTRUCTION (17, make_char32, "make-char32", 4,
0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (18, list, "list", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
diff --git a/module/Makefile.am b/module/Makefile.am
index a904a8f..2971fc6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -34,6 +34,7 @@ SOURCES =
\
ice-9/psyntax-pp.scm
\
system/base/pmatch.scm system/base/syntax.scm
\
system/base/compile.scm system/base/language.scm \
+ system/base/message.scm \
\
language/tree-il.scm \
language/ghil.scm language/glil.scm language/assembly.scm \
diff --git a/module/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
index 180d49e..63170de 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -132,6 +132,7 @@
;; meets the alignment requirements of `scm_objcode'. See
;; `scm_c_make_objcode_slice ()'.
(write-bytecode meta write get-addr '()))))
+ ((make-char32 ,x) (write-uint32-be x))
((load-unsigned-integer ,str) (write-loader str))
((load-integer ,str) (write-loader str))
((load-number ,str) (write-loader str))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 0f8448a..aec4eed 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -17,6 +17,7 @@
(define-module (language tree-il)
+ #:use-module (srfi srfi-1)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
@@ -38,11 +39,12 @@
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-body
<let-values> let-values? make-let-values let-values-src
let-values-names let-values-vars let-values-exp let-values-body
-
+
parse-tree-il
unparse-tree-il
tree-il->scheme
+ tree-il-fold
post-order!
pre-order!))
@@ -258,6 +260,51 @@
`(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body))))))
+
+(define (tree-il-fold leaf down up seed tree)
+ "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
+into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is
+invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
+and SEED is the current result, intially seeded with SEED.
+
+This is an implementation of `foldts' as described by Andy Wingo in
+``Applications of fold to XML transformation''."
+ (let loop ((tree tree)
+ (result seed))
+ (if (or (null? tree) (pair? tree))
+ (fold loop result tree)
+ (record-case tree
+ ((<lexical-set> exp)
+ (up tree (loop exp (down tree result))))
+ ((<module-set> exp)
+ (up tree (loop exp (down tree result))))
+ ((<toplevel-set> exp)
+ (up tree (loop exp (down tree result))))
+ ((<toplevel-define> exp)
+ (up tree (loop exp (down tree result))))
+ ((<conditional> test then else)
+ (up tree (loop else
+ (loop then
+ (loop test (down tree result))))))
+ ((<application> proc args)
+ (up tree (loop (cons proc args) (down tree result))))
+ ((<sequence> exps)
+ (up tree (loop exps (down tree result))))
+ ((<lambda> body)
+ (up tree (loop body (down tree result))))
+ ((<let> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<letrec> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<let-values> body)
+ (up tree (loop body (down tree result))))
+ (else
+ (leaf tree result))))))
+
(define (post-order! f x)
(let lp ((x x))
(record-case x
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 4ed796c..1b39b2d 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -20,9 +20,12 @@
(define-module (language tree-il analyze)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (system base syntax)
+ #:use-module (system base message)
#:use-module (language tree-il)
- #:export (analyze-lexicals))
+ #:export (analyze-lexicals
+ report-unused-variables))
;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage
@@ -308,3 +311,127 @@
(allocate! x #f 0)
allocation)
+
+
+;;;
+;;; Unused variable analysis.
+;;;
+
+;; <binding-info> records are used during tree traversals in
+;; `report-unused-variables'. They contain a list of the local vars
+;; currently in scope, a list of locals vars that have been referenced, and a
+;; "location stack" (the stack of `tree-il-src' values for each parent tree).
+(define-record-type <binding-info>
+ (make-binding-info vars refs locs)
+ binding-info?
+ (vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
+ (refs binding-info-refs) ;; (GENSYM ...)
+ (locs binding-info-locs)) ;; (LOCATION ...)
+
+(define (report-unused-variables tree)
+ "Report about unused variables in TREE. Return TREE."
+
+ (define (dotless-list lst)
+ ;; If LST is a dotted list, return a proper list equal to LST except that
+ ;; the very last element is a pair; otherwise return LST.
+ (let loop ((lst lst)
+ (result '()))
+ (cond ((null? lst)
+ (reverse result))
+ ((pair? lst)
+ (loop (cdr lst) (cons (car lst) result)))
+ (else
+ (loop '() (cons lst result))))))
+
+ (tree-il-fold (lambda (x info)
+ ;; X is a leaf: extend INFO's refs accordingly.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info)))
+ (record-case x
+ ((<lexical-ref> gensym)
+ (make-binding-info vars (cons gensym refs) locs))
+ (else info))))
+
+ (lambda (x info)
+ ;; Going down into X: extend INFO's variable list
+ ;; accordingly.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info))
+ (src (tree-il-src x)))
+ (define (extend inner-vars inner-names)
+ (append (map (lambda (var name)
+ (list var name src))
+ inner-vars
+ inner-names)
+ vars))
+ (record-case x
+ ((<lexical-set> gensym)
+ (make-binding-info vars (cons gensym refs)
+ (cons src locs)))
+ ((<lambda> vars names)
+ (let ((vars (dotless-list vars))
+ (names (dotless-list names)))
+ (make-binding-info (extend vars names) refs
+ (cons src locs))))
+ ((<let> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ ((<letrec> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ ((<let-values> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
+ (else info))))
+
+ (lambda (x info)
+ ;; Leaving X's scope: shrink INFO's variable list
+ ;; accordingly and reported unused nested variables.
+ (let ((refs (binding-info-refs info))
+ (vars (binding-info-vars info))
+ (locs (binding-info-locs info)))
+ (define (shrink inner-vars refs)
+ (for-each (lambda (var)
+ (let ((gensym (car var)))
+ ;; Don't report lambda parameters as
+ ;; unused.
+ (if (and (not (memq gensym refs))
+ (not (and (lambda? x)
+ (memq gensym
+ inner-vars))))
+ (let ((name (cadr var))
+ ;; We can get approximate
+ ;; source location by going up
+ ;; the LOCS location stack.
+ (loc (or (caddr var)
+ (find pair? locs))))
+ (warning 'unused-variable loc
name)))))
+ (filter (lambda (var)
+ (memq (car var) inner-vars))
+ vars))
+ (fold alist-delete vars inner-vars))
+
+ ;; For simplicity, we leave REFS untouched, i.e., with
+ ;; names of variables that are now going out of scope.
+ ;; It doesn't hurt as these are unique names, it just
+ ;; makes REFS unnecessarily fat.
+ (record-case x
+ ((<lambda> vars)
+ (let ((vars (dotless-list vars)))
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs))))
+ ((<let> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<letrec> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ ((<let-values> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
+ (else info))))
+ (make-binding-info '() '() '())
+ tree)
+ tree)
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index f1d86e3..bf46997 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -21,6 +21,7 @@
(define-module (language tree-il compile-glil)
#:use-module (system base syntax)
#:use-module (system base pmatch)
+ #:use-module (system base message)
#:use-module (ice-9 receive)
#:use-module (language glil)
#:use-module (system vm instruction)
@@ -44,10 +45,25 @@
(define *comp-module* (make-fluid))
+(define %warning-passes
+ `((unused-variable . ,report-unused-variables)))
+
(define (compile-glil x e opts)
+ (define warnings
+ (or (and=> (memq #:warnings opts) cadr)
+ '()))
+
(let* ((x (make-lambda (tree-il-src x) '() '() '() x))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
+
+ ;; Go throught the warning passes.
+ (for-each (lambda (kind)
+ (let ((warn (assoc-ref %warning-passes kind)))
+ (and (procedure? warn)
+ (warn x))))
+ warnings)
+
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()
(values (flatten-lambda x allocation)
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 311e35b..89d35bc 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -30,9 +30,11 @@
(define-module (scripts compile)
#:use-module ((system base compile) #:select (compile-file))
+ #:use-module (system base message)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (srfi srfi-37)
+ #:use-module (ice-9 format)
#:export (compile))
@@ -58,6 +60,17 @@
(fail "`-o' option cannot be specified more than once")
(alist-cons 'output-file arg result))))
+ (option '(#\W "warn") #t #f
+ (lambda (opt name arg result)
+ (if (string=? arg "help")
+ (begin
+ (show-warning-help)
+ (exit 0))
+ (let ((warnings (assoc-ref result 'warnings)))
+ (alist-cons 'warnings
+ (cons (string->symbol arg) warnings)
+ (alist-delete 'warnings result))))))
+
(option '(#\O "optimize") #f #f
(lambda (opt name arg result)
(alist-cons 'optimize? #t result)))
@@ -86,13 +99,27 @@ options."
;; default option values
'((input-files)
- (load-path))))
+ (load-path)
+ (warnings unsupported-warning))))
+
+(define (show-warning-help)
+ (format #t "The available warning types are:~%~%")
+ (for-each (lambda (wt)
+ (format #t " ~22A ~A~%"
+ (format #f "`~A'" (warning-type-name wt))
+ (warning-type-description wt)))
+ %warning-types)
+ (format #t "~%"))
(define (compile . args)
(let* ((options (parse-args args))
(help? (assoc-ref options 'help?))
- (compile-opts (if (assoc-ref options 'optimize?) '(#:O) '()))
+ (compile-opts (let ((o `(#:warnings
+ ,(assoc-ref options 'warnings))))
+ (if (assoc-ref options 'optimize?)
+ (cons #:O o)
+ o)))
(from (or (assoc-ref options 'from) 'scheme))
(to (or (assoc-ref options 'to) 'objcode))
(input-files (assoc-ref options 'input-files))
@@ -108,6 +135,9 @@ Compile each Guile source file FILE into a Guile object.
-L, --load-path=DIR add DIR to the front of the module load path
-o, --output=OFILE write output to OFILE
+ -W, --warn=WARNING emit warnings of type WARNING; use `--warn=help'
+ for a list of available warnings
+
-f, --from=LANG specify a source language other than `scheme'
-t, --to=LANG specify a target language other than `objcode'
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 7e26609..8470f39 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -21,6 +21,7 @@
(define-module (system base compile)
#:use-module (system base syntax)
#:use-module (system base language)
+ #:use-module (system base message)
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't
remember why tho
#:use-module (ice-9 regex)
#:use-module (ice-9 optargs)
@@ -213,6 +214,16 @@
(from (current-language))
(to 'value)
(opts '()))
+
+ (let ((warnings (memq #:warnings opts)))
+ (if (pair? warnings)
+ (let ((warnings (cadr warnings)))
+ ;; Sanity-check the requested warnings.
+ (for-each (lambda (w)
+ (or (lookup-warning-type w)
+ (warning 'unsupported-warning #f w)))
+ warnings))))
+
(receive (exp env cenv)
(compile-fold (compile-passes from to opts) x env opts)
exp))
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
new file mode 100644
index 0000000..6b68c56
--- /dev/null
+++ b/module/system/base/message.scm
@@ -0,0 +1,102 @@
+;;; User interface messages
+
+;; Copyright (C) 2009 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 as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; This module provide a simple interface to send messages to the user.
+;;; TODO: Internationalize messages.
+;;;
+;;; Code:
+
+(define-module (system base message)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:export (*current-warning-port* warning
+
+ warning-type? warning-type-name warning-type-description
+ warning-type-printer lookup-warning-type
+
+ %warning-types))
+
+
+;;;
+;;; Source location
+;;;
+
+(define (location-string loc)
+ (if (pair? loc)
+ (format #f "~a:~a:~a"
+ (or (assoc-ref loc 'filename) "<stdin>")
+ (1+ (assoc-ref loc 'line))
+ (assoc-ref loc 'column))
+ "<unknown-location>"))
+
+
+;;;
+;;; Warnings
+;;;
+
+(define *current-warning-port*
+ ;; The port where warnings are sent.
+ (make-fluid))
+
+(fluid-set! *current-warning-port* (current-error-port))
+
+(define-record-type <warning-type>
+ (make-warning-type name description printer)
+ warning-type?
+ (name warning-type-name)
+ (description warning-type-description)
+ (printer warning-type-printer))
+
+(define %warning-types
+ ;; List of know warning types.
+ (map (lambda (args)
+ (apply make-warning-type args))
+
+ `((unsupported-warning ;; a "meta warning"
+ "warn about unknown warning types"
+ ,(lambda (port unused name)
+ (format port "warning: unknown warning type `~A'~%"
+ name)))
+
+ (unused-variable
+ "report unused variables"
+ ,(lambda (port loc name)
+ (format port "~A: warning: unused variable `~A'~%"
+ loc name))))))
+
+(define (lookup-warning-type name)
+ "Return the warning type NAME or `#f' if not found."
+ (find (lambda (wt)
+ (eq? name (warning-type-name wt)))
+ %warning-types))
+
+(define (warning type location . args)
+ "Emit a warning of type TYPE for source location LOCATION (a source
+property alist) using the data in ARGS."
+ (let ((wt (lookup-warning-type type))
+ (port (fluid-ref *current-warning-port*)))
+ (if (warning-type? wt)
+ (apply (warning-type-printer wt)
+ port (location-string location)
+ args)
+ (format port "~A: unknown warning type `~A': ~A~%"
+ (location-string location) type args))))
+
+;;; message.scm ends here
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 6634dcd..896206b 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -21,8 +21,10 @@
#:use-module (test-suite lib)
#:use-module (system base compile)
#:use-module (system base pmatch)
+ #:use-module (system base message)
#:use-module (language tree-il)
- #:use-module (language glil))
+ #:use-module (language glil)
+ #:use-module (srfi srfi-13))
;; Of course, the GLIL that is emitted depends on the source info of the
;; input. Here we're not concerned about that, so we strip source
@@ -467,3 +469,116 @@
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))
+
+(with-test-prefix "tree-il-fold"
+
+ (pass-if "empty tree"
+ (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
+ (and (eq? mark
+ (tree-il-fold (lambda (x y) (set! leaf? #t) y)
+ (lambda (x y) (set! down? #t) y)
+ (lambda (x y) (set! up? #t) y)
+ mark
+ '()))
+ (not leaf?)
+ (not up?)
+ (not down?))))
+
+ (pass-if "lambda and application"
+ (let* ((leaves '()) (ups '()) (downs '())
+ (result (tree-il-fold (lambda (x y)
+ (set! leaves (cons x leaves))
+ (1+ y))
+ (lambda (x y)
+ (set! downs (cons x downs))
+ (1+ y))
+ (lambda (x y)
+ (set! ups (cons x ups))
+ (1+ y))
+ 0
+ (parse-tree-il
+ '(lambda (x y) (x1 y1)
+ (apply (toplevel +)
+ (lexical x x1)
+ (lexical y y1)))))))
+ (and (equal? (map strip-source leaves)
+ (list (make-lexical-ref #f 'y 'y1)
+ (make-lexical-ref #f 'x 'x1)
+ (make-toplevel-ref #f '+)))
+ (= (length downs) 2)
+ (equal? (reverse (map strip-source ups))
+ (map strip-source downs))))))
+
+
+;;;
+;;; Warnings.
+;;;
+
+;; Make sure we get English messages.
+(setlocale LC_ALL "C")
+
+(define (call-with-warnings thunk)
+ (let ((port (open-output-string)))
+ (with-fluid* *current-warning-port* port
+ thunk)
+ (let ((warnings (get-output-string port)))
+ (string-tokenize warnings
+ (char-set-complement (char-set #\newline))))))
+
+(define %opts-w-unused
+ '(#:warnings (unused-variable)))
+
+
+(with-test-prefix "warnings"
+
+ (pass-if "unknown warning type"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile #t #:opts '(#:warnings (does-not-exist)))))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unknown warning")))))
+
+ (with-test-prefix "unused-variable"
+
+ (pass-if "quiet"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(lambda (x y) (+ x y))
+ #:opts %opts-w-unused)))))
+
+ (pass-if "let/unused"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(lambda (x)
+ (let ((y (+ x 2)))
+ x))
+ #:opts %opts-w-unused)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unused variable `y'")))))
+
+ (pass-if "shadowed variable"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(lambda (x)
+ (let ((y x))
+ (let ((y (+ x 2)))
+ (+ x y))))
+ #:opts %opts-w-unused)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w) "unused variable `y'")))))
+
+ (pass-if "letrec"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(lambda ()
+ (letrec ((x (lambda () (y)))
+ (y (lambda () (x))))
+ y))
+ #:opts %opts-w-unused)))))
+
+ (pass-if "unused argument"
+ ;; Unused arguments should not be reported.
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(lambda (x y z) #t)
+ #:opts %opts-w-unused)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, string_abstraction2, updated. release_1-9-1-110-g8241a7d,
Michael Gran <=