[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-126-g42f9187 |
|
Date: |
Mon, 10 Aug 2009 12:54:34 +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=42f9187a79e160e77f572b3b153e46efd739a884
The branch, string_abstraction2 has been updated
via 42f9187a79e160e77f572b3b153e46efd739a884 (commit)
via aa131e9e673b36c73a5ae33091f7305f21351288 (commit)
via 9c44cd4559a5d04ba70bbd9ff47f41bfdfebd09d (commit)
via d97b69d9cd7207e947d22b2417defc58560e6457 (commit)
via 230cfcfb3e3558a6981487042cc5358d0da1f8bb (commit)
via 9059993fe0bf38045ae52552c68d985a3e3c5344 (commit)
via 9b29d6079184d2d92fef5a1b7eba79f39fa3ef82 (commit)
via 80af1168751e59a3ee5c4a79febb2da23d36112d (commit)
via bca488f186ce662e8c41b8ac1675fa2f03bb3fc2 (commit)
via 4dcd84998fc61e15920aea83c4420c7357b9be46 (commit)
via c21c89b1384415313cd4bc03e76d6e1507e48d7a (commit)
via dab0f9d55db2e2f4251265443ab0599e424a02c9 (commit)
via 7382f23e58725eef2f7a374ec101a42c0192527e (commit)
via f4863880f5ef539cb545999c19b6b5c0eec9382d (commit)
via 45cc8a38777c9f971b6aae4895311fcc9e15ce3e (commit)
via ee0ddd21211757664092eaec631c4c76f4aae74f (commit)
from 8241a7d8d27ffcccdc2fac180f55df7f655f3773 (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 42f9187a79e160e77f572b3b153e46efd739a884
Merge: 8241a7d8d27ffcccdc2fac180f55df7f655f3773
aa131e9e673b36c73a5ae33091f7305f21351288
Author: Michael Gran <address@hidden>
Date: Sun Aug 9 08:17:55 2009 -0700
Merge commit 'origin/master' into string_abstraction2
This does include the renaming of scm_to_encoded_stringn to
scm_to_stringn.
Conflicts:
libguile/numbers.c
libguile/ports.c
libguile/ports.h
libguile/print.c
libguile/print.h
libguile/read.c
libguile/socket.c
libguile/srfi-13.c
libguile/strings.c
libguile/strings.h
libguile/vm-i-loader.c
module/language/assembly/compile-bytecode.scm
-----------------------------------------------------------------------
Summary of changes:
configure.in => configure.ac | 23 +-
guile-readline/{configure.in => configure.ac} | 0
libguile/Makefile.am | 2 +-
libguile/numbers.c | 15 +
libguile/ports.c | 57 ++--
libguile/ports.h | 3 +-
libguile/print.c | 68 ++--
libguile/read.c | 247 +++++++-----
libguile/srfi-13.c | 6 +-
libguile/strings.c | 543 ++++++++++++-------------
libguile/strings.h | 54 ++-
libguile/vm-i-loader.c | 33 +-
libguile/vm-i-scheme.c | 36 ++-
libguile/vm-i-system.c | 14 +
module/Makefile.am | 15 +-
module/language/assembly/compile-bytecode.scm | 1 -
module/language/glil/compile-assembly.scm | 60 ++--
module/language/scheme/spec.scm | 6 +-
module/language/tree-il.scm | 80 ++++-
module/language/tree-il/analyze.scm | 262 ++++++++++--
module/language/tree-il/compile-glil.scm | 351 +++++++++++-----
module/language/tree-il/fix-letrec.scm | 180 ++++++++
module/language/tree-il/inline.scm | 81 ++++
module/language/tree-il/optimize.scm | 18 +-
module/language/tree-il/primitives.scm | 66 +++-
module/srfi/srfi-11.scm | 215 +++--------
module/system/base/syntax.scm | 89 +++--
test-suite/tests/asm-to-bytecode.test | 6 +-
test-suite/tests/tree-il.test | 2 +-
29 files changed, 1638 insertions(+), 895 deletions(-)
rename configure.in => configure.ac (99%)
rename guile-readline/{configure.in => configure.ac} (100%)
create mode 100644 module/language/tree-il/fix-letrec.scm
create mode 100644 module/language/tree-il/inline.scm
diff --git a/configure.in b/configure.ac
similarity index 99%
rename from configure.in
rename to configure.ac
index 7235f6f..b28cde8 100644
--- a/configure.in
+++ b/configure.ac
@@ -827,22 +827,19 @@ fi
dnl GMP tests
-AC_LIB_LINKFLAGS(gmp)
-AC_CHECK_LIB([gmp], [__gmpz_init], ,
- [AC_MSG_ERROR([GNU MP not found, see README])])
-
-# mpz_import is a macro so we need to include <gmp.h>
-AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <gmp.h>]],
- [[mpz_import (0, 0, 0, 0, 0, 0, 0); ]])],
+AC_LIB_HAVE_LINKFLAGS(gmp,
[],
- [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])])
+ [#include <gmp.h>],
+ [mpz_import (0, 0, 0, 0, 0, 0, 0);],
+ AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README]))
dnl GNU libunistring tests.
-if test "x$LTLIBUNISTRING" != "x"; then
- LIBS="$LTLIBUNISTRING $LIBS"
-else
- AC_MSG_ERROR([GNU libunistring is required, please install it.])
-fi
+AC_LIB_HAVE_LINKFLAGS(unistring,
+ [],
+ [#include <unistr.h>],
+ [u8_check ("foo", 3)]
+ AC_MSG_ERROR([GNU libunistring not found, see README]))
+
dnl i18n tests
#AC_CHECK_HEADERS([libintl.h])
diff --git a/guile-readline/configure.in b/guile-readline/configure.ac
similarity index 100%
rename from guile-readline/configure.in
rename to guile-readline/configure.ac
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 57f173e..0f34994 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -220,7 +220,7 @@ noinst_HEADERS = convert.i.c
\
noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
libguile_la_DEPENDENCIES = @LIBLOBJS@
-libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
+libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) $(LTLIBUNISTRING)
libguile_la_LDFLAGS = @LTLIBINTL@ -version-info
@LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@
-export-dynamic -no-undefined
# These are headers visible as <guile/mumble.h>
diff --git a/libguile/numbers.c b/libguile/numbers.c
index e74cc67..1d4bc1d 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -2658,17 +2658,26 @@ mem2decimal_from_point (SCM result, SCM mem,
case 'l': case 'L':
case 's': case 'S':
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
start = idx;
c = scm_i_string_ref (mem, idx);
if (c == '-')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
sign = -1;
c = scm_i_string_ref (mem, idx);
}
else if (c == '+')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
sign = 1;
c = scm_i_string_ref (mem, idx);
}
@@ -2785,6 +2794,8 @@ mem2ureal (SCM mem, unsigned int *p_idx,
SCM divisor;
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
divisor = mem2uinteger (mem, &idx, radix, &x);
if (scm_is_false (divisor))
@@ -2909,11 +2920,15 @@ mem2complex (SCM mem, unsigned int idx,
if (c == '+')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
sign = 1;
}
else if (c == '-')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
sign = -1;
}
else
diff --git a/libguile/ports.c b/libguile/ports.c
index c3d6123..a6289ee 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1127,26 +1127,32 @@ scm_fill_input (SCM port)
static void
update_port_lf (scm_t_wchar c, SCM port)
{
- if (c == '\a') {
- }
- else if (c == '\b') {
- SCM_DECCOL(port);
- }
- else if (c == '\n') {
- SCM_INCLINE(port);
- }
- else if (c == '\r') {
- SCM_ZEROCOL(port);
- }
- else if (c == '\t') {
- SCM_TABCOL(port);
- }
- else {
- SCM_INCCOL(port);
- }
+ if (c == '\a')
+ {
+ }
+ else if (c == '\b')
+ {
+ SCM_DECCOL (port);
+ }
+ else if (c == '\n')
+ {
+ SCM_INCLINE (port);
+ }
+ else if (c == '\r')
+ {
+ SCM_ZEROCOL (port);
+ }
+ else if (c == '\t')
+ {
+ SCM_TABCOL (port);
+ }
+ else
+ {
+ SCM_INCCOL (port);
+ }
}
-void
+void
scm_lfwrite (const char *ptr, size_t size, SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -1157,14 +1163,16 @@ scm_lfwrite (const char *ptr, size_t size, SCM port)
ptob->write (port, ptr, size);
- for (; size; ptr++, size--)
- update_port_lf ((scm_t_wchar)(unsigned char)*ptr, port);
+ for (; size; ptr++, size--)
+ update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_WRITE;
}
-void
+/* Write a scheme string STR to PORT from START inclusive to END
+ exclusive. */
+void
scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
{
size_t i, size = scm_i_string_length (str);
@@ -1181,8 +1189,8 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end,
SCM port)
end = size;
size = end - start;
- buf = scm_to_encoded_stringn (scm_c_substring (str, start, end), &len,
- pt->encoding, pt->ilseq_handler);
+ buf = scm_to_stringn (scm_c_substring (str, start, end), &len,
+ pt->encoding, pt->ilseq_handler);
ptob->write (port, buf, len);
free (buf);
@@ -1196,6 +1204,7 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end,
SCM port)
pt->rw_active = SCM_PORT_WRITE;
}
+/* Write a scheme string STR to PORT. */
void
scm_lfwrite_str (SCM str, SCM port)
{
@@ -1400,7 +1409,7 @@ scm_ungetc (scm_t_wchar c, SCM port)
int i;
wbuf[0] = c;
- buf = scm_to_encoded_stringn (str, &len, pt->encoding, pt->ilseq_handler);
+ buf = scm_to_stringn (str, &len, pt->encoding, pt->ilseq_handler);
for (i = len - 1; i >= 0; i--)
{
diff --git a/libguile/ports.h b/libguile/ports.h
index 93fd7f5..4f228fe 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -278,7 +278,8 @@ SCM_API size_t scm_c_read (SCM port, void *buffer, size_t
size);
SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
SCM_INTERNAL void scm_lfwrite_str (SCM str, SCM port);
-SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM
port);
+SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end,
+ SCM port);
SCM_API void scm_flush (SCM port);
SCM_API void scm_end_input (SCM port);
SCM_API int scm_fill_input (SCM port);
diff --git a/libguile/print.c b/libguile/print.c
index dac47d4..7a35f74 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -583,37 +583,38 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
break;
}
break;
- case scm_tc7_string:
- if (SCM_WRITINGP (pstate))
- {
- size_t i, j, len;
- static char const hex[]="0123456789abcdef";
- char buf[8];
+ case scm_tc7_string:
+ if (SCM_WRITINGP (pstate))
+ {
+ size_t i, j, len;
+ static char const hex[] = "0123456789abcdef";
+ char buf[8];
- scm_putc ('"', port);
- len = scm_i_string_length (exp);
- for (i = 0; i < len; ++i)
- {
- scm_t_wchar ch = scm_i_string_ref (exp, i);
+ scm_putc ('"', port);
+ len = scm_i_string_length (exp);
+ for (i = 0; i < len; ++i)
+ {
+ scm_t_wchar ch = scm_i_string_ref (exp, i);
int printed = 0;
-
+
if (ch == ' ' || ch == '\n')
{
scm_putc (ch, port);
printed = 1;
}
- else if (ch == '"' || ch == '\\')
- {
- scm_putc ('\\', port);
+ else if (ch == '"' || ch == '\\')
+ {
+ scm_putc ('\\', port);
scm_charprint (ch, port);
printed = 1;
- }
- else if (uc_is_general_category_withtable (ch,
UC_CATEGORY_MASK_L
- |
UC_CATEGORY_MASK_M
- |
UC_CATEGORY_MASK_N
- |
UC_CATEGORY_MASK_P
- |
UC_CATEGORY_MASK_S))
+ }
+ else
+ if (uc_is_general_category_withtable
+ (ch,
+ UC_CATEGORY_MASK_L | UC_CATEGORY_MASK_M |
+ UC_CATEGORY_MASK_N | UC_CATEGORY_MASK_P |
+ UC_CATEGORY_MASK_S))
{
/* Print the character since it is a graphic
character. */
@@ -648,18 +649,18 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
buf[0] = '\\';
buf[1] = 'x';
- buf[2] = hex [ch / 16];
- buf[3] = hex [ch % 16];
+ buf[2] = hex[ch / 16];
+ buf[3] = hex[ch % 16];
scm_lfwrite (buf, 4, port);
}
else if (ch <= 0xFFFF)
{
buf[0] = '\\';
buf[1] = 'u';
- buf[2] = hex [(ch & 0xF000) >> 12];
- buf[3] = hex [(ch & 0xF00) >> 8];
- buf[4] = hex [(ch & 0xF0) >> 4];
- buf[5] = hex [(ch & 0xF)];
+ buf[2] = hex[(ch & 0xF000) >> 12];
+ buf[3] = hex[(ch & 0xF00) >> 8];
+ buf[4] = hex[(ch & 0xF0) >> 4];
+ buf[5] = hex[(ch & 0xF)];
scm_lfwrite (buf, 6, port);
j = i + 1;
}
@@ -667,12 +668,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
buf[0] = '\\';
buf[1] = 'U';
- buf[2] = hex [(ch & 0xF00000) >> 20];
- buf[3] = hex [(ch & 0xF0000) >> 16];
- buf[4] = hex [(ch & 0xF000) >> 12];
- buf[5] = hex [(ch & 0xF00) >> 8];
- buf[6] = hex [(ch & 0xF0) >> 4];
- buf[7] = hex [(ch & 0xF)];
+ buf[2] = hex[(ch & 0xF00000) >> 20];
+ buf[3] = hex[(ch & 0xF0000) >> 16];
+ buf[4] = hex[(ch & 0xF000) >> 12];
+ buf[5] = hex[(ch & 0xF00) >> 8];
+ buf[6] = hex[(ch & 0xF0) >> 4];
+ buf[7] = hex[(ch & 0xF)];
scm_lfwrite (buf, 8, port);
j = i + 1;
}
@@ -844,7 +845,6 @@ scm_prin1 (SCM exp, SCM port, int writingp)
}
}
-
/* Print a character.
*/
void
diff --git a/libguile/read.c b/libguile/read.c
index eb7332a..cb80a6c 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -435,124 +435,153 @@ scm_read_string (int chr, SCM port)
unsigned c_str_len = 0;
scm_t_wchar c;
- str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
+ str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
while ('"' != (c = scm_getc (port)))
{
if (c == EOF)
- {
- str_eof:
- scm_i_input_error (FUNC_NAME, port,
- "end of file in string constant",
- SCM_EOL);
- }
+ {
+ str_eof:
+ scm_i_input_error (FUNC_NAME, port,
+ "end of file in string constant", SCM_EOL);
+ }
if (c_str_len + 1 >= scm_i_string_length (str))
- {
- SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
-
- str = scm_string_append (scm_list_2 (str, addy));
- }
+ {
+ SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
+
+ str = scm_string_append (scm_list_2 (str, addy));
+ }
if (c == '\\')
- {
- switch (c = scm_getc (port))
- {
- case EOF:
- goto str_eof;
- case '"':
- case '\\':
- break;
+ {
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ goto str_eof;
+ case '"':
+ case '\\':
+ break;
#if SCM_ENABLE_ELISP
- case '(':
- case ')':
- if (SCM_ESCAPED_PARENS_P)
- break;
- goto bad_escaped;
+ case '(':
+ case ')':
+ if (SCM_ESCAPED_PARENS_P)
+ break;
+ goto bad_escaped;
#endif
- case '\n':
- continue;
- case '0':
- c = '\0';
- break;
- case 'f':
- c = '\f';
- break;
- case 'n':
- c = '\n';
- break;
- case 'r':
- c = '\r';
- break;
- case 't':
- c = '\t';
- break;
- case 'a':
- c = '\007';
- break;
- case 'v':
- c = '\v';
- break;
- case 'x':
- {
- scm_t_wchar a, b;
- a = scm_getc (port);
- if (a == EOF) goto str_eof;
- b = scm_getc (port);
- if (b == EOF) goto str_eof;
- if ('0' <= a && a <= '9') a -= '0';
- else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
- else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
- else goto bad_escaped;
- if ('0' <= b && b <= '9') b -= '0';
- else if ('A' <= b && b <= 'F') b = b - 'A' + 10;
- else if ('a' <= b && b <= 'f') b = b - 'a' + 10;
- else goto bad_escaped;
- c = a * 16 + b;
- break;
- }
- case 'u':
- {
- scm_t_wchar a;
- int i;
- c = 0;
- for (i = 0; i < 4; i ++)
- {
- a = scm_getc (port);
- if (a == EOF)
- goto str_eof;
- if ('0' <= a && a <= '9') a -= '0';
- else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
- else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
- else goto bad_escaped;
- c = c * 16 + a;
- }
- break;
- }
- case 'U':
- {
- scm_t_wchar a;
- int i;
- c = 0;
- for (i = 0; i < 6; i ++)
- {
- a = scm_getc (port);
- if (a == EOF)
- goto str_eof;
- if ('0' <= a && a <= '9') a -= '0';
- else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
- else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
- else goto bad_escaped;
- c = c * 16 + a;
- }
- break;
- }
- default:
- bad_escaped:
- scm_i_input_error (FUNC_NAME, port,
- "illegal character in escape sequence: ~S",
- scm_list_1 (SCM_MAKE_CHAR (c)));
- }
- }
+ case '\n':
+ continue;
+ case '0':
+ c = '\0';
+ break;
+ case 'f':
+ c = '\f';
+ break;
+ case 'n':
+ c = '\n';
+ break;
+ case 'r':
+ c = '\r';
+ break;
+ case 't':
+ c = '\t';
+ break;
+ case 'a':
+ c = '\007';
+ break;
+ case 'v':
+ c = '\v';
+ break;
+ case 'x':
+ {
+ scm_t_wchar a, b;
+ a = scm_getc (port);
+ if (a == EOF)
+ goto str_eof;
+ b = scm_getc (port);
+ if (b == EOF)
+ goto str_eof;
+ if ('0' <= a && a <= '9')
+ a -= '0';
+ else if ('A' <= a && a <= 'F')
+ a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f')
+ a = a - 'a' + 10;
+ else
+ {
+ c = a;
+ goto bad_escaped;
+ }
+ if ('0' <= b && b <= '9')
+ b -= '0';
+ else if ('A' <= b && b <= 'F')
+ b = b - 'A' + 10;
+ else if ('a' <= b && b <= 'f')
+ b = b - 'a' + 10;
+ else
+ {
+ c = b;
+ goto bad_escaped;
+ }
+ c = a * 16 + b;
+ break;
+ }
+ case 'u':
+ {
+ scm_t_wchar a;
+ int i;
+ c = 0;
+ for (i = 0; i < 4; i++)
+ {
+ a = scm_getc (port);
+ if (a == EOF)
+ goto str_eof;
+ if ('0' <= a && a <= '9')
+ a -= '0';
+ else if ('A' <= a && a <= 'F')
+ a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f')
+ a = a - 'a' + 10;
+ else
+ {
+ c = a;
+ goto bad_escaped;
+ }
+ c = c * 16 + a;
+ }
+ break;
+ }
+ case 'U':
+ {
+ scm_t_wchar a;
+ int i;
+ c = 0;
+ for (i = 0; i < 6; i++)
+ {
+ a = scm_getc (port);
+ if (a == EOF)
+ goto str_eof;
+ if ('0' <= a && a <= '9')
+ a -= '0';
+ else if ('A' <= a && a <= 'F')
+ a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f')
+ a = a - 'a' + 10;
+ else
+ {
+ c = a;
+ goto bad_escaped;
+ }
+ c = c * 16 + a;
+ }
+ break;
+ }
+ default:
+ bad_escaped:
+ scm_i_input_error (FUNC_NAME, port,
+ "illegal character in escape sequence: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+ }
+ }
str = scm_i_string_start_writing (str);
scm_i_string_set_x (str, c_str_len++, c);
scm_i_string_stop_writing ();
diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index 4a0fb0e..ae88fb2 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -509,15 +509,15 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
len = cend - cstart;
SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
- scm_dynwind_begin (0);
- scm_dynwind_unwind_handler (stop_writing, NULL, SCM_F_WIND_EXPLICITLY);
target = scm_i_string_start_writing (target);
for (i = 0; i < cend - cstart; i++)
{
scm_i_string_set_x (target, ctstart + i,
scm_i_string_ref (s, cstart + i));
}
- scm_dynwind_end ();
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (target);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/libguile/strings.c b/libguile/strings.c
index 8fc9264..0e7f3ad 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -23,8 +23,8 @@
#endif
#include <string.h>
-#include <ctype.h>
#include <stdio.h>
+#include <ctype.h>
#include <uniconv.h>
#include <unistr.h>
@@ -104,12 +104,6 @@
static size_t lenhist[1001];
#endif
-/* Helper function for dynwind. */
-static void stop_writing (void *x)
-{
- scm_i_string_stop_writing ();
-}
-
static SCM
make_stringbuf (size_t len)
{
@@ -145,7 +139,6 @@ static SCM
make_wide_stringbuf (size_t len)
{
scm_t_wchar *mem;
-
#if SCM_DEBUG
if (len < 1000)
lenhist[len]++;
@@ -153,10 +146,10 @@ make_wide_stringbuf (size_t len)
lenhist[1000]++;
#endif
- mem = scm_gc_malloc (sizeof(scm_t_wchar) * (len+1), "string");
+ mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
mem[len] = 0;
return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_WIDE, (scm_t_bits) mem,
- (scm_t_bits) len, (scm_t_bits) 0);
+ (scm_t_bits) len, (scm_t_bits) 0);
}
/* Return a new stringbuf whose underlying storage consists of the LEN+1
@@ -182,12 +175,12 @@ scm_i_stringbuf_free (SCM buf)
if (!STRINGBUF_INLINE (buf))
{
if (!STRINGBUF_WIDE (buf))
- scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
- STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
+ scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
+ STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
else
- scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
- sizeof (scm_t_wchar) * (STRINGBUF_OUTLINE_LENGTH (buf) +
1),
- "string");
+ scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
+ sizeof (scm_t_wchar) * (STRINGBUF_OUTLINE_LENGTH (buf)
+ + 1), "string");
}
}
@@ -205,9 +198,10 @@ widen_stringbuf (SCM buf)
{
len = STRINGBUF_INLINE_LENGTH (buf);
- mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len+1), "string");
- for (i = 0; i < len; i ++)
- mem[i] = (scm_t_wchar) (unsigned char) STRINGBUF_INLINE_CHARS
(buf)[i];
+ mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
+ for (i = 0; i < len; i++)
+ mem[i] =
+ (scm_t_wchar) (unsigned char) STRINGBUF_INLINE_CHARS (buf)[i];
mem[len] = 0;
SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_INLINE);
@@ -219,9 +213,10 @@ widen_stringbuf (SCM buf)
{
len = STRINGBUF_OUTLINE_LENGTH (buf);
- mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len+1), "string");
- for (i = 0; i < len; i ++)
- mem[i] = (scm_t_wchar) (unsigned char) STRINGBUF_OUTLINE_CHARS
(buf)[i];
+ mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
+ for (i = 0; i < len; i++)
+ mem[i] =
+ (scm_t_wchar) (unsigned char) STRINGBUF_OUTLINE_CHARS (buf)[i];
mem[len] = 0;
scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), len + 1, "string");
@@ -277,14 +272,14 @@ scm_i_make_string (size_t len, char **charsp)
}
SCM
-scm_i_make_wide_string (size_t len, scm_t_wchar **charsp)
+scm_i_make_wide_string (size_t len, scm_t_wchar ** charsp)
{
SCM buf = make_wide_stringbuf (len);
SCM res;
if (charsp)
*charsp = STRINGBUF_WIDE_CHARS (buf);
- res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
- (scm_t_bits)0, (scm_t_bits) len);
+ res = scm_double_cell (STRING_TAG, SCM_UNPACK (buf),
+ (scm_t_bits) 0, (scm_t_bits) len);
return res;
}
@@ -350,20 +345,20 @@ scm_i_substring_copy (SCM str, size_t start, size_t end)
{
my_buf = make_stringbuf (len);
memcpy (STRINGBUF_CHARS (my_buf),
- STRINGBUF_CHARS (buf) + str_start + start, len);
+ STRINGBUF_CHARS (buf) + str_start + start, len);
}
else
{
my_buf = make_wide_stringbuf (len);
u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (my_buf),
- (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + str_start + start,
- len);
+ (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + str_start
+ + start), len);
/* Even though this string is wide, the substring may be narrow.
- Consider adding code to narrow string. */
+ Consider adding code to narrow string. */
}
scm_remember_upto_here_1 (buf);
- return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf),
- (scm_t_bits)0, (scm_t_bits) len);
+ return scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf),
+ (scm_t_bits) 0, (scm_t_bits) len);
}
SCM
@@ -450,9 +445,9 @@ scm_i_string_chars (SCM str)
if (scm_i_is_narrow_string (str))
return STRINGBUF_CHARS (buf) + start;
else
- scm_misc_error (NULL, "Invalid access to chars of wide string: ~s",
- scm_list_1 (str));
- return NULL;
+ scm_misc_error (NULL, "Invalid read access of chars of wide string: ~s",
+ scm_list_1 (str));
+ return NULL;
}
const scm_t_wchar *
@@ -465,16 +460,19 @@ scm_i_string_wide_chars (SCM str)
if (!scm_i_is_narrow_string (str))
return STRINGBUF_WIDE_CHARS (buf) + start;
else
- scm_misc_error (NULL, "Invalid access to chars of narrow string: ~s",
- scm_list_1 (str));
+ scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s",
+ scm_list_1 (str));
}
+/* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to
+ a new string buffer, so that it can be modified without modifying
+ other strings. */
SCM
scm_i_string_start_writing (SCM orig_str)
{
SCM buf, str = orig_str;
size_t start;
-
+
get_str_buf_start (&str, &buf, &start);
if (IS_RO_STRING (str))
scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (orig_str));
@@ -482,39 +480,41 @@ scm_i_string_start_writing (SCM orig_str)
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
if (STRINGBUF_SHARED (buf))
{
+ /* Clone the stringbuf. */
size_t len = STRING_LENGTH (str);
SCM new_buf;
-
+
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+
if (scm_i_is_narrow_string (str))
- {
- /* Clone stringbuf. For this, we put all threads to sleep.
- */
- new_buf = make_stringbuf (len);
- memcpy (STRINGBUF_CHARS (new_buf),
- STRINGBUF_CHARS (buf) + STRING_START (str), len);
-
- }
+ {
+ new_buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_CHARS (buf) + STRING_START (str), len);
+
+ }
else
- {
- new_buf = make_wide_stringbuf (len);
- u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
- (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + STRING_START
(str),
- len);
- }
+ {
+ new_buf = make_wide_stringbuf (len);
+ u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
+ (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf)
+ + STRING_START (str)), len);
+ }
scm_i_thread_put_to_sleep ();
SET_STRING_STRINGBUF (str, new_buf);
start -= STRING_START (str);
SET_STRING_START (str, 0);
scm_i_thread_wake_up ();
-
+
buf = new_buf;
-
+
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
}
return orig_str;
}
+/* Return a pointer to the chars of a string that fits in a Latin-1
+ encoding. */
char *
scm_i_string_writable_chars (SCM str)
{
@@ -522,9 +522,15 @@ scm_i_string_writable_chars (SCM str)
size_t start;
get_str_buf_start (&str, &buf, &start);
- return STRINGBUF_CHARS (buf) + start;
+ if (scm_i_is_narrow_string (str))
+ return STRINGBUF_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid write access of chars of wide string: ~s",
+ scm_list_1 (str));
+ return NULL;
}
+/* Return a pointer to the Unicode codepoints of a string. */
static scm_t_wchar *
scm_i_string_writable_wide_chars (SCM str)
{
@@ -532,7 +538,11 @@ scm_i_string_writable_wide_chars (SCM str)
size_t start;
get_str_buf_start (&str, &buf, &start);
- return STRINGBUF_WIDE_CHARS (buf) + start;
+ if (!scm_i_is_narrow_string (str))
+ return STRINGBUF_WIDE_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s",
+ scm_list_1 (str));
}
void
@@ -562,21 +572,21 @@ scm_i_string_contains_char (SCM str, char ch)
if (scm_i_is_narrow_string (str))
{
while (i < len)
- {
- if (scm_i_string_chars (str)[i] == ch)
- return 1;
- i++;
- }
+ {
+ if (scm_i_string_chars (str)[i] == ch)
+ return 1;
+ i++;
+ }
}
else
{
while (i < len)
- {
- if (scm_i_string_wide_chars (str)[i]
- == (scm_t_wchar) (unsigned char) ch)
- return 1;
- i++;
- }
+ {
+ if (scm_i_string_wide_chars (str)[i]
+ == (scm_t_wchar) (unsigned char) ch)
+ return 1;
+ i++;
+ }
}
return 0;
}
@@ -596,10 +606,10 @@ scm_i_string_strcmp (SCM sstr, size_t start_x, const char
*cstr)
const scm_t_wchar *a = scm_i_string_wide_chars (sstr) + start_x;
const char *b = cstr;
for (i = 0; i < strlen (b); i++)
- {
- if (a[i] != (unsigned char) b[i])
- return 1;
- }
+ {
+ if (a[i] != (unsigned char) b[i])
+ return 1;
+ }
}
return 0;
}
@@ -622,7 +632,6 @@ scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr)
}
}
-
/* Symbols.
Basic symbol creation and accessing is done here, the rest is in
@@ -658,19 +667,20 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
{
/* make new buf. */
if (scm_i_is_narrow_string (name))
- {
- SCM new_buf = make_stringbuf (length);
- memcpy (STRINGBUF_CHARS (new_buf),
- STRINGBUF_CHARS (buf) + start, length);
- buf = new_buf;
- }
+ {
+ SCM new_buf = make_stringbuf (length);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_CHARS (buf) + start, length);
+ buf = new_buf;
+ }
else
- {
- SCM new_buf = make_wide_stringbuf (length);
- u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
- (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + start, length);
- buf = new_buf;
- }
+ {
+ SCM new_buf = make_wide_stringbuf (length);
+ u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
+ (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + start,
+ length);
+ buf = new_buf;
+ }
}
return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
(scm_t_bits) hash, SCM_UNPACK (props));
@@ -733,10 +743,11 @@ scm_i_symbol_chars (SCM sym)
if (!STRINGBUF_WIDE (buf))
return STRINGBUF_CHARS (buf);
else
- scm_misc_error (NULL, "Invalid access of chars of a wide symbol ~S",
- scm_list_1 (sym));
+ scm_misc_error (NULL, "Invalid access of chars of a wide symbol ~S",
+ scm_list_1 (sym));
}
+/* Return a pointer to the Unicode codepoints of a symbol's name. */
const scm_t_wchar *
scm_i_symbol_wide_chars (SCM sym)
{
@@ -746,8 +757,8 @@ scm_i_symbol_wide_chars (SCM sym)
if (STRINGBUF_WIDE (buf))
return STRINGBUF_WIDE_CHARS (buf);
else
- scm_misc_error (NULL, "Invalid access of chars of a narrow symbol ~S",
- scm_list_1 (sym));
+ scm_misc_error (NULL, "Invalid access of chars of a narrow symbol ~S",
+ scm_list_1 (sym));
}
SCM
@@ -791,11 +802,11 @@ scm_i_symbol_strcmp (SCM sym, char *str)
else
{
if (strlen(str) != scm_i_symbol_length (sym))
- return 1;
+ return 1;
for (i = 0; i < scm_i_symbol_length (sym); i++)
- if ((scm_t_uint32) scm_i_symbol_wide_chars (sym)[i]
- != (unsigned char) str[i])
- return 1;
+ if ((scm_t_uint32) scm_i_symbol_wide_chars (sym)[i]
+ != (unsigned char) str[i])
+ return 1;
return 0;
}
}
@@ -809,9 +820,7 @@ SCM scm_sys_string_dump (SCM);
SCM scm_sys_symbol_dump (SCM);
SCM scm_sys_stringbuf_hist (void);
-SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
- (SCM str),
- "")
+SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), "")
#define FUNC_NAME s_scm_sys_string_dump
{
SCM_VALIDATE_STRING (1, str);
@@ -833,27 +842,25 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
SCM buf = STRING_STRINGBUF (str);
fprintf (stderr, " buf: %p\n", buf);
if (scm_i_is_narrow_string (str))
- fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
+ fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
else
- fprintf (stderr, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf));
+ fprintf (stderr, " chars: %p\n", STRINGBUF_WIDE_CHARS (buf));
fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
if (STRINGBUF_SHARED (buf))
- fprintf (stderr, " shared: true\n");
+ fprintf (stderr, " shared: true\n");
else
- fprintf (stderr, " shared: false\n");
+ fprintf (stderr, " shared: false\n");
if (STRINGBUF_INLINE (buf))
- fprintf (stderr, " inline: true\n");
+ fprintf (stderr, " inline: true\n");
else
- fprintf (stderr, " inline: false\n");
+ fprintf (stderr, " inline: false\n");
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
- (SCM sym),
- "")
+SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), "")
#define FUNC_NAME s_scm_sys_symbol_dump
{
SCM_VALIDATE_SYMBOL (1, sym);
@@ -881,9 +888,7 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
- (void),
- "")
+SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "")
#define FUNC_NAME s_scm_sys_stringbuf_hist
{
int i;
@@ -919,39 +924,46 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
#define FUNC_NAME s_scm_string
{
SCM result;
+ SCM rest;
size_t len;
size_t p = 0;
+ long i;
- {
- long i = scm_ilength (chrs);
-
- SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
- len = (size_t) i;
- }
+ /* Verify that this is a list of chars. */
+ i = scm_ilength (chrs);
+ len = (size_t) i;
+ rest = chrs;
- result = scm_i_make_string (len, NULL);
+ SCM_ASSERT (len >= 0, chrs, SCM_ARG1, FUNC_NAME);
+ while (len > 0 && scm_is_pair (rest))
+ {
+ SCM elt = SCM_CAR (rest);
+ SCM_VALIDATE_CHAR (SCM_ARGn, elt);
+ rest = SCM_CDR (rest);
+ len--;
+ scm_remember_upto_here_1 (elt);
+ }
- scm_dynwind_begin (0);
- scm_dynwind_unwind_handler (stop_writing, NULL, SCM_F_WIND_EXPLICITLY);
+ /* Construct a string containing this list of chars. */
+ len = (size_t) i;
+ rest = chrs;
+ result = scm_i_make_string (len, NULL);
result = scm_i_string_start_writing (result);
- while (len > 0 && scm_is_pair (chrs))
+ while (len > 0 && scm_is_pair (rest))
{
- SCM elt = SCM_CAR (chrs);
-
- SCM_VALIDATE_CHAR (SCM_ARGn, elt);
+ SCM elt = SCM_CAR (rest);
scm_i_string_set_x (result, p, SCM_CHAR (elt));
p++;
- chrs = SCM_CDR (chrs);
+ rest = SCM_CDR (rest);
len--;
scm_remember_upto_here_1 (elt);
}
- scm_dynwind_end ();
-
+ scm_i_string_stop_writing ();
if (len > 0)
scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
- if (!scm_is_null (chrs))
+ if (!scm_is_null (rest))
scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
return result;
@@ -977,17 +989,14 @@ scm_c_make_string (size_t len, SCM chr)
size_t p;
SCM res = scm_i_make_string (len, NULL);
- scm_dynwind_begin (0);
- scm_dynwind_unwind_handler (stop_writing, NULL, SCM_F_WIND_EXPLICITLY);
-
- res = scm_i_string_start_writing (res);
if (!SCM_UNBNDP (chr))
{
SCM_VALIDATE_CHAR (0, chr);
- for (p = 0; p < len; p ++)
- scm_i_string_set_x (res, p, SCM_CHAR (chr));
+ res = scm_i_string_start_writing (res);
+ for (p = 0; p < len; p++)
+ scm_i_string_set_x (res, p, SCM_CHAR (chr));
+ scm_i_string_stop_writing ();
}
- scm_dynwind_end ();
return res;
}
@@ -1003,9 +1012,9 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_string_width, "string-width", 1, 0, 0,
- (SCM string),
- "Return the bytes used to represent a character in @var{string}."
+SCM_DEFINE (scm_string_width, "string-width", 1, 0, 0,
+ (SCM string),
+ "Return the bytes used to represent a character in @var{string}."
"This will return 1 or 4.")
#define FUNC_NAME s_scm_string_width
{
@@ -1027,8 +1036,8 @@ scm_c_string_length (SCM string)
SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
(SCM str, SCM k),
- "Return character @var{k} of @var{str} using zero-origin\n"
- "indexing. @var{k} must be a valid index of @var{str}.")
+ "Return character @var{k} of @var{str} using zero-origin\n"
+ "indexing. @var{k} must be a valid index of @var{str}.")
#define FUNC_NAME s_scm_string_ref
{
size_t len;
@@ -1063,9 +1072,9 @@ scm_c_string_ref (SCM str, size_t p)
SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
(SCM str, SCM k, SCM chr),
- "Store @var{chr} in element @var{k} of @var{str} and return\n"
- "an unspecified value. @var{k} must be a valid index of\n"
- "@var{str}.")
+ "Store @var{chr} in element @var{k} of @var{str} and return\n"
+ "an unspecified value. @var{k} must be a valid index of\n"
+ "@var{str}.")
#define FUNC_NAME s_scm_string_set_x
{
size_t len;
@@ -1080,7 +1089,6 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
scm_out_of_range (NULL, k);
SCM_VALIDATE_CHAR (3, chr);
-
str = scm_i_string_start_writing (str);
scm_i_string_set_x (str, idx, SCM_CHAR (chr));
scm_i_string_stop_writing ();
@@ -1094,7 +1102,6 @@ scm_c_string_set_x (SCM str, size_t p, SCM chr)
{
if (p >= scm_i_string_length (str))
scm_out_of_range (NULL, scm_from_size_t (p));
-
str = scm_i_string_start_writing (str);
scm_i_string_set_x (str, p, SCM_CHAR (chr));
scm_i_string_stop_writing ();
@@ -1198,7 +1205,7 @@ SCM_DEFINE (scm_substring_shared, "substring/shared", 2,
1, 0,
SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
(SCM args),
- "Return a newly allocated string whose characters form the\n"
+ "Return a newly allocated string whose characters form the\n"
"concatenation of the given strings, @var{args}.")
#define FUNC_NAME s_scm_string_append
{
@@ -1211,43 +1218,41 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
int i;
SCM_VALIDATE_REST_ARGUMENT (args);
- for (l = args; !scm_is_null (l); l = SCM_CDR (l))
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
{
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
len += scm_i_string_length (s);
if (!scm_i_is_narrow_string (s))
- wide = 1;
+ wide = 1;
}
-
if (!wide)
res = scm_i_make_string (len, &data);
else
res = scm_i_make_wide_string (len, &wdata);
- for (l = args; !scm_is_null (l); l = SCM_CDR (l))
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
{
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
len = scm_i_string_length (s);
if (!wide)
- {
- memcpy (data, scm_i_string_chars (s), len);
- data += len;
- }
+ {
+ memcpy (data, scm_i_string_chars (s), len);
+ data += len;
+ }
else
- {
- if (scm_i_is_narrow_string (s))
- {
- for (i = 0; i < scm_i_string_length (s); i++)
- wdata[i] = (unsigned char) scm_i_string_chars (s)[i];
- }
- else
- u32_cpy ((scm_t_uint32 *) wdata,
- (scm_t_uint32 *) scm_i_string_wide_chars (s),
- len);
- wdata += len;
- }
+ {
+ if (scm_i_is_narrow_string (s))
+ {
+ for (i = 0; i < scm_i_string_length (s); i++)
+ wdata[i] = (unsigned char) scm_i_string_chars (s)[i];
+ }
+ else
+ u32_cpy ((scm_t_uint32 *) wdata,
+ (scm_t_uint32 *) scm_i_string_wide_chars (s), len);
+ wdata += len;
+ }
scm_remember_upto_here_1 (s);
}
return res;
@@ -1272,9 +1277,8 @@ scm_from_locale_stringn (const char *str, size_t len)
SCM inport;
scm_t_port *pt;
- if (len == (size_t)-1)
+ if (len == (size_t) -1)
len = strlen (str);
-
if (len == 0)
return scm_nullstr;
@@ -1296,42 +1300,42 @@ scm_from_locale_stringn (const char *str, size_t len)
u32len = 0;
u32 = (scm_t_wchar *) u32_conv_from_encoding (enc,
- scm_i_get_conversion_strategy
(SCM_BOOL_F),
- str, len,
- NULL,
- NULL, &u32len);
+ scm_i_get_conversion_strategy
(SCM_BOOL_F),
+ str, len,
+ NULL,
+ NULL, &u32len);
if (u32 == NULL)
{
- if (errno == ENOMEM)
- scm_memory_error ("locale string conversion");
+ if (errno == ENOMEM)
+ scm_memory_error ("locale string conversion");
else
- {
- /* Input encoding error should only occur when there
- are invalid sequences in the input string. */
- SCM escaped_str;
- /* Try to generate an string for the error message. */
- escaped_str = scm_i_make_string (len, &dst);
- memcpy (dst, str, len);
- scm_misc_error (NULL, "input locale conversion error from ~s: ~s",
- scm_list_2 (scm_from_locale_string (enc),
- escaped_str));
- }
+ {
+ /* Input encoding error should only occur when there
+ are invalid sequences in the input string. */
+ SCM escaped_str;
+ /* Try to generate an string for the error message. */
+ escaped_str = scm_i_make_string (len, &dst);
+ memcpy (dst, str, len);
+ scm_misc_error (NULL, "input locale conversion error from ~s: ~s",
+ scm_list_2 (scm_from_locale_string (enc),
+ escaped_str));
+ }
}
i = 0;
while (i < u32len)
if (u32[i++] > 0xFF)
{
- wide = 1;
- break;
+ wide = 1;
+ break;
}
if (!wide)
{
res = scm_i_make_string (u32len, &dst);
for (i = 0; i < u32len; i ++)
- dst[i] = (char) (unsigned char) u32[i];
+ dst[i] = (char) (unsigned char) u32[i];
dst[u32len] = '\0';
}
else
@@ -1365,21 +1369,20 @@ scm_take_locale_stringn (char *str, size_t len)
{
SCM buf, res;
- if (len == (size_t)-1)
+ if (len == (size_t) -1)
len = strlen (str);
else
{
/* Ensure STR is null terminated. A realloc for 1 extra byte should
often be satisfied from the alignment padding after the block, with
no actual data movement. */
- str = scm_realloc (str, len+1);
+ str = scm_realloc (str, len + 1);
str[len] = '\0';
}
buf = scm_i_take_stringbufn (str, len);
res = scm_double_cell (STRING_TAG,
- SCM_UNPACK (buf),
- (scm_t_bits) 0, (scm_t_bits) len);
+ SCM_UNPACK (buf), (scm_t_bits) 0, (scm_t_bits) len);
return res;
}
@@ -1389,6 +1392,8 @@ scm_take_locale_string (char *str)
return scm_take_locale_stringn (str, -1);
}
+/* Change libunistring escapes (\uXXXX and \UXXXXXXXX) to \xXX \uXXXX
+ and \UXXXXXX. */
static void
unistring_escapes_to_guile_escapes (char **bufp, size_t *lenp)
{
@@ -1402,50 +1407,48 @@ unistring_escapes_to_guile_escapes (char **bufp, size_t
*lenp)
while (i < *lenp)
{
if ((i <= *lenp - 6)
- && before[i] == '\\'
- && before[i+1] == 'u'
- && before[i+2] == '0'
- && before[i+3] == '0')
- {
- /* Convert \u00NN to \xNN */
- after[j] = '\\';
- after[j+1] = 'x';
- after[j+2] = tolower(before[i+4]);
- after[j+3] = tolower(before[i+5]);
- i += 6;
- j += 4;
- }
+ && before[i] == '\\'
+ && before[i + 1] == 'u'
+ && before[i + 2] == '0' && before[i + 3] == '0')
+ {
+ /* Convert \u00NN to \xNN */
+ after[j] = '\\';
+ after[j + 1] = 'x';
+ after[j + 2] = tolower (before[i + 4]);
+ after[j + 3] = tolower (before[i + 5]);
+ i += 6;
+ j += 4;
+ }
else if ((i <= *lenp - 10)
- && before[i] == '\\'
- && before[i+1] == 'U'
- && before[i+2] == '0'
- && before[i+3] == '0')
- {
- /* Convert \U00NNNNNN to \UNNNNNN */
- after[j] = '\\';
- after[j+1] = 'U';
- after[j+2] = tolower(before[i+4]);
- after[j+3] = tolower(before[i+5]);
- after[j+4] = tolower(before[i+6]);
- after[j+5] = tolower(before[i+7]);
- after[j+6] = tolower(before[i+8]);
- after[j+7] = tolower(before[i+9]);
- i += 10;
- j += 8;
- }
+ && before[i] == '\\'
+ && before[i + 1] == 'U'
+ && before[i + 2] == '0' && before[i + 3] == '0')
+ {
+ /* Convert \U00NNNNNN to \UNNNNNN */
+ after[j] = '\\';
+ after[j + 1] = 'U';
+ after[j + 2] = tolower (before[i + 4]);
+ after[j + 3] = tolower (before[i + 5]);
+ after[j + 4] = tolower (before[i + 6]);
+ after[j + 5] = tolower (before[i + 7]);
+ after[j + 6] = tolower (before[i + 8]);
+ after[j + 7] = tolower (before[i + 9]);
+ i += 10;
+ j += 8;
+ }
else
- {
- after[j] = before[i];
- i ++;
- j ++;
- }
+ {
+ after[j] = before[i];
+ i++;
+ j++;
+ }
}
*lenp = j;
after = scm_realloc (after, j);
}
char *
-scm_to_locale_stringn (SCM str, size_t *lenp)
+scm_to_locale_stringn (SCM str, size_t * lenp)
{
SCM outport;
scm_t_port *pt;
@@ -1460,14 +1463,14 @@ scm_to_locale_stringn (SCM str, size_t *lenp)
else
enc = NULL;
- return scm_to_encoded_stringn (str, lenp,
- enc,
- scm_i_get_conversion_strategy (SCM_BOOL_F));
+ return scm_to_stringn (str, lenp,
+ enc,
+ scm_i_get_conversion_strategy (SCM_BOOL_F));
}
char *
-scm_to_encoded_stringn (SCM str, size_t *lenp, const char *encoding,
- enum iconv_ilseq_handler handler)
+scm_to_stringn (SCM str, size_t *lenp, const char *encoding,
+ enum iconv_ilseq_handler handler)
{
char *buf;
size_t ilen, len, i;
@@ -1476,7 +1479,6 @@ scm_to_encoded_stringn (SCM str, size_t *lenp, const char
*encoding,
if (!scm_is_string (str))
scm_wrong_type_arg_msg (NULL, 0, str, "string");
-
ilen = scm_i_string_length (str);
if (ilen == 0)
@@ -1484,33 +1486,32 @@ scm_to_encoded_stringn (SCM str, size_t *lenp, const
char *encoding,
buf = scm_malloc (1);
buf[0] = '\0';
if (lenp)
- *lenp = 0;
+ *lenp = 0;
return buf;
}
-
if (lenp == NULL)
for (i = 0; i < ilen; i++)
if (scm_i_string_ref (str, i) == '\0')
- scm_misc_error (NULL,
- "string contains #\\nul character: ~S",
- scm_list_1 (str));
-
+ scm_misc_error (NULL,
+ "string contains #\\nul character: ~S",
+ scm_list_1 (str));
+
if (scm_i_is_narrow_string (str) && (encoding == NULL))
{
if (lenp)
- {
- buf = scm_malloc (ilen);
- memcpy (buf, scm_i_string_chars (str), ilen);
- *lenp = ilen;
- return buf;
- }
+ {
+ buf = scm_malloc (ilen);
+ memcpy (buf, scm_i_string_chars (str), ilen);
+ *lenp = ilen;
+ return buf;
+ }
else
- {
- buf = scm_malloc (ilen + 1);
- memcpy (buf, scm_i_string_chars (str), ilen);
- buf[ilen] = '\0';
- return buf;
- }
+ {
+ buf = scm_malloc (ilen + 1);
+ memcpy (buf, scm_i_string_chars (str), ilen);
+ buf[ilen] = '\0';
+ return buf;
+ }
}
buf = NULL;
@@ -1521,41 +1522,40 @@ scm_to_encoded_stringn (SCM str, size_t *lenp, const
char *encoding,
if (scm_i_is_narrow_string (str))
{
ret = mem_iconveh (scm_i_string_chars (str), ilen,
- "ISO-8859-1", enc,
- handler, NULL,
- &buf, &len);
+ "ISO-8859-1", enc,
+ handler, NULL,
+ &buf, &len);
if (ret == 0 && handler == iconveh_escape_sequence)
- unistring_escapes_to_guile_escapes (&buf, &len);
+ unistring_escapes_to_guile_escapes (&buf, &len);
if (ret != 0)
- {
- scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
- scm_list_2 (scm_from_locale_string (enc),
- str));
- }
+ {
+ scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
+ scm_list_2 (scm_from_locale_string (enc),
+ str));
+ }
}
else
{
buf = u32_conv_to_encoding (enc,
- handler,
- (scm_t_uint32 *) scm_i_string_wide_chars
(str),
- ilen,
- NULL,
- NULL, &len);
+ handler,
+ (scm_t_uint32 *) scm_i_string_wide_chars
(str),
+ ilen,
+ NULL,
+ NULL, &len);
if (buf == NULL)
- {
- scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
- scm_list_2 (scm_from_locale_string (enc),
- str));
- }
+ {
+ scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
+ scm_list_2 (scm_from_locale_string (enc),
+ str));
+ }
}
-
if (lenp)
*lenp = len;
else
{
- buf = scm_realloc (buf, len+1);
+ buf = scm_realloc (buf, len + 1);
buf[len] = '\0';
}
@@ -1563,7 +1563,6 @@ scm_to_encoded_stringn (SCM str, size_t *lenp, const char
*encoding,
return buf;
}
-
char *
scm_to_locale_string (SCM str)
{
@@ -1581,10 +1580,8 @@ scm_to_locale_stringbuf (SCM str, char *buf, size_t
max_len)
{
size_t len;
char *result = NULL;
-
if (!scm_is_string (str))
scm_wrong_type_arg_msg (NULL, 0, str, "string");
-
result = scm_to_locale_stringn (str, &len);
memcpy (buf, result, (len > max_len) ? max_len : len);
@@ -1596,7 +1593,7 @@ scm_to_locale_stringbuf (SCM str, char *buf, size_t
max_len)
/* converts C scm_array of strings to SCM scm_list of strings. */
/* If argc < 0, a null terminated scm_array is assumed. */
-SCM
+SCM
scm_makfromstrs (int argc, char **argv)
{
int i = argc;
@@ -1729,9 +1726,9 @@ scm_i_deprecated_string_length (SCM str)
void
scm_init_strings ()
{
-#include "libguile/strings.x"
scm_nullstr = scm_i_make_string (0, NULL);
+#include "libguile/strings.x"
}
diff --git a/libguile/strings.h b/libguile/strings.h
index e702aa4..a1f698a 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -23,6 +23,7 @@
+#include <uniconv.h>
#include "libguile/__scm.h"
@@ -46,26 +47,37 @@
Internal, low level interface to the character arrays
- - Use scm_i_string_chars to get a pointer to the byte array of a
- string for reading. Use scm_i_string_length to get the number of
- bytes in that array. The array is not null-terminated.
+ - Use scm_is_narrow_string to determine is the string is narrow or
+ wide.
+
+ - Use scm_i_string_chars or scm_i_string_wide_chars to get a
+ pointer to the byte or scm_t_wchar array of a string for reading.
+ Use scm_i_string_length to get the number of characters in that
+ array. The array is not null-terminated.
- The array is valid as long as the corresponding SCM object is
protected but only until the next SCM_TICK. During such a 'safe
point', strings might change their representation.
- - Use scm_i_string_writable_chars to get the same pointer as with
- scm_i_string_chars, but for reading and writing. This is a
- potentially costly operation since it implements the
- copy-on-write behavior. When done with the writing, call
- scm_i_string_stop_writing. You must do this before the next
- SCM_TICK. (This means, before calling almost any other scm_
- function and you can't allow throws, of course.)
-
- - New strings can be created with scm_i_make_string. This gives
- access to a writable pointer that remains valid as long as nobody
- else makes a copy-on-write substring of the string. Do not call
- scm_i_string_stop_writing for this pointer.
+ - Use scm_i_string_start_writing to get a version of the string
+ ready for reading and writing. This is a potentially costly
+ operation since it implements the copy-on-write behavior. When
+ done with the writing, call scm_i_string_stop_writing. You must
+ do this before the next SCM_TICK. (This means, before calling
+ almost any other scm_ function and you can't allow throws, of
+ course.)
+
+ - New strings can be created with scm_i_make_string or
+ scm_i_make_wide_string. This gives access to a writable pointer
+ that remains valid as long as nobody else makes a copy-on-write
+ substring of the string. Do not call scm_i_string_stop_writing
+ for this pointer.
+
+ - Alternately, scm_i_string_ref and scm_i_string_set_x can be used
+ to read and write strings without worrying about whether the
+ string is narrow or wide. scm_i_string_set_x still needs to be
+ bracketed by scm_i_string_start_writing and
+ scm_i_string_stop_writing.
Legacy interface
@@ -74,7 +86,8 @@
- SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately
calls scm_i_stop_writing, hoping for the best. SCM_STRING_LENGTH
is the same as scm_i_string_length. SCM_STRING_CHARS will throw
- an error for for strings that are not null-terminated.
+ an error for for strings that are not null-terminated. There is
+ no wide version of this interface.
*/
#define SCM_PORT_ENCODING (scm_i_get_port_encoding())
@@ -110,9 +123,9 @@ SCM_API SCM scm_take_locale_string (char *str);
SCM_API SCM scm_take_locale_stringn (char *str, size_t len);
SCM_API char *scm_to_locale_string (SCM str);
SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp);
-SCM_INTERNAL char *scm_to_encoded_stringn (SCM str, size_t *lenp,
- const char *encoding,
- enum iconv_ilseq_handler handler);
+SCM_INTERNAL char *scm_to_stringn (SCM str, size_t *lenp,
+ const char *encoding,
+ enum iconv_ilseq_handler handler);
SCM_INTERNAL scm_t_uint8 *scm_i_to_utf8_string (SCM str);
SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);
@@ -137,7 +150,6 @@ SCM_INTERNAL scm_t_wchar scm_i_string_ref (SCM str, size_t
x);
SCM_INTERNAL int scm_i_string_contains_char (SCM str, char c);
SCM_INTERNAL int scm_i_string_strcmp (SCM sstr, size_t start_x, const char
*cstr);
SCM_INTERNAL void scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr);
-
/* internal functions related to symbols. */
SCM_INTERNAL SCM scm_i_make_symbol (SCM name, scm_t_bits flags,
@@ -156,8 +168,6 @@ SCM_INTERNAL SCM scm_i_symbol_substring (SCM sym, size_t
start, size_t end);
SCM_INTERNAL scm_t_wchar scm_i_symbol_ref (SCM sym, size_t x);
SCM_INTERNAL int scm_i_symbol_strcmp (SCM sym, char *str);
-
-
/* internal GC functions. */
SCM_INTERNAL SCM scm_i_string_mark (SCM str);
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 06e8852..8de7f00 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -81,14 +81,14 @@ VM_DEFINE_LOADER (83, load_string, "load-string")
if (width == 1)
{
char *buf;
- str = scm_i_make_string(len, &buf);
- memcpy (buf, (char *)ip, len);
+ str = scm_i_make_string (len, &buf);
+ memcpy (buf, (char *) ip, len);
}
else if (width == 4)
{
scm_t_wchar *wbuf;
- str = scm_i_make_wide_string(len, &wbuf);
- memcpy ((char *)wbuf, (char *)ip, len * width);
+ str = scm_i_make_wide_string (len, &wbuf);
+ memcpy ((char *) wbuf, (char *) ip, len * width);
}
else
SCM_MISC_ERROR ("load-string: invalid character width", SCM_EOL);
@@ -108,14 +108,14 @@ VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
if (width == 1)
{
char *buf;
- str = scm_i_make_string(len, &buf);
- memcpy (buf, (char *)ip, len);
+ str = scm_i_make_string (len, &buf);
+ memcpy (buf, (char *) ip, len);
}
else if (width == 4)
{
scm_t_wchar *wbuf;
- str = scm_i_make_wide_string(len, &wbuf);
- memcpy ((char *)wbuf, (char *)ip, len * width);
+ str = scm_i_make_wide_string (len, &wbuf);
+ memcpy ((char *) wbuf, (char *) ip, len * width);
}
else
SCM_MISC_ERROR ("load-symbol: invalid character width", SCM_EOL);
@@ -135,14 +135,14 @@ VM_DEFINE_LOADER (85, load_keyword, "load-keyword")
if (width == 1)
{
char *buf;
- str = scm_i_make_string(len, &buf);
- memcpy (buf, (char *)ip, len);
+ str = scm_i_make_string (len, &buf);
+ memcpy (buf, (char *) ip, len);
}
else if (width == 4)
{
scm_t_wchar *wbuf;
- str = scm_i_make_wide_string(len, &wbuf);
- memcpy ((char *)wbuf, (char *)ip, len * width);
+ str = scm_i_make_wide_string (len, &wbuf);
+ memcpy ((char *) wbuf, (char *) ip, len * width);
}
else
SCM_MISC_ERROR ("load-keyword: invalid character width", SCM_EOL);
@@ -185,6 +185,7 @@ VM_DEFINE_LOADER (88, define, "define")
{
SCM str, sym;
size_t len;
+
int width;
FETCH_LENGTH (len);
FETCH_WIDTH (width);
@@ -192,14 +193,14 @@ VM_DEFINE_LOADER (88, define, "define")
if (width == 1)
{
char *buf;
- str = scm_i_make_string(len, &buf);
- memcpy (buf, (char *)ip, len);
+ str = scm_i_make_string (len, &buf);
+ memcpy (buf, (char *) ip, len);
}
else if (width == 4)
{
scm_t_wchar *wbuf;
- str = scm_i_make_wide_string(len, &wbuf);
- memcpy ((char *)wbuf, (char *)ip, len * width);
+ str = scm_i_make_wide_string (len, &wbuf);
+ memcpy ((char *) wbuf, (char *) ip, len * width);
}
else
SCM_MISC_ERROR ("load define: invalid character width", SCM_EOL);
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index dce9b5f..0cace14 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -215,11 +215,37 @@ VM_DEFINE_FUNCTION (120, add, "add", 2)
FUNC2 (+, scm_sum);
}
+VM_DEFINE_FUNCTION (167, add1, "add1", 1)
+{
+ ARGS1 (x);
+ if (SCM_I_INUMP (x))
+ {
+ scm_t_int64 n = SCM_I_INUM (x) + 1;
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_I_MAKINUM (n));
+ }
+ SYNC_REGISTER ();
+ RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
+}
+
VM_DEFINE_FUNCTION (121, sub, "sub", 2)
{
FUNC2 (-, scm_difference);
}
+VM_DEFINE_FUNCTION (168, sub1, "sub1", 1)
+{
+ ARGS1 (x);
+ if (SCM_I_INUMP (x))
+ {
+ scm_t_int64 n = SCM_I_INUM (x) - 1;
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_I_MAKINUM (n));
+ }
+ SYNC_REGISTER ();
+ RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
+}
+
VM_DEFINE_FUNCTION (122, mul, "mul", 2)
{
ARGS2 (x, y);
@@ -289,7 +315,10 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
&& i < SCM_I_VECTOR_LENGTH (vect)))
RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
else
- RETURN (scm_vector_ref (vect, idx));
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_vector_ref (vect, idx));
+ }
}
VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
@@ -303,7 +332,10 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0,
3, 0)
&& i < SCM_I_VECTOR_LENGTH (vect)))
SCM_I_VECTOR_WELTS (vect)[i] = val;
else
- scm_vector_set_x (vect, idx, val);
+ {
+ SYNC_REGISTER ();
+ scm_vector_set_x (vect, idx, val);
+ }
NEXT;
}
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 3db92aa..cb7498e 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1219,6 +1219,20 @@ VM_DEFINE_INSTRUCTION (64, make_variable,
"make-variable", 0, 0, 1)
NEXT;
}
+VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1)
+{
+ SCM x, vect;
+ unsigned int i = FETCH ();
+ i <<= 8;
+ i += FETCH ();
+ POP (vect);
+ /* FIXME CHECK_LOCAL (i) */
+ x = LOCAL_REF (i);
+ /* FIXME ASSERT_PROGRAM (x); */
+ SCM_SET_CELL_WORD_3 (x, vect);
+ NEXT;
+}
+
/*
(defun renumber-ops ()
diff --git a/module/Makefile.am b/module/Makefile.am
index 2971fc6..5eec063 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -37,11 +37,11 @@ SOURCES =
\
system/base/message.scm \
\
language/tree-il.scm \
- language/ghil.scm language/glil.scm language/assembly.scm \
+ language/glil.scm language/assembly.scm \
\
$(SCHEME_LANG_SOURCES) \
$(TREE_IL_LANG_SOURCES) \
- $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
+ $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)
\
\
@@ -50,9 +50,10 @@ SOURCES =
\
$(RNRS_SOURCES) \
$(OOP_SOURCES) \
$(SYSTEM_SOURCES) \
+ $(SCRIPTS_SOURCES) \
+ $(GHIL_LANG_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
- $(BRAINFUCK_LANG_SOURCES) \
- $(SCRIPTS_SOURCES)
+ $(BRAINFUCK_LANG_SOURCES)
## test.scm is not currently installed.
EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008
@@ -77,12 +78,14 @@ SCHEME_LANG_SOURCES =
\
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/optimize.scm \
+ language/tree-il/inline.scm \
+ language/tree-il/fix-letrec.scm \
language/tree-il/analyze.scm \
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
-GHIL_LANG_SOURCES = \
- language/ghil/spec.scm language/ghil/compile-glil.scm
+GHIL_LANG_SOURCES = \
+ language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \
diff --git a/module/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
index 63170de..840c73b 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -140,7 +140,6 @@
((load-symbol ,str) (write-sized-loader str))
((load-keyword ,str) (write-sized-loader str))
((load-array ,bv) (write-bytevector bv))
- ((make-char32 ,x) (write-uint32-be x))
((define ,str) (write-sized-loader str))
((br ,l) (write-break l))
((br-if ,l) (write-break l))
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index fa58057..4bd6c4f 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -251,35 +251,41 @@
(emit-code
(if local?
(if (< index 256)
- `((,(case op
- ((ref) (if boxed? 'local-boxed-ref 'local-ref))
- ((set) (if boxed? 'local-boxed-set 'local-set))
- ((box) 'box)
- ((empty-box) 'empty-box)
- (else (error "what" op)))
- ,index))
+ (case op
+ ((ref) (if boxed?
+ `((local-boxed-ref ,index))
+ `((local-ref ,index))))
+ ((set) (if boxed?
+ `((local-boxed-set ,index))
+ `((local-set ,index))))
+ ((box) `((box ,index)))
+ ((empty-box) `((empty-box ,index)))
+ ((fix) `((fix-closure 0 ,index)))
+ (else (error "what" op)))
(let ((a (quotient i 256))
(b (modulo i 256)))
- `((,(case op
- ((ref)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-ref))
- `((long-local-ref ,a ,b))))
- ((set)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-set))
- `((long-local-set ,a ,b))))
- ((box)
- `((make-variable)
- (variable-set)
- (long-local-set ,a ,b)))
- ((empty-box)
- `((make-variable)
- (long-local-set ,a ,b)))
- (else (error "what" op)))
- ,index))))
+ `((,(case op
+ ((ref)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-ref))
+ `((long-local-ref ,a ,b))))
+ ((set)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-set))
+ `((long-local-set ,a ,b))))
+ ((box)
+ `((make-variable)
+ (variable-set)
+ (long-local-set ,a ,b)))
+ ((empty-box)
+ `((make-variable)
+ (long-local-set ,a ,b)))
+ ((fix)
+ `((fix-closure ,a ,b)))
+ (else (error "what" op)))
+ ,index))))
`((,(case op
((ref) (if boxed? 'free-boxed-ref 'free-ref))
((set) (if boxed? 'free-boxed-set (error "what." glil)))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 21aa023..df61858 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Scheme specification
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 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
@@ -20,7 +20,6 @@
(define-module (language scheme spec)
#:use-module (system base language)
- #:use-module (language scheme compile-ghil)
#:use-module (language scheme compile-tree-il)
#:use-module (language scheme decompile-tree-il)
#:export (scheme))
@@ -39,8 +38,7 @@
#:title "Guile Scheme"
#:version "0.5"
#:reader read
- #:compilers `((tree-il . ,compile-tree-il)
- (ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il))
#:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index aec4eed..ad8b731 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -18,6 +18,7 @@
(define-module (language tree-il)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
@@ -38,6 +39,7 @@
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars
lambda-meta lambda-body
<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
+ <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-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
@@ -45,6 +47,7 @@
tree-il->scheme
tree-il-fold
+ make-tree-il-folder
post-order!
pre-order!))
@@ -65,6 +68,7 @@
(<lambda> names vars meta body)
(<let> names vars vals body)
(<letrec> names vars vals body)
+ (<fix> names vars vals body)
(<let-values> names vars exp body))
@@ -141,6 +145,9 @@
((letrec ,names ,vars ,vals ,body)
(make-letrec loc names vars (map retrans vals) (retrans body)))
+ ((fix ,names ,vars ,vals ,body)
+ (make-fix loc names vars (map retrans vals) (retrans body)))
+
((let-values ,names ,vars ,exp ,body)
(make-let-values loc names vars (retrans exp) (retrans body)))
@@ -197,6 +204,9 @@
((<letrec> names vars vals body)
`(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il
body)))
+ ((<fix> names vars vals body)
+ `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
((<let-values> names vars exp body)
`(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il
body)))))
@@ -256,6 +266,10 @@
((<letrec> vars vals body)
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
+ ((<fix> vars vals body)
+ ;; not a typo, we really do translate back to letrec
+ `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
+
((<let-values> vars exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body))))))
@@ -300,11 +314,65 @@ This is an implementation of `foldts' as described by
Andy Wingo in
(up tree (loop body
(loop vals
(down tree result)))))
- ((<let-values> body)
- (up tree (loop body (down tree result))))
+ ((<fix> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<let-values> exp body)
+ (up tree (loop body (loop exp (down tree result)))))
(else
(leaf tree result))))))
+
+(define-syntax make-tree-il-folder
+ (syntax-rules ()
+ ((_ seed ...)
+ (lambda (tree down up seed ...)
+ (define (fold-values proc exps seed ...)
+ (if (null? exps)
+ (values seed ...)
+ (let-values (((seed ...) (proc (car exps) seed ...)))
+ (fold-values proc (cdr exps) seed ...))))
+ (let foldts ((tree tree) (seed seed) ...)
+ (let*-values
+ (((seed ...) (down tree seed ...))
+ ((seed ...)
+ (record-case tree
+ ((<lexical-set> exp)
+ (foldts exp seed ...))
+ ((<module-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-set> exp)
+ (foldts exp seed ...))
+ ((<toplevel-define> exp)
+ (foldts exp seed ...))
+ ((<conditional> test then else)
+ (let*-values (((seed ...) (foldts test seed ...))
+ ((seed ...) (foldts then seed ...)))
+ (foldts else seed ...)))
+ ((<application> proc args)
+ (let-values (((seed ...) (foldts proc seed ...)))
+ (fold-values foldts args seed ...)))
+ ((<sequence> exps)
+ (fold-values foldts exps seed ...))
+ ((<lambda> body)
+ (foldts body seed ...))
+ ((<let> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed
...)))
+ (foldts body seed ...)))
+ ((<letrec> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed
...)))
+ (foldts body seed ...)))
+ ((<fix> vals body)
+ (let*-values (((seed ...) (fold-values foldts vals seed
...)))
+ (foldts body seed ...)))
+ ((<let-values> exp body)
+ (let*-values (((seed ...) (foldts exp seed ...)))
+ (foldts body seed ...)))
+ (else
+ (values seed ...)))))
+ (up tree seed ...)))))))
+
(define (post-order! f x)
(let lp ((x x))
(record-case x
@@ -343,6 +411,10 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
+ ((<fix> vars vals body)
+ (set! (fix-vals x) (map lp vals))
+ (set! (fix-body x) (lp body)))
+
((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
@@ -390,6 +462,10 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
+ ((<fix> vars vals body)
+ (set! (fix-vals x) (map lp vals))
+ (set! (fix-body x) (lp body)))
+
((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 1b39b2d..b93a0bd 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -78,6 +78,25 @@
;; in a vector. Each closure variable has a unique index into that
;; vector.
;;
+;; There is one more complication. Procedures bound by <fix> may, in
+;; some cases, be rendered inline to their parent procedure. That is to
+;; say,
+;;
+;; (letrec ((lp (lambda () (lp)))) (lp))
+;; => (fix ((lp (lambda () (lp)))) (lp))
+;; => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
+;; ^ jump over the loop ^ the fixpoint lp ^ starting off the loop
+;;
+;; The upshot is that we don't have to allocate any space for the `lp'
+;; closure at all, as it can be rendered inline as a loop. So there is
+;; another kind of allocation, "label allocation", in which the
+;; procedure is simply a label, placed at the start of the lambda body.
+;; The label is the gensym under which the lambda expression is bound.
+;;
+;; The analyzer checks to see that the label is called with the correct
+;; number of arguments. Calls to labels compile to rename + goto.
+;; Lambda, the ultimate goto!
+;;
;;
;; The return value of `analyze-lexicals' is a hash table, the
;; "allocation".
@@ -88,15 +107,17 @@
;; in many procedures, it is a two-level map.
;;
;; The allocation also stored information on how many local variables
-;; need to be allocated for each procedure, and information on what free
-;; variables to capture from its lexical parent procedure.
+;; need to be allocated for each procedure, lexicals that have been
+;; translated into labels, and information on what free variables to
+;; capture from its lexical parent procedure.
;;
;; That is:
;;
;; sym -> {lambda -> address}
-;; lambda -> (nlocs . free-locs)
+;; lambda -> (nlocs labels . free-locs)
;;
-;; address := (local? boxed? . index)
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda-vars) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.
@@ -108,32 +129,52 @@
(define (analyze-lexicals x)
;; bound-vars: lambda -> (sym ...)
;; all identifiers bound within a lambda
+ (define bound-vars (make-hash-table))
;; free-vars: lambda -> (sym ...)
;; all identifiers referenced in a lambda, but not bound
;; NB, this includes identifiers referenced by contained lambdas
+ (define free-vars (make-hash-table))
;; assigned: sym -> #t
;; variables that are assigned
+ (define assigned (make-hash-table))
;; refcounts: sym -> count
;; allows us to detect the or-expansion in O(1) time
-
+ (define refcounts (make-hash-table))
+ ;; labels: sym -> lambda-vars
+ ;; for determining if fixed-point procedures can be rendered as
+ ;; labels. lambda-vars may be an improper list.
+ (define labels (make-hash-table))
+
;; returns variables referenced in expr
- (define (analyze! x proc)
- (define (step y) (analyze! y proc))
- (define (recur x new-proc) (analyze! x new-proc))
+ (define (analyze! x proc labels-in-proc tail? tail-call-args)
+ (define (step y) (analyze! y proc labels-in-proc #f #f))
+ (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
+ (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
+ (and tail? args)))
+ (define (recur/labels x new-proc labels)
+ (analyze! x new-proc (append labels labels-in-proc) #t #f))
+ (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
(record-case x
((<application> proc args)
- (apply lset-union eq? (step proc) (map step args)))
+ (apply lset-union eq? (step-tail-call proc args)
+ (map step args)))
((<conditional> test then else)
- (lset-union eq? (step test) (step then) (step else)))
+ (lset-union eq? (step test) (step-tail then) (step-tail else)))
((<lexical-ref> name gensym)
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
+ (if (not (and tail-call-args
+ (memq gensym labels-in-proc)
+ (let ((args (hashq-ref labels gensym)))
+ (and (list? args)
+ (= (length args) (length tail-call-args))))))
+ (hashq-set! labels gensym #f))
(list gensym))
((<lexical-set> name gensym exp)
- (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(hashq-set! assigned gensym #t)
+ (hashq-set! labels gensym #f)
(lset-adjoin eq? (step exp) gensym))
((<module-set> mod name public? exp)
@@ -146,7 +187,12 @@
(step exp))
((<sequence> exps)
- (apply lset-union eq? (map step exps)))
+ (let lp ((exps exps) (ret '()))
+ (cond ((null? exps) '())
+ ((null? (cdr exps))
+ (lset-union eq? ret (step-tail (car exps))))
+ (else
+ (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
((<lambda> vars meta body)
(let ((locally-bound (let rev* ((vars vars) (out '()))
@@ -166,7 +212,7 @@
(hashq-set! bound-vars proc
(append (reverse vars) (hashq-ref bound-vars proc)))
(lset-difference eq?
- (apply lset-union eq? (step body) (map step vals))
+ (apply lset-union eq? (step-tail body) (map step vals))
vars))
((<letrec> vars vals body)
@@ -174,21 +220,103 @@
(append (reverse vars) (hashq-ref bound-vars proc)))
(for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
(lset-difference eq?
- (apply lset-union eq? (step body) (map step vals))
+ (apply lset-union eq? (step-tail body) (map step vals))
vars))
- ((<let-values> vars exp body)
+ ((<fix> vars vals body)
+ ;; Try to allocate these procedures as labels.
+ (for-each (lambda (sym val) (hashq-set! labels sym (lambda-vars val)))
+ vars vals)
(hashq-set! bound-vars proc
- (let lp ((out (hashq-ref bound-vars proc)) (in vars))
- (if (pair? in)
- (lp (cons (car in) out) (cdr in))
- (if (null? in) out (cons in out)))))
- (lset-difference eq?
- (lset-union eq? (step exp) (step body))
- vars))
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ ;; Step into subexpressions.
+ (let* ((var-refs
+ (map
+ ;; Since we're trying to label-allocate the lambda,
+ ;; pretend it's not a closure, and just recurse into its
+ ;; body directly. (Otherwise, recursing on a closure
+ ;; that references one of the fix's bound vars would
+ ;; prevent label allocation.)
+ (lambda (x)
+ (record-case x
+ ((<lambda> (lvars vars) body)
+ (let ((locally-bound
+ (let rev* ((lvars lvars) (out '()))
+ (cond ((null? lvars) out)
+ ((pair? lvars) (rev* (cdr lvars)
+ (cons (car lvars)
out)))
+ (else (cons lvars out))))))
+ (hashq-set! bound-vars x locally-bound)
+ ;; recur/labels, the difference from the closure case
+ (let* ((referenced (recur/labels body x vars))
+ (free (lset-difference eq? referenced
locally-bound))
+ (all-bound (reverse! (hashq-ref bound-vars x))))
+ (hashq-set! bound-vars x all-bound)
+ (hashq-set! free-vars x free)
+ free)))))
+ vals))
+ (vars-with-refs (map cons vars var-refs))
+ (body-refs (recur/labels body proc vars)))
+ (define (delabel-dependents! sym)
+ (let ((refs (assq-ref vars-with-refs sym)))
+ (if refs
+ (for-each (lambda (sym)
+ (if (hashq-ref labels sym)
+ (begin
+ (hashq-set! labels sym #f)
+ (delabel-dependents! sym))))
+ refs))))
+ ;; Stepping into the lambdas and the body might have made some
+ ;; procedures not label-allocatable -- which might have
+ ;; knock-on effects. For example:
+ ;; (fix ((a (lambda () (b)))
+ ;; (b (lambda () a)))
+ ;; (a))
+ ;; As far as `a' is concerned, both `a' and `b' are
+ ;; label-allocatable. But `b' references `a' not in a proc-tail
+ ;; position, which makes `a' not label-allocatable. The
+ ;; knock-on effect is that, when back-propagating this
+ ;; information to `a', `b' will also become not
+ ;; label-allocatable, as it is referenced within `a', which is
+ ;; allocated as a closure. This is a transitive relationship.
+ (for-each (lambda (sym)
+ (if (not (hashq-ref labels sym))
+ (delabel-dependents! sym)))
+ vars)
+ ;; Now lift bound variables with label-allocated lambdas to the
+ ;; parent procedure.
+ (for-each
+ (lambda (sym val)
+ (if (hashq-ref labels sym)
+ ;; Remove traces of the label-bound lambda. The free
+ ;; vars will propagate up via the return val.
+ (begin
+ (hashq-set! bound-vars proc
+ (append (hashq-ref bound-vars val)
+ (hashq-ref bound-vars proc)))
+ (hashq-remove! bound-vars val)
+ (hashq-remove! free-vars val))))
+ vars vals)
+ (lset-difference eq?
+ (apply lset-union eq? body-refs var-refs)
+ vars)))
+
+ ((<let-values> vars exp body)
+ (let ((bound (let lp ((out (hashq-ref bound-vars proc)) (in vars))
+ (if (pair? in)
+ (lp (cons (car in) out) (cdr in))
+ (if (null? in) out (cons in out))))))
+ (hashq-set! bound-vars proc bound)
+ (lset-difference eq?
+ (lset-union eq? (step exp) (step-tail body))
+ bound)))
(else '())))
+ ;; allocation: sym -> {lambda -> address}
+ ;; lambda -> (nlocs labels . free-locs)
+ (define allocation (make-hash-table))
+
(define (allocate! x proc n)
(define (recur y) (allocate! y proc n))
(record-case x
@@ -237,9 +365,13 @@
(free-addresses
(map (lambda (v)
(hashq-ref (hashq-ref allocation v) proc))
- (hashq-ref free-vars x))))
+ (hashq-ref free-vars x)))
+ (labels (filter cdr
+ (map (lambda (sym)
+ (cons sym (hashq-ref labels sym)))
+ (hashq-ref bound-vars x)))))
;; set procedure allocations
- (hashq-set! allocation x (cons nlocs free-addresses)))
+ (hashq-set! allocation x (cons* nlocs labels free-addresses)))
n)
((<let> vars vals body)
@@ -285,29 +417,71 @@
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))
+ ((<fix> vars vals body)
+ (let lp ((in vars) (n n))
+ (if (null? in)
+ (let lp ((vars vars) (vals vals) (nmax n))
+ (cond
+ ((null? vars)
+ (max nmax (allocate! body proc n)))
+ ((hashq-ref labels (car vars))
+ ;; allocate label bindings & body inline to proc
+ (lp (cdr vars)
+ (cdr vals)
+ (record-case (car vals)
+ ((<lambda> vars body)
+ (let lp ((vars vars) (n n))
+ (if (not (null? vars))
+ ;; allocate bindings
+ (let ((v (if (pair? vars) (car vars) vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq
+ proc `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (if (pair? vars) (cdr vars) '()) (1+ n)))
+ ;; allocate body
+ (max nmax (allocate! body proc n))))))))
+ (else
+ ;; allocate closure
+ (lp (cdr vars)
+ (cdr vals)
+ (max nmax (allocate! (car vals) proc n))))))
+
+ (let ((v (car in)))
+ (cond
+ ((hashq-ref assigned v)
+ (error "fixpoint procedures may not be assigned" x))
+ ((hashq-ref labels v)
+ ;; no binding, it's a label
+ (lp (cdr in) n))
+ (else
+ ;; allocate closure binding
+ (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
+ (lp (cdr in) (1+ n))))))))
+
((<let-values> vars exp body)
(let ((nmax (recur exp)))
(let lp ((vars vars) (n n))
- (if (null? vars)
- (max nmax (allocate! body proc n))
- (let ((v (if (pair? vars) (car vars) vars)))
- (let ((v (car vars)))
- (hashq-set!
- allocation v
- (make-hashq proc
- `(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n))))))))
+ (cond
+ ((null? vars)
+ (max nmax (allocate! body proc n)))
+ ((not (pair? vars))
+ (hashq-set! allocation vars
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned vars) . ,n)))
+ ;; the 1+ for this var
+ (max nmax (allocate! body proc (1+ n))))
+ (else
+ (let ((v (car vars)))
+ (hashq-set!
+ allocation v
+ (make-hashq proc
+ `(#t ,(hashq-ref assigned v) . ,n)))
+ (lp (cdr vars) (1+ n))))))))
(else n)))
- (define bound-vars (make-hash-table))
- (define free-vars (make-hash-table))
- (define assigned (make-hash-table))
- (define refcounts (make-hash-table))
-
- (define allocation (make-hash-table))
-
- (analyze! x #f)
+ (analyze! x #f '() #t #f)
(allocate! x #f 0)
allocation)
@@ -381,6 +555,9 @@
((<letrec> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
+ ((<fix> 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)))
@@ -428,6 +605,9 @@
((<letrec> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
+ ((<fix> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
((<let-values> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index bf46997..48db6f6 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -37,7 +37,7 @@
;; allocation:
;; sym -> {lambda -> address}
-;; lambda -> (nlocs . closure-vars)
+;; lambda -> (nlocs labels . free-locs)
;;
;; address := (local? boxed? . index)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
@@ -66,7 +66,7 @@
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()
- (values (flatten-lambda x allocation)
+ (values (flatten-lambda x #f allocation)
(and e (cons (car e) (cddr e)))
e)))))
@@ -85,6 +85,8 @@
((>= . 2) . ge?)
((+ . 2) . add)
((- . 2) . sub)
+ ((1+ . 1) . add1)
+ ((1- . 1) . sub1)
((* . 2) . mul)
((/ . 2) . div)
((quotient . 2) . quo)
@@ -161,10 +163,10 @@
ids
vars))
+;; FIXME: always emit? otherwise it's hard to pair bind with unbind
(define (emit-bindings src ids vars allocation proc emit-code)
- (if (pair? vars)
- (emit-code src (make-glil-bind
- (vars->bind-list ids vars allocation proc)))))
+ (emit-code src (make-glil-bind
+ (vars->bind-list ids vars allocation proc))))
(define (with-output-to-code proc)
(let ((out '()))
@@ -175,7 +177,7 @@
(proc emit-code)
(reverse out)))
-(define (flatten-lambda x allocation)
+(define (flatten-lambda x self-label allocation)
(receive (ids vars nargs nrest)
(let lp ((ids (lambda-names x)) (vars (lambda-vars x))
(oids '()) (ovars '()) (n 0))
@@ -186,53 +188,67 @@
(else (values (reverse (cons ids oids))
(reverse (cons vars ovars))
(1+ n) 1))))
- (let ((nlocs (car (hashq-ref allocation x))))
+ (let ((nlocs (car (hashq-ref allocation x)))
+ (labels (cadr (hashq-ref allocation x))))
(make-glil-program
nargs nrest nlocs (lambda-meta x)
(with-output-to-code
(lambda (emit-code)
+ ;; emit label for self tail calls
+ (if self-label
+ (emit-code #f (make-glil-label self-label)))
;; write bindings and source debugging info
- (emit-bindings #f ids vars allocation x emit-code)
+ (if (not (null? ids))
+ (emit-bindings #f ids vars allocation x emit-code))
(if (lambda-src x)
(emit-code #f (make-glil-source (lambda-src x))))
;; box args if necessary
(for-each
(lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) x)
- ((#t #t . ,n)
- (emit-code #f (make-glil-lexical #t #f 'ref n))
- (emit-code #f (make-glil-lexical #t #t 'box n)))))
+ ((#t #t . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'ref n))
+ (emit-code #f (make-glil-lexical #t #t 'box n)))))
vars)
;; and here, here, dear reader: we compile.
- (flatten (lambda-body x) allocation x emit-code)))))))
+ (flatten (lambda-body x) allocation x self-label
+ labels emit-code)))))))
-(define (flatten x allocation proc emit-code)
+(define (flatten x allocation self self-label fix-labels emit-code)
(define (emit-label label)
(emit-code #f (make-glil-label label)))
(define (emit-branch src inst label)
(emit-code src (make-glil-branch inst label)))
- ;; LMVRA == "let-values MV return address"
- (let comp ((x x) (context 'tail) (LMVRA #f))
- (define (comp-tail tree) (comp tree context LMVRA))
- (define (comp-push tree) (comp tree 'push #f))
- (define (comp-drop tree) (comp tree 'drop #f))
- (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
-
+ ;; RA: "return address"; #f unless we're in a non-tail fix with labels
+ ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
+ (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
+ (define (comp-tail tree) (comp tree context RA MVRA))
+ (define (comp-push tree) (comp tree 'push #f #f))
+ (define (comp-drop tree) (comp tree 'drop #f #f))
+ (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
+ (define (comp-fix tree RA) (comp tree context RA MVRA))
+
+ ;; A couple of helpers. Note that if we are in tail context, we
+ ;; won't have an RA.
+ (define (maybe-emit-return)
+ (if RA
+ (emit-branch #f 'br RA)
+ (if (eq? context 'tail)
+ (emit-code #f (make-glil-call 'return 1)))))
+
(record-case x
((<void>)
(case context
- ((push vals) (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((push vals tail)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<const> src exp)
(case context
- ((push vals) (emit-code src (make-glil-const exp)))
- ((tail)
- (emit-code src (make-glil-const exp))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((push vals tail)
+ (emit-code src (make-glil-const exp))))
+ (maybe-emit-return))
;; FIXME: should represent sequence as exps tail
((<sequence> src exps)
@@ -258,7 +274,7 @@
;; drop: (lambda () (apply values '(1 2)) 3)
;; push: (lambda () (list (apply values '(10 12)) 1))
(case context
- ((drop) (for-each comp-drop args))
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values* (length
args))))))
@@ -272,12 +288,14 @@
((push)
(comp-push proc)
(for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args)))))
+ (emit-code src (make-glil-call 'apply (1+ (length args))))
+ (maybe-emit-return))
((vals)
(comp-vals
(make-application src (make-primitive-ref #f 'apply)
(cons proc args))
- LMVRA))
+ MVRA)
+ (maybe-emit-return))
((drop)
;; Well, shit. The proc might return any number of
;; values (including 0), since it's in a drop context,
@@ -285,8 +303,9 @@
;; mv-call out to our trampoline instead.
(comp-drop
(make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))))))))
-
+ (cons proc args)))
+ (maybe-emit-return)))))))
+
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
(not (eq? context 'push)))
;; tail: (lambda () (values '(1 2)))
@@ -294,11 +313,11 @@
;; push: (lambda () (list (values '(10 12)) 1))
;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
(case context
- ((drop) (for-each comp-drop args))
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
((vals)
(for-each comp-push args)
(emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br LMVRA))
+ (emit-branch src 'br MVRA))
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values (length args))))))
@@ -319,7 +338,8 @@
(comp-vals
(make-application src (make-primitive-ref #f 'call-with-values)
args)
- LMVRA))
+ MVRA)
+ (maybe-emit-return))
(else
(let ((MV (make-label)) (POST (make-label))
(producer (car args)) (consumer (cadr args)))
@@ -336,7 +356,8 @@
(else (emit-code src (make-glil-call 'call/nargs 0))
(emit-label POST)
(if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))))))))
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-current-continuation)
@@ -350,16 +371,19 @@
(make-application
src (make-primitive-ref #f 'call-with-current-continuation)
args)
- LMVRA))
+ MVRA)
+ (maybe-emit-return))
((push)
(comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1)))
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
((drop)
;; Crap. Just like `apply' in drop context.
(comp-drop
(make-application
src (make-primitive-ref #f 'call-with-current-continuation)
- args)))))
+ args))
+ (maybe-emit-return))))
((and (primitive-ref? proc)
(or (hash-ref *primcall-ops*
@@ -371,34 +395,74 @@
(case (instruction-pushes op)
((0)
(case context
- ((tail) (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))
- ((push vals) (emit-code #f (make-glil-void)))))
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((1)
(case context
- ((tail) (emit-code #f (make-glil-call 'return 1)))
- ((drop) (emit-code #f (make-glil-call 'drop 1)))))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
(else
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
+ ;; da capo al fine
+ ((and (lexical-ref? proc)
+ self-label (eq? (lexical-ref-gensym proc) self-label)
+ ;; self-call in tail position is a goto
+ (eq? context 'tail)
+ ;; make sure the arity is right
+ (list? (lambda-vars self))
+ (= (length args) (length (lambda-vars self))))
+ ;; evaluate new values
+ (for-each comp-push args)
+ ;; rename & goto
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t ,boxed? . ,index)
+ ;; set unboxed, as the proc prelude will box if needed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ (,x (error "what" x))))
+ (reverse (lambda-vars self)))
+ (emit-branch src 'br self-label))
+
+ ;; lambda, the ultimate goto
+ ((and (lexical-ref? proc)
+ (assq (lexical-ref-gensym proc) fix-labels))
+ ;; evaluate new values, assuming that analyze-lexicals did its
+ ;; job, and that the arity was right
+ (for-each comp-push args)
+ ;; rename
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index)
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index)
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "what" x))))
+ (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
+ ;; goto!
+ (emit-branch src 'br (lexical-ref-gensym proc)))
+
(else
(comp-push proc)
(for-each comp-push args)
(let ((len (length args)))
(case context
((tail) (emit-code src (make-glil-call 'goto/args len)))
- ((push) (emit-code src (make-glil-call 'call len)))
- ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA)))
- ((drop)
- (let ((MV (make-label)) (POST (make-label)))
- (emit-code src (make-glil-mv-call len MV))
- (emit-code #f (make-glil-call 'drop 1))
- (emit-branch #f 'br POST)
- (emit-label MV)
- (emit-code #f (make-glil-mv-bind '() #f))
- (emit-code #f (make-glil-unbind))
- (emit-label POST))))))))
+ ((push) (emit-code src (make-glil-call 'call len))
+ (maybe-emit-return))
+ ((vals) (emit-code src (make-glil-mv-call len MVRA))
+ (maybe-emit-return))
+ ((drop) (let ((MV (make-label)) (POST (make-label)))
+ (emit-code src (make-glil-mv-call len MV))
+ (emit-code #f (make-glil-call 'drop 1))
+ (emit-branch #f 'br (or RA POST))
+ (emit-label MV)
+ (emit-code #f (make-glil-mv-bind '() #f))
+ (emit-code #f (make-glil-unbind))
+ (if RA
+ (emit-branch #f 'br RA)
+ (emit-label POST)))))))))
((<conditional> src test then else)
;; TEST
@@ -411,104 +475,93 @@
(comp-push test)
(emit-branch src 'br-if-not L1)
(comp-tail then)
- (if (not (eq? context 'tail))
+ ;; if there is an RA, comp-tail will cause a jump to it -- just
+ ;; have to clean up here if there is no RA.
+ (if (and (not RA) (not (eq? context 'tail)))
(emit-branch #f 'br L2))
(emit-label L1)
(comp-tail else)
- (if (not (eq? context 'tail))
+ (if (and (not RA) (not (eq? context 'tail)))
(emit-label L2))))
-
+
((<primitive-ref> src name)
(cond
((eq? (module-variable (fluid-ref *comp-module*) name)
(module-variable the-root-module name))
(case context
- ((push vals)
- (emit-code src (make-glil-toplevel 'ref name)))
- ((tail)
- (emit-code src (make-glil-toplevel 'ref name))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code src (make-glil-toplevel 'ref name))))
+ (maybe-emit-return))
(else
(pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
(case context
- ((push vals)
- (emit-code src (make-glil-module 'ref '(guile) name #f)))
- ((tail)
- (emit-code src (make-glil-module 'ref '(guile) name #f))
- (emit-code #f (make-glil-call 'return 1)))))))
+ ((tail push vals)
+ (emit-code src (make-glil-module 'ref '(guile) name #f))))
+ (maybe-emit-return))))
((<lexical-ref> src name gensym)
(case context
((push vals tail)
- (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+ (pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'ref index)))
(,loc
(error "badness" x loc)))))
- (case context
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
+ (maybe-emit-return))
((<lexical-set> src name gensym exp)
(comp-push exp)
- (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+ (pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'set index)))
(,loc
(error "badness" x loc)))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<module-ref> src mod name public?)
(emit-code src (make-glil-module 'ref mod name public?))
(case context
- ((drop) (emit-code #f (make-glil-call 'drop 1)))
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
((<module-set> src mod name public? exp)
(comp-push exp)
(emit-code src (make-glil-module 'set mod name public?))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<toplevel-ref> src name)
(emit-code src (make-glil-toplevel 'ref name))
(case context
- ((drop) (emit-code #f (make-glil-call 'drop 1)))
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
((<toplevel-set> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'set name))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<toplevel-define> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'define name))
(case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
((<lambda>)
- (let ((free-locs (cdr (hashq-ref allocation x))))
+ (let ((free-locs (cddr (hashq-ref allocation x))))
(case context
((push vals tail)
- (emit-code #f (flatten-lambda x allocation))
+ (emit-code #f (flatten-lambda x #f allocation))
(if (not (null? free-locs))
(begin
(for-each
@@ -519,15 +572,14 @@
(else (error "what" x loc))))
free-locs)
(emit-code #f (make-glil-call 'vector (length free-locs)))
- (emit-code #f (make-glil-call 'make-closure 2))))
- (if (eq? context 'tail)
- (emit-code #f (make-glil-call 'return 1)))))))
+ (emit-code #f (make-glil-call 'make-closure 2)))))))
+ (maybe-emit-return))
((<let> src names vars vals body)
(for-each comp-push vals)
- (emit-bindings src names vars allocation proc emit-code)
+ (emit-bindings src names vars allocation self emit-code)
(for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
@@ -539,15 +591,15 @@
((<letrec> src names vars vals body)
(for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc))))
vars)
(for-each comp-push vals)
- (emit-bindings src names vars allocation proc emit-code)
+ (emit-bindings src names vars allocation self emit-code)
(for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc))))
@@ -555,6 +607,87 @@
(comp-tail body)
(emit-code #f (make-glil-unbind)))
+ ((<fix> src names vars vals body)
+ ;; The ideal here is to just render the lambda bodies inline, and
+ ;; wire the code together with gotos. We can do that if
+ ;; analyze-lexicals has determined that a given var has "label"
+ ;; allocation -- which is the case if it is in `fix-labels'.
+ ;;
+ ;; But even for closures that we can't inline, we can do some
+ ;; tricks to avoid heap-allocation for the binding itself. Since
+ ;; we know the vals are lambdas, we can set them to their local
+ ;; var slots first, then capture their bindings, mutating them in
+ ;; place.
+ (let ((RA (if (eq? context 'tail) #f (make-label))))
+ (for-each
+ (lambda (x v)
+ (cond
+ ((hashq-ref allocation x)
+ ;; allocating a closure
+ (emit-code #f (flatten-lambda x v allocation))
+ (if (not (null? (cddr (hashq-ref allocation x))))
+ ;; Need to make-closure first, but with a temporary #f
+ ;; free-variables vector, so we are mutating fresh
+ ;; closures on the heap.
+ (begin
+ (emit-code #f (make-glil-const #f))
+ (emit-code #f (make-glil-call 'make-closure 2))))
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ (,loc (error "badness" x loc))))
+ (else
+ ;; labels allocation: emit label & body, but jump over it
+ (let ((POST (make-label)))
+ (emit-branch #f 'br POST)
+ (emit-label v)
+ ;; we know the lambda vars are a list
+ (emit-bindings #f (lambda-names x) (lambda-vars x)
+ allocation self emit-code)
+ (if (lambda-src x)
+ (emit-code #f (make-glil-source (lambda-src x))))
+ (comp-fix (lambda-body x) RA)
+ (emit-code #f (make-glil-unbind))
+ (emit-label POST)))))
+ vals
+ vars)
+ ;; Emit bindings metadata for closures
+ (let ((binds (let lp ((out '()) (vars vars) (names names))
+ (cond ((null? vars) (reverse! out))
+ ((assq (car vars) fix-labels)
+ (lp out (cdr vars) (cdr names)))
+ (else
+ (lp (acons (car vars) (car names) out)
+ (cdr vars) (cdr names)))))))
+ (emit-bindings src (map cdr binds) (map car binds)
+ allocation self emit-code))
+ ;; Now go back and fix up the bindings for closures.
+ (for-each
+ (lambda (x v)
+ (let ((free-locs (if (hashq-ref allocation x)
+ (cddr (hashq-ref allocation x))
+ ;; can hit this latter case for labels
allocation
+ '())))
+ (if (not (null? free-locs))
+ (begin
+ (for-each
+ (lambda (loc)
+ (pmatch loc
+ ((,local? ,boxed? . ,n)
+ (emit-code #f (make-glil-lexical local? #f 'ref n)))
+ (else (error "what" x loc))))
+ free-locs)
+ (emit-code #f (make-glil-call 'vector (length free-locs)))
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'fix n)))
+ (,loc (error "badness" x loc)))))))
+ vals
+ vars)
+ (comp-tail body)
+ (emit-label RA)
+ (emit-code #f (make-glil-unbind))))
+
((<let-values> src names vars exp body)
(let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
(cond
@@ -571,10 +704,10 @@
(emit-code #f (make-glil-const 1))
(emit-label MV)
(emit-code src (make-glil-mv-bind
- (vars->bind-list names vars allocation proc)
+ (vars->bind-list names vars allocation self)
rest?))
(for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
diff --git a/module/language/tree-il/fix-letrec.scm
b/module/language/tree-il/fix-letrec.scm
new file mode 100644
index 0000000..0ed7b6b
--- /dev/null
+++ b/module/language/tree-il/fix-letrec.scm
@@ -0,0 +1,180 @@
+;;; transformation of letrec into simpler forms
+
+;; 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
+
+(define-module (language tree-il fix-letrec)
+ #:use-module (system base syntax)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:export (fix-letrec!))
+
+;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
+;; Efficient Implementation of Schemeâs Recursive Binding Construct", by
+;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
+
+(define fix-fold
+ (make-tree-il-folder unref ref set simple lambda complex))
+
+(define (simple-expression? x bound-vars)
+ (record-case x
+ ((<void>) #t)
+ ((<const>) #t)
+ ((<lexical-ref> gensym)
+ (not (memq gensym bound-vars)))
+ ((<conditional> test then else)
+ (and (simple-expression? test bound-vars)
+ (simple-expression? then bound-vars)
+ (simple-expression? else bound-vars)))
+ ((<sequence> exps)
+ (and-map (lambda (x) (simple-expression? x bound-vars))
+ exps))
+ ((<application> proc args)
+ (and (primitive-ref? proc)
+ (effect-free-primitive? (primitive-ref-name proc))
+ (and-map (lambda (x) (simple-expression? x bound-vars))
+ args)))
+ (else #f)))
+
+(define (partition-vars x)
+ (let-values
+ (((unref ref set simple lambda* complex)
+ (fix-fold x
+ (lambda (x unref ref set simple lambda* complex)
+ (record-case x
+ ((<lexical-ref> gensym)
+ (values (delq gensym unref)
+ (lset-adjoin eq? ref gensym)
+ set
+ simple
+ lambda*
+ complex))
+ ((<lexical-set> gensym)
+ (values unref
+ ref
+ (lset-adjoin eq? set gensym)
+ simple
+ lambda*
+ complex))
+ ((<letrec> vars)
+ (values (append vars unref)
+ ref
+ set
+ simple
+ lambda*
+ complex))
+ (else
+ (values unref ref set simple lambda* complex))))
+ (lambda (x unref ref set simple lambda* complex)
+ (record-case x
+ ((<letrec> (orig-vars vars) vals)
+ (let lp ((vars orig-vars) (vals vals)
+ (s '()) (l '()) (c '()))
+ (cond
+ ((null? vars)
+ (values unref
+ ref
+ set
+ (append s simple)
+ (append l lambda*)
+ (append c complex)))
+ ((memq (car vars) unref)
+ (lp (cdr vars) (cdr vals)
+ s l c))
+ ((memq (car vars) set)
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c)))
+ ((lambda? (car vals))
+ (lp (cdr vars) (cdr vals)
+ s (cons (car vars) l) c))
+ ((simple-expression? (car vals) orig-vars)
+ (lp (cdr vars) (cdr vals)
+ (cons (car vars) s) l c))
+ (else
+ (lp (cdr vars) (cdr vals)
+ s l (cons (car vars) c))))))
+ (else
+ (values unref ref set simple lambda* complex))))
+ '()
+ '()
+ '()
+ '()
+ '()
+ '())))
+ (values unref simple lambda* complex)))
+
+(define (fix-letrec! x)
+ (let-values (((unref simple lambda* complex) (partition-vars x)))
+ (post-order!
+ (lambda (x)
+ (record-case x
+
+ ;; Sets to unreferenced variables may be replaced by their
+ ;; expression, called for effect.
+ ((<lexical-set> gensym exp)
+ (if (memq gensym unref)
+ (make-sequence #f (list (make-void #f) exp))
+ x))
+
+ ((<letrec> src names vars vals body)
+ (let ((binds (map list vars names vals)))
+ (define (lookup set)
+ (map (lambda (v) (assq v binds))
+ (lset-intersection eq? vars set)))
+ (let ((u (lookup unref))
+ (s (lookup simple))
+ (l (lookup lambda*))
+ (c (lookup complex)))
+ ;; Bind "simple" bindings, and locations for complex
+ ;; bindings.
+ (make-let
+ src
+ (append (map cadr s) (map cadr c))
+ (append (map car s) (map car c))
+ (append (map caddr s) (map (lambda (x) (make-void #f)) c))
+ ;; Bind lambdas using the fixpoint operator.
+ (make-fix
+ src (map cadr l) (map car l) (map caddr l)
+ (make-sequence
+ src
+ (append
+ ;; The right-hand-sides of the unreferenced
+ ;; bindings, for effect.
+ (map caddr u)
+ (if (null? c)
+ ;; No complex bindings, just emit the body.
+ (list body)
+ (list
+ ;; Evaluate the the "complex" bindings, in a `let' to
+ ;; indicate that order doesn't matter, and bind to
+ ;; their variables.
+ (let ((tmps (map (lambda (x) (gensym)) c)))
+ (make-let
+ #f (map cadr c) tmps (map caddr c)
+ (make-sequence
+ #f
+ (map (lambda (x tmp)
+ (make-lexical-set
+ #f (cadr x) (car x)
+ (make-lexical-ref #f (cadr x) tmp)))
+ c tmps))))
+ ;; Finally, the body.
+ body)))))))))
+
+ (else x)))
+ x)))
diff --git a/module/language/tree-il/inline.scm
b/module/language/tree-il/inline.scm
new file mode 100644
index 0000000..adc3f18
--- /dev/null
+++ b/module/language/tree-il/inline.scm
@@ -0,0 +1,81 @@
+;;; a simple inliner
+
+;; 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
+
+(define-module (language tree-il inline)
+ #:use-module (system base syntax)
+ #:use-module (language tree-il)
+ #:export (inline!))
+
+;; Possible optimizations:
+;; * constant folding, propagation
+;; * procedure inlining
+;; * always when single call site
+;; * always for "trivial" procs
+;; * otherwise who knows
+;; * dead code elimination
+;; * degenerate case optimizations
+;; * "fixing letrec"
+
+;; This is a completely brain-dead optimization pass whose sole claim to
+;; fame is ((lambda () x)) => x.
+(define (inline! x)
+ (post-order!
+ (lambda (x)
+ (record-case x
+ ((<application> src proc args)
+ (cond
+
+ ;; ((lambda () x)) => x
+ ((and (lambda? proc) (null? (lambda-vars proc))
+ (null? args))
+ (lambda-body proc))
+
+ ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
+ ;; => (let-values (((a b . c) foo)) bar)
+ ;;
+ ;; Note that this is a singly-binding form of let-values. Also
+ ;; note that Scheme's let-values expands into call-with-values,
+ ;; then here we reduce it to tree-il's let-values.
+ ((and (primitive-ref? proc)
+ (eq? (primitive-ref-name proc) '@call-with-values)
+ (= (length args) 2)
+ (lambda? (cadr args)))
+ (let ((producer (car args))
+ (consumer (cadr args)))
+ (make-let-values src
+ (lambda-names consumer)
+ (lambda-vars consumer)
+ (if (and (lambda? producer)
+ (null? (lambda-names producer)))
+ (lambda-body producer)
+ (make-application src producer '()))
+ (lambda-body consumer))))
+
+ (else #f)))
+
+ ((<let> vars body)
+ (if (null? vars) body x))
+
+ ((<letrec> vars body)
+ (if (null? vars) body x))
+
+ ((<fix> vars body)
+ (if (null? vars) body x))
+
+ (else #f)))
+ x))
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index ac16a9e..0e490a6 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -21,21 +21,15 @@
(define-module (language tree-il optimize)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
+ #:use-module (language tree-il inline)
+ #:use-module (language tree-il fix-letrec)
#:export (optimize!))
(define (env-module e)
(if e (car e) (current-module)))
(define (optimize! x env opts)
- (expand-primitives! (resolve-primitives! x (env-module env))))
-
-;; Possible optimizations:
-;; * constant folding, propagation
-;; * procedure inlining
-;; * always when single call site
-;; * always for "trivial" procs
-;; * otherwise who knows
-;; * dead code elimination
-;; * degenerate case optimizations
-;; * "fixing letrec"
-
+ (inline!
+ (fix-letrec!
+ (expand-primitives!
+ (resolve-primitives! x (env-module env))))))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 9ccd272..955c7bf 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -19,12 +19,13 @@
;;; Code:
(define-module (language tree-il primitives)
+ #:use-module (system base pmatch)
#:use-module (rnrs bytevector)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
- expand-primitives!))
+ expand-primitives! effect-free-primitive?))
(define *interesting-primitive-names*
'(apply @apply
@@ -84,6 +85,39 @@
(for-each add-interesting-primitive! *interesting-primitive-names*)
+(define *effect-free-primitives*
+ '(values
+ eq? eqv? equal?
+ = < > <= >= zero?
+ + * - / 1- 1+ quotient remainder modulo
+ not
+ pair? null? list? acons cons cons*
+ list vector
+ car cdr
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ vector-ref
+ bytevector-u8-ref bytevector-s8-ref
+ bytevector-u16-ref bytevector-u16-native-ref
+ bytevector-s16-ref bytevector-s16-native-ref
+ bytevector-u32-ref bytevector-u32-native-ref
+ bytevector-s32-ref bytevector-s32-native-ref
+ bytevector-u64-ref bytevector-u64-native-ref
+ bytevector-s64-ref bytevector-s64-native-ref
+ bytevector-ieee-single-ref bytevector-ieee-single-native-ref
+ bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
+
+
+(define *effect-free-primitive-table* (make-hash-table))
+
+(for-each (lambda (x) (hashq-set! *effect-free-primitive-table* x #t))
+ *effect-free-primitives*)
+
+(define (effect-free-primitive? prim)
+ (hashq-ref *effect-free-primitive-table* prim))
+
(define (resolve-primitives! x mod)
(post-order!
(lambda (x)
@@ -142,8 +176,14 @@
(define (consequent exp)
(cond
((pair? exp)
- `(make-application src (make-primitive-ref src ',(car exp))
- ,(inline-args (cdr exp))))
+ (pmatch exp
+ ((if ,test ,then ,else)
+ `(if ,test
+ ,(consequent then)
+ ,(consequent else)))
+ (else
+ `(make-application src (make-primitive-ref src ',(car exp))
+ ,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
@@ -160,9 +200,21 @@
(cons `((src . ,(car in))
,(consequent (cadr in))) out)))))))
+(define-primitive-expander zero? (x)
+ (= x 0))
+
(define-primitive-expander +
() 0
(x) x
+ (x y) (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (exact? y) (= y 1))))
+ (1+ x)
+ (if (and (const? x)
+ (let ((x (const-exp x)))
+ (and (exact? x) (= x 1))))
+ (1+ y)
+ (+ x y)))
(x y z . rest) (+ x (+ y z . rest)))
(define-primitive-expander *
@@ -172,11 +224,13 @@
(define-primitive-expander -
(x) (- 0 x)
+ (x y) (if (and (const? y)
+ (let ((y (const-exp y)))
+ (and (exact? y) (= y 1))))
+ (1- x)
+ (- x y))
(x y z . rest) (- x (+ y z . rest)))
-(define-primitive-expander 1-
- (x) (- x 1))
-
(define-primitive-expander /
(x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest)))
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
index c8422ee..22bda21 100644
--- a/module/srfi/srfi-11.scm
+++ b/module/srfi/srfi-11.scm
@@ -1,6 +1,6 @@
;;; srfi-11.scm --- let-values and let*-values
-;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 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
@@ -63,148 +63,58 @@
;; (q <tmp-q>))
;; (baz x y z p q))))))
-;; I originally wrote this as a define-macro, but then I found out
-;; that guile's gensym/gentemp was broken, so I tried rewriting it as
-;; a syntax-rules statement.
-;; [make-symbol now fixes gensym/gentemp problems.]
-;;
-;; Since syntax-rules didn't seem powerful enough to implement
-;; let-values in one definition without exposing illegal syntax (or
-;; perhaps my brain's just not powerful enough :>). I tried writing
-;; it using a private helper, but that didn't work because the
-;; let-values expands outside the scope of this module. I wonder why
-;; syntax-rules wasn't designed to allow "private" patterns or
-;; similar...
-;;
-;; So in the end, I dumped the syntax-rules implementation, reproduced
-;; here for posterity, and went with the define-macro one below --
-;; gensym/gentemp's got to be fixed anyhow...
-;
-; (define-syntax let-values-helper
-; (syntax-rules ()
-; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
-; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
-; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
-; ;; temps you create so you can use them later...
-; ;;
-; ;; I really don't fully understand why the (var-1 var-1) trick
-; ;; works below, but basically, when all those (x x) bindings show
-; ;; up in the final "let", syntax-rules forces a renaming.
-
-; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
-; body ...)
-; (lambda lambda-tmps
-; (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
-
-; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings
lv-bindings
-; body ...)
-; (let-values-helper "consumer"
-; (var-2 ...)
-; (lambda-tmp ... var-1)
-; ((var-1 var-1) . final-let-bindings)
-; lv-bindings
-; body ...))
-
-; ((_ "cwv" () final-let-bindings body ...)
-; (let final-let-bindings
-; body ...))
-
-; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
-; body ...)
-; (call-with-values (lambda () binding-1)
-; (let-values-helper "consumer"
-; vars-1
-; ()
-; final-let-bindings
-; (other-bindings ...)
-; body ...)))))
-;
-; (define-syntax let-values
-; (syntax-rules ()
-; ((let-values () body ...)
-; (begin body ...))
-; ((let-values (binding ...) body ...)
-; (let-values-helper "cwv" (binding ...) () body ...))))
-;
-;
-; (define-syntax let-values
-; (letrec-syntax ((build-consumer
-; ;; Take the vars from one let binding (i.e. the (x
-; ;; y z) from ((x y z) (values 1 2 3)) and turn it
-; ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
-; ;; <tmp-z>) ...) from above.
-; (syntax-rules ()
-; ((_ () new-tmps tmp-vars () body ...)
-; (lambda new-tmps
-; body ...))
-; ((_ () new-tmps tmp-vars vars body ...)
-; (lambda new-tmps
-; (lv-builder vars tmp-vars body ...)))
-; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
-; (build-consumer (var-2 ...)
-; (tmp-1 . new-tmps)
-; ((var-1 tmp-1) . tmp-vars)
-; bindings
-; body ...))))
-; (lv-builder
-; (syntax-rules ()
-; ((_ () tmp-vars body ...)
-; (let tmp-vars
-; body ...))
-; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
-; tmp-vars
-; body ...)
-; (call-with-values (lambda () binding-1)
-; (build-consumer vars-1
-; ()
-; tmp-vars
-; ((vars-2 binding-2) ...)
-; body ...))))))
-;
-; (syntax-rules ()
-; ((_ () body ...)
-; (begin body ...))
-; ((_ ((vars binding) ...) body ...)
-; (lv-builder ((vars binding) ...) () body ...)))))
-
-(define-macro (let-values vars . body)
-
- (define (map-1-dot proc elts)
- ;; map over one optionally dotted (a b c . d) list, producing an
- ;; optionally dotted result.
- (cond
- ((null? elts) '())
- ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
- (else (proc elts))))
-
- (define (undot-list lst)
- ;; produce a non-dotted list from a possibly dotted list.
- (cond
- ((null? lst) '())
- ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
- (else (list lst))))
-
- (define (let-values-helper vars body prev-let-vars)
- (let* ((var-binding (car vars))
- (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var"))
- (car var-binding)))
- (let-vars (map (lambda (sym tmp) (list sym tmp))
- (undot-list (car var-binding))
- (undot-list new-tmps))))
-
- (if (null? (cdr vars))
- `(call-with-values (lambda () ,(cadr var-binding))
- (lambda ,new-tmps
- (let ,(apply append let-vars prev-let-vars)
- ,@body)))
- `(call-with-values (lambda () ,(cadr var-binding))
- (lambda ,new-tmps
- ,(let-values-helper (cdr vars) body
- (cons let-vars prev-let-vars)))))))
-
- (if (null? vars)
- `(begin ,@body)
- (let-values-helper vars body '())))
+;; We could really use quasisyntax here...
+(define-syntax let-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((binds exp)) b0 b1 ...)
+ (syntax (call-with-values (lambda () exp)
+ (lambda binds b0 b1 ...))))
+ ((_ (clause ...) b0 b1 ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (ids '())
+ (tmps '()))
+ (if (null? clauses)
+ (with-syntax (((id ...) ids)
+ ((tmp ...) tmps))
+ (syntax (let ((id tmp) ...)
+ b0 b1 ...)))
+ (syntax-case (car clauses) ()
+ (((var ...) exp)
+ (with-syntax (((new-tmp ...) (generate-temporaries
+ (syntax (var ...))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (var ... id ...))
+ (syntax (new-tmp ... tmp ...)))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda (new-tmp ...) inner))))))
+ ((vars exp)
+ (with-syntax ((((new-tmp . new-var) ...)
+ (let lp ((vars (syntax vars)))
+ (syntax-case vars ()
+ ((id . rest)
+ (acons (syntax id)
+ (car
+ (generate-temporaries (syntax
(id))))
+ (lp (syntax rest))))
+ (id (acons (syntax id)
+ (car
+ (generate-temporaries (syntax
(id))))
+ '())))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (new-var ... id ...))
+ (syntax (new-tmp ... tmp ...))))
+ (args (let lp ((tmps (syntax (new-tmp ...))))
+ (syntax-case tmps ()
+ ((id) (syntax id))
+ ((id . rest) (cons (syntax id)
+ (lp (syntax
rest))))))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda args inner)))))))))))))
;;;;;;;;;;;;;;
;; let*-values
@@ -226,28 +136,11 @@
(define-syntax let*-values
(syntax-rules ()
((let*-values () body ...)
- (begin body ...))
+ (let () body ...))
((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
(call-with-values (lambda () binding-1)
(lambda vars-1
(let*-values ((vars-2 binding-2) ...)
body ...))))))
-; Alternate define-macro implementation...
-;
-; (define-macro (let*-values vars . body)
-; (define (let-values-helper vars body)
-; (let ((var-binding (car vars)))
-; (if (null? (cdr vars))
-; `(call-with-values (lambda () ,(cadr var-binding))
-; (lambda ,(car var-binding)
-; ,@body))
-; `(call-with-values (lambda () ,(cadr var-binding))
-; (lambda ,(car var-binding)
-; ,(let-values-helper (cdr vars) body))))))
-
-; (if (null? vars)
-; `(begin ,@body)
-; (let-values-helper vars body)))
-
;;; srfi-11.scm ends here
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index cc73f38..249961d 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -1,6 +1,6 @@
;;; Guile VM specific syntaxes and utilities
-;; Copyright (C) 2001 Free Software Foundation, Inc
+;; Copyright (C) 2001, 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
@@ -174,29 +174,70 @@
;; 5.88 0.01 0.01 list-index
-(define-macro (record-case record . clauses)
- (let ((r (gensym))
- (rtd (gensym)))
- (define (process-clause clause)
- (if (eq? (car clause) 'else)
- clause
- (let ((record-type (caar clause))
- (slots (cdar clause))
- (body (cdr clause)))
- (let ((stem (trim-brackets record-type)))
- `((eq? ,rtd ,record-type)
- (let ,(map (lambda (slot)
- (if (pair? slot)
- `(,(car slot) (,(symbol-append stem '- (cadr
slot)) ,r))
- `(,slot (,(symbol-append stem '- slot) ,r))))
- slots)
- ,@(if (pair? body) body '((if #f #f)))))))))
- `(let* ((,r ,record)
- (,rtd (struct-vtable ,r)))
- (cond ,@(let ((clauses (map process-clause clauses)))
- (if (assq 'else clauses)
- clauses
- (append clauses `((else (error "unhandled record"
,r))))))))))
+;;; So ugly... but I am too ignorant to know how to make it better.
+(define-syntax record-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ record clause ...)
+ (let ((r (syntax r))
+ (rtd (syntax rtd)))
+ (define (process-clause tag fields exprs)
+ (let ((infix (trim-brackets (syntax->datum tag))))
+ (with-syntax ((tag tag)
+ (((f . accessor) ...)
+ (let lp ((fields fields))
+ (syntax-case fields ()
+ (() (syntax ()))
+ (((v0 f0) f1 ...)
+ (acons (syntax v0)
+ (datum->syntax x
+ (symbol-append infix '-
(syntax->datum
+
(syntax f0))))
+ (lp (syntax (f1 ...)))))
+ ((f0 f1 ...)
+ (acons (syntax f0)
+ (datum->syntax x
+ (symbol-append infix '-
(syntax->datum
+
(syntax f0))))
+ (lp (syntax (f1 ...))))))))
+ ((e0 e1 ...)
+ (syntax-case exprs ()
+ (() (syntax (#t)))
+ ((e0 e1 ...) (syntax (e0 e1 ...))))))
+ (syntax
+ ((eq? rtd tag)
+ (let ((f (accessor r))
+ ...)
+ e0 e1 ...))))))
+ (with-syntax
+ ((r r)
+ (rtd rtd)
+ ((processed ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (out '()))
+ (syntax-case clauses (else)
+ (()
+ (reverse! (cons (syntax
+ (else (error "unhandled record" r)))
+ out)))
+ (((else e0 e1 ...))
+ (reverse! (cons (syntax (else e0 e1 ...)) out)))
+ (((else e0 e1 ...) . rest)
+ (syntax-violation 'record-case
+ "bad else clause placement"
+ (syntax x)
+ (syntax (else e0 e1 ...))))
+ ((((<foo> f0 ...) e0 ...) . rest)
+ (lp (syntax rest)
+ (cons (process-clause (syntax <foo>)
+ (syntax (f0 ...))
+ (syntax (e0 ...)))
+ out)))))))
+ (syntax
+ (let* ((r record)
+ (rtd (struct-vtable r)))
+ (cond processed ...)))))))))
+
;; Here we take the terrorism to another level. Nasty, but the client
;; code looks good.
diff --git a/test-suite/tests/asm-to-bytecode.test
b/test-suite/tests/asm-to-bytecode.test
index 33a2a45..d01e93c 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -79,15 +79,15 @@
(char->integer #\1) (char->integer #\4)))
(comp-test '(load-string "foo")
- (vector 'load-string 0 0 3 (char->integer #\f) (char->integer
#\o)
+ (vector 'load-string 0 0 3 1 (char->integer #\f) (char->integer
#\o)
(char->integer #\o)))
(comp-test '(load-symbol "foo")
- (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer
#\o)
+ (vector 'load-symbol 0 0 3 1 (char->integer #\f) (char->integer
#\o)
(char->integer #\o)))
(comp-test '(load-keyword "qux")
- (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer
#\u)
+ (vector 'load-keyword 0 0 3 1 (char->integer #\q)
(char->integer #\u)
(char->integer #\x)))
(comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 896206b..d993e4f 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -72,7 +72,7 @@
(program 0 0 0 () (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
- (program 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
+ (program 0 0 0 () (void) (call add1 1) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
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-126-g42f9187,
Michael Gran <=