mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-15 08:10:17 +02:00
Merge branch 'master' of git://git.savannah.gnu.org/guile into elisp
This commit is contained in:
Daniel Kraft
commit
a43df0ae47
42 changed files with 1767 additions and 1099 deletions
5
gdbinit
5
gdbinit
|
|
@ -148,11 +148,6 @@ define nextframe
|
|||
output $vmdl
|
||||
newline
|
||||
set $vmsp=$vmsp-1
|
||||
sputs "el:\t"
|
||||
output $vmsp
|
||||
sputs "\t"
|
||||
gwrite *$vmsp
|
||||
set $vmsp=$vmsp-1
|
||||
set $vmnlocs=(int)$vmbp->nlocs
|
||||
while $vmnlocs > 0
|
||||
sputs "loc #"
|
||||
|
|
|
|||
209
libguile/chars.c
209
libguile/chars.c
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
|
|
@ -24,6 +24,8 @@
|
|||
|
||||
#include <ctype.h>
|
||||
#include <limits.h>
|
||||
#include <unicase.h>
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/validate.h"
|
||||
|
||||
|
|
@ -55,7 +57,7 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
|
|||
|
||||
SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
|
||||
(SCM x, SCM y),
|
||||
"Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence,\n"
|
||||
"Return @code{#t} iff @var{x} is less than @var{y} in the Unicode sequence,\n"
|
||||
"else @code{#f}.")
|
||||
#define FUNC_NAME s_scm_char_less_p
|
||||
{
|
||||
|
|
@ -68,7 +70,7 @@ SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
|
|||
SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
|
||||
(SCM x, SCM y),
|
||||
"Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
|
||||
"ASCII sequence, else @code{#f}.")
|
||||
"Unicode sequence, else @code{#f}.")
|
||||
#define FUNC_NAME s_scm_char_leq_p
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, x);
|
||||
|
|
@ -79,7 +81,7 @@ SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
|
|||
|
||||
SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
|
||||
(SCM x, SCM y),
|
||||
"Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
|
||||
"Return @code{#t} iff @var{x} is greater than @var{y} in the Unicode\n"
|
||||
"sequence, else @code{#f}.")
|
||||
#define FUNC_NAME s_scm_char_gr_p
|
||||
{
|
||||
|
|
@ -92,7 +94,7 @@ SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
|
|||
SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
|
||||
(SCM x, SCM y),
|
||||
"Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
|
||||
"ASCII sequence, else @code{#f}.")
|
||||
"Unicode sequence, else @code{#f}.")
|
||||
#define FUNC_NAME s_scm_char_geq_p
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, x);
|
||||
|
|
@ -104,7 +106,7 @@ SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
|
|||
SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
|
||||
(SCM x, SCM y),
|
||||
"Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n"
|
||||
"case, else @code{#f}.")
|
||||
"case, else @code{#f}. Case is locale free and not context sensitive.")
|
||||
#define FUNC_NAME s_scm_char_ci_eq_p
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, x);
|
||||
|
|
@ -115,8 +117,9 @@ SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
|
|||
|
||||
SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
|
||||
(SCM x, SCM y),
|
||||
"Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence\n"
|
||||
"ignoring case, else @code{#f}.")
|
||||
"Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
|
||||
"than the Unicode uppercase form @var{y} in the Unicode sequence,\n"
|
||||
"else @code{#f}.")
|
||||
#define FUNC_NAME s_scm_char_ci_less_p
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, x);
|
||||
|
|
@ -127,8 +130,9 @@ SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
|
|||
|
||||
SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
|
||||
(SCM x, SCM y),
|
||||
"Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
|
||||
"ASCII sequence ignoring case, else @code{#f}.")
|
||||
"Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
|
||||
"than or equal to the Unicode uppercase form of @var{y} in the\n"
|
||||
"Unicode sequence, else @code{#f}.")
|
||||
#define FUNC_NAME s_scm_char_ci_leq_p
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, x);
|
||||
|
|
@ -139,8 +143,9 @@ SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
|
|||
|
||||
SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
|
||||
(SCM x, SCM y),
|
||||
"Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
|
||||
"sequence ignoring case, else @code{#f}.")
|
||||
"Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
|
||||
"than the Unicode uppercase form of @var{y} in the Unicode\n"
|
||||
"sequence, else @code{#f}.")
|
||||
#define FUNC_NAME s_scm_char_ci_gr_p
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, x);
|
||||
|
|
@ -151,8 +156,9 @@ SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
|
|||
|
||||
SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
|
||||
(SCM x, SCM y),
|
||||
"Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
|
||||
"ASCII sequence ignoring case, else @code{#f}.")
|
||||
"Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
|
||||
"than or equal to the Unicode uppercase form of @var{y} in the\n"
|
||||
"Unicode sequence, else @code{#f}.")
|
||||
#define FUNC_NAME s_scm_char_ci_geq_p
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, x);
|
||||
|
|
@ -233,7 +239,7 @@ SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
|
|||
#define FUNC_NAME s_scm_char_to_integer
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, chr);
|
||||
return scm_from_ulong (SCM_CHAR(chr));
|
||||
return scm_from_uint32 (SCM_CHAR(chr));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -244,7 +250,15 @@ SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
|
|||
"Return the character at position @var{n} in the ASCII sequence.")
|
||||
#define FUNC_NAME s_scm_integer_to_char
|
||||
{
|
||||
return SCM_MAKE_CHAR (scm_to_uchar (n));
|
||||
scm_t_wchar cn;
|
||||
|
||||
cn = scm_to_wchar (n);
|
||||
|
||||
/* Avoid the surrogates. */
|
||||
if (!SCM_IS_UNICODE_CHAR (cn))
|
||||
scm_out_of_range (FUNC_NAME, n);
|
||||
|
||||
return SCM_MAKE_CHAR (cn);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -255,7 +269,7 @@ SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0,
|
|||
#define FUNC_NAME s_scm_char_upcase
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, chr);
|
||||
return SCM_MAKE_CHAR (toupper (SCM_CHAR (chr)));
|
||||
return SCM_MAKE_CHAR (scm_c_upcase (SCM_CHAR (chr)));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -266,7 +280,7 @@ SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0,
|
|||
#define FUNC_NAME s_scm_char_downcase
|
||||
{
|
||||
SCM_VALIDATE_CHAR (1, chr);
|
||||
return SCM_MAKE_CHAR (tolower (SCM_CHAR(chr)));
|
||||
return SCM_MAKE_CHAR (scm_c_downcase (SCM_CHAR(chr)));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -279,80 +293,121 @@ TODO: change name to scm_i_.. ? --hwn
|
|||
*/
|
||||
|
||||
|
||||
int
|
||||
scm_c_upcase (unsigned int c)
|
||||
scm_t_wchar
|
||||
scm_c_upcase (scm_t_wchar c)
|
||||
{
|
||||
if (c <= UCHAR_MAX)
|
||||
return toupper (c);
|
||||
else
|
||||
return c;
|
||||
return uc_toupper (c);
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
scm_c_downcase (unsigned int c)
|
||||
scm_t_wchar
|
||||
scm_c_downcase (scm_t_wchar c)
|
||||
{
|
||||
if (c <= UCHAR_MAX)
|
||||
return tolower (c);
|
||||
else
|
||||
return c;
|
||||
return uc_tolower (c);
|
||||
}
|
||||
|
||||
|
||||
|
||||
#ifdef _DCC
|
||||
# define ASCII
|
||||
#else
|
||||
# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
|
||||
# define EBCDIC
|
||||
# endif /* (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
|
||||
# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
|
||||
# define ASCII
|
||||
# endif /* (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
|
||||
#endif /* def _DCC */
|
||||
/* There are a few sets of character names: R5RS, Guile
|
||||
extensions for control characters, and leftover Guile extensions.
|
||||
They are listed in order of precedence. */
|
||||
|
||||
const char *const scm_r5rs_charnames[] =
|
||||
{
|
||||
"space", "newline"
|
||||
};
|
||||
|
||||
#ifdef EBCDIC
|
||||
char *const scm_charnames[] =
|
||||
const scm_t_uint32 const scm_r5rs_charnums[] =
|
||||
{
|
||||
0x20, 0x0A
|
||||
};
|
||||
|
||||
const int scm_n_r5rs_charnames = sizeof (scm_r5rs_charnames) / sizeof (char *);
|
||||
|
||||
/* The abbreviated names for control characters. */
|
||||
const char *const scm_C0_control_charnames[] =
|
||||
{
|
||||
/* C0 controls */
|
||||
"nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel",
|
||||
"bs", "ht", "lf", "vt", "ff", "cr", "so", "si",
|
||||
"dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb",
|
||||
"can", "em", "sub", "esc", "fs", "gs", "rs", "us",
|
||||
"sp", "del"
|
||||
};
|
||||
|
||||
const scm_t_uint32 const scm_C0_control_charnums[] =
|
||||
{
|
||||
0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
|
||||
0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
|
||||
0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
|
||||
0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
|
||||
0x20, 0x7f
|
||||
};
|
||||
|
||||
int scm_n_C0_control_charnames = sizeof (scm_C0_control_charnames) / sizeof (char *);
|
||||
|
||||
const char *const scm_alt_charnames[] =
|
||||
{
|
||||
"null", "backspace", "tab", "nl", "newline", "np", "page", "return",
|
||||
};
|
||||
|
||||
const scm_t_uint32 const scm_alt_charnums[] =
|
||||
{
|
||||
0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d
|
||||
};
|
||||
|
||||
const int scm_n_alt_charnames = sizeof (scm_alt_charnames) / sizeof (char *);
|
||||
|
||||
/* Returns the string charname for a character if it exists, or NULL
|
||||
otherwise. */
|
||||
const char *
|
||||
scm_i_charname (SCM chr)
|
||||
{
|
||||
"nul", "soh", "stx", "etx", "pf", "ht", "lc", "del",
|
||||
0 , 0 , "smm", "vt", "ff", "cr", "so", "si",
|
||||
"dle", "dc1", "dc2", "dc3", "res", "nl", "bs", "il",
|
||||
"can", "em", "cc", 0 , "ifs", "igs", "irs", "ius",
|
||||
"ds", "sos", "fs", 0 , "byp", "lf", "eob", "pre",
|
||||
0 , 0 , "sm", 0 , 0 , "enq", "ack", "bel",
|
||||
0 , 0 , "syn", 0 , "pn", "rs", "uc", "eot",
|
||||
0 , 0 , 0 , 0 , "dc4", "nak", 0 , "sub",
|
||||
"space", scm_s_newline, "tab", "backspace", "return", "page", "null"};
|
||||
int c;
|
||||
scm_t_uint32 i = SCM_CHAR (chr);
|
||||
|
||||
const char scm_charnums[] =
|
||||
"\000\001\002\003\004\005\006\007\
|
||||
\010\011\012\013\014\015\016\017\
|
||||
\020\021\022\023\024\025\026\027\
|
||||
\030\031\032\033\034\035\036\037\
|
||||
\040\041\042\043\044\045\046\047\
|
||||
\050\051\052\053\054\055\056\057\
|
||||
\060\061\062\063\064\065\066\067\
|
||||
\070\071\072\073\074\075\076\077\
|
||||
\n\t\b\r\f\0";
|
||||
#endif /* def EBCDIC */
|
||||
#ifdef ASCII
|
||||
char *const scm_charnames[] =
|
||||
for (c = 0; c < scm_n_r5rs_charnames; c++)
|
||||
if (scm_r5rs_charnums[c] == i)
|
||||
return scm_r5rs_charnames[c];
|
||||
|
||||
for (c = 0; c < scm_n_C0_control_charnames; c++)
|
||||
if (scm_C0_control_charnums[c] == i)
|
||||
return scm_C0_control_charnames[c];
|
||||
|
||||
for (c = 0; c < scm_n_alt_charnames; c++)
|
||||
if (scm_alt_charnums[c] == i)
|
||||
return scm_alt_charnames[i];
|
||||
|
||||
return NULL;
|
||||
}
|
||||
|
||||
/* Return a character from a string charname. */
|
||||
SCM
|
||||
scm_i_charname_to_char (const char *charname, size_t charname_len)
|
||||
{
|
||||
"nul","soh","stx","etx","eot","enq","ack","bel",
|
||||
"bs", "ht", "newline", "vt", "np", "cr", "so", "si",
|
||||
"dle","dc1","dc2","dc3","dc4","nak","syn","etb",
|
||||
"can", "em","sub","esc", "fs", "gs", "rs", "us",
|
||||
"space", "sp", "nl", "tab", "backspace", "return", "page", "null", "del"};
|
||||
const char scm_charnums[] =
|
||||
"\000\001\002\003\004\005\006\007\
|
||||
\010\011\012\013\014\015\016\017\
|
||||
\020\021\022\023\024\025\026\027\
|
||||
\030\031\032\033\034\035\036\037\
|
||||
\n\t\b\r\f\0\177";
|
||||
#endif /* def ASCII */
|
||||
int c;
|
||||
|
||||
int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);
|
||||
/* The R5RS charnames. These are supposed to be case
|
||||
insensitive. */
|
||||
for (c = 0; c < scm_n_r5rs_charnames; c++)
|
||||
if ((strlen (scm_r5rs_charnames[c]) == charname_len)
|
||||
&& (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len)))
|
||||
return SCM_MAKE_CHAR (scm_r5rs_charnums[c]);
|
||||
|
||||
/* Then come the controls. These are not case sensitive. */
|
||||
for (c = 0; c < scm_n_C0_control_charnames; c++)
|
||||
if ((strlen (scm_C0_control_charnames[c]) == charname_len)
|
||||
&& (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len)))
|
||||
return SCM_MAKE_CHAR (scm_C0_control_charnums[c]);
|
||||
|
||||
/* Lastly are some old names carried over for compatibility. */
|
||||
for (c = 0; c < scm_n_alt_charnames; c++)
|
||||
if ((strlen (scm_alt_charnames[c]) == charname_len)
|
||||
&& (!strncasecmp (scm_alt_charnames[c], charname, charname_len)))
|
||||
return SCM_MAKE_CHAR (scm_alt_charnums[c]);
|
||||
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
#ifndef SCM_CHARS_H
|
||||
#define SCM_CHARS_H
|
||||
|
||||
/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
|
|
@ -28,15 +28,24 @@
|
|||
|
||||
/* Immediate Characters
|
||||
*/
|
||||
|
||||
#ifndef SCM_WCHAR_DEFINED
|
||||
typedef scm_t_int32 scm_t_wchar;
|
||||
#define SCM_WCHAR_DEFINED
|
||||
#endif
|
||||
|
||||
#define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
|
||||
#define SCM_CHAR(x) ((unsigned int)SCM_ITAG8_DATA(x))
|
||||
#define SCM_MAKE_CHAR(x) SCM_MAKE_ITAG8((scm_t_bits) (unsigned char) (x), scm_tc8_char)
|
||||
#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x))
|
||||
|
||||
|
||||
#define SCM_MAKE_CHAR(x) ({scm_t_int32 _x = (x); \
|
||||
_x < 0 \
|
||||
? SCM_MAKE_ITAG8((scm_t_bits)(unsigned char)_x, scm_tc8_char) \
|
||||
: SCM_MAKE_ITAG8((scm_t_bits)_x, scm_tc8_char);})
|
||||
|
||||
SCM_API char *const scm_charnames[];
|
||||
SCM_API int scm_n_charnames;
|
||||
SCM_API const char scm_charnums[];
|
||||
#define SCM_CODEPOINT_MAX (0x10ffff)
|
||||
#define SCM_IS_UNICODE_CHAR(c) \
|
||||
((scm_t_wchar)(c)<=0xd7ff || \
|
||||
((scm_t_wchar)(c)>=0xe000 && (scm_t_wchar)(c)<=SCM_CODEPOINT_MAX))
|
||||
|
||||
|
||||
|
||||
|
|
@ -61,8 +70,11 @@ SCM_API SCM scm_char_to_integer (SCM chr);
|
|||
SCM_API SCM scm_integer_to_char (SCM n);
|
||||
SCM_API SCM scm_char_upcase (SCM chr);
|
||||
SCM_API SCM scm_char_downcase (SCM chr);
|
||||
SCM_API int scm_c_upcase (unsigned int c);
|
||||
SCM_API int scm_c_downcase (unsigned int c);
|
||||
SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar c);
|
||||
SCM_API scm_t_wchar scm_c_downcase (scm_t_wchar c);
|
||||
SCM_INTERNAL const char *scm_i_charname (SCM chr);
|
||||
SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname,
|
||||
size_t charname_len);
|
||||
SCM_INTERNAL void scm_init_chars (void);
|
||||
|
||||
#endif /* SCM_CHARS_H */
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* 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 License
|
||||
|
|
@ -222,16 +222,6 @@ SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_frame_external_link, "vm-frame-external-link", 1, 0, 0,
|
||||
(SCM frame),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_vm_frame_external_link
|
||||
{
|
||||
SCM_VALIDATE_VM_FRAME (1, frame);
|
||||
return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
|
||||
(SCM frame),
|
||||
"")
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* 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 License
|
||||
|
|
@ -30,12 +30,11 @@
|
|||
/* VM Frame Layout
|
||||
---------------
|
||||
|
||||
| | <- fp + bp->nargs + bp->nlocs + 4
|
||||
| | <- fp + bp->nargs + bp->nlocs + 3
|
||||
+------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
|
||||
| Return address |
|
||||
| MV return address|
|
||||
| Dynamic link |
|
||||
| External link | <- fp + bp->nargs + bp->nlocs
|
||||
| Dynamic link | <- fp + bp->nargs + bp->blocs
|
||||
| Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
|
||||
| Local variable 0 | <- fp + bp->nargs
|
||||
| Argument 1 |
|
||||
|
|
@ -51,21 +50,20 @@
|
|||
#define SCM_FRAME_DATA_ADDRESS(fp) \
|
||||
(fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
|
||||
+ SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
|
||||
#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4)
|
||||
#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 3)
|
||||
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
|
||||
|
||||
#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
|
||||
#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
|
||||
|
||||
#define SCM_FRAME_RETURN_ADDRESS(fp) \
|
||||
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
|
||||
#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
|
||||
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
|
||||
#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
|
||||
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
|
||||
#define SCM_FRAME_DYNAMIC_LINK(fp) \
|
||||
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
|
||||
(SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
|
||||
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
|
||||
((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl);
|
||||
#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0])
|
||||
((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
|
||||
#define SCM_FRAME_VARIABLE(fp,i) fp[i]
|
||||
#define SCM_FRAME_PROGRAM(fp) fp[-1]
|
||||
|
||||
|
|
@ -106,7 +104,6 @@ SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
|
|||
SCM_API SCM scm_vm_frame_return_address (SCM frame);
|
||||
SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
|
||||
SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
|
||||
SCM_API SCM scm_vm_frame_external_link (SCM frame);
|
||||
SCM_API SCM scm_vm_frame_stack (SCM frame);
|
||||
|
||||
SCM_API SCM scm_c_vm_frame_prev (SCM frame);
|
||||
|
|
|
|||
|
|
@ -5863,6 +5863,14 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max)
|
|||
#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
|
||||
#include "libguile/conv-uinteger.i.c"
|
||||
|
||||
#define TYPE scm_t_wchar
|
||||
#define TYPE_MIN (scm_t_int32)-1
|
||||
#define TYPE_MAX (scm_t_int32)0x10ffff
|
||||
#define SIZEOF_TYPE 4
|
||||
#define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
|
||||
#define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
|
||||
#include "libguile/conv-integer.i.c"
|
||||
|
||||
#if SCM_HAVE_T_INT64
|
||||
|
||||
#define TYPE scm_t_int64
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
#ifndef SCM_NUMBERS_H
|
||||
#define SCM_NUMBERS_H
|
||||
|
||||
/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009 Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
* modify it under the terms of the GNU Lesser General Public License
|
||||
|
|
@ -174,6 +174,11 @@ typedef struct scm_t_complex
|
|||
double imag;
|
||||
} scm_t_complex;
|
||||
|
||||
#ifndef SCM_WCHAR_DEFINED
|
||||
typedef scm_t_int32 scm_t_wchar;
|
||||
#define SCM_WCHAR_DEFINED
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
SCM_API SCM scm_exact_p (SCM x);
|
||||
|
|
@ -322,6 +327,9 @@ SCM_API SCM scm_from_int32 (scm_t_int32 x);
|
|||
SCM_API scm_t_uint32 scm_to_uint32 (SCM x);
|
||||
SCM_API SCM scm_from_uint32 (scm_t_uint32 x);
|
||||
|
||||
SCM_API scm_t_wchar scm_to_wchar (SCM x);
|
||||
SCM_API SCM scm_from_wchar (scm_t_wchar x);
|
||||
|
||||
#if SCM_HAVE_T_INT64
|
||||
|
||||
SCM_API scm_t_int64 scm_to_int64 (SCM x);
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@
|
|||
|
||||
/* The objcode magic header. */
|
||||
#define OBJCODE_COOKIE \
|
||||
"GOOF-0.6-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---"
|
||||
"GOOF-0.9-" OBJCODE_ENDIANNESS "-" OBJCODE_WORD_SIZE "---"
|
||||
|
||||
/* The length of the header must be a multiple of 8 bytes. */
|
||||
verify (((sizeof (OBJCODE_COOKIE) - 1) & 7) == 0);
|
||||
|
|
|
|||
|
|
@ -25,11 +25,11 @@
|
|||
struct scm_objcode {
|
||||
scm_t_uint8 nargs;
|
||||
scm_t_uint8 nrest;
|
||||
scm_t_uint8 nlocs;
|
||||
scm_t_uint8 nexts;
|
||||
scm_t_uint16 nlocs;
|
||||
scm_t_uint32 len; /* the maximum index of base[] */
|
||||
scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of
|
||||
base[] for metadata */
|
||||
scm_t_uint32 unused; /* pad so that `base' is 8-byte aligned */
|
||||
scm_t_uint8 base[0];
|
||||
};
|
||||
|
||||
|
|
@ -49,7 +49,6 @@ SCM_API scm_t_bits scm_tc16_objcode;
|
|||
#define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs)
|
||||
#define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest)
|
||||
#define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs)
|
||||
#define SCM_OBJCODE_NEXTS(x) (SCM_OBJCODE_DATA (x)->nexts)
|
||||
#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
|
||||
|
||||
#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
#endif
|
||||
|
||||
#include <errno.h>
|
||||
#include <unictype.h>
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/chars.h"
|
||||
|
|
@ -436,21 +437,39 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
|
|||
case scm_tc3_imm24:
|
||||
if (SCM_CHARP (exp))
|
||||
{
|
||||
long i = SCM_CHAR (exp);
|
||||
scm_t_wchar i = SCM_CHAR (exp);
|
||||
const char *name;
|
||||
|
||||
if (SCM_WRITINGP (pstate))
|
||||
{
|
||||
scm_puts ("#\\", port);
|
||||
if ((i >= 0) && (i <= ' ') && scm_charnames[i])
|
||||
scm_puts (scm_charnames[i], port);
|
||||
#ifndef EBCDIC
|
||||
else if (i == '\177')
|
||||
scm_puts (scm_charnames[scm_n_charnames - 1], port);
|
||||
#endif
|
||||
else if (i < 0 || i > '\177')
|
||||
scm_intprint (i, 8, port);
|
||||
else
|
||||
scm_putc (i, port);
|
||||
name = scm_i_charname (exp);
|
||||
if (name != NULL)
|
||||
scm_puts (name, port);
|
||||
else if (uc_is_general_category_withtable (i, UC_CATEGORY_MASK_L
|
||||
| UC_CATEGORY_MASK_M
|
||||
| UC_CATEGORY_MASK_N
|
||||
| UC_CATEGORY_MASK_P
|
||||
| UC_CATEGORY_MASK_S))
|
||||
/* Print the character if is graphic character. */
|
||||
{
|
||||
if (i<256)
|
||||
{
|
||||
/* Character is graphic. Print it. */
|
||||
scm_putc (i, port);
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Character is graphic but unrepresentable in
|
||||
this port's encoding. */
|
||||
scm_intprint (i, 8, port);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Character is a non-graphical character. */
|
||||
scm_intprint (i, 8, port);
|
||||
}
|
||||
}
|
||||
else
|
||||
scm_putc (i, port);
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* 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 License
|
||||
|
|
@ -36,7 +36,7 @@ scm_t_bits scm_tc16_program;
|
|||
static SCM write_program = SCM_BOOL_F;
|
||||
|
||||
SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
|
||||
(SCM objcode, SCM objtable, SCM external),
|
||||
(SCM objcode, SCM objtable, SCM free_variables),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_make_program
|
||||
{
|
||||
|
|
@ -45,18 +45,12 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
|
|||
objtable = SCM_BOOL_F;
|
||||
else if (scm_is_true (objtable))
|
||||
SCM_VALIDATE_VECTOR (2, objtable);
|
||||
if (SCM_UNLIKELY (SCM_UNBNDP (external)))
|
||||
external = SCM_EOL;
|
||||
else
|
||||
/* FIXME: currently this test is quite expensive (can be 2-3% of total
|
||||
execution time in programs that make many closures). We could remove it,
|
||||
yes, but we'd get much better gains if we used some other method, like
|
||||
just capturing the variables that we need instead of all heap-allocated
|
||||
variables. Dunno. Keeping the check for now, as it's a user-callable
|
||||
function, and inlining the op in the vm's make-closure operation. */
|
||||
SCM_VALIDATE_LIST (3, external);
|
||||
if (SCM_UNLIKELY (SCM_UNBNDP (free_variables)))
|
||||
free_variables = SCM_BOOL_F;
|
||||
else if (free_variables != SCM_BOOL_F)
|
||||
SCM_VALIDATE_VECTOR (3, free_variables);
|
||||
|
||||
SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external);
|
||||
SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_variables);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -65,8 +59,8 @@ program_mark (SCM obj)
|
|||
{
|
||||
if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
|
||||
scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
|
||||
if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj)))
|
||||
scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj));
|
||||
if (scm_is_true (SCM_PROGRAM_FREE_VARIABLES (obj)))
|
||||
scm_gc_mark (SCM_PROGRAM_FREE_VARIABLES (obj));
|
||||
return SCM_PROGRAM_OBJCODE (obj);
|
||||
}
|
||||
|
||||
|
|
@ -151,10 +145,9 @@ SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
|
|||
SCM_VALIDATE_PROGRAM (1, program);
|
||||
|
||||
p = SCM_PROGRAM_DATA (program);
|
||||
return scm_list_4 (SCM_I_MAKINUM (p->nargs),
|
||||
return scm_list_3 (SCM_I_MAKINUM (p->nargs),
|
||||
SCM_I_MAKINUM (p->nrest),
|
||||
SCM_I_MAKINUM (p->nlocs),
|
||||
SCM_I_MAKINUM (p->nexts));
|
||||
SCM_I_MAKINUM (p->nlocs));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -191,7 +184,7 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
|
|||
|
||||
metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
|
||||
if (scm_is_true (metaobj))
|
||||
return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL);
|
||||
return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F);
|
||||
else
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
|
|
@ -300,26 +293,13 @@ scm_c_program_source (SCM program, size_t ip)
|
|||
return source; /* (addr . (filename . (line . column))) */
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
|
||||
SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0,
|
||||
(SCM program),
|
||||
"")
|
||||
#define FUNC_NAME s_scm_program_external
|
||||
#define FUNC_NAME s_scm_program_free_variables
|
||||
{
|
||||
SCM_VALIDATE_PROGRAM (1, program);
|
||||
return SCM_PROGRAM_EXTERNALS (program);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
|
||||
(SCM program, SCM external),
|
||||
"Modify the list of closure variables of @var{program} (for "
|
||||
"debugging purposes).")
|
||||
#define FUNC_NAME s_scm_program_external_set_x
|
||||
{
|
||||
SCM_VALIDATE_PROGRAM (1, program);
|
||||
SCM_VALIDATE_LIST (2, external);
|
||||
SCM_PROGRAM_EXTERNALS (program) = external;
|
||||
return SCM_UNSPECIFIED;
|
||||
return SCM_PROGRAM_FREE_VARIABLES (program);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* 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 License
|
||||
|
|
@ -35,12 +35,12 @@ SCM_API scm_t_bits scm_tc16_program;
|
|||
#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x))
|
||||
#define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x))
|
||||
#define SCM_PROGRAM_OBJTABLE(x) (SCM_SMOB_OBJECT_2 (x))
|
||||
#define SCM_PROGRAM_EXTERNALS(x) (SCM_SMOB_OBJECT_3 (x))
|
||||
#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_SMOB_OBJECT_3 (x))
|
||||
#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
|
||||
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
|
||||
#define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
|
||||
|
||||
SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
|
||||
SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
|
||||
|
||||
SCM_API SCM scm_program_p (SCM obj);
|
||||
SCM_API SCM scm_program_base (SCM program);
|
||||
|
|
@ -53,8 +53,7 @@ SCM_API SCM scm_program_properties (SCM program);
|
|||
SCM_API SCM scm_program_name (SCM program);
|
||||
SCM_API SCM scm_program_objects (SCM program);
|
||||
SCM_API SCM scm_program_module (SCM program);
|
||||
SCM_API SCM scm_program_external (SCM program);
|
||||
SCM_API SCM scm_program_external_set_x (SCM program, SCM external);
|
||||
SCM_API SCM scm_program_free_variables (SCM program);
|
||||
SCM_API SCM scm_program_objcode (SCM program);
|
||||
|
||||
SCM_API SCM scm_c_program_source (SCM program, size_t ip);
|
||||
|
|
|
|||
|
|
@ -801,7 +801,7 @@ static SCM
|
|||
scm_read_character (int chr, SCM port)
|
||||
#define FUNC_NAME "scm_lreadr"
|
||||
{
|
||||
unsigned c;
|
||||
SCM ch;
|
||||
char charname[READER_CHAR_NAME_MAX_SIZE];
|
||||
size_t charname_len;
|
||||
|
||||
|
|
@ -834,10 +834,9 @@ scm_read_character (int chr, SCM port)
|
|||
return SCM_MAKE_CHAR (SCM_I_INUM (p));
|
||||
}
|
||||
|
||||
for (c = 0; c < scm_n_charnames; c++)
|
||||
if (scm_charnames[c]
|
||||
&& (!strncasecmp (scm_charnames[c], charname, charname_len)))
|
||||
return SCM_MAKE_CHAR (scm_charnums[c]);
|
||||
ch = scm_i_charname_to_char (charname, charname_len);
|
||||
if (scm_is_true (ch))
|
||||
return ch;
|
||||
|
||||
char_error:
|
||||
scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
|
||||
|
|
|
|||
|
|
@ -21,14 +21,14 @@
|
|||
#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
|
||||
#define VM_USE_HOOKS 0 /* Various hooks */
|
||||
#define VM_USE_CLOCK 0 /* Bogoclock */
|
||||
#define VM_CHECK_EXTERNAL 1 /* Check external link */
|
||||
#define VM_CHECK_OBJECT 1 /* Check object table */
|
||||
#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */
|
||||
#define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */
|
||||
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
|
||||
#define VM_USE_HOOKS 1
|
||||
#define VM_USE_CLOCK 1
|
||||
#define VM_CHECK_EXTERNAL 1
|
||||
#define VM_CHECK_OBJECT 1
|
||||
#define VM_CHECK_FREE_VARIABLES 1
|
||||
#define VM_PUSH_DEBUG_FRAMES 1
|
||||
#else
|
||||
#error unknown debug engine VM_ENGINE
|
||||
|
|
@ -47,7 +47,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
|
|||
|
||||
/* Cache variables */
|
||||
struct scm_objcode *bp = NULL; /* program base pointer */
|
||||
SCM external = SCM_EOL; /* external environment */
|
||||
SCM *free_vars = NULL; /* free variables */
|
||||
size_t free_vars_count = 0; /* length of FREE_VARS */
|
||||
SCM *objects = NULL; /* constant objects */
|
||||
size_t object_count = 0; /* length of OBJECTS */
|
||||
SCM *stack_base = vp->stack_base; /* stack base address */
|
||||
|
|
@ -226,16 +227,16 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
|
|||
goto vm_error;
|
||||
#endif
|
||||
|
||||
#if VM_CHECK_EXTERNAL
|
||||
vm_error_external:
|
||||
err_msg = scm_from_locale_string ("VM: Invalid external access");
|
||||
#if VM_CHECK_OBJECT
|
||||
vm_error_object:
|
||||
err_msg = scm_from_locale_string ("VM: Invalid object table access");
|
||||
finish_args = SCM_EOL;
|
||||
goto vm_error;
|
||||
#endif
|
||||
|
||||
#if VM_CHECK_OBJECT
|
||||
vm_error_object:
|
||||
err_msg = scm_from_locale_string ("VM: Invalid object table access");
|
||||
#if VM_CHECK_FREE_VARIABLES
|
||||
vm_error_free_variable:
|
||||
err_msg = scm_from_locale_string ("VM: Invalid free variable access");
|
||||
finish_args = SCM_EOL;
|
||||
goto vm_error;
|
||||
#endif
|
||||
|
|
@ -252,8 +253,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
|
|||
|
||||
#undef VM_USE_HOOKS
|
||||
#undef VM_USE_CLOCK
|
||||
#undef VM_CHECK_EXTERNAL
|
||||
#undef VM_CHECK_OBJECT
|
||||
#undef VM_CHECK_FREE_VARIABLE
|
||||
#undef VM_PUSH_DEBUG_FRAMES
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -117,26 +117,36 @@
|
|||
vp->fp = fp; \
|
||||
}
|
||||
|
||||
/* FIXME */
|
||||
#define ASSERT_VARIABLE(x) \
|
||||
do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); } \
|
||||
} while (0)
|
||||
#define ASSERT_BOUND_VARIABLE(x) \
|
||||
do { ASSERT_VARIABLE (x); \
|
||||
if (SCM_VARIABLE_REF (x) == SCM_UNDEFINED) \
|
||||
{ SYNC_REGISTER (); abort(); } \
|
||||
} while (0)
|
||||
|
||||
#ifdef VM_ENABLE_PARANOID_ASSERTIONS
|
||||
#define CHECK_IP() \
|
||||
do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
|
||||
#define ASSERT_ALIGNED_PROCEDURE() \
|
||||
do { if ((scm_t_bits)bp % 8) abort (); } while (0)
|
||||
#define ASSERT_BOUND(x) \
|
||||
do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
|
||||
} while (0)
|
||||
#else
|
||||
#define CHECK_IP()
|
||||
#define ASSERT_ALIGNED_PROCEDURE()
|
||||
#define ASSERT_BOUND(x)
|
||||
#endif
|
||||
|
||||
/* Get a local copy of the program's "object table" (i.e. the vector of
|
||||
external bindings that are referenced by the program), initialized by
|
||||
`load-program'. */
|
||||
/* XXX: We could instead use the "simple vector macros", thus not having to
|
||||
call `scm_vector_writable_elements ()' and the likes. */
|
||||
/* Cache the object table and free variables. */
|
||||
#define CACHE_PROGRAM() \
|
||||
{ \
|
||||
if (bp != SCM_PROGRAM_DATA (program)) { \
|
||||
bp = SCM_PROGRAM_DATA (program); \
|
||||
ASSERT_ALIGNED_PROCEDURE (); \
|
||||
if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
|
||||
objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
|
||||
object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \
|
||||
|
|
@ -145,6 +155,19 @@
|
|||
object_count = 0; \
|
||||
} \
|
||||
} \
|
||||
{ \
|
||||
SCM c = SCM_PROGRAM_FREE_VARIABLES (program); \
|
||||
if (SCM_I_IS_VECTOR (c)) \
|
||||
{ \
|
||||
free_vars = SCM_I_VECTOR_WELTS (c); \
|
||||
free_vars_count = SCM_I_VECTOR_LENGTH (c); \
|
||||
} \
|
||||
else \
|
||||
{ \
|
||||
free_vars = NULL; \
|
||||
free_vars_count = 0; \
|
||||
} \
|
||||
} \
|
||||
}
|
||||
|
||||
#define SYNC_BEFORE_GC() \
|
||||
|
|
@ -162,14 +185,6 @@
|
|||
* Error check
|
||||
*/
|
||||
|
||||
#undef CHECK_EXTERNAL
|
||||
#if VM_CHECK_EXTERNAL
|
||||
#define CHECK_EXTERNAL(e) \
|
||||
do { if (SCM_UNLIKELY (!SCM_CONSP (e))) goto vm_error_external; } while (0)
|
||||
#else
|
||||
#define CHECK_EXTERNAL(e)
|
||||
#endif
|
||||
|
||||
/* Accesses to a program's object table. */
|
||||
#if VM_CHECK_OBJECT
|
||||
#define CHECK_OBJECT(_num) \
|
||||
|
|
@ -178,6 +193,13 @@
|
|||
#define CHECK_OBJECT(_num)
|
||||
#endif
|
||||
|
||||
#if VM_CHECK_FREE_VARIABLES
|
||||
#define CHECK_FREE_VARIABLE(_num) \
|
||||
do { if (SCM_UNLIKELY ((_num) >= free_vars_count)) goto vm_error_free_variable; } while (0)
|
||||
#else
|
||||
#define CHECK_FREE_VARIABLE(_num)
|
||||
#endif
|
||||
|
||||
|
||||
/*
|
||||
* Hooks
|
||||
|
|
@ -376,7 +398,7 @@ do { \
|
|||
/* New registers */ \
|
||||
fp = sp - bp->nargs + 1; \
|
||||
data = SCM_FRAME_DATA_ADDRESS (fp); \
|
||||
sp = data + 3; \
|
||||
sp = data + 2; \
|
||||
CHECK_OVERFLOW (); \
|
||||
stack_base = sp; \
|
||||
ip = bp->base; \
|
||||
|
|
@ -386,23 +408,11 @@ do { \
|
|||
data[-i] = SCM_UNDEFINED; \
|
||||
\
|
||||
/* Set frame data */ \
|
||||
data[3] = (SCM)ra; \
|
||||
data[2] = 0x0; \
|
||||
data[1] = (SCM)dl; \
|
||||
\
|
||||
/* Postpone initializing external vars, \
|
||||
because if the CONS causes a GC, we \
|
||||
want the stack marker to see the data \
|
||||
array formatted as expected. */ \
|
||||
data[0] = SCM_UNDEFINED; \
|
||||
external = SCM_PROGRAM_EXTERNALS (fp[-1]); \
|
||||
for (i = 0; i < bp->nexts; i++) \
|
||||
CONS (external, SCM_UNDEFINED, external); \
|
||||
data[0] = external; \
|
||||
data[2] = (SCM)ra; \
|
||||
data[1] = 0x0; \
|
||||
data[0] = (SCM)dl; \
|
||||
}
|
||||
|
||||
#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
|
||||
/* This file is included in vm_engine.c */
|
||||
|
||||
VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer")
|
||||
VM_DEFINE_LOADER (80, load_unsigned_integer, "load-unsigned-integer")
|
||||
{
|
||||
size_t len;
|
||||
|
||||
|
|
@ -38,7 +38,7 @@ VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer")
|
|||
SCM_MISC_ERROR ("load-unsigned-integer: not implemented yet", SCM_EOL);
|
||||
}
|
||||
|
||||
VM_DEFINE_LOADER (60, load_integer, "load-integer")
|
||||
VM_DEFINE_LOADER (81, load_integer, "load-integer")
|
||||
{
|
||||
size_t len;
|
||||
|
||||
|
|
@ -56,7 +56,7 @@ VM_DEFINE_LOADER (60, load_integer, "load-integer")
|
|||
SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
|
||||
}
|
||||
|
||||
VM_DEFINE_LOADER (61, load_number, "load-number")
|
||||
VM_DEFINE_LOADER (82, load_number, "load-number")
|
||||
{
|
||||
size_t len;
|
||||
|
||||
|
|
@ -69,7 +69,7 @@ VM_DEFINE_LOADER (61, load_number, "load-number")
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_LOADER (62, load_string, "load-string")
|
||||
VM_DEFINE_LOADER (83, load_string, "load-string")
|
||||
{
|
||||
size_t len;
|
||||
FETCH_LENGTH (len);
|
||||
|
|
@ -80,7 +80,7 @@ VM_DEFINE_LOADER (62, load_string, "load-string")
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_LOADER (63, load_symbol, "load-symbol")
|
||||
VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
|
||||
{
|
||||
size_t len;
|
||||
FETCH_LENGTH (len);
|
||||
|
|
@ -90,7 +90,7 @@ VM_DEFINE_LOADER (63, load_symbol, "load-symbol")
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_LOADER (64, load_keyword, "load-keyword")
|
||||
VM_DEFINE_LOADER (85, load_keyword, "load-keyword")
|
||||
{
|
||||
size_t len;
|
||||
FETCH_LENGTH (len);
|
||||
|
|
@ -100,7 +100,7 @@ VM_DEFINE_LOADER (64, load_keyword, "load-keyword")
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_LOADER (65, load_program, "load-program")
|
||||
VM_DEFINE_LOADER (86, load_program, "load-program")
|
||||
{
|
||||
scm_t_uint32 len;
|
||||
SCM objs, objcode;
|
||||
|
|
@ -114,14 +114,14 @@ VM_DEFINE_LOADER (65, load_program, "load-program")
|
|||
objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
|
||||
len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
|
||||
|
||||
PUSH (scm_make_program (objcode, objs, SCM_EOL));
|
||||
PUSH (scm_make_program (objcode, objs, SCM_BOOL_F));
|
||||
|
||||
ip += len;
|
||||
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1)
|
||||
VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1)
|
||||
{
|
||||
SCM what;
|
||||
POP (what);
|
||||
|
|
@ -130,7 +130,7 @@ VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_LOADER (67, define, "define")
|
||||
VM_DEFINE_LOADER (88, define, "define")
|
||||
{
|
||||
SCM sym;
|
||||
size_t len;
|
||||
|
|
@ -145,7 +145,7 @@ VM_DEFINE_LOADER (67, define, "define")
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_LOADER (68, load_array, "load-array")
|
||||
VM_DEFINE_LOADER (89, load_array, "load-array")
|
||||
{
|
||||
SCM type, shape;
|
||||
size_t len;
|
||||
|
|
@ -163,7 +163,7 @@ VM_DEFINE_LOADER (68, load_array, "load-array")
|
|||
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
|
||||
(interactive "")
|
||||
(save-excursion
|
||||
(let ((counter 59)) (goto-char (point-min))
|
||||
(let ((counter 79)) (goto-char (point-min))
|
||||
(while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
|
||||
(replace-match
|
||||
(number-to-string (setq counter (1+ counter)))
|
||||
|
|
|
|||
|
|
@ -29,43 +29,43 @@
|
|||
|
||||
#define RETURN(x) do { *sp = x; NEXT; } while (0)
|
||||
|
||||
VM_DEFINE_FUNCTION (80, not, "not", 1)
|
||||
VM_DEFINE_FUNCTION (100, not, "not", 1)
|
||||
{
|
||||
ARGS1 (x);
|
||||
RETURN (SCM_BOOL (SCM_FALSEP (x)));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (81, not_not, "not-not", 1)
|
||||
VM_DEFINE_FUNCTION (101, not_not, "not-not", 1)
|
||||
{
|
||||
ARGS1 (x);
|
||||
RETURN (SCM_BOOL (!SCM_FALSEP (x)));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (82, eq, "eq?", 2)
|
||||
VM_DEFINE_FUNCTION (102, eq, "eq?", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (83, not_eq, "not-eq?", 2)
|
||||
VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (84, nullp, "null?", 1)
|
||||
VM_DEFINE_FUNCTION (104, nullp, "null?", 1)
|
||||
{
|
||||
ARGS1 (x);
|
||||
RETURN (SCM_BOOL (SCM_NULLP (x)));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (85, not_nullp, "not-null?", 1)
|
||||
VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1)
|
||||
{
|
||||
ARGS1 (x);
|
||||
RETURN (SCM_BOOL (!SCM_NULLP (x)));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2)
|
||||
VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
if (SCM_EQ_P (x, y))
|
||||
|
|
@ -76,7 +76,7 @@ VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2)
|
|||
RETURN (scm_eqv_p (x, y));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (87, equal, "equal?", 2)
|
||||
VM_DEFINE_FUNCTION (107, equal, "equal?", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
if (SCM_EQ_P (x, y))
|
||||
|
|
@ -87,13 +87,13 @@ VM_DEFINE_FUNCTION (87, equal, "equal?", 2)
|
|||
RETURN (scm_equal_p (x, y));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (88, pairp, "pair?", 1)
|
||||
VM_DEFINE_FUNCTION (108, pairp, "pair?", 1)
|
||||
{
|
||||
ARGS1 (x);
|
||||
RETURN (SCM_BOOL (SCM_CONSP (x)));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (89, listp, "list?", 1)
|
||||
VM_DEFINE_FUNCTION (109, listp, "list?", 1)
|
||||
{
|
||||
ARGS1 (x);
|
||||
RETURN (SCM_BOOL (scm_ilength (x) >= 0));
|
||||
|
|
@ -104,7 +104,7 @@ VM_DEFINE_FUNCTION (89, listp, "list?", 1)
|
|||
* Basic data
|
||||
*/
|
||||
|
||||
VM_DEFINE_FUNCTION (90, cons, "cons", 2)
|
||||
VM_DEFINE_FUNCTION (110, cons, "cons", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
CONS (x, x, y);
|
||||
|
|
@ -117,21 +117,21 @@ VM_DEFINE_FUNCTION (90, cons, "cons", 2)
|
|||
goto vm_error_not_a_pair; \
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (91, car, "car", 1)
|
||||
VM_DEFINE_FUNCTION (111, car, "car", 1)
|
||||
{
|
||||
ARGS1 (x);
|
||||
VM_VALIDATE_CONS (x);
|
||||
RETURN (SCM_CAR (x));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (92, cdr, "cdr", 1)
|
||||
VM_DEFINE_FUNCTION (112, cdr, "cdr", 1)
|
||||
{
|
||||
ARGS1 (x);
|
||||
VM_VALIDATE_CONS (x);
|
||||
RETURN (SCM_CDR (x));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0)
|
||||
VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0)
|
||||
{
|
||||
SCM x, y;
|
||||
POP (y);
|
||||
|
|
@ -141,7 +141,7 @@ VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0)
|
||||
VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0)
|
||||
{
|
||||
SCM x, y;
|
||||
POP (y);
|
||||
|
|
@ -166,27 +166,27 @@ VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0)
|
|||
RETURN (srel (x, y)); \
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (95, ee, "ee?", 2)
|
||||
VM_DEFINE_FUNCTION (115, ee, "ee?", 2)
|
||||
{
|
||||
REL (==, scm_num_eq_p);
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (96, lt, "lt?", 2)
|
||||
VM_DEFINE_FUNCTION (116, lt, "lt?", 2)
|
||||
{
|
||||
REL (<, scm_less_p);
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (97, le, "le?", 2)
|
||||
VM_DEFINE_FUNCTION (117, le, "le?", 2)
|
||||
{
|
||||
REL (<=, scm_leq_p);
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (98, gt, "gt?", 2)
|
||||
VM_DEFINE_FUNCTION (118, gt, "gt?", 2)
|
||||
{
|
||||
REL (>, scm_gr_p);
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
|
||||
VM_DEFINE_FUNCTION (119, ge, "ge?", 2)
|
||||
{
|
||||
REL (>=, scm_geq_p);
|
||||
}
|
||||
|
|
@ -210,45 +210,45 @@ VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
|
|||
RETURN (SFUNC (x, y)); \
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (100, add, "add", 2)
|
||||
VM_DEFINE_FUNCTION (120, add, "add", 2)
|
||||
{
|
||||
FUNC2 (+, scm_sum);
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (101, sub, "sub", 2)
|
||||
VM_DEFINE_FUNCTION (121, sub, "sub", 2)
|
||||
{
|
||||
FUNC2 (-, scm_difference);
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (102, mul, "mul", 2)
|
||||
VM_DEFINE_FUNCTION (122, mul, "mul", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
SYNC_REGISTER ();
|
||||
RETURN (scm_product (x, y));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (103, div, "div", 2)
|
||||
VM_DEFINE_FUNCTION (123, div, "div", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
SYNC_REGISTER ();
|
||||
RETURN (scm_divide (x, y));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (104, quo, "quo", 2)
|
||||
VM_DEFINE_FUNCTION (124, quo, "quo", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
SYNC_REGISTER ();
|
||||
RETURN (scm_quotient (x, y));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (105, rem, "rem", 2)
|
||||
VM_DEFINE_FUNCTION (125, rem, "rem", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
SYNC_REGISTER ();
|
||||
RETURN (scm_remainder (x, y));
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (106, mod, "mod", 2)
|
||||
VM_DEFINE_FUNCTION (126, mod, "mod", 2)
|
||||
{
|
||||
ARGS2 (x, y);
|
||||
SYNC_REGISTER ();
|
||||
|
|
@ -259,7 +259,7 @@ VM_DEFINE_FUNCTION (106, mod, "mod", 2)
|
|||
/*
|
||||
* GOOPS support
|
||||
*/
|
||||
VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
|
||||
VM_DEFINE_FUNCTION (127, slot_ref, "slot-ref", 2)
|
||||
{
|
||||
size_t slot;
|
||||
ARGS2 (instance, idx);
|
||||
|
|
@ -267,7 +267,7 @@ VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
|
|||
RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (128, slot_set, "slot-set", 0, 3, 0)
|
||||
{
|
||||
SCM instance, idx, val;
|
||||
size_t slot;
|
||||
|
|
@ -279,7 +279,7 @@ VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2)
|
||||
VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
|
||||
{
|
||||
long i = 0;
|
||||
ARGS2 (vect, idx);
|
||||
|
|
@ -292,7 +292,7 @@ VM_DEFINE_FUNCTION (109, vector_ref, "vector-ref", 2)
|
|||
RETURN (scm_vector_ref (vect, idx));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
|
||||
{
|
||||
long i = 0;
|
||||
SCM vect, idx, val;
|
||||
|
|
@ -325,21 +325,21 @@ VM_DEFINE_INSTRUCTION (110, vector_set, "vector-set", 0, 3, 0)
|
|||
} \
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (111, bv_u16_ref, "bv-u16-ref", 3)
|
||||
VM_DEFINE_FUNCTION (131, bv_u16_ref, "bv-u16-ref", 3)
|
||||
BV_REF_WITH_ENDIANNESS (u16, u16)
|
||||
VM_DEFINE_FUNCTION (112, bv_s16_ref, "bv-s16-ref", 3)
|
||||
VM_DEFINE_FUNCTION (132, bv_s16_ref, "bv-s16-ref", 3)
|
||||
BV_REF_WITH_ENDIANNESS (s16, s16)
|
||||
VM_DEFINE_FUNCTION (113, bv_u32_ref, "bv-u32-ref", 3)
|
||||
VM_DEFINE_FUNCTION (133, bv_u32_ref, "bv-u32-ref", 3)
|
||||
BV_REF_WITH_ENDIANNESS (u32, u32)
|
||||
VM_DEFINE_FUNCTION (114, bv_s32_ref, "bv-s32-ref", 3)
|
||||
VM_DEFINE_FUNCTION (134, bv_s32_ref, "bv-s32-ref", 3)
|
||||
BV_REF_WITH_ENDIANNESS (s32, s32)
|
||||
VM_DEFINE_FUNCTION (115, bv_u64_ref, "bv-u64-ref", 3)
|
||||
VM_DEFINE_FUNCTION (135, bv_u64_ref, "bv-u64-ref", 3)
|
||||
BV_REF_WITH_ENDIANNESS (u64, u64)
|
||||
VM_DEFINE_FUNCTION (116, bv_s64_ref, "bv-s64-ref", 3)
|
||||
VM_DEFINE_FUNCTION (136, bv_s64_ref, "bv-s64-ref", 3)
|
||||
BV_REF_WITH_ENDIANNESS (s64, s64)
|
||||
VM_DEFINE_FUNCTION (117, bv_f32_ref, "bv-f32-ref", 3)
|
||||
VM_DEFINE_FUNCTION (137, bv_f32_ref, "bv-f32-ref", 3)
|
||||
BV_REF_WITH_ENDIANNESS (f32, ieee_single)
|
||||
VM_DEFINE_FUNCTION (118, bv_f64_ref, "bv-f64-ref", 3)
|
||||
VM_DEFINE_FUNCTION (138, bv_f64_ref, "bv-f64-ref", 3)
|
||||
BV_REF_WITH_ENDIANNESS (f64, ieee_double)
|
||||
|
||||
#undef BV_REF_WITH_ENDIANNESS
|
||||
|
|
@ -392,26 +392,26 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
|
|||
RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \
|
||||
}
|
||||
|
||||
VM_DEFINE_FUNCTION (119, bv_u8_ref, "bv-u8-ref", 2)
|
||||
VM_DEFINE_FUNCTION (139, bv_u8_ref, "bv-u8-ref", 2)
|
||||
BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
|
||||
VM_DEFINE_FUNCTION (120, bv_s8_ref, "bv-s8-ref", 2)
|
||||
VM_DEFINE_FUNCTION (140, bv_s8_ref, "bv-s8-ref", 2)
|
||||
BV_FIXABLE_INT_REF (s8, s8, int8, 1)
|
||||
VM_DEFINE_FUNCTION (121, bv_u16_native_ref, "bv-u16-native-ref", 2)
|
||||
VM_DEFINE_FUNCTION (141, bv_u16_native_ref, "bv-u16-native-ref", 2)
|
||||
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
|
||||
VM_DEFINE_FUNCTION (122, bv_s16_native_ref, "bv-s16-native-ref", 2)
|
||||
VM_DEFINE_FUNCTION (142, bv_s16_native_ref, "bv-s16-native-ref", 2)
|
||||
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
|
||||
VM_DEFINE_FUNCTION (123, bv_u32_native_ref, "bv-u32-native-ref", 2)
|
||||
VM_DEFINE_FUNCTION (143, bv_u32_native_ref, "bv-u32-native-ref", 2)
|
||||
/* FIXME: u32 is always a fixnum on 64-bit builds */
|
||||
BV_INT_REF (u32, uint32, 4)
|
||||
VM_DEFINE_FUNCTION (124, bv_s32_native_ref, "bv-s32-native-ref", 2)
|
||||
VM_DEFINE_FUNCTION (144, bv_s32_native_ref, "bv-s32-native-ref", 2)
|
||||
BV_INT_REF (s32, int32, 4)
|
||||
VM_DEFINE_FUNCTION (125, bv_u64_native_ref, "bv-u64-native-ref", 2)
|
||||
VM_DEFINE_FUNCTION (145, bv_u64_native_ref, "bv-u64-native-ref", 2)
|
||||
BV_INT_REF (u64, uint64, 8)
|
||||
VM_DEFINE_FUNCTION (126, bv_s64_native_ref, "bv-s64-native-ref", 2)
|
||||
VM_DEFINE_FUNCTION (146, bv_s64_native_ref, "bv-s64-native-ref", 2)
|
||||
BV_INT_REF (s64, int64, 8)
|
||||
VM_DEFINE_FUNCTION (127, bv_f32_native_ref, "bv-f32-native-ref", 2)
|
||||
VM_DEFINE_FUNCTION (147, bv_f32_native_ref, "bv-f32-native-ref", 2)
|
||||
BV_FLOAT_REF (f32, ieee_single, float, 4)
|
||||
VM_DEFINE_FUNCTION (128, bv_f64_native_ref, "bv-f64-native-ref", 2)
|
||||
VM_DEFINE_FUNCTION (148, bv_f64_native_ref, "bv-f64-native-ref", 2)
|
||||
BV_FLOAT_REF (f64, ieee_double, double, 8)
|
||||
|
||||
#undef BV_FIXABLE_INT_REF
|
||||
|
|
@ -433,21 +433,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8)
|
|||
} \
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (129, bv_u16_set, "bv-u16-set", 0, 4, 0)
|
||||
VM_DEFINE_INSTRUCTION (149, bv_u16_set, "bv-u16-set", 0, 4, 0)
|
||||
BV_SET_WITH_ENDIANNESS (u16, u16)
|
||||
VM_DEFINE_INSTRUCTION (130, bv_s16_set, "bv-s16-set", 0, 4, 0)
|
||||
VM_DEFINE_INSTRUCTION (150, bv_s16_set, "bv-s16-set", 0, 4, 0)
|
||||
BV_SET_WITH_ENDIANNESS (s16, s16)
|
||||
VM_DEFINE_INSTRUCTION (131, bv_u32_set, "bv-u32-set", 0, 4, 0)
|
||||
VM_DEFINE_INSTRUCTION (151, bv_u32_set, "bv-u32-set", 0, 4, 0)
|
||||
BV_SET_WITH_ENDIANNESS (u32, u32)
|
||||
VM_DEFINE_INSTRUCTION (132, bv_s32_set, "bv-s32-set", 0, 4, 0)
|
||||
VM_DEFINE_INSTRUCTION (152, bv_s32_set, "bv-s32-set", 0, 4, 0)
|
||||
BV_SET_WITH_ENDIANNESS (s32, s32)
|
||||
VM_DEFINE_INSTRUCTION (133, bv_u64_set, "bv-u64-set", 0, 4, 0)
|
||||
VM_DEFINE_INSTRUCTION (153, bv_u64_set, "bv-u64-set", 0, 4, 0)
|
||||
BV_SET_WITH_ENDIANNESS (u64, u64)
|
||||
VM_DEFINE_INSTRUCTION (134, bv_s64_set, "bv-s64-set", 0, 4, 0)
|
||||
VM_DEFINE_INSTRUCTION (154, bv_s64_set, "bv-s64-set", 0, 4, 0)
|
||||
BV_SET_WITH_ENDIANNESS (s64, s64)
|
||||
VM_DEFINE_INSTRUCTION (135, bv_f32_set, "bv-f32-set", 0, 4, 0)
|
||||
VM_DEFINE_INSTRUCTION (155, bv_f32_set, "bv-f32-set", 0, 4, 0)
|
||||
BV_SET_WITH_ENDIANNESS (f32, ieee_single)
|
||||
VM_DEFINE_INSTRUCTION (136, bv_f64_set, "bv-f64-set", 0, 4, 0)
|
||||
VM_DEFINE_INSTRUCTION (156, bv_f64_set, "bv-f64-set", 0, 4, 0)
|
||||
BV_SET_WITH_ENDIANNESS (f64, ieee_double)
|
||||
|
||||
#undef BV_SET_WITH_ENDIANNESS
|
||||
|
|
@ -500,26 +500,26 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
|
|||
NEXT; \
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (137, bv_u8_set, "bv-u8-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (157, bv_u8_set, "bv-u8-set", 0, 3, 0)
|
||||
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
|
||||
VM_DEFINE_INSTRUCTION (138, bv_s8_set, "bv-s8-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (158, bv_s8_set, "bv-s8-set", 0, 3, 0)
|
||||
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
|
||||
VM_DEFINE_INSTRUCTION (139, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (159, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
|
||||
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
|
||||
VM_DEFINE_INSTRUCTION (140, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (160, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
|
||||
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
|
||||
VM_DEFINE_INSTRUCTION (141, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (161, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
|
||||
/* FIXME: u32 is always a fixnum on 64-bit builds */
|
||||
BV_INT_SET (u32, uint32, 4)
|
||||
VM_DEFINE_INSTRUCTION (142, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (162, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
|
||||
BV_INT_SET (s32, int32, 4)
|
||||
VM_DEFINE_INSTRUCTION (143, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (163, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
|
||||
BV_INT_SET (u64, uint64, 8)
|
||||
VM_DEFINE_INSTRUCTION (144, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (164, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
|
||||
BV_INT_SET (s64, int64, 8)
|
||||
VM_DEFINE_INSTRUCTION (145, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (165, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
|
||||
BV_FLOAT_SET (f32, ieee_single, float, 4)
|
||||
VM_DEFINE_INSTRUCTION (146, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
|
||||
VM_DEFINE_INSTRUCTION (166, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
|
||||
BV_FLOAT_SET (f64, ieee_double, double, 8)
|
||||
|
||||
#undef BV_FIXABLE_INT_SET
|
||||
|
|
@ -531,7 +531,7 @@ BV_FLOAT_SET (f64, ieee_double, double, 8)
|
|||
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
|
||||
(interactive "")
|
||||
(save-excursion
|
||||
(let ((counter 79)) (goto-char (point-min))
|
||||
(let ((counter 99)) (goto-char (point-min))
|
||||
(while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
|
||||
(replace-match
|
||||
(number-to-string (setq counter (1+ counter)))
|
||||
|
|
|
|||
|
|
@ -145,7 +145,7 @@ VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (55, make_int64, "make-int64", 8, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1)
|
||||
{
|
||||
scm_t_uint64 v = 0;
|
||||
v += FETCH ();
|
||||
|
|
@ -160,7 +160,7 @@ VM_DEFINE_INSTRUCTION (55, make_int64, "make-int64", 8, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (56, make_uint64, "make-uint64", 8, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1)
|
||||
{
|
||||
scm_t_uint64 v = 0;
|
||||
v += FETCH ();
|
||||
|
|
@ -175,13 +175,26 @@ VM_DEFINE_INSTRUCTION (56, make_uint64, "make-uint64", 8, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (14, make_char8, "make-char8", 1, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
|
||||
{
|
||||
PUSH (SCM_MAKE_CHAR (FETCH ()));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1)
|
||||
{
|
||||
scm_t_wchar v = 0;
|
||||
v += FETCH ();
|
||||
v <<= 8; v += FETCH ();
|
||||
v <<= 8; v += FETCH ();
|
||||
v <<= 8; v += FETCH ();
|
||||
PUSH (SCM_MAKE_CHAR (v));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
|
||||
|
||||
VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
|
||||
{
|
||||
unsigned h = FETCH ();
|
||||
unsigned l = FETCH ();
|
||||
|
|
@ -190,7 +203,7 @@ VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
|
||||
{
|
||||
unsigned h = FETCH ();
|
||||
unsigned l = FETCH ();
|
||||
|
|
@ -208,19 +221,19 @@ VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (17, list_mark, "list-mark", 0, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (19, list_mark, "list-mark", 0, 0, 0)
|
||||
{
|
||||
POP_LIST_MARK ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (18, cons_mark, "cons-mark", 0, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (20, cons_mark, "cons-mark", 0, 0, 0)
|
||||
{
|
||||
POP_CONS_MARK ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (21, vector_mark, "vector-mark", 0, 0, 0)
|
||||
{
|
||||
POP_LIST_MARK ();
|
||||
SYNC_REGISTER ();
|
||||
|
|
@ -228,7 +241,7 @@ VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
|
||||
{
|
||||
SCM l;
|
||||
POP (l);
|
||||
|
|
@ -254,9 +267,11 @@ VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0)
|
|||
#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
|
||||
#define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED)
|
||||
|
||||
#define FREE_VARIABLE_REF(i) free_vars[i]
|
||||
|
||||
/* ref */
|
||||
|
||||
VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
|
||||
{
|
||||
register unsigned objnum = FETCH ();
|
||||
CHECK_OBJECT (objnum);
|
||||
|
|
@ -264,29 +279,35 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
|
||||
/* FIXME: necessary? elt 255 of the vector could be a vector... */
|
||||
VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1)
|
||||
{
|
||||
unsigned int objnum = FETCH ();
|
||||
objnum <<= 8;
|
||||
objnum += FETCH ();
|
||||
CHECK_OBJECT (objnum);
|
||||
PUSH (OBJECT_REF (objnum));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1)
|
||||
{
|
||||
PUSH (LOCAL_REF (FETCH ()));
|
||||
ASSERT_BOUND (*sp);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1)
|
||||
{
|
||||
unsigned int i;
|
||||
SCM e = external;
|
||||
for (i = FETCH (); i; i--)
|
||||
{
|
||||
CHECK_EXTERNAL(e);
|
||||
e = SCM_CDR (e);
|
||||
}
|
||||
CHECK_EXTERNAL(e);
|
||||
PUSH (SCM_CAR (e));
|
||||
unsigned int i = FETCH ();
|
||||
i <<= 8;
|
||||
i += FETCH ();
|
||||
PUSH (LOCAL_REF (i));
|
||||
ASSERT_BOUND (*sp);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1)
|
||||
{
|
||||
SCM x = *sp;
|
||||
|
||||
|
|
@ -305,7 +326,7 @@ VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
|
||||
{
|
||||
unsigned objnum = FETCH ();
|
||||
SCM what;
|
||||
|
|
@ -328,38 +349,58 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
|
||||
{
|
||||
SCM what;
|
||||
unsigned int objnum = FETCH ();
|
||||
objnum <<= 8;
|
||||
objnum += FETCH ();
|
||||
CHECK_OBJECT (objnum);
|
||||
what = OBJECT_REF (objnum);
|
||||
|
||||
if (!SCM_VARIABLEP (what))
|
||||
{
|
||||
SYNC_REGISTER ();
|
||||
what = resolve_variable (what, scm_program_module (program));
|
||||
if (!VARIABLE_BOUNDP (what))
|
||||
{
|
||||
finish_args = scm_list_1 (what);
|
||||
goto vm_error_unbound;
|
||||
}
|
||||
OBJECT_SET (objnum, what);
|
||||
}
|
||||
|
||||
PUSH (VARIABLE_REF (what));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
/* set */
|
||||
|
||||
VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
|
||||
VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
|
||||
{
|
||||
LOCAL_SET (FETCH (), *sp);
|
||||
DROP ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (27, external_set, "external-set", 1, 1, 0)
|
||||
VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
|
||||
{
|
||||
unsigned int i;
|
||||
SCM e = external;
|
||||
for (i = FETCH (); i; i--)
|
||||
{
|
||||
CHECK_EXTERNAL(e);
|
||||
e = SCM_CDR (e);
|
||||
}
|
||||
CHECK_EXTERNAL(e);
|
||||
SCM_SETCAR (e, *sp);
|
||||
unsigned int i = FETCH ();
|
||||
i <<= 8;
|
||||
i += FETCH ();
|
||||
LOCAL_SET (i, *sp);
|
||||
DROP ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0)
|
||||
VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0)
|
||||
{
|
||||
VARIABLE_SET (sp[0], sp[-1]);
|
||||
DROPN (2);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
|
||||
VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
|
||||
{
|
||||
unsigned objnum = FETCH ();
|
||||
SCM what;
|
||||
|
|
@ -378,12 +419,33 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
|
||||
{
|
||||
SCM what;
|
||||
unsigned int objnum = FETCH ();
|
||||
objnum <<= 8;
|
||||
objnum += FETCH ();
|
||||
CHECK_OBJECT (objnum);
|
||||
what = OBJECT_REF (objnum);
|
||||
|
||||
if (!SCM_VARIABLEP (what))
|
||||
{
|
||||
SYNC_BEFORE_GC ();
|
||||
what = resolve_variable (what, scm_program_module (program));
|
||||
OBJECT_SET (objnum, what);
|
||||
}
|
||||
|
||||
VARIABLE_SET (what, *sp);
|
||||
DROP ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* branch and jump
|
||||
*/
|
||||
|
||||
/* offset must be a signed short!!! */
|
||||
/* offset must be a signed 16 bit int!!! */
|
||||
#define FETCH_OFFSET(offset) \
|
||||
{ \
|
||||
int h = FETCH (); \
|
||||
|
|
@ -393,51 +455,51 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
|
|||
|
||||
#define BR(p) \
|
||||
{ \
|
||||
signed short offset; \
|
||||
scm_t_int16 offset; \
|
||||
FETCH_OFFSET (offset); \
|
||||
if (p) \
|
||||
ip += offset; \
|
||||
ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); \
|
||||
NULLSTACK (1); \
|
||||
DROP (); \
|
||||
NEXT; \
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
|
||||
{
|
||||
int h = FETCH ();
|
||||
int l = FETCH ();
|
||||
ip += (signed short) (h << 8) + l;
|
||||
scm_t_int16 offset;
|
||||
FETCH_OFFSET (offset);
|
||||
ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 2, 0, 0)
|
||||
{
|
||||
BR (!SCM_FALSEP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 2, 0, 0)
|
||||
{
|
||||
BR (SCM_FALSEP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 2, 0, 0)
|
||||
{
|
||||
sp--; /* underflow? */
|
||||
BR (SCM_EQ_P (sp[0], sp[1]));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
|
||||
{
|
||||
sp--; /* underflow? */
|
||||
BR (!SCM_EQ_P (sp[0], sp[1]));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 2, 0, 0)
|
||||
{
|
||||
BR (SCM_NULLP (*sp));
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0)
|
||||
{
|
||||
BR (!SCM_NULLP (*sp));
|
||||
}
|
||||
|
|
@ -447,15 +509,7 @@ VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
|
|||
* Subprogram call
|
||||
*/
|
||||
|
||||
VM_DEFINE_INSTRUCTION (38, make_closure, "make-closure", 0, 1, 1)
|
||||
{
|
||||
SYNC_BEFORE_GC ();
|
||||
SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
|
||||
SCM_PROGRAM_OBJTABLE (*sp), external);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
|
||||
{
|
||||
SCM x;
|
||||
nargs = FETCH ();
|
||||
|
|
@ -576,7 +630,7 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
|
|||
goto vm_error_wrong_type_apply;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
|
||||
{
|
||||
register SCM x;
|
||||
nargs = FETCH ();
|
||||
|
|
@ -603,12 +657,6 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
|
|||
sp -= 2;
|
||||
NULLSTACK (bp->nargs + 1);
|
||||
|
||||
/* Freshen the externals */
|
||||
external = SCM_PROGRAM_EXTERNALS (x);
|
||||
for (i = 0; i < bp->nexts; i++)
|
||||
CONS (external, SCM_UNDEFINED, external);
|
||||
SCM_FRAME_DATA_ADDRESS (fp)[0] = external;
|
||||
|
||||
/* Init locals to valid SCM values */
|
||||
for (i = 0; i < bp->nlocs; i++)
|
||||
LOCAL_SET (i + bp->nargs, SCM_UNDEFINED);
|
||||
|
|
@ -657,7 +705,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
|
|||
sure we have space for the locals now */
|
||||
data = SCM_FRAME_DATA_ADDRESS (fp);
|
||||
ip = bp->base;
|
||||
stack_base = data + 3;
|
||||
stack_base = data + 2;
|
||||
sp = stack_base;
|
||||
CHECK_OVERFLOW ();
|
||||
|
||||
|
|
@ -672,17 +720,9 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
|
|||
data[-i] = SCM_UNDEFINED;
|
||||
|
||||
/* Set frame data */
|
||||
data[3] = (SCM)ra;
|
||||
data[2] = (SCM)mvra;
|
||||
data[1] = (SCM)dl;
|
||||
|
||||
/* Postpone initializing external vars, because if the CONS causes a GC,
|
||||
we want the stack marker to see the data array formatted as expected. */
|
||||
data[0] = SCM_UNDEFINED;
|
||||
external = SCM_PROGRAM_EXTERNALS (fp[-1]);
|
||||
for (i = 0; i < bp->nexts; i++)
|
||||
CONS (external, SCM_UNDEFINED, external);
|
||||
data[0] = external;
|
||||
data[2] = (SCM)ra;
|
||||
data[1] = (SCM)mvra;
|
||||
data[0] = (SCM)dl;
|
||||
|
||||
ENTER_HOOK ();
|
||||
APPLY_HOOK ();
|
||||
|
|
@ -770,7 +810,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
|
|||
goto vm_error_wrong_type_apply;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1)
|
||||
{
|
||||
SCM x;
|
||||
POP (x);
|
||||
|
|
@ -779,7 +819,7 @@ VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
|
|||
goto vm_goto_args;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
|
||||
{
|
||||
SCM x;
|
||||
POP (x);
|
||||
|
|
@ -788,13 +828,15 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
|
|||
goto vm_call;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
|
||||
{
|
||||
SCM x;
|
||||
signed short offset;
|
||||
scm_t_int16 offset;
|
||||
scm_t_uint8 *mvra;
|
||||
|
||||
nargs = FETCH ();
|
||||
FETCH_OFFSET (offset);
|
||||
mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8;
|
||||
|
||||
x = sp[-nargs];
|
||||
|
||||
|
|
@ -807,7 +849,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
|
|||
CACHE_PROGRAM ();
|
||||
INIT_ARGS ();
|
||||
NEW_FRAME ();
|
||||
SCM_FRAME_DATA_ADDRESS (fp)[2] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
|
||||
SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)mvra;
|
||||
ENTER_HOOK ();
|
||||
APPLY_HOOK ();
|
||||
NEXT;
|
||||
|
|
@ -832,7 +874,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
|
|||
len = scm_length (values);
|
||||
PUSH_LIST (values, SCM_NULLP);
|
||||
PUSH (len);
|
||||
ip += offset;
|
||||
ip = mvra;
|
||||
}
|
||||
NEXT;
|
||||
}
|
||||
|
|
@ -849,7 +891,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
|
|||
goto vm_error_wrong_type_apply;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
|
||||
{
|
||||
int len;
|
||||
SCM ls;
|
||||
|
|
@ -868,7 +910,7 @@ VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
|
|||
goto vm_call;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1)
|
||||
{
|
||||
int len;
|
||||
SCM ls;
|
||||
|
|
@ -887,7 +929,7 @@ VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
|
|||
goto vm_goto_args;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
|
||||
VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
|
||||
{
|
||||
int first;
|
||||
SCM proc, cont;
|
||||
|
|
@ -921,7 +963,7 @@ VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
|
|||
}
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
|
||||
VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
|
||||
{
|
||||
int first;
|
||||
SCM proc, cont;
|
||||
|
|
@ -953,7 +995,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
|
|||
}
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
|
||||
VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
|
||||
{
|
||||
vm_return:
|
||||
EXIT_HOOK ();
|
||||
|
|
@ -966,12 +1008,12 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
|
|||
|
||||
POP (ret);
|
||||
ASSERT (sp == stack_base);
|
||||
ASSERT (stack_base == data + 3);
|
||||
ASSERT (stack_base == data + 2);
|
||||
|
||||
/* Restore registers */
|
||||
sp = SCM_FRAME_LOWER_ADDRESS (fp);
|
||||
ip = SCM_FRAME_BYTE_CAST (data[3]);
|
||||
fp = SCM_FRAME_STACK_CAST (data[1]);
|
||||
ip = SCM_FRAME_BYTE_CAST (data[2]);
|
||||
fp = SCM_FRAME_STACK_CAST (data[0]);
|
||||
{
|
||||
#ifdef VM_ENABLE_STACK_NULLING
|
||||
int nullcount = stack_base - sp;
|
||||
|
|
@ -987,12 +1029,11 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
|
|||
/* Restore the last program */
|
||||
program = SCM_FRAME_PROGRAM (fp);
|
||||
CACHE_PROGRAM ();
|
||||
CACHE_EXTERNAL ();
|
||||
CHECK_IP ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
|
||||
VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
|
||||
{
|
||||
/* nvalues declared at top level, because for some reason gcc seems to think
|
||||
that perhaps it might be used without declaration. Fooey to that, I say. */
|
||||
|
|
@ -1004,16 +1045,16 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
|
|||
RETURN_HOOK ();
|
||||
|
||||
data = SCM_FRAME_DATA_ADDRESS (fp);
|
||||
ASSERT (stack_base == data + 3);
|
||||
ASSERT (stack_base == data + 2);
|
||||
|
||||
/* data[2] is the mv return address */
|
||||
if (nvalues != 1 && data[2])
|
||||
/* data[1] is the mv return address */
|
||||
if (nvalues != 1 && data[1])
|
||||
{
|
||||
int i;
|
||||
/* Restore registers */
|
||||
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
|
||||
ip = SCM_FRAME_BYTE_CAST (data[2]); /* multiple value ra */
|
||||
fp = SCM_FRAME_STACK_CAST (data[1]);
|
||||
ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */
|
||||
fp = SCM_FRAME_STACK_CAST (data[0]);
|
||||
|
||||
/* Push return values, and the number of values */
|
||||
for (i = 0; i < nvalues; i++)
|
||||
|
|
@ -1032,8 +1073,8 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
|
|||
continuation.) */
|
||||
/* Restore registers */
|
||||
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
|
||||
ip = SCM_FRAME_BYTE_CAST (data[3]); /* single value ra */
|
||||
fp = SCM_FRAME_STACK_CAST (data[1]);
|
||||
ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */
|
||||
fp = SCM_FRAME_STACK_CAST (data[0]);
|
||||
|
||||
/* Push first value */
|
||||
*++sp = stack_base[1];
|
||||
|
|
@ -1048,12 +1089,11 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
|
|||
/* Restore the last program */
|
||||
program = SCM_FRAME_PROGRAM (fp);
|
||||
CACHE_PROGRAM ();
|
||||
CACHE_EXTERNAL ();
|
||||
CHECK_IP ();
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
|
||||
VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1)
|
||||
{
|
||||
SCM l;
|
||||
|
||||
|
|
@ -1076,7 +1116,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
|
|||
goto vm_return_values;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
|
||||
VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
|
||||
{
|
||||
SCM x;
|
||||
int nbinds, rest;
|
||||
|
|
@ -1099,62 +1139,100 @@ VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (52, long_object_ref, "long-object-ref", 2, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
|
||||
{
|
||||
unsigned int objnum = FETCH ();
|
||||
objnum <<= 8;
|
||||
objnum += FETCH ();
|
||||
CHECK_OBJECT (objnum);
|
||||
PUSH (OBJECT_REF (objnum));
|
||||
SCM val;
|
||||
POP (val);
|
||||
SYNC_BEFORE_GC ();
|
||||
LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (53, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
|
||||
/* for letrec:
|
||||
(let ((a *undef*) (b *undef*) ...)
|
||||
(set! a (lambda () (b ...)))
|
||||
...)
|
||||
*/
|
||||
VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
|
||||
{
|
||||
SCM what;
|
||||
unsigned int objnum = FETCH ();
|
||||
objnum <<= 8;
|
||||
objnum += FETCH ();
|
||||
CHECK_OBJECT (objnum);
|
||||
what = OBJECT_REF (objnum);
|
||||
|
||||
if (!SCM_VARIABLEP (what))
|
||||
{
|
||||
SYNC_REGISTER ();
|
||||
what = resolve_variable (what, scm_program_module (program));
|
||||
if (!VARIABLE_BOUNDP (what))
|
||||
{
|
||||
finish_args = scm_list_1 (what);
|
||||
goto vm_error_unbound;
|
||||
}
|
||||
OBJECT_SET (objnum, what);
|
||||
}
|
||||
|
||||
PUSH (VARIABLE_REF (what));
|
||||
SYNC_BEFORE_GC ();
|
||||
LOCAL_SET (FETCH (),
|
||||
scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (54, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
|
||||
VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
|
||||
{
|
||||
SCM what;
|
||||
unsigned int objnum = FETCH ();
|
||||
objnum <<= 8;
|
||||
objnum += FETCH ();
|
||||
CHECK_OBJECT (objnum);
|
||||
what = OBJECT_REF (objnum);
|
||||
|
||||
if (!SCM_VARIABLEP (what))
|
||||
{
|
||||
SYNC_BEFORE_GC ();
|
||||
what = resolve_variable (what, scm_program_module (program));
|
||||
OBJECT_SET (objnum, what);
|
||||
}
|
||||
|
||||
VARIABLE_SET (what, *sp);
|
||||
DROP ();
|
||||
SCM v = LOCAL_REF (FETCH ());
|
||||
ASSERT_BOUND_VARIABLE (v);
|
||||
PUSH (VARIABLE_REF (v));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
|
||||
{
|
||||
SCM v, val;
|
||||
v = LOCAL_REF (FETCH ());
|
||||
POP (val);
|
||||
ASSERT_VARIABLE (v);
|
||||
VARIABLE_SET (v, val);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
|
||||
{
|
||||
scm_t_uint8 idx = FETCH ();
|
||||
|
||||
CHECK_FREE_VARIABLE (idx);
|
||||
PUSH (FREE_VARIABLE_REF (idx));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
/* no free-set -- if a var is assigned, it should be in a box */
|
||||
|
||||
VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
|
||||
{
|
||||
SCM v;
|
||||
scm_t_uint8 idx = FETCH ();
|
||||
CHECK_FREE_VARIABLE (idx);
|
||||
v = FREE_VARIABLE_REF (idx);
|
||||
ASSERT_BOUND_VARIABLE (v);
|
||||
PUSH (VARIABLE_REF (v));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0)
|
||||
{
|
||||
SCM v, val;
|
||||
scm_t_uint8 idx = FETCH ();
|
||||
POP (val);
|
||||
CHECK_FREE_VARIABLE (idx);
|
||||
v = FREE_VARIABLE_REF (idx);
|
||||
ASSERT_BOUND_VARIABLE (v);
|
||||
VARIABLE_SET (v, val);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1)
|
||||
{
|
||||
SCM vect;
|
||||
POP (vect);
|
||||
SYNC_BEFORE_GC ();
|
||||
/* fixme underflow */
|
||||
SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
|
||||
SCM_PROGRAM_OBJTABLE (*sp), vect);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
|
||||
{
|
||||
SYNC_BEFORE_GC ();
|
||||
/* fixme underflow */
|
||||
PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
|
||||
NEXT;
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
(defun renumber-ops ()
|
||||
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* 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 License
|
||||
|
|
@ -220,46 +220,35 @@ static SCM sym_vm_run;
|
|||
static SCM sym_vm_error;
|
||||
static SCM sym_debug;
|
||||
|
||||
static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len)
|
||||
{
|
||||
scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector");
|
||||
memcpy (new_bytes, bytes, len);
|
||||
return scm_take_u8vector (new_bytes, len);
|
||||
}
|
||||
|
||||
/* Dummy structure to guarantee 32-bit alignment. */
|
||||
struct t_32bit_aligned
|
||||
{
|
||||
scm_t_int32 dummy;
|
||||
scm_t_uint8 bytes[18];
|
||||
};
|
||||
|
||||
static SCM
|
||||
really_make_boot_program (long nargs)
|
||||
{
|
||||
SCM u8vec;
|
||||
struct t_32bit_aligned bytes =
|
||||
{
|
||||
.dummy = 0,
|
||||
.bytes = { 0, 0, 0, 0,
|
||||
0, 0, 0, 0,
|
||||
0, 0, 0, 0,
|
||||
scm_op_mv_call, 0, 0, 1,
|
||||
scm_op_make_int8_1, scm_op_halt }
|
||||
};
|
||||
|
||||
/* Make sure "bytes" is 64-bit aligned. */
|
||||
scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
|
||||
scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop,
|
||||
scm_op_halt };
|
||||
struct scm_objcode *bp;
|
||||
SCM ret;
|
||||
|
||||
/* Set length in current endianness, no meta. */
|
||||
((scm_t_uint32 *) bytes.bytes)[1] = 6;
|
||||
|
||||
if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
|
||||
abort ();
|
||||
bytes.bytes[13] = (scm_byte_t) nargs;
|
||||
text[1] = (scm_t_uint8)nargs;
|
||||
|
||||
u8vec = make_u8vector (bytes.bytes, sizeof (bytes.bytes));
|
||||
bp = scm_gc_malloc (sizeof (struct scm_objcode) + sizeof (text),
|
||||
"make-u8vector");
|
||||
memcpy (bp->base, text, sizeof (text));
|
||||
bp->nargs = 0;
|
||||
bp->nrest = 0;
|
||||
bp->nlocs = 0;
|
||||
bp->len = sizeof(text);
|
||||
bp->metalen = 0;
|
||||
bp->unused = 0;
|
||||
|
||||
u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
|
||||
sizeof (struct scm_objcode) + sizeof (text));
|
||||
ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
|
||||
SCM_BOOL_F, SCM_EOL);
|
||||
SCM_BOOL_F, SCM_BOOL_F);
|
||||
SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
|
||||
|
||||
return ret;
|
||||
|
|
@ -325,7 +314,7 @@ resolve_variable (SCM what, SCM program_module)
|
|||
}
|
||||
|
||||
|
||||
#define VM_DEFAULT_STACK_SIZE (16 * 1024)
|
||||
#define VM_DEFAULT_STACK_SIZE (64 * 1024)
|
||||
|
||||
#define VM_NAME vm_regular_engine
|
||||
#define FUNC_NAME "vm-regular-engine"
|
||||
|
|
@ -663,7 +652,7 @@ SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
|
|||
SCM scm_load_compiled_with_vm (SCM file)
|
||||
{
|
||||
SCM program = scm_make_program (scm_load_objcode (file),
|
||||
SCM_BOOL_F, SCM_EOL);
|
||||
SCM_BOOL_F, SCM_BOOL_F);
|
||||
|
||||
return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ SOURCES = \
|
|||
ice-9/psyntax-pp.scm \
|
||||
system/base/pmatch.scm system/base/syntax.scm \
|
||||
system/base/compile.scm system/base/language.scm \
|
||||
system/base/message.scm \
|
||||
\
|
||||
language/tree-il.scm \
|
||||
language/ghil.scm language/glil.scm language/assembly.scm \
|
||||
|
|
|
|||
|
|
@ -54,7 +54,8 @@
|
|||
(let ((id293 (if (syntax-object?99 id292)
|
||||
(syntax-object-expression100 id292)
|
||||
id292)))
|
||||
(gensym (symbol->string id293)))))
|
||||
(gensym
|
||||
(string-append (symbol->string id293) " ")))))
|
||||
(strip161
|
||||
(lambda (x294 w295)
|
||||
(if (memq (quote top) (wrap-marks118 w295))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; -*-scheme-*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001, 2003, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2001, 2003, 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
|
||||
|
|
@ -529,10 +529,10 @@
|
|||
`(letrec ,(map list vars val-exps) ,body-exp)
|
||||
src))))))
|
||||
|
||||
;; FIXME: wingo: use make-lexical ?
|
||||
;; FIXME: use a faster gensym
|
||||
(define-syntax build-lexical-var
|
||||
(syntax-rules ()
|
||||
((_ src id) (gensym (symbol->string id)))))
|
||||
((_ src id) (gensym (string-append (symbol->string id) " ")))))
|
||||
|
||||
(define-structure (syntax-object expression wrap module))
|
||||
|
||||
|
|
|
|||
|
|
@ -24,12 +24,12 @@
|
|||
#:use-module (system vm instruction)
|
||||
#:use-module ((srfi srfi-1) #:select (fold))
|
||||
#:export (byte-length
|
||||
addr+ align-program align-code
|
||||
addr+ align-program align-code align-block
|
||||
assembly-pack assembly-unpack
|
||||
object->assembly assembly->object))
|
||||
|
||||
;; nargs, nrest, nlocs, nexts, len, metalen
|
||||
(define *program-header-len* (+ 1 1 1 1 4 4))
|
||||
;; nargs, nrest, nlocs, len, metalen, padding
|
||||
(define *program-header-len* (+ 1 1 2 4 4 4))
|
||||
|
||||
;; lengths are encoded in 3 bytes
|
||||
(define *len-len* 3)
|
||||
|
|
@ -54,7 +54,7 @@
|
|||
(+ 1 *len-len* (bytevector-length bv)))
|
||||
((define ,str)
|
||||
(+ 1 *len-len* (string-length str)))
|
||||
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
|
||||
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
|
||||
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
|
||||
((,inst . _) (guard (>= (instruction-length inst) 0))
|
||||
(+ 1 (instruction-length inst)))
|
||||
|
|
@ -63,17 +63,24 @@
|
|||
|
||||
(define *program-alignment* 8)
|
||||
|
||||
(define *block-alignment* 8)
|
||||
|
||||
(define (addr+ addr code)
|
||||
(fold (lambda (x len) (+ (byte-length x) len))
|
||||
addr
|
||||
code))
|
||||
|
||||
(define (code-alignment addr alignment header-len)
|
||||
(make-list (modulo (- alignment
|
||||
(modulo (+ addr header-len) alignment))
|
||||
alignment)
|
||||
'(nop)))
|
||||
|
||||
(define (align-block addr)
|
||||
(code-alignment addr *block-alignment* 0))
|
||||
|
||||
(define (align-code code addr alignment header-len)
|
||||
`(,@(make-list (modulo (- alignment
|
||||
(modulo (+ addr header-len) alignment))
|
||||
alignment)
|
||||
'(nop))
|
||||
`(,@(code-alignment addr alignment header-len)
|
||||
,code))
|
||||
|
||||
(define (align-program prog addr)
|
||||
|
|
@ -110,7 +117,7 @@
|
|||
((null? x) `(make-eol))
|
||||
((and (integer? x) (exact? x))
|
||||
(cond ((and (<= -128 x) (< x 128))
|
||||
`(make-int8 ,(modulo x 256)))
|
||||
(assembly-pack `(make-int8 ,(modulo x 256))))
|
||||
((and (<= -32768 x) (< x 32768))
|
||||
(let ((n (if (< x 0) (+ x 65536) x)))
|
||||
`(make-int16 ,(quotient n 256) ,(modulo n 256))))
|
||||
|
|
@ -125,7 +132,11 @@
|
|||
(bytevector-s64-set! bv 0 x (endianness big))
|
||||
bv))))
|
||||
(else #f)))
|
||||
((char? x) `(make-char8 ,(char->integer x)))
|
||||
((char? x)
|
||||
(cond ((<= (char->integer x) #xff)
|
||||
`(make-char8 ,(char->integer x)))
|
||||
(else
|
||||
`(make-char32 ,(char->integer x)))))
|
||||
(else #f)))
|
||||
|
||||
(define (assembly->object code)
|
||||
|
|
@ -151,6 +162,11 @@
|
|||
(endianness big)))
|
||||
((make-char8 ,n)
|
||||
(integer->char n))
|
||||
((make-char32 ,n1 ,n2 ,n3 ,n4)
|
||||
(integer->char (+ (* n1 #x1000000)
|
||||
(* n2 #x10000)
|
||||
(* n3 #x100)
|
||||
n4)))
|
||||
((load-string ,s) s)
|
||||
((load-symbol ,s) (string->symbol s))
|
||||
((load-keyword ,s) (symbol->keyword (string->symbol s)))
|
||||
|
|
|
|||
|
|
@ -77,10 +77,19 @@
|
|||
;; Ew!
|
||||
(for-each write-byte (bytevector->u8-list bv)))
|
||||
(define (write-break label)
|
||||
(write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2))))
|
||||
(let ((offset (- (assq-ref labels label)
|
||||
(logand (+ (get-addr) 2) (lognot #x7)))))
|
||||
(cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
|
||||
((>= offset (ash 1 18)) (error "jump too far forward" offset))
|
||||
((< offset (- (ash 1 18))) (error "jump too far backwards" offset))
|
||||
(else (write-uint16-be (ash offset -3))))))
|
||||
|
||||
(let ((inst (car asm))
|
||||
(args (cdr asm))
|
||||
(write-uint16 (case byte-order
|
||||
((1234) write-uint16-le)
|
||||
((4321) write-uint16-be)
|
||||
(else (error "unknown endianness" byte-order))))
|
||||
(write-uint32 (case byte-order
|
||||
((1234) write-uint32-le)
|
||||
((4321) write-uint32-be)
|
||||
|
|
@ -89,14 +98,13 @@
|
|||
(len (instruction-length inst)))
|
||||
(write-byte opcode)
|
||||
(pmatch asm
|
||||
((load-program ,nargs ,nrest ,nlocs ,nexts
|
||||
,labels ,length ,meta . ,code)
|
||||
((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
|
||||
(write-byte nargs)
|
||||
(write-byte nrest)
|
||||
(write-byte nlocs)
|
||||
(write-byte nexts)
|
||||
(write-uint16 nlocs)
|
||||
(write-uint32 length)
|
||||
(write-uint32 (if meta (1- (byte-length meta)) 0))
|
||||
(write-uint32 0) ; padding
|
||||
(letrec ((i 0)
|
||||
(write (lambda (x) (set! i (1+ i)) (write-byte x)))
|
||||
(get-addr (lambda () i)))
|
||||
|
|
@ -114,6 +122,7 @@
|
|||
;; meets the alignment requirements of `scm_objcode'. See
|
||||
;; `scm_c_make_objcode_slice ()'.
|
||||
(write-bytecode meta write get-addr '()))))
|
||||
((make-char32 ,x) (write-uint32-be x))
|
||||
((load-unsigned-integer ,str) (write-loader str))
|
||||
((load-integer ,str) (write-loader str))
|
||||
((load-number ,str) (write-loader str))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile VM code converters
|
||||
|
||||
;; 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
|
||||
|
|
@ -48,17 +48,21 @@
|
|||
x
|
||||
(- x (ash 1 16)))))
|
||||
|
||||
;; FIXME: this is a little-endian disassembly!!!
|
||||
(define (decode-load-program pop)
|
||||
(let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop))
|
||||
(let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
|
||||
(nlocs (+ nlocs0 (ash nlocs1 8)))
|
||||
(a (pop)) (b (pop)) (c (pop)) (d (pop))
|
||||
(e (pop)) (f (pop)) (g (pop)) (h (pop))
|
||||
(len (+ a (ash b 8) (ash c 16) (ash d 24)))
|
||||
(metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
|
||||
(totlen (+ len metalen))
|
||||
(pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop))
|
||||
(labels '())
|
||||
(i 0))
|
||||
(define (ensure-label rel1 rel2)
|
||||
(let ((where (+ i (bytes->s16 rel1 rel2))))
|
||||
(let ((where (+ (logand i (lognot #x7))
|
||||
(* (bytes->s16 rel1 rel2) 8))))
|
||||
(or (assv-ref labels where)
|
||||
(begin
|
||||
(let ((l (gensym ":L")))
|
||||
|
|
@ -74,7 +78,7 @@
|
|||
(cond ((> i len)
|
||||
(error "error decoding program -- read too many bytes" out))
|
||||
((= i len)
|
||||
`(load-program ,nargs ,nrest ,nlocs ,nexts
|
||||
`(load-program ,nargs ,nrest ,nlocs
|
||||
,(map (lambda (x) (cons (cdr x) (car x)))
|
||||
(reverse labels))
|
||||
,len
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile VM code converters
|
||||
|
||||
;; 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
|
||||
|
|
@ -35,12 +35,11 @@
|
|||
|
||||
(define (disassemble-load-program asm env)
|
||||
(pmatch asm
|
||||
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
|
||||
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
|
||||
(let ((objs (and env (assq-ref env 'objects)))
|
||||
(free-vars (and env (assq-ref env 'free-vars)))
|
||||
(meta (and env (assq-ref env 'meta)))
|
||||
(exts (and env (assq-ref env 'exts)))
|
||||
(blocs (and env (assq-ref env 'blocs)))
|
||||
(bexts (and env (assq-ref env 'bexts)))
|
||||
(srcs (and env (assq-ref env 'sources))))
|
||||
(let lp ((pos 0) (code code) (programs '()))
|
||||
(cond
|
||||
|
|
@ -63,13 +62,13 @@
|
|||
(acons sym asm programs))))
|
||||
(else
|
||||
(print-info pos asm
|
||||
(code-annotation end asm objs nargs blocs bexts
|
||||
(code-annotation end asm objs nargs blocs
|
||||
labels)
|
||||
(and=> (and srcs (assq end srcs)) source->string))
|
||||
(lp (+ pos (byte-length asm)) (cdr code) programs)))))))
|
||||
|
||||
(if (pair? exts)
|
||||
(disassemble-externals exts))
|
||||
(if (pair? free-vars)
|
||||
(disassemble-free-vars free-vars))
|
||||
(if meta
|
||||
(disassemble-meta meta))
|
||||
|
||||
|
|
@ -92,13 +91,12 @@
|
|||
((= n len) (newline))
|
||||
(print-info n (vector-ref objs n) #f #f))))
|
||||
|
||||
(define (disassemble-externals exts)
|
||||
(display "Externals:\n\n")
|
||||
(let ((len (length exts)))
|
||||
(do ((n 0 (1+ n))
|
||||
(l exts (cdr l)))
|
||||
((null? l) (newline))
|
||||
(print-info n (car l) #f #f))))
|
||||
(define (disassemble-free-vars free-vars)
|
||||
(display "Free variables:\n\n")
|
||||
(let ((i 0))
|
||||
(cond ((< i (vector-length free-vars))
|
||||
(print-info i (vector-ref free-vars i) #f #f)
|
||||
(lp (1+ i))))))
|
||||
|
||||
(define-macro (unless test . body)
|
||||
`(if (not ,test) (begin ,@body)))
|
||||
|
|
@ -122,7 +120,7 @@
|
|||
(define (make-int16 byte1 byte2)
|
||||
(+ (* byte1 256) byte2))
|
||||
|
||||
(define (code-annotation end-addr code objs nargs blocs bexts labels)
|
||||
(define (code-annotation end-addr code objs nargs blocs labels)
|
||||
(let* ((code (assembly-unpack code))
|
||||
(inst (car code))
|
||||
(args (cdr code)))
|
||||
|
|
@ -133,7 +131,7 @@
|
|||
(list "-> ~A" (assq-ref labels (car args))))
|
||||
((object-ref)
|
||||
(and objs (list "~s" (vector-ref objs (car args)))))
|
||||
((local-ref local-set)
|
||||
((local-ref local-boxed-ref local-set local-boxed-set)
|
||||
(and blocs
|
||||
(let lp ((bindings (list-ref blocs (car args))))
|
||||
(and (pair? bindings)
|
||||
|
|
@ -143,13 +141,9 @@
|
|||
(list "`~a'~@[ (arg)~]"
|
||||
(binding:name b) (< (binding:index b) nargs))
|
||||
(lp (cdr bindings))))))))
|
||||
((external-ref external-set)
|
||||
(and bexts
|
||||
(if (< (car args) (length bexts))
|
||||
(let ((b (list-ref bexts (car args))))
|
||||
(list "`~a'~@[ (arg)~]"
|
||||
(binding:name b) (< (binding:index b) nargs)))
|
||||
(list "(closure variable)"))))
|
||||
((free-ref free-boxed-ref free-boxed-set)
|
||||
;; FIXME: we can do better than this
|
||||
(list "(closure variable)"))
|
||||
((toplevel-ref toplevel-set)
|
||||
(and objs
|
||||
(let ((v (vector-ref objs (car args))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile Low Intermediate Language
|
||||
|
||||
;; 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
|
||||
|
|
@ -24,9 +24,9 @@
|
|||
#:use-module ((srfi srfi-1) #:select (fold))
|
||||
#:export
|
||||
(<glil-program> make-glil-program glil-program?
|
||||
glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
|
||||
glil-program-meta glil-program-body glil-program-closure-level
|
||||
|
||||
glil-program-nargs glil-program-nrest glil-program-nlocs
|
||||
glil-program-meta glil-program-body
|
||||
|
||||
<glil-bind> make-glil-bind glil-bind?
|
||||
glil-bind-vars
|
||||
|
||||
|
|
@ -43,11 +43,8 @@
|
|||
<glil-const> make-glil-const glil-const?
|
||||
glil-const-obj
|
||||
|
||||
<glil-local> make-glil-local glil-local?
|
||||
glil-local-op glil-local-index
|
||||
|
||||
<glil-external> make-glil-external glil-external?
|
||||
glil-external-op glil-external-depth glil-external-index
|
||||
<glil-lexical> make-glil-lexical glil-lexical?
|
||||
glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
|
||||
|
||||
<glil-toplevel> make-glil-toplevel glil-toplevel?
|
||||
glil-toplevel-op glil-toplevel-name
|
||||
|
|
@ -74,7 +71,7 @@
|
|||
|
||||
(define-type (<glil> #:printer print-glil)
|
||||
;; Meta operations
|
||||
(<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
|
||||
(<glil-program> nargs nrest nlocs meta body)
|
||||
(<glil-bind> vars)
|
||||
(<glil-mv-bind> vars rest)
|
||||
(<glil-unbind>)
|
||||
|
|
@ -83,8 +80,7 @@
|
|||
(<glil-void>)
|
||||
(<glil-const> obj)
|
||||
;; Variables
|
||||
(<glil-local> op index)
|
||||
(<glil-external> op depth index)
|
||||
(<glil-lexical> local? boxed? op index)
|
||||
(<glil-toplevel> op name)
|
||||
(<glil-module> op mod name public?)
|
||||
;; Controls
|
||||
|
|
@ -93,35 +89,19 @@
|
|||
(<glil-call> inst nargs)
|
||||
(<glil-mv-call> nargs ra))
|
||||
|
||||
(define (compute-closure-level body)
|
||||
(fold (lambda (x ret)
|
||||
(record-case x
|
||||
((<glil-program> closure-level) (max ret closure-level))
|
||||
((<glil-external> depth) (max ret depth))
|
||||
(else ret)))
|
||||
0 body))
|
||||
|
||||
(define %make-glil-program make-glil-program)
|
||||
(define (make-glil-program . args)
|
||||
(let ((prog (apply %make-glil-program args)))
|
||||
(if (not (glil-program-closure-level prog))
|
||||
(set! (glil-program-closure-level prog)
|
||||
(compute-closure-level (glil-program-body prog))))
|
||||
prog))
|
||||
|
||||
|
||||
|
||||
(define (parse-glil x)
|
||||
(pmatch x
|
||||
((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
|
||||
(make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
|
||||
((program ,nargs ,nrest ,nlocs ,meta . ,body)
|
||||
(make-glil-program nargs nrest nlocs meta (map parse-glil body)))
|
||||
((bind . ,vars) (make-glil-bind vars))
|
||||
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
|
||||
((unbind) (make-glil-unbind))
|
||||
((source ,props) (make-glil-source props))
|
||||
((void) (make-glil-void))
|
||||
((const ,obj) (make-glil-const obj))
|
||||
((local ,op ,index) (make-glil-local op index))
|
||||
((external ,op ,depth ,index) (make-glil-external op depth index))
|
||||
((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
|
||||
((toplevel ,op ,name) (make-glil-toplevel op name))
|
||||
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
|
||||
((module private ,op ,mod ,name) (make-glil-module op mod name #f))
|
||||
|
|
@ -134,8 +114,8 @@
|
|||
(define (unparse-glil glil)
|
||||
(record-case glil
|
||||
;; meta
|
||||
((<glil-program> nargs nrest nlocs nexts meta body)
|
||||
`(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
|
||||
((<glil-program> nargs nrest nlocs meta body)
|
||||
`(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
|
||||
((<glil-bind> vars) `(bind ,@vars))
|
||||
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
|
||||
((<glil-unbind>) `(unbind))
|
||||
|
|
@ -144,10 +124,8 @@
|
|||
((<glil-void>) `(void))
|
||||
((<glil-const> obj) `(const ,obj))
|
||||
;; variables
|
||||
((<glil-local> op index)
|
||||
`(local ,op ,index))
|
||||
((<glil-external> op depth index)
|
||||
`(external ,op ,depth ,index))
|
||||
((<glil-lexical> local? boxed? op index)
|
||||
`(lexical ,local? ,boxed? ,op ,index))
|
||||
((<glil-toplevel> op name)
|
||||
`(toplevel ,op ,name))
|
||||
((<glil-module> op mod name public?)
|
||||
|
|
|
|||
|
|
@ -72,14 +72,14 @@
|
|||
(if (and (null? bindings) (null? sources) (null? tail))
|
||||
#f
|
||||
(compile-assembly
|
||||
(make-glil-program 0 0 0 0 '()
|
||||
(make-glil-program 0 0 0 '()
|
||||
(list
|
||||
(make-glil-const `(,bindings ,sources ,@tail))
|
||||
(make-glil-call 'return 1))))))
|
||||
|
||||
;; A functional stack of names of live variables.
|
||||
(define (make-open-binding name ext? index)
|
||||
(list name ext? index))
|
||||
(define (make-open-binding name boxed? index)
|
||||
(list name boxed? index))
|
||||
(define (make-closed-binding open-binding start end)
|
||||
(make-binding (car open-binding) (cadr open-binding)
|
||||
(caddr open-binding) start end))
|
||||
|
|
@ -89,8 +89,8 @@
|
|||
(map
|
||||
(lambda (v)
|
||||
(pmatch v
|
||||
((,name local ,i) (make-open-binding name #f i))
|
||||
((,name external ,i) (make-open-binding name #t i))
|
||||
((,name ,boxed? ,i)
|
||||
(make-open-binding name boxed? i))
|
||||
(else (error "unknown binding type" v))))
|
||||
vars)
|
||||
(car bindings))
|
||||
|
|
@ -128,74 +128,77 @@
|
|||
|
||||
(define (compile-assembly glil)
|
||||
(receive (code . _)
|
||||
(glil->assembly glil '() '(()) '() '() #f -1)
|
||||
(glil->assembly glil #t '(()) '() '() #f -1)
|
||||
(car code)))
|
||||
(define (make-object-table objects)
|
||||
(and (not (null? objects))
|
||||
(list->vector (cons #f objects))))
|
||||
|
||||
(define (glil->assembly glil nexts-stack bindings
|
||||
(define (glil->assembly glil toplevel? bindings
|
||||
source-alist label-alist object-alist addr)
|
||||
(define (emit-code x)
|
||||
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
|
||||
(values x bindings source-alist label-alist object-alist))
|
||||
(define (emit-code/object x object-alist)
|
||||
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
|
||||
(values x bindings source-alist label-alist object-alist))
|
||||
|
||||
(record-case glil
|
||||
((<glil-program> nargs nrest nlocs nexts meta body closure-level)
|
||||
(let ((toplevel? (null? nexts-stack)))
|
||||
(define (process-body)
|
||||
(let ((nexts-stack (cons nexts nexts-stack)))
|
||||
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
|
||||
(label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
|
||||
(cond
|
||||
((null? body)
|
||||
(values (reverse code)
|
||||
(close-all-bindings bindings addr)
|
||||
(limn-sources (reverse! source-alist))
|
||||
(reverse label-alist)
|
||||
(and object-alist (map car (reverse object-alist)))
|
||||
addr))
|
||||
(else
|
||||
(receive (subcode bindings source-alist label-alist object-alist)
|
||||
(glil->assembly (car body) nexts-stack bindings
|
||||
source-alist label-alist object-alist addr)
|
||||
(lp (cdr body) (append (reverse subcode) code)
|
||||
bindings source-alist label-alist object-alist
|
||||
(addr+ addr subcode))))))))
|
||||
((<glil-program> nargs nrest nlocs meta body)
|
||||
(define (process-body)
|
||||
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
|
||||
(label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
|
||||
(cond
|
||||
((null? body)
|
||||
(values (reverse code)
|
||||
(close-all-bindings bindings addr)
|
||||
(limn-sources (reverse! source-alist))
|
||||
(reverse label-alist)
|
||||
(and object-alist (map car (reverse object-alist)))
|
||||
addr))
|
||||
(else
|
||||
(receive (subcode bindings source-alist label-alist object-alist)
|
||||
(glil->assembly (car body) #f bindings
|
||||
source-alist label-alist object-alist addr)
|
||||
(lp (cdr body) (append (reverse subcode) code)
|
||||
bindings source-alist label-alist object-alist
|
||||
(addr+ addr subcode)))))))
|
||||
|
||||
(receive (code bindings sources labels objects len)
|
||||
(process-body)
|
||||
(let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
|
||||
,len
|
||||
,(make-meta bindings sources meta)
|
||||
. ,code)))
|
||||
(cond
|
||||
(toplevel?
|
||||
;; toplevel bytecode isn't loaded by the vm, no way to do
|
||||
;; object table or closure capture (not in the bytecode,
|
||||
;; anyway)
|
||||
(emit-code (align-program prog addr)))
|
||||
(else
|
||||
(let ((table (dump-object (make-object-table objects) addr))
|
||||
(closure (if (> closure-level 0) '((make-closure)) '())))
|
||||
(cond
|
||||
(object-alist
|
||||
;; if we are being compiled from something with an object
|
||||
;; table, cache the program there
|
||||
(receive (i object-alist)
|
||||
(object-index-and-alist (make-subprogram table prog)
|
||||
object-alist)
|
||||
(emit-code/object `(,(if (< i 256)
|
||||
`(object-ref ,i)
|
||||
`(long-object-ref ,(quotient i 256)
|
||||
,(modulo i 256)))
|
||||
,@closure)
|
||||
object-alist)))
|
||||
(else
|
||||
;; otherwise emit a load directly
|
||||
(emit-code `(,@table ,@(align-program prog (addr+ addr table))
|
||||
,@closure)))))))))))
|
||||
(receive (code bindings sources labels objects len)
|
||||
(process-body)
|
||||
(let* ((meta (make-meta bindings sources meta))
|
||||
(meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
|
||||
(prog `(load-program ,nargs ,nrest ,nlocs ,labels
|
||||
,(+ len meta-pad)
|
||||
,meta
|
||||
,@code
|
||||
,@(if meta
|
||||
(make-list meta-pad '(nop))
|
||||
'()))))
|
||||
(cond
|
||||
(toplevel?
|
||||
;; toplevel bytecode isn't loaded by the vm, no way to do
|
||||
;; object table or closure capture (not in the bytecode,
|
||||
;; anyway)
|
||||
(emit-code (align-program prog addr)))
|
||||
(else
|
||||
(let ((table (make-object-table objects)))
|
||||
(cond
|
||||
(object-alist
|
||||
;; if we are being compiled from something with an object
|
||||
;; table, cache the program there
|
||||
(receive (i object-alist)
|
||||
(object-index-and-alist (make-subprogram table prog)
|
||||
object-alist)
|
||||
(emit-code/object `(,(if (< i 256)
|
||||
`(object-ref ,i)
|
||||
`(long-object-ref ,(quotient i 256)
|
||||
,(modulo i 256))))
|
||||
object-alist)))
|
||||
(else
|
||||
;; otherwise emit a load directly
|
||||
(let ((table-code (dump-object table addr)))
|
||||
(emit-code
|
||||
`(,@table-code
|
||||
,@(align-program prog (addr+ addr table-code)))))))))))))
|
||||
|
||||
((<glil-bind> vars)
|
||||
(values '()
|
||||
|
|
@ -244,19 +247,45 @@
|
|||
,(modulo i 256))))
|
||||
object-alist)))))
|
||||
|
||||
((<glil-local> op index)
|
||||
(emit-code (if (eq? op 'ref)
|
||||
`((local-ref ,index))
|
||||
`((local-set ,index)))))
|
||||
|
||||
((<glil-external> op depth index)
|
||||
(emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
|
||||
(if (> d 0)
|
||||
(lp (1- d) (+ n (car stack)) (cdr stack))
|
||||
(if (eq? op 'ref)
|
||||
`((external-ref ,(+ n index)))
|
||||
`((external-set ,(+ n index))))))))
|
||||
|
||||
((<glil-lexical> local? boxed? op index)
|
||||
(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))
|
||||
(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? 'free-boxed-ref 'free-ref))
|
||||
((set) (if boxed? 'free-boxed-set (error "what." glil)))
|
||||
(else (error "what" op)))
|
||||
,index)))))
|
||||
|
||||
((<glil-toplevel> op name)
|
||||
(case op
|
||||
((ref set)
|
||||
|
|
@ -311,11 +340,12 @@
|
|||
(error "unknown module var kind" op key)))))
|
||||
|
||||
((<glil-label> label)
|
||||
(values '()
|
||||
bindings
|
||||
source-alist
|
||||
(acons label addr label-alist)
|
||||
object-alist))
|
||||
(let ((code (align-block addr)))
|
||||
(values code
|
||||
bindings
|
||||
source-alist
|
||||
(acons label (addr+ addr code) label-alist)
|
||||
object-alist)))
|
||||
|
||||
((<glil-branch> inst label)
|
||||
(emit-code `((,inst ,label))))
|
||||
|
|
@ -348,9 +378,10 @@
|
|||
((object->assembly x) => list)
|
||||
((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
|
||||
((subprogram? x)
|
||||
`(,@(subprogram-table x)
|
||||
,@(align-program (subprogram-prog x)
|
||||
(addr+ addr (subprogram-table x)))))
|
||||
(let ((table-code (dump-object (subprogram-table x) addr)))
|
||||
`(,@table-code
|
||||
,@(align-program (subprogram-prog x)
|
||||
(addr+ addr table-code)))))
|
||||
((number? x)
|
||||
`((load-number ,(number->string x))))
|
||||
((string? x)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile VM code converters
|
||||
|
||||
;; 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
|
||||
|
|
@ -31,8 +31,8 @@
|
|||
|
||||
(define (decompile-toplevel x)
|
||||
(pmatch x
|
||||
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body)
|
||||
(decompile-load-program nargs nrest nlocs nexts
|
||||
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
|
||||
(decompile-load-program nargs nrest nlocs
|
||||
(decompile-meta meta)
|
||||
body labels #f))
|
||||
(else
|
||||
|
|
@ -56,7 +56,7 @@
|
|||
((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
|
||||
(else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
|
||||
|
||||
(define (decompile-load-program nargs nrest nlocs nexts meta body labels
|
||||
(define (decompile-load-program nargs nrest nlocs meta body labels
|
||||
objects)
|
||||
(let ((glil-labels (sort (map (lambda (x)
|
||||
(cons (cdr x) (make-glil-label (car x))))
|
||||
|
|
@ -100,19 +100,11 @@
|
|||
(cond
|
||||
((null? in)
|
||||
(or (null? stack) (error "leftover stack insts" stack body))
|
||||
(make-glil-program nargs nrest nlocs nexts props (reverse out) #f))
|
||||
(make-glil-program nargs nrest nlocs props (reverse out) #f))
|
||||
((pop-bindings! pos)
|
||||
=> (lambda (bindings)
|
||||
(lp in stack
|
||||
(cons (make-glil-bind
|
||||
(map (lambda (x)
|
||||
(let ((name (binding:name x))
|
||||
(i (binding:index x)))
|
||||
(cond
|
||||
((binding:extp x) `(,name external ,i))
|
||||
((< i nargs) `(,name argument ,i))
|
||||
(else `(,name local ,(- i nargs))))))
|
||||
bindings))
|
||||
(cons (make-glil-bind bindings)
|
||||
out)
|
||||
pos)))
|
||||
((pop-unbindings! pos)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile Lowlevel Intermediate Language
|
||||
|
||||
;; 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
|
||||
|
|
@ -31,7 +31,7 @@
|
|||
(if env (car env) (current-module)))
|
||||
|
||||
(define (objcode-env-externals env)
|
||||
(if env (cdr env) '()))
|
||||
(and env (vector? (cdr env)) (cdr env)))
|
||||
|
||||
(define (objcode->value x e opts)
|
||||
(let ((thunk (make-program x #f (objcode-env-externals e))))
|
||||
|
|
@ -66,23 +66,16 @@
|
|||
((program? x)
|
||||
(let ((objs (program-objects x))
|
||||
(meta (program-meta x))
|
||||
(exts (program-external x))
|
||||
(free-vars (program-free-variables x))
|
||||
(binds (program-bindings x))
|
||||
(srcs (program-sources x))
|
||||
(nargs (arity:nargs (program-arity x))))
|
||||
(let ((blocs (and binds
|
||||
(collapse-locals
|
||||
(append (list-head binds nargs)
|
||||
(filter (lambda (x) (not (binding:extp x)))
|
||||
(list-tail binds nargs))))))
|
||||
(bexts (and binds
|
||||
(filter binding:extp binds))))
|
||||
(let ((blocs (and binds (collapse-locals binds))))
|
||||
(values (program-objcode x)
|
||||
`((objects . ,objs)
|
||||
(meta . ,(and meta (meta)))
|
||||
(exts . ,exts)
|
||||
(free-vars . ,free-vars)
|
||||
(blocs . ,blocs)
|
||||
(bexts . ,bexts)
|
||||
(sources . ,srcs))))))
|
||||
((objcode? x)
|
||||
(values x #f))
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@
|
|||
|
||||
|
||||
(define-module (language tree-il)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system base syntax)
|
||||
#:export (tree-il-src
|
||||
|
|
@ -38,11 +39,12 @@
|
|||
<let> let? make-let let-src let-names let-vars let-vals let-body
|
||||
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
|
||||
<let-values> let-values? make-let-values let-values-src let-values-names let-values-vars let-values-exp let-values-body
|
||||
|
||||
|
||||
parse-tree-il
|
||||
unparse-tree-il
|
||||
tree-il->scheme
|
||||
|
||||
tree-il-fold
|
||||
post-order!
|
||||
pre-order!))
|
||||
|
||||
|
|
@ -258,6 +260,51 @@
|
|||
`(call-with-values (lambda () ,(tree-il->scheme exp))
|
||||
(lambda ,vars ,(tree-il->scheme body))))))
|
||||
|
||||
|
||||
(define (tree-il-fold leaf down up seed tree)
|
||||
"Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
|
||||
into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is
|
||||
invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
|
||||
and SEED is the current result, intially seeded with SEED.
|
||||
|
||||
This is an implementation of `foldts' as described by Andy Wingo in
|
||||
``Applications of fold to XML transformation''."
|
||||
(let loop ((tree tree)
|
||||
(result seed))
|
||||
(if (or (null? tree) (pair? tree))
|
||||
(fold loop result tree)
|
||||
(record-case tree
|
||||
((<lexical-set> exp)
|
||||
(up tree (loop exp (down tree result))))
|
||||
((<module-set> exp)
|
||||
(up tree (loop exp (down tree result))))
|
||||
((<toplevel-set> exp)
|
||||
(up tree (loop exp (down tree result))))
|
||||
((<toplevel-define> exp)
|
||||
(up tree (loop exp (down tree result))))
|
||||
((<conditional> test then else)
|
||||
(up tree (loop else
|
||||
(loop then
|
||||
(loop test (down tree result))))))
|
||||
((<application> proc args)
|
||||
(up tree (loop (cons proc args) (down tree result))))
|
||||
((<sequence> exps)
|
||||
(up tree (loop exps (down tree result))))
|
||||
((<lambda> body)
|
||||
(up tree (loop body (down tree result))))
|
||||
((<let> vals body)
|
||||
(up tree (loop body
|
||||
(loop vals
|
||||
(down tree result)))))
|
||||
((<letrec> vals body)
|
||||
(up tree (loop body
|
||||
(loop vals
|
||||
(down tree result)))))
|
||||
((<let-values> body)
|
||||
(up tree (loop body (down tree result))))
|
||||
(else
|
||||
(leaf tree result))))))
|
||||
|
||||
(define (post-order! f x)
|
||||
(let lp ((x x))
|
||||
(record-case x
|
||||
|
|
|
|||
|
|
@ -19,14 +19,40 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (language tree-il analyze)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (system base message)
|
||||
#:use-module (language tree-il)
|
||||
#:export (analyze-lexicals))
|
||||
#:export (analyze-lexicals
|
||||
report-unused-variables))
|
||||
|
||||
;; allocation: the process of assigning a type and index to each var
|
||||
;; a var is external if it is heaps; assigning index is easy
|
||||
;; args are assigned in order
|
||||
;; locals are indexed as their linear position in the binding path
|
||||
;; Allocation is the process of assigning storage locations for lexical
|
||||
;; variables. A lexical variable has a distinct "address", or storage
|
||||
;; location, for each procedure in which it is referenced.
|
||||
;;
|
||||
;; A variable is "local", i.e., allocated on the stack, if it is
|
||||
;; referenced from within the procedure that defined it. Otherwise it is
|
||||
;; a "closure" variable. For example:
|
||||
;;
|
||||
;; (lambda (a) a) ; a will be local
|
||||
;; `a' is local to the procedure.
|
||||
;;
|
||||
;; (lambda (a) (lambda () a))
|
||||
;; `a' is local to the outer procedure, but a closure variable with
|
||||
;; respect to the inner procedure.
|
||||
;;
|
||||
;; If a variable is ever assigned, it needs to be heap-allocated
|
||||
;; ("boxed"). This is so that closures and continuations capture the
|
||||
;; variable's identity, not just one of the values it may have over the
|
||||
;; course of program execution. If the variable is never assigned, there
|
||||
;; is no distinction between value and identity, so closing over its
|
||||
;; identity (whether through closures or continuations) can make a copy
|
||||
;; of its value instead.
|
||||
;;
|
||||
;; Local variables are stored on the stack within a procedure's call
|
||||
;; frame. Their index into the stack is determined from their linear
|
||||
;; postion within a procedure's binding path:
|
||||
;; (let (0 1)
|
||||
;; (let (2 3) ...)
|
||||
;; (let (2) ...))
|
||||
|
|
@ -48,49 +74,67 @@
|
|||
;; case. A proper solution would be some sort of liveness analysis, and
|
||||
;; not our linear allocation algorithm.
|
||||
;;
|
||||
;; allocation:
|
||||
;; sym -> (local . index) | (heap level . index)
|
||||
;; lambda -> (nlocs . nexts)
|
||||
;; Closure variables are captured when a closure is created, and stored
|
||||
;; in a vector. Each closure variable has a unique index into that
|
||||
;; vector.
|
||||
;;
|
||||
;;
|
||||
;; The return value of `analyze-lexicals' is a hash table, the
|
||||
;; "allocation".
|
||||
;;
|
||||
;; The allocation maps gensyms -- recall that each lexically bound
|
||||
;; variable has a unique gensym -- to storage locations ("addresses").
|
||||
;; Since one gensym may have many storage locations, if it is referenced
|
||||
;; 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.
|
||||
;;
|
||||
;; That is:
|
||||
;;
|
||||
;; sym -> {lambda -> address}
|
||||
;; lambda -> (nlocs . free-locs)
|
||||
;;
|
||||
;; address := (local? boxed? . index)
|
||||
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
|
||||
;; free variable addresses are relative to parent proc.
|
||||
|
||||
(define (make-hashq k v)
|
||||
(let ((res (make-hash-table)))
|
||||
(hashq-set! res k v)
|
||||
res))
|
||||
|
||||
(define (analyze-lexicals x)
|
||||
;; parents: lambda -> parent
|
||||
;; useful when we see a closed-over var, so we can calculate its
|
||||
;; coordinates (depth and index).
|
||||
;; bindings: lambda -> (sym ...)
|
||||
;; useful for two reasons: one, so we know how much space to allocate
|
||||
;; when we go into a lambda; and two, so that we know when to stop,
|
||||
;; when looking for closed-over vars.
|
||||
;; heaps: sym -> lambda
|
||||
;; allows us to heapify vars in an O(1) fashion
|
||||
;; bound-vars: lambda -> (sym ...)
|
||||
;; all identifiers bound within a lambda
|
||||
;; free-vars: lambda -> (sym ...)
|
||||
;; all identifiers referenced in a lambda, but not bound
|
||||
;; NB, this includes identifiers referenced by contained lambdas
|
||||
;; assigned: sym -> #t
|
||||
;; variables that are assigned
|
||||
;; refcounts: sym -> count
|
||||
;; allows us to detect the or-expansion an O(1) time
|
||||
|
||||
(define (find-heap sym parent)
|
||||
;; fixme: check displaced lexicals here?
|
||||
(if (memq sym (hashq-ref bindings parent))
|
||||
parent
|
||||
(find-heap sym (hashq-ref parents parent))))
|
||||
|
||||
(define (analyze! x parent level)
|
||||
(define (step y) (analyze! y parent level))
|
||||
(define (recur x parent) (analyze! x parent (1+ level)))
|
||||
;; allows us to detect the or-expansion in O(1) time
|
||||
|
||||
;; returns variables referenced in expr
|
||||
(define (analyze! x proc)
|
||||
(define (step y) (analyze! y proc))
|
||||
(define (recur x new-proc) (analyze! x new-proc))
|
||||
(record-case x
|
||||
((<application> proc args)
|
||||
(step proc) (for-each step args))
|
||||
(apply lset-union eq? (step proc) (map step args)))
|
||||
|
||||
((<conditional> test then else)
|
||||
(step test) (step then) (step else))
|
||||
(lset-union eq? (step test) (step then) (step else)))
|
||||
|
||||
((<lexical-ref> name gensym)
|
||||
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
|
||||
(if (and (not (memq gensym (hashq-ref bindings parent)))
|
||||
(not (hashq-ref heaps gensym)))
|
||||
(hashq-set! heaps gensym (find-heap gensym parent))))
|
||||
(list gensym))
|
||||
|
||||
((<lexical-set> name gensym exp)
|
||||
(step exp)
|
||||
(if (not (hashq-ref heaps gensym))
|
||||
(hashq-set! heaps gensym (find-heap gensym parent))))
|
||||
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
|
||||
(hashq-set! assigned gensym #t)
|
||||
(lset-adjoin eq? (step exp) gensym))
|
||||
|
||||
((<module-set> mod name public? exp)
|
||||
(step exp))
|
||||
|
|
@ -102,157 +146,292 @@
|
|||
(step exp))
|
||||
|
||||
((<sequence> exps)
|
||||
(for-each step exps))
|
||||
(apply lset-union eq? (map step exps)))
|
||||
|
||||
((<lambda> vars meta body)
|
||||
(hashq-set! parents x parent)
|
||||
(hashq-set! bindings x
|
||||
(let rev* ((vars vars) (out '()))
|
||||
(cond ((null? vars) out)
|
||||
((pair? vars) (rev* (cdr vars)
|
||||
(cons (car vars) out)))
|
||||
(else (cons vars out)))))
|
||||
(recur body x)
|
||||
(hashq-set! bindings x (reverse! (hashq-ref bindings x))))
|
||||
|
||||
(let ((locally-bound (let rev* ((vars vars) (out '()))
|
||||
(cond ((null? vars) out)
|
||||
((pair? vars) (rev* (cdr vars)
|
||||
(cons (car vars) out)))
|
||||
(else (cons vars out))))))
|
||||
(hashq-set! bound-vars x locally-bound)
|
||||
(let* ((referenced (recur body x))
|
||||
(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)))
|
||||
|
||||
((<let> vars vals body)
|
||||
(for-each step vals)
|
||||
(hashq-set! bindings parent
|
||||
(append (reverse vars) (hashq-ref bindings parent)))
|
||||
(step body))
|
||||
(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))
|
||||
vars))
|
||||
|
||||
((<letrec> vars vals body)
|
||||
(hashq-set! bindings parent
|
||||
(append (reverse vars) (hashq-ref bindings parent)))
|
||||
(for-each step vals)
|
||||
(step body))
|
||||
|
||||
(hashq-set! bound-vars proc
|
||||
(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))
|
||||
vars))
|
||||
|
||||
((<let-values> vars exp body)
|
||||
(hashq-set! bindings parent
|
||||
(let lp ((out (hashq-ref bindings parent)) (in vars))
|
||||
(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)))))
|
||||
(step exp)
|
||||
(step body))
|
||||
(lset-difference eq?
|
||||
(lset-union eq? (step exp) (step body))
|
||||
vars))
|
||||
|
||||
(else '())))
|
||||
|
||||
(define (allocate! x proc n)
|
||||
(define (recur y) (allocate! y proc n))
|
||||
(record-case x
|
||||
((<application> proc args)
|
||||
(apply max (recur proc) (map recur args)))
|
||||
|
||||
(else #f)))
|
||||
((<conditional> test then else)
|
||||
(max (recur test) (recur then) (recur else)))
|
||||
|
||||
(define (allocate-heap! binder)
|
||||
(hashq-set! heap-indexes binder
|
||||
(1+ (hashq-ref heap-indexes binder -1))))
|
||||
((<lexical-set> name gensym exp)
|
||||
(recur exp))
|
||||
|
||||
((<module-set> mod name public? exp)
|
||||
(recur exp))
|
||||
|
||||
((<toplevel-set> name exp)
|
||||
(recur exp))
|
||||
|
||||
((<toplevel-define> name exp)
|
||||
(recur exp))
|
||||
|
||||
((<sequence> exps)
|
||||
(apply max (map recur exps)))
|
||||
|
||||
((<lambda> vars meta body)
|
||||
;; allocate closure vars in order
|
||||
(let lp ((c (hashq-ref free-vars x)) (n 0))
|
||||
(if (pair? c)
|
||||
(begin
|
||||
(hashq-set! (hashq-ref allocation (car c))
|
||||
x
|
||||
`(#f ,(hashq-ref assigned (car c)) . ,n))
|
||||
(lp (cdr c) (1+ n)))))
|
||||
|
||||
(let ((nlocs
|
||||
(let lp ((vars vars) (n 0))
|
||||
(if (not (null? vars))
|
||||
;; allocate args
|
||||
(let ((v (if (pair? vars) (car vars) vars)))
|
||||
(hashq-set! allocation v
|
||||
(make-hashq
|
||||
x `(#t ,(hashq-ref assigned v) . ,n)))
|
||||
(lp (if (pair? vars) (cdr vars) '()) (1+ n)))
|
||||
;; allocate body, return number of additional locals
|
||||
(- (allocate! body x n) n))))
|
||||
(free-addresses
|
||||
(map (lambda (v)
|
||||
(hashq-ref (hashq-ref allocation v) proc))
|
||||
(hashq-ref free-vars x))))
|
||||
;; set procedure allocations
|
||||
(hashq-set! allocation x (cons nlocs free-addresses)))
|
||||
n)
|
||||
|
||||
(define (allocate! x level n)
|
||||
(define (recur y) (allocate! y level n))
|
||||
(record-case x
|
||||
((<application> proc args)
|
||||
(apply max (recur proc) (map recur args)))
|
||||
|
||||
((<conditional> test then else)
|
||||
(max (recur test) (recur then) (recur else)))
|
||||
|
||||
((<lexical-set> name gensym exp)
|
||||
(recur exp))
|
||||
|
||||
((<module-set> mod name public? exp)
|
||||
(recur exp))
|
||||
|
||||
((<toplevel-set> name exp)
|
||||
(recur exp))
|
||||
|
||||
((<toplevel-define> name exp)
|
||||
(recur exp))
|
||||
|
||||
((<sequence> exps)
|
||||
(apply max (map recur exps)))
|
||||
|
||||
((<lambda> vars meta body)
|
||||
(let lp ((vars vars) (n 0))
|
||||
(if (null? vars)
|
||||
(hashq-set! allocation x
|
||||
(let ((nlocs (- (allocate! body (1+ level) n) n)))
|
||||
(cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
|
||||
(let ((v (if (pair? vars) (car vars) vars)))
|
||||
(let ((binder (hashq-ref heaps v)))
|
||||
(hashq-set!
|
||||
allocation v
|
||||
(if binder
|
||||
(cons* 'heap (1+ level) (allocate-heap! binder))
|
||||
(cons 'stack n))))
|
||||
(lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
|
||||
n)
|
||||
|
||||
((<let> vars vals body)
|
||||
(let ((nmax (apply max (map recur vals))))
|
||||
(cond
|
||||
;; the `or' hack
|
||||
((and (conditional? body)
|
||||
(= (length vars) 1)
|
||||
(let ((v (car vars)))
|
||||
(and (not (hashq-ref heaps v))
|
||||
(= (hashq-ref refcounts v 0) 2)
|
||||
(lexical-ref? (conditional-test body))
|
||||
(eq? (lexical-ref-gensym (conditional-test body)) v)
|
||||
(lexical-ref? (conditional-then body))
|
||||
(eq? (lexical-ref-gensym (conditional-then body)) v))))
|
||||
(hashq-set! allocation (car vars) (cons 'stack n))
|
||||
;; the 1+ for this var
|
||||
(max nmax (1+ n) (allocate! (conditional-else body) level n)))
|
||||
(else
|
||||
(let lp ((vars vars) (n n))
|
||||
(if (null? vars)
|
||||
(max nmax (allocate! body level n))
|
||||
(let ((v (car vars)))
|
||||
(let ((binder (hashq-ref heaps v)))
|
||||
(hashq-set!
|
||||
allocation v
|
||||
(if binder
|
||||
(cons* 'heap level (allocate-heap! binder))
|
||||
(cons 'stack n)))
|
||||
(lp (cdr vars) (if binder n (1+ n)))))))))))
|
||||
|
||||
((<letrec> vars vals body)
|
||||
(let lp ((vars vars) (n n))
|
||||
(if (null? vars)
|
||||
(let ((nmax (apply max
|
||||
(map (lambda (x)
|
||||
(allocate! x level n))
|
||||
vals))))
|
||||
(max nmax (allocate! body level n)))
|
||||
(let ((v (car vars)))
|
||||
(let ((binder (hashq-ref heaps v)))
|
||||
(hashq-set!
|
||||
allocation v
|
||||
(if binder
|
||||
(cons* 'heap level (allocate-heap! binder))
|
||||
(cons 'stack n)))
|
||||
(lp (cdr vars) (if binder n (1+ n))))))))
|
||||
|
||||
((<let-values> vars exp body)
|
||||
(let ((nmax (recur exp)))
|
||||
((<let> vars vals body)
|
||||
(let ((nmax (apply max (map recur vals))))
|
||||
(cond
|
||||
;; the `or' hack
|
||||
((and (conditional? body)
|
||||
(= (length vars) 1)
|
||||
(let ((v (car vars)))
|
||||
(and (not (hashq-ref assigned v))
|
||||
(= (hashq-ref refcounts v 0) 2)
|
||||
(lexical-ref? (conditional-test body))
|
||||
(eq? (lexical-ref-gensym (conditional-test body)) v)
|
||||
(lexical-ref? (conditional-then body))
|
||||
(eq? (lexical-ref-gensym (conditional-then body)) v))))
|
||||
(hashq-set! allocation (car vars)
|
||||
(make-hashq proc `(#t #f . ,n)))
|
||||
;; the 1+ for this var
|
||||
(max nmax (1+ n) (allocate! (conditional-else body) proc n)))
|
||||
(else
|
||||
(let lp ((vars vars) (n n))
|
||||
(if (null? vars)
|
||||
(max nmax (allocate! body level n))
|
||||
(let ((v (if (pair? vars) (car vars) vars)))
|
||||
(let ((binder (hashq-ref heaps v)))
|
||||
(hashq-set!
|
||||
allocation v
|
||||
(if binder
|
||||
(cons* 'heap level (allocate-heap! binder))
|
||||
(cons 'stack n)))
|
||||
(lp (if (pair? vars) (cdr vars) '())
|
||||
(if binder n (1+ n)))))))))
|
||||
|
||||
(else n)))
|
||||
(max nmax (allocate! body proc n))
|
||||
(let ((v (car vars)))
|
||||
(hashq-set!
|
||||
allocation v
|
||||
(make-hashq proc
|
||||
`(#t ,(hashq-ref assigned v) . ,n)))
|
||||
(lp (cdr vars) (1+ n)))))))))
|
||||
|
||||
((<letrec> vars vals body)
|
||||
(let lp ((vars vars) (n n))
|
||||
(if (null? vars)
|
||||
(let ((nmax (apply max
|
||||
(map (lambda (x)
|
||||
(allocate! x proc n))
|
||||
vals))))
|
||||
(max nmax (allocate! body proc n)))
|
||||
(let ((v (car vars)))
|
||||
(hashq-set!
|
||||
allocation v
|
||||
(make-hashq proc
|
||||
`(#t ,(hashq-ref assigned v) . ,n)))
|
||||
(lp (cdr vars) (1+ n))))))
|
||||
|
||||
(define parents (make-hash-table))
|
||||
(define bindings (make-hash-table))
|
||||
(define heaps (make-hash-table))
|
||||
((<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))))))))
|
||||
|
||||
(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))
|
||||
(define heap-indexes (make-hash-table))
|
||||
|
||||
(analyze! x #f -1)
|
||||
(allocate! x -1 0)
|
||||
|
||||
(analyze! x #f)
|
||||
(allocate! x #f 0)
|
||||
|
||||
allocation)
|
||||
|
||||
|
||||
;;;
|
||||
;;; Unused variable analysis.
|
||||
;;;
|
||||
|
||||
;; <binding-info> records are used during tree traversals in
|
||||
;; `report-unused-variables'. They contain a list of the local vars
|
||||
;; currently in scope, a list of locals vars that have been referenced, and a
|
||||
;; "location stack" (the stack of `tree-il-src' values for each parent tree).
|
||||
(define-record-type <binding-info>
|
||||
(make-binding-info vars refs locs)
|
||||
binding-info?
|
||||
(vars binding-info-vars) ;; ((GENSYM NAME LOCATION) ...)
|
||||
(refs binding-info-refs) ;; (GENSYM ...)
|
||||
(locs binding-info-locs)) ;; (LOCATION ...)
|
||||
|
||||
(define (report-unused-variables tree)
|
||||
"Report about unused variables in TREE. Return TREE."
|
||||
|
||||
(define (dotless-list lst)
|
||||
;; If LST is a dotted list, return a proper list equal to LST except that
|
||||
;; the very last element is a pair; otherwise return LST.
|
||||
(let loop ((lst lst)
|
||||
(result '()))
|
||||
(cond ((null? lst)
|
||||
(reverse result))
|
||||
((pair? lst)
|
||||
(loop (cdr lst) (cons (car lst) result)))
|
||||
(else
|
||||
(loop '() (cons lst result))))))
|
||||
|
||||
(tree-il-fold (lambda (x info)
|
||||
;; X is a leaf: extend INFO's refs accordingly.
|
||||
(let ((refs (binding-info-refs info))
|
||||
(vars (binding-info-vars info))
|
||||
(locs (binding-info-locs info)))
|
||||
(record-case x
|
||||
((<lexical-ref> gensym)
|
||||
(make-binding-info vars (cons gensym refs) locs))
|
||||
(else info))))
|
||||
|
||||
(lambda (x info)
|
||||
;; Going down into X: extend INFO's variable list
|
||||
;; accordingly.
|
||||
(let ((refs (binding-info-refs info))
|
||||
(vars (binding-info-vars info))
|
||||
(locs (binding-info-locs info))
|
||||
(src (tree-il-src x)))
|
||||
(define (extend inner-vars inner-names)
|
||||
(append (map (lambda (var name)
|
||||
(list var name src))
|
||||
inner-vars
|
||||
inner-names)
|
||||
vars))
|
||||
(record-case x
|
||||
((<lexical-set> gensym)
|
||||
(make-binding-info vars (cons gensym refs)
|
||||
(cons src locs)))
|
||||
((<lambda> vars names)
|
||||
(let ((vars (dotless-list vars))
|
||||
(names (dotless-list names)))
|
||||
(make-binding-info (extend vars names) refs
|
||||
(cons src locs))))
|
||||
((<let> vars names)
|
||||
(make-binding-info (extend vars names) refs
|
||||
(cons src locs)))
|
||||
((<letrec> vars names)
|
||||
(make-binding-info (extend vars names) refs
|
||||
(cons src locs)))
|
||||
((<let-values> vars names)
|
||||
(make-binding-info (extend vars names) refs
|
||||
(cons src locs)))
|
||||
(else info))))
|
||||
|
||||
(lambda (x info)
|
||||
;; Leaving X's scope: shrink INFO's variable list
|
||||
;; accordingly and reported unused nested variables.
|
||||
(let ((refs (binding-info-refs info))
|
||||
(vars (binding-info-vars info))
|
||||
(locs (binding-info-locs info)))
|
||||
(define (shrink inner-vars refs)
|
||||
(for-each (lambda (var)
|
||||
(let ((gensym (car var)))
|
||||
;; Don't report lambda parameters as
|
||||
;; unused.
|
||||
(if (and (not (memq gensym refs))
|
||||
(not (and (lambda? x)
|
||||
(memq gensym
|
||||
inner-vars))))
|
||||
(let ((name (cadr var))
|
||||
;; We can get approximate
|
||||
;; source location by going up
|
||||
;; the LOCS location stack.
|
||||
(loc (or (caddr var)
|
||||
(find pair? locs))))
|
||||
(warning 'unused-variable loc name)))))
|
||||
(filter (lambda (var)
|
||||
(memq (car var) inner-vars))
|
||||
vars))
|
||||
(fold alist-delete vars inner-vars))
|
||||
|
||||
;; For simplicity, we leave REFS untouched, i.e., with
|
||||
;; names of variables that are now going out of scope.
|
||||
;; It doesn't hurt as these are unique names, it just
|
||||
;; makes REFS unnecessarily fat.
|
||||
(record-case x
|
||||
((<lambda> vars)
|
||||
(let ((vars (dotless-list vars)))
|
||||
(make-binding-info (shrink vars refs) refs
|
||||
(cdr locs))))
|
||||
((<let> vars)
|
||||
(make-binding-info (shrink vars refs) refs
|
||||
(cdr locs)))
|
||||
((<letrec> vars)
|
||||
(make-binding-info (shrink vars refs) refs
|
||||
(cdr locs)))
|
||||
((<let-values> vars)
|
||||
(make-binding-info (shrink vars refs) refs
|
||||
(cdr locs)))
|
||||
(else info))))
|
||||
(make-binding-info '() '() '())
|
||||
tree)
|
||||
tree)
|
||||
|
|
|
|||
|
|
@ -20,6 +20,8 @@
|
|||
|
||||
(define-module (language tree-il compile-glil)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system base message)
|
||||
#:use-module (ice-9 receive)
|
||||
#:use-module (language glil)
|
||||
#:use-module (system vm instruction)
|
||||
|
|
@ -34,18 +36,37 @@
|
|||
;; basic degenerate-case reduction
|
||||
|
||||
;; allocation:
|
||||
;; sym -> (local . index) | (heap level . index)
|
||||
;; lambda -> (nlocs . nexts)
|
||||
;; sym -> {lambda -> address}
|
||||
;; lambda -> (nlocs . closure-vars)
|
||||
;;
|
||||
;; address := (local? boxed? . index)
|
||||
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
|
||||
;; free variable addresses are relative to parent proc.
|
||||
|
||||
(define *comp-module* (make-fluid))
|
||||
|
||||
(define %warning-passes
|
||||
`((unused-variable . ,report-unused-variables)))
|
||||
|
||||
(define (compile-glil x e opts)
|
||||
(define warnings
|
||||
(or (and=> (memq #:warnings opts) cadr)
|
||||
'()))
|
||||
|
||||
(let* ((x (make-lambda (tree-il-src x) '() '() '() x))
|
||||
(x (optimize! x e opts))
|
||||
(allocation (analyze-lexicals x)))
|
||||
|
||||
;; Go throught the warning passes.
|
||||
(for-each (lambda (kind)
|
||||
(let ((warn (assoc-ref %warning-passes kind)))
|
||||
(and (procedure? warn)
|
||||
(warn x))))
|
||||
warnings)
|
||||
|
||||
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
|
||||
(lambda ()
|
||||
(values (flatten-lambda x -1 allocation)
|
||||
(values (flatten-lambda x allocation)
|
||||
(and e (cons (car e) (cddr e)))
|
||||
e)))))
|
||||
|
||||
|
|
@ -131,20 +152,19 @@
|
|||
|
||||
(define (make-label) (gensym ":L"))
|
||||
|
||||
(define (vars->bind-list ids vars allocation)
|
||||
(define (vars->bind-list ids vars allocation proc)
|
||||
(map (lambda (id v)
|
||||
(let ((loc (hashq-ref allocation v)))
|
||||
(case (car loc)
|
||||
((stack) (list id 'local (cdr loc)))
|
||||
((heap) (list id 'external (cddr loc)))
|
||||
(else (error "badness" id v loc)))))
|
||||
(pmatch (hashq-ref (hashq-ref allocation v) proc)
|
||||
((#t ,boxed? . ,n)
|
||||
(list id boxed? n))
|
||||
(,x (error "badness" x))))
|
||||
ids
|
||||
vars))
|
||||
|
||||
(define (emit-bindings src ids vars allocation emit-code)
|
||||
(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)))))
|
||||
(vars->bind-list ids vars allocation proc)))))
|
||||
|
||||
(define (with-output-to-code proc)
|
||||
(let ((out '()))
|
||||
|
|
@ -155,7 +175,7 @@
|
|||
(proc emit-code)
|
||||
(reverse out)))
|
||||
|
||||
(define (flatten-lambda x level allocation)
|
||||
(define (flatten-lambda x allocation)
|
||||
(receive (ids vars nargs nrest)
|
||||
(let lp ((ids (lambda-names x)) (vars (lambda-vars x))
|
||||
(oids '()) (ovars '()) (n 0))
|
||||
|
|
@ -166,31 +186,27 @@
|
|||
(else (values (reverse (cons ids oids))
|
||||
(reverse (cons vars ovars))
|
||||
(1+ n) 1))))
|
||||
(let ((nlocs (car (hashq-ref allocation x)))
|
||||
(nexts (cdr (hashq-ref allocation x))))
|
||||
(let ((nlocs (car (hashq-ref allocation x))))
|
||||
(make-glil-program
|
||||
nargs nrest nlocs nexts (lambda-meta x)
|
||||
nargs nrest nlocs (lambda-meta x)
|
||||
(with-output-to-code
|
||||
(lambda (emit-code)
|
||||
;; write bindings and source debugging info
|
||||
(emit-bindings #f ids vars allocation emit-code)
|
||||
(emit-bindings #f ids vars allocation x emit-code)
|
||||
(if (lambda-src x)
|
||||
(emit-code #f (make-glil-source (lambda-src x))))
|
||||
|
||||
;; copy args to the heap if necessary
|
||||
(let lp ((in vars) (n 0))
|
||||
(if (not (null? in))
|
||||
(let ((loc (hashq-ref allocation (car in))))
|
||||
(case (car loc)
|
||||
((heap)
|
||||
(emit-code #f (make-glil-local 'ref n))
|
||||
(emit-code #f (make-glil-external 'set 0 (cddr loc)))))
|
||||
(lp (cdr in) (1+ n)))))
|
||||
|
||||
;; 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)))))
|
||||
vars)
|
||||
;; and here, here, dear reader: we compile.
|
||||
(flatten (lambda-body x) (1+ level) allocation emit-code)))))))
|
||||
(flatten (lambda-body x) allocation x emit-code)))))))
|
||||
|
||||
(define (flatten x level allocation emit-code)
|
||||
(define (flatten x allocation proc emit-code)
|
||||
(define (emit-label label)
|
||||
(emit-code #f (make-glil-label label)))
|
||||
(define (emit-branch src inst label)
|
||||
|
|
@ -424,27 +440,21 @@
|
|||
((<lexical-ref> src name gensym)
|
||||
(case context
|
||||
((push vals tail)
|
||||
(let ((loc (hashq-ref allocation gensym)))
|
||||
(case (car loc)
|
||||
((stack)
|
||||
(emit-code src (make-glil-local 'ref (cdr loc))))
|
||||
((heap)
|
||||
(emit-code src (make-glil-external
|
||||
'ref (- level (cadr loc)) (cddr loc))))
|
||||
(else (error "badness" x loc)))
|
||||
(if (eq? context 'tail)
|
||||
(emit-code #f (make-glil-call 'return 1)))))))
|
||||
|
||||
(pmatch (hashq-ref (hashq-ref allocation gensym) proc)
|
||||
((,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)))))
|
||||
|
||||
((<lexical-set> src name gensym exp)
|
||||
(comp-push exp)
|
||||
(let ((loc (hashq-ref allocation gensym)))
|
||||
(case (car loc)
|
||||
((stack)
|
||||
(emit-code src (make-glil-local 'set (cdr loc))))
|
||||
((heap)
|
||||
(emit-code src (make-glil-external
|
||||
'set (- level (cadr loc)) (cddr loc))))
|
||||
(else (error "badness" x loc))))
|
||||
(pmatch (hashq-ref (hashq-ref allocation gensym) proc)
|
||||
((,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)))
|
||||
|
|
@ -495,39 +505,52 @@
|
|||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
((<lambda>)
|
||||
(case context
|
||||
((push vals)
|
||||
(emit-code #f (flatten-lambda x level allocation)))
|
||||
((tail)
|
||||
(emit-code #f (flatten-lambda x level allocation))
|
||||
(emit-code #f (make-glil-call 'return 1)))))
|
||||
|
||||
(let ((free-locs (cdr (hashq-ref allocation x))))
|
||||
(case context
|
||||
((push vals tail)
|
||||
(emit-code #f (flatten-lambda x 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)))
|
||||
(emit-code #f (make-glil-call 'make-closure 2))))
|
||||
(if (eq? context 'tail)
|
||||
(emit-code #f (make-glil-call 'return 1)))))))
|
||||
|
||||
((<let> src names vars vals body)
|
||||
(for-each comp-push vals)
|
||||
(emit-bindings src names vars allocation emit-code)
|
||||
(emit-bindings src names vars allocation proc emit-code)
|
||||
(for-each (lambda (v)
|
||||
(let ((loc (hashq-ref allocation v)))
|
||||
(case (car loc)
|
||||
((stack)
|
||||
(emit-code src (make-glil-local 'set (cdr loc))))
|
||||
((heap)
|
||||
(emit-code src (make-glil-external 'set 0 (cddr loc))))
|
||||
(else (error "badness" x loc)))))
|
||||
(pmatch (hashq-ref (hashq-ref allocation v) proc)
|
||||
((#t #f . ,n)
|
||||
(emit-code src (make-glil-lexical #t #f 'set n)))
|
||||
((#t #t . ,n)
|
||||
(emit-code src (make-glil-lexical #t #t 'box n)))
|
||||
(,loc (error "badness" x loc))))
|
||||
(reverse vars))
|
||||
(comp-tail body)
|
||||
(emit-code #f (make-glil-unbind)))
|
||||
|
||||
((<letrec> src names vars vals body)
|
||||
(for-each comp-push vals)
|
||||
(emit-bindings src names vars allocation emit-code)
|
||||
(for-each (lambda (v)
|
||||
(let ((loc (hashq-ref allocation v)))
|
||||
(case (car loc)
|
||||
((stack)
|
||||
(emit-code src (make-glil-local 'set (cdr loc))))
|
||||
((heap)
|
||||
(emit-code src (make-glil-external 'set 0 (cddr loc))))
|
||||
(else (error "badness" x loc)))))
|
||||
(pmatch (hashq-ref (hashq-ref allocation v) proc)
|
||||
((#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)
|
||||
(for-each (lambda (v)
|
||||
(pmatch (hashq-ref (hashq-ref allocation v) proc)
|
||||
((#t #t . ,n)
|
||||
(emit-code src (make-glil-lexical #t #t 'set n)))
|
||||
(,loc (error "badness" x loc))))
|
||||
(reverse vars))
|
||||
(comp-tail body)
|
||||
(emit-code #f (make-glil-unbind)))
|
||||
|
|
@ -548,16 +571,15 @@
|
|||
(emit-code #f (make-glil-const 1))
|
||||
(emit-label MV)
|
||||
(emit-code src (make-glil-mv-bind
|
||||
(vars->bind-list names vars allocation)
|
||||
(vars->bind-list names vars allocation proc)
|
||||
rest?))
|
||||
(for-each (lambda (v)
|
||||
(let ((loc (hashq-ref allocation v)))
|
||||
(case (car loc)
|
||||
((stack)
|
||||
(emit-code src (make-glil-local 'set (cdr loc))))
|
||||
((heap)
|
||||
(emit-code src (make-glil-external 'set 0 (cddr loc))))
|
||||
(else (error "badness" x loc)))))
|
||||
(pmatch (hashq-ref (hashq-ref allocation v) proc)
|
||||
((#t #f . ,n)
|
||||
(emit-code src (make-glil-lexical #t #f 'set n)))
|
||||
((#t #t . ,n)
|
||||
(emit-code src (make-glil-lexical #t #t 'box n)))
|
||||
(,loc (error "badness" x loc))))
|
||||
(reverse vars))
|
||||
(comp-tail body)
|
||||
(emit-code #f (make-glil-unbind))))))))))
|
||||
|
|
|
|||
|
|
@ -30,9 +30,11 @@
|
|||
|
||||
(define-module (scripts compile)
|
||||
#:use-module ((system base compile) #:select (compile-file))
|
||||
#:use-module (system base message)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-13)
|
||||
#:use-module (srfi srfi-37)
|
||||
#:use-module (ice-9 format)
|
||||
#:export (compile))
|
||||
|
||||
|
||||
|
|
@ -58,6 +60,17 @@
|
|||
(fail "`-o' option cannot be specified more than once")
|
||||
(alist-cons 'output-file arg result))))
|
||||
|
||||
(option '(#\W "warn") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(if (string=? arg "help")
|
||||
(begin
|
||||
(show-warning-help)
|
||||
(exit 0))
|
||||
(let ((warnings (assoc-ref result 'warnings)))
|
||||
(alist-cons 'warnings
|
||||
(cons (string->symbol arg) warnings)
|
||||
(alist-delete 'warnings result))))))
|
||||
|
||||
(option '(#\O "optimize") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'optimize? #t result)))
|
||||
|
|
@ -86,13 +99,27 @@ options."
|
|||
|
||||
;; default option values
|
||||
'((input-files)
|
||||
(load-path))))
|
||||
(load-path)
|
||||
(warnings unsupported-warning))))
|
||||
|
||||
(define (show-warning-help)
|
||||
(format #t "The available warning types are:~%~%")
|
||||
(for-each (lambda (wt)
|
||||
(format #t " ~22A ~A~%"
|
||||
(format #f "`~A'" (warning-type-name wt))
|
||||
(warning-type-description wt)))
|
||||
%warning-types)
|
||||
(format #t "~%"))
|
||||
|
||||
|
||||
(define (compile . args)
|
||||
(let* ((options (parse-args args))
|
||||
(help? (assoc-ref options 'help?))
|
||||
(compile-opts (if (assoc-ref options 'optimize?) '(#:O) '()))
|
||||
(compile-opts (let ((o `(#:warnings
|
||||
,(assoc-ref options 'warnings))))
|
||||
(if (assoc-ref options 'optimize?)
|
||||
(cons #:O o)
|
||||
o)))
|
||||
(from (or (assoc-ref options 'from) 'scheme))
|
||||
(to (or (assoc-ref options 'to) 'objcode))
|
||||
(input-files (assoc-ref options 'input-files))
|
||||
|
|
@ -108,6 +135,9 @@ Compile each Guile source file FILE into a Guile object.
|
|||
-L, --load-path=DIR add DIR to the front of the module load path
|
||||
-o, --output=OFILE write output to OFILE
|
||||
|
||||
-W, --warn=WARNING emit warnings of type WARNING; use `--warn=help'
|
||||
for a list of available warnings
|
||||
|
||||
-f, --from=LANG specify a source language other than `scheme'
|
||||
-t, --to=LANG specify a target language other than `objcode'
|
||||
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@
|
|||
(define-module (system base compile)
|
||||
#:use-module (system base syntax)
|
||||
#:use-module (system base language)
|
||||
#:use-module (system base message)
|
||||
#:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 optargs)
|
||||
|
|
@ -213,6 +214,16 @@
|
|||
(from (current-language))
|
||||
(to 'value)
|
||||
(opts '()))
|
||||
|
||||
(let ((warnings (memq #:warnings opts)))
|
||||
(if (pair? warnings)
|
||||
(let ((warnings (cadr warnings)))
|
||||
;; Sanity-check the requested warnings.
|
||||
(for-each (lambda (w)
|
||||
(or (lookup-warning-type w)
|
||||
(warning 'unsupported-warning #f w)))
|
||||
warnings))))
|
||||
|
||||
(receive (exp env cenv)
|
||||
(compile-fold (compile-passes from to opts) x env opts)
|
||||
exp))
|
||||
|
|
|
|||
102
module/system/base/message.scm
Normal file
102
module/system/base/message.scm
Normal file
|
|
@ -0,0 +1,102 @@
|
|||
;;; User interface messages
|
||||
|
||||
;; Copyright (C) 2009 Free Software Foundation, Inc.
|
||||
|
||||
;;; This library is free software; you can redistribute it and/or
|
||||
;;; modify it under the terms of the GNU Lesser General Public
|
||||
;;; License as published by the Free Software Foundation; either
|
||||
;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;
|
||||
;;; This library is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; Lesser General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;; License along with this library; if not, write to the Free Software
|
||||
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; This module provide a simple interface to send messages to the user.
|
||||
;;; TODO: Internationalize messages.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (system base message)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:export (*current-warning-port* warning
|
||||
|
||||
warning-type? warning-type-name warning-type-description
|
||||
warning-type-printer lookup-warning-type
|
||||
|
||||
%warning-types))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Source location
|
||||
;;;
|
||||
|
||||
(define (location-string loc)
|
||||
(if (pair? loc)
|
||||
(format #f "~a:~a:~a"
|
||||
(or (assoc-ref loc 'filename) "<stdin>")
|
||||
(1+ (assoc-ref loc 'line))
|
||||
(assoc-ref loc 'column))
|
||||
"<unknown-location>"))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Warnings
|
||||
;;;
|
||||
|
||||
(define *current-warning-port*
|
||||
;; The port where warnings are sent.
|
||||
(make-fluid))
|
||||
|
||||
(fluid-set! *current-warning-port* (current-error-port))
|
||||
|
||||
(define-record-type <warning-type>
|
||||
(make-warning-type name description printer)
|
||||
warning-type?
|
||||
(name warning-type-name)
|
||||
(description warning-type-description)
|
||||
(printer warning-type-printer))
|
||||
|
||||
(define %warning-types
|
||||
;; List of know warning types.
|
||||
(map (lambda (args)
|
||||
(apply make-warning-type args))
|
||||
|
||||
`((unsupported-warning ;; a "meta warning"
|
||||
"warn about unknown warning types"
|
||||
,(lambda (port unused name)
|
||||
(format port "warning: unknown warning type `~A'~%"
|
||||
name)))
|
||||
|
||||
(unused-variable
|
||||
"report unused variables"
|
||||
,(lambda (port loc name)
|
||||
(format port "~A: warning: unused variable `~A'~%"
|
||||
loc name))))))
|
||||
|
||||
(define (lookup-warning-type name)
|
||||
"Return the warning type NAME or `#f' if not found."
|
||||
(find (lambda (wt)
|
||||
(eq? name (warning-type-name wt)))
|
||||
%warning-types))
|
||||
|
||||
(define (warning type location . args)
|
||||
"Emit a warning of type TYPE for source location LOCATION (a source
|
||||
property alist) using the data in ARGS."
|
||||
(let ((wt (lookup-warning-type type))
|
||||
(port (fluid-ref *current-warning-port*)))
|
||||
(if (warning-type? wt)
|
||||
(apply (warning-type-printer wt)
|
||||
port (location-string location)
|
||||
args)
|
||||
(format port "~A: unknown warning type `~A': ~A~%"
|
||||
(location-string location) type args))))
|
||||
|
||||
;;; message.scm ends here
|
||||
|
|
@ -386,7 +386,6 @@ Trace execution.
|
|||
|
||||
-s Display stack
|
||||
-l Display local variables
|
||||
-e Display external variables
|
||||
-b Bytecode level trace"
|
||||
(apply vm-trace (repl-vm repl)
|
||||
(repl-compile repl (repl-parse repl form))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile VM frame functions
|
||||
|
||||
;;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||
;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
|
||||
;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
|
||||
;;;
|
||||
;;; This program is free software; you can redistribute it and/or modify
|
||||
|
|
@ -27,20 +27,20 @@
|
|||
vm-frame-program
|
||||
vm-frame-local-ref vm-frame-local-set!
|
||||
vm-frame-return-address vm-frame-mv-return-address
|
||||
vm-frame-dynamic-link vm-frame-external-link
|
||||
vm-frame-dynamic-link
|
||||
vm-frame-stack
|
||||
|
||||
|
||||
vm-frame-number vm-frame-address
|
||||
make-frame-chain
|
||||
print-frame print-frame-chain-as-backtrace
|
||||
frame-arguments frame-local-variables frame-external-variables
|
||||
frame-environment
|
||||
frame-variable-exists? frame-variable-ref frame-variable-set!
|
||||
frame-object-name
|
||||
frame-local-ref frame-external-link frame-local-set!
|
||||
frame-return-address frame-program
|
||||
frame-dynamic-link heap-frame?))
|
||||
make-frame-chain
|
||||
print-frame print-frame-chain-as-backtrace
|
||||
frame-arguments frame-local-variables
|
||||
frame-environment
|
||||
frame-variable-exists? frame-variable-ref frame-variable-set!
|
||||
frame-object-name
|
||||
frame-local-ref frame-local-set!
|
||||
frame-return-address frame-program
|
||||
frame-dynamic-link heap-frame?))
|
||||
|
||||
(load-extension "libguile" "scm_init_frames")
|
||||
|
||||
|
|
@ -158,24 +158,19 @@
|
|||
(l '() (cons (frame-local-ref frame n) l)))
|
||||
((< n 0) l))))
|
||||
|
||||
(define (frame-external-variables frame)
|
||||
(frame-external-link frame))
|
||||
|
||||
(define (frame-external-ref frame index)
|
||||
(list-ref (frame-external-link frame) index))
|
||||
|
||||
(define (frame-external-set! frame index val)
|
||||
(list-set! (frame-external-link frame) index val))
|
||||
|
||||
(define (frame-binding-ref frame binding)
|
||||
(if (binding:extp binding)
|
||||
(frame-external-ref frame (binding:index binding))
|
||||
(frame-local-ref frame (binding:index binding))))
|
||||
(let ((x (frame-local-ref frame (binding:index binding))))
|
||||
(if (and (binding:boxed? binding) (variable? x))
|
||||
(variable-ref x)
|
||||
x)))
|
||||
|
||||
(define (frame-binding-set! frame binding val)
|
||||
(if (binding:extp binding)
|
||||
(frame-external-set! frame (binding:index binding) val)
|
||||
(frame-local-set! frame (binding:index binding) val)))
|
||||
(if (binding:boxed? binding)
|
||||
(let ((v (frame-local-ref frame binding)))
|
||||
(if (variable? v)
|
||||
(variable-set! v val)
|
||||
(frame-local-set! frame binding (make-variable val))))
|
||||
(frame-local-set! frame binding val)))
|
||||
|
||||
;; FIXME handle #f program-bindings return
|
||||
(define (frame-bindings frame addr)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile VM program functions
|
||||
|
||||
;;; 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
|
||||
|
|
@ -21,9 +21,9 @@
|
|||
(define-module (system vm program)
|
||||
#:export (make-program
|
||||
|
||||
arity:nargs arity:nrest arity:nlocs arity:nexts
|
||||
arity:nargs arity:nrest arity:nlocs
|
||||
|
||||
make-binding binding:name binding:extp binding:index
|
||||
make-binding binding:name binding:boxed? binding:index
|
||||
binding:start binding:end
|
||||
|
||||
source:addr source:line source:column source:file
|
||||
|
|
@ -31,21 +31,20 @@
|
|||
program-properties program-property program-documentation
|
||||
program-name program-arguments
|
||||
|
||||
program-arity program-external-set! program-meta
|
||||
program-arity program-meta
|
||||
program-objcode program? program-objects
|
||||
program-module program-base program-external))
|
||||
program-module program-base program-free-variables))
|
||||
|
||||
(load-extension "libguile" "scm_init_programs")
|
||||
|
||||
(define arity:nargs car)
|
||||
(define arity:nrest cadr)
|
||||
(define arity:nlocs caddr)
|
||||
(define arity:nexts cadddr)
|
||||
|
||||
(define (make-binding name extp index start end)
|
||||
(list name extp index start end))
|
||||
(define (make-binding name boxed? index start end)
|
||||
(list name boxed? index start end))
|
||||
(define (binding:name b) (list-ref b 0))
|
||||
(define (binding:extp b) (list-ref b 1))
|
||||
(define (binding:boxed? b) (list-ref b 1))
|
||||
(define (binding:index b) (list-ref b 2))
|
||||
(define (binding:start b) (list-ref b 3))
|
||||
(define (binding:end b) (list-ref b 4))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile VM tracer
|
||||
|
||||
;; 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
|
||||
|
|
@ -54,8 +54,7 @@
|
|||
((null? opts) (newline))
|
||||
(case (car opts)
|
||||
((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
|
||||
((:l) (puts (vm-fetch-locals vm)))
|
||||
((:e) (puts (vm-fetch-externals vm))))))
|
||||
((:l) (puts (vm-fetch-locals vm))))))
|
||||
|
||||
(define (trace-apply vm)
|
||||
(if (vm-option vm 'trace-first)
|
||||
|
|
|
|||
|
|
@ -20,16 +20,28 @@
|
|||
#:use-module (system vm instruction)
|
||||
#:use-module (language assembly compile-bytecode))
|
||||
|
||||
(define (->u8-list sym val)
|
||||
(let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
|
||||
(uint32 4 ,bytevector-u32-native-set!))
|
||||
sym)))
|
||||
(or entry (error "unknown sym" sym))
|
||||
(let ((bv (make-bytevector (car entry))))
|
||||
((cadr entry) bv 0 val)
|
||||
(bytevector->u8-list bv))))
|
||||
|
||||
(define (munge-bytecode v)
|
||||
(let ((newv (make-u8vector (vector-length v))))
|
||||
(let lp ((i 0))
|
||||
(if (= i (vector-length v))
|
||||
newv
|
||||
(let ((x (vector-ref v i)))
|
||||
(u8vector-set! newv i (if (symbol? x)
|
||||
(instruction->opcode x)
|
||||
x))
|
||||
(lp (1+ i)))))))
|
||||
(let lp ((i 0) (out '()))
|
||||
(if (= i (vector-length v))
|
||||
(list->u8vector (reverse out))
|
||||
(let ((x (vector-ref v i)))
|
||||
(cond
|
||||
((symbol? x)
|
||||
(lp (1+ i) (cons (instruction->opcode x) out)))
|
||||
((integer? x)
|
||||
(lp (1+ i) (cons x out)))
|
||||
((pair? x)
|
||||
(lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
|
||||
(else (error "bad test bytecode" x)))))))
|
||||
|
||||
(define (comp-test x y)
|
||||
(let* ((y (munge-bytecode y))
|
||||
|
|
@ -46,13 +58,6 @@
|
|||
(lambda ()
|
||||
(equal? v y)))))
|
||||
|
||||
(define (u32->u8-list x)
|
||||
;; Return a 4 uint8 list corresponding to the host's native representation
|
||||
;; of X, a uint32.
|
||||
(let ((bv (make-bytevector 4)))
|
||||
(bytevector-u32-native-set! bv 0 x)
|
||||
(bytevector->u8-list bv)))
|
||||
|
||||
|
||||
(with-test-prefix "compiler"
|
||||
(with-test-prefix "asm-to-bytecode"
|
||||
|
|
@ -85,29 +90,34 @@
|
|||
(vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u)
|
||||
(char->integer #\x)))
|
||||
|
||||
(comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return))
|
||||
(list->vector
|
||||
`(load-program
|
||||
3 2 1 0 ;; nargs, nrest, nlocs, nexts
|
||||
,@(u32->u8-list 3) ;; len
|
||||
,@(u32->u8-list 0) ;; metalen
|
||||
make-int8 3
|
||||
return)))
|
||||
(comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
|
||||
#(load-program
|
||||
3 2 (uint16 1) ;; nargs, nrest, nlocs
|
||||
(uint32 3) ;; len
|
||||
(uint32 0) ;; metalen
|
||||
(uint32 0) ;; padding
|
||||
make-int8 3
|
||||
return))
|
||||
|
||||
(comp-test '(load-program 3 2 1 0 () 3
|
||||
(load-program 3 2 1 0 () 3
|
||||
;; the nops are to pad meta to an 8-byte alignment. not strictly
|
||||
;; necessary for this test, but representative of the common case.
|
||||
(comp-test '(load-program 3 2 1 () 8
|
||||
(load-program 3 2 1 () 3
|
||||
#f
|
||||
(make-int8 3) (return))
|
||||
(make-int8 3) (return))
|
||||
(list->vector
|
||||
`(load-program
|
||||
3 2 1 0 ;; nargs, nrest, nlocs, nexts
|
||||
,@(u32->u8-list 3) ;; len
|
||||
,@(u32->u8-list (+ 3 12)) ;; metalen
|
||||
make-int8 3
|
||||
return
|
||||
3 2 1 0 ;; nargs, nrest, nlocs, nexts
|
||||
,@(u32->u8-list 3) ;; len
|
||||
,@(u32->u8-list 0) ;; metalen
|
||||
make-int8 3
|
||||
return)))))
|
||||
(make-int8 3) (return)
|
||||
(nop) (nop) (nop) (nop) (nop))
|
||||
#(load-program
|
||||
3 2 (uint16 1) ;; nargs, nrest, nlocs
|
||||
(uint32 8) ;; len
|
||||
(uint32 19) ;; metalen
|
||||
(uint32 0) ;; padding
|
||||
make-int8 3
|
||||
return
|
||||
nop nop nop nop nop
|
||||
3 2 (uint16 1) ;; nargs, nrest, nlocs
|
||||
(uint32 3) ;; len
|
||||
(uint32 0) ;; metalen
|
||||
(uint32 0) ;; padding
|
||||
make-int8 3
|
||||
return))))
|
||||
|
|
|
|||
|
|
@ -21,8 +21,10 @@
|
|||
#:use-module (test-suite lib)
|
||||
#:use-module (system base compile)
|
||||
#:use-module (system base pmatch)
|
||||
#:use-module (system base message)
|
||||
#:use-module (language tree-il)
|
||||
#:use-module (language glil))
|
||||
#:use-module (language glil)
|
||||
#:use-module (srfi srfi-13))
|
||||
|
||||
;; Of course, the GLIL that is emitted depends on the source info of the
|
||||
;; input. Here we're not concerned about that, so we strip source
|
||||
|
|
@ -64,21 +66,21 @@
|
|||
(with-test-prefix "void"
|
||||
(assert-tree-il->glil
|
||||
(void)
|
||||
(program 0 0 0 0 () (void) (call return 1)))
|
||||
(program 0 0 0 () (void) (call return 1)))
|
||||
(assert-tree-il->glil
|
||||
(begin (void) (const 1))
|
||||
(program 0 0 0 0 () (const 1) (call return 1)))
|
||||
(program 0 0 0 () (const 1) (call return 1)))
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive +) (void) (const 1))
|
||||
(program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
|
||||
(program 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
|
||||
|
||||
(with-test-prefix "application"
|
||||
(assert-tree-il->glil
|
||||
(apply (toplevel foo) (const 1))
|
||||
(program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
|
||||
(program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
|
||||
(assert-tree-il->glil/pmatch
|
||||
(begin (apply (toplevel foo) (const 1)) (void))
|
||||
(program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
|
||||
(program 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
|
||||
(call drop 1) (branch br ,l2)
|
||||
(label ,l3) (mv-bind () #f) (unbind)
|
||||
(label ,l4)
|
||||
|
|
@ -86,26 +88,26 @@
|
|||
(and (eq? l1 l3) (eq? l2 l4)))
|
||||
(assert-tree-il->glil
|
||||
(apply (toplevel foo) (apply (toplevel bar)))
|
||||
(program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
|
||||
(program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
|
||||
(call goto/args 1))))
|
||||
|
||||
(with-test-prefix "conditional"
|
||||
(assert-tree-il->glil/pmatch
|
||||
(if (const #t) (const 1) (const 2))
|
||||
(program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
|
||||
(program 0 0 0 () (const #t) (branch br-if-not ,l1)
|
||||
(const 1) (call return 1)
|
||||
(label ,l2) (const 2) (call return 1))
|
||||
(eq? l1 l2))
|
||||
|
||||
(assert-tree-il->glil/pmatch
|
||||
(begin (if (const #t) (const 1) (const 2)) (const #f))
|
||||
(program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
|
||||
(program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
|
||||
(label ,l3) (label ,l4) (const #f) (call return 1))
|
||||
(eq? l1 l3) (eq? l2 l4))
|
||||
|
||||
(assert-tree-il->glil/pmatch
|
||||
(apply (primitive null?) (if (const #t) (const 1) (const 2)))
|
||||
(program 0 0 0 0 () (const #t) (branch br-if-not ,l1)
|
||||
(program 0 0 0 () (const #t) (branch br-if-not ,l1)
|
||||
(const 1) (branch br ,l2)
|
||||
(label ,l3) (const 2) (label ,l4)
|
||||
(call null? 1) (call return 1))
|
||||
|
|
@ -114,279 +116,281 @@
|
|||
(with-test-prefix "primitive-ref"
|
||||
(assert-tree-il->glil
|
||||
(primitive +)
|
||||
(program 0 0 0 0 () (toplevel ref +) (call return 1)))
|
||||
(program 0 0 0 () (toplevel ref +) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (primitive +) (const #f))
|
||||
(program 0 0 0 0 () (const #f) (call return 1)))
|
||||
(program 0 0 0 () (const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (primitive +))
|
||||
(program 0 0 0 0 () (toplevel ref +) (call null? 1)
|
||||
(program 0 0 0 () (toplevel ref +) (call null? 1)
|
||||
(call return 1))))
|
||||
|
||||
(with-test-prefix "lexical refs"
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1)) (lexical x y))
|
||||
(program 0 0 1 0 ()
|
||||
(const 1) (bind (x local 0)) (local set 0)
|
||||
(local ref 0) (call return 1)
|
||||
(program 0 0 1 ()
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
|
||||
(program 0 0 1 0 ()
|
||||
(const 1) (bind (x local 0)) (local set 0)
|
||||
(program 0 0 1 ()
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(const #f) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
|
||||
(program 0 0 1 0 ()
|
||||
(const 1) (bind (x local 0)) (local set 0)
|
||||
(local ref 0) (call null? 1) (call return 1)
|
||||
(program 0 0 1 ()
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(lexical #t #f ref 0) (call null? 1) (call return 1)
|
||||
(unbind))))
|
||||
|
||||
(with-test-prefix "lexical sets"
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
|
||||
(program 0 0 0 1 ()
|
||||
(const 1) (bind (x external 0)) (external set 0 0)
|
||||
(const 2) (external set 0 0) (void) (call return 1)
|
||||
(program 0 0 1 ()
|
||||
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
|
||||
(const 2) (lexical #t #t set 0) (void) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
|
||||
(program 0 0 0 1 ()
|
||||
(const 1) (bind (x external 0)) (external set 0 0)
|
||||
(const 2) (external set 0 0) (const #f) (call return 1)
|
||||
(program 0 0 1 ()
|
||||
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
|
||||
(const 2) (lexical #t #t set 0) (const #f) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1))
|
||||
(apply (primitive null?) (set! (lexical x y) (const 2))))
|
||||
(program 0 0 0 1 ()
|
||||
(const 1) (bind (x external 0)) (external set 0 0)
|
||||
(const 2) (external set 0 0) (void) (call null? 1) (call return 1)
|
||||
(program 0 0 1 ()
|
||||
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
|
||||
(const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
|
||||
(unbind))))
|
||||
|
||||
(with-test-prefix "module refs"
|
||||
(assert-tree-il->glil
|
||||
(@ (foo) bar)
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(module public ref (foo) bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (@ (foo) bar) (const #f))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(module public ref (foo) bar) (call drop 1)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (@ (foo) bar))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(module public ref (foo) bar)
|
||||
(call null? 1) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(@@ (foo) bar)
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(module private ref (foo) bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (@@ (foo) bar) (const #f))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(module private ref (foo) bar) (call drop 1)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (@@ (foo) bar))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(module private ref (foo) bar)
|
||||
(call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "module sets"
|
||||
(assert-tree-il->glil
|
||||
(set! (@ (foo) bar) (const 2))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (module public set (foo) bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (set! (@ (foo) bar) (const 2)) (const #f))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (module public set (foo) bar)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (set! (@ (foo) bar) (const 2)))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (module public set (foo) bar)
|
||||
(void) (call null? 1) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(set! (@@ (foo) bar) (const 2))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (module private set (foo) bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (set! (@@ (foo) bar) (const 2)) (const #f))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (module private set (foo) bar)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (module private set (foo) bar)
|
||||
(void) (call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "toplevel refs"
|
||||
(assert-tree-il->glil
|
||||
(toplevel bar)
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(toplevel ref bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (toplevel bar) (const #f))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(toplevel ref bar) (call drop 1)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (toplevel bar))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(toplevel ref bar)
|
||||
(call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "toplevel sets"
|
||||
(assert-tree-il->glil
|
||||
(set! (toplevel bar) (const 2))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (toplevel set bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (set! (toplevel bar) (const 2)) (const #f))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (toplevel set bar)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (set! (toplevel bar) (const 2)))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (toplevel set bar)
|
||||
(void) (call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "toplevel defines"
|
||||
(assert-tree-il->glil
|
||||
(define bar (const 2))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (toplevel define bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (define bar (const 2)) (const #f))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (toplevel define bar)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (define bar (const 2)))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (toplevel define bar)
|
||||
(void) (call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "constants"
|
||||
(assert-tree-il->glil
|
||||
(const 2)
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (const 2) (const #f))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (const 2))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "lambda"
|
||||
(assert-tree-il->glil
|
||||
(lambda (x) (y) () (const 2))
|
||||
(program 0 0 0 0 ()
|
||||
(program 1 0 0 0 ()
|
||||
(bind (x local 0))
|
||||
(program 0 0 0 ()
|
||||
(program 1 0 0 ()
|
||||
(bind (x #f 0))
|
||||
(const 2) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x x1) (y y1) () (const 2))
|
||||
(program 0 0 0 0 ()
|
||||
(program 2 0 0 0 ()
|
||||
(bind (x local 0) (x1 local 1))
|
||||
(program 0 0 0 ()
|
||||
(program 2 0 0 ()
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(const 2) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda x y () (const 2))
|
||||
(program 0 0 0 0 ()
|
||||
(program 1 1 0 0 ()
|
||||
(bind (x local 0))
|
||||
(program 0 0 0 ()
|
||||
(program 1 1 0 ()
|
||||
(bind (x #f 0))
|
||||
(const 2) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x . x1) (y . y1) () (const 2))
|
||||
(program 0 0 0 0 ()
|
||||
(program 2 1 0 0 ()
|
||||
(bind (x local 0) (x1 local 1))
|
||||
(program 0 0 0 ()
|
||||
(program 2 1 0 ()
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(const 2) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x . x1) (y . y1) () (lexical x y))
|
||||
(program 0 0 0 0 ()
|
||||
(program 2 1 0 0 ()
|
||||
(bind (x local 0) (x1 local 1))
|
||||
(local ref 0) (call return 1))
|
||||
(program 0 0 0 ()
|
||||
(program 2 1 0 ()
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(lexical #t #f ref 0) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x . x1) (y . y1) () (lexical x1 y1))
|
||||
(program 0 0 0 0 ()
|
||||
(program 2 1 0 0 ()
|
||||
(bind (x local 0) (x1 local 1))
|
||||
(local ref 1) (call return 1))
|
||||
(program 0 0 0 ()
|
||||
(program 2 1 0 ()
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(lexical #t #f ref 1) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
|
||||
(program 0 0 0 0 ()
|
||||
(program 1 0 0 1 ()
|
||||
(bind (x external 0))
|
||||
(local ref 0) (external set 0 0)
|
||||
(program 1 0 0 0 ()
|
||||
(bind (y local 0))
|
||||
(external ref 1 0) (call return 1))
|
||||
(program 0 0 0 ()
|
||||
(program 1 0 0 ()
|
||||
(bind (x #f 0))
|
||||
(program 1 0 0 ()
|
||||
(bind (y #f 0))
|
||||
(lexical #f #f ref 0) (call return 1))
|
||||
(lexical #t #f ref 0)
|
||||
(call vector 1)
|
||||
(call make-closure 2)
|
||||
(call return 1))
|
||||
(call return 1))))
|
||||
|
||||
(with-test-prefix "sequence"
|
||||
(assert-tree-il->glil
|
||||
(begin (begin (const 2) (const #f)) (const #t))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const #t) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (begin (const #f) (const 2)))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(const 2) (call null? 1) (call return 1))))
|
||||
|
||||
;; FIXME: binding info for or-hacked locals might bork the disassembler,
|
||||
|
|
@ -398,13 +402,13 @@
|
|||
(lexical x y)
|
||||
(let (a) (b) ((const 2))
|
||||
(lexical a b))))
|
||||
(program 0 0 1 0 ()
|
||||
(const 1) (bind (x local 0)) (local set 0)
|
||||
(local ref 0) (branch br-if-not ,l1)
|
||||
(local ref 0) (call return 1)
|
||||
(program 0 0 1 ()
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(lexical #t #f ref 0) (branch br-if-not ,l1)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(label ,l2)
|
||||
(const 2) (bind (a local 0)) (local set 0)
|
||||
(local ref 0) (call return 1)
|
||||
(const 2) (bind (a #f 0)) (lexical #t #f set 0)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(unbind)
|
||||
(unbind))
|
||||
(eq? l1 l2))
|
||||
|
|
@ -415,13 +419,13 @@
|
|||
(lexical x y)
|
||||
(let (a) (b) ((const 2))
|
||||
(lexical x y))))
|
||||
(program 0 0 2 0 ()
|
||||
(const 1) (bind (x local 0)) (local set 0)
|
||||
(local ref 0) (branch br-if-not ,l1)
|
||||
(local ref 0) (call return 1)
|
||||
(program 0 0 2 ()
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(lexical #t #f ref 0) (branch br-if-not ,l1)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(label ,l2)
|
||||
(const 2) (bind (a local 1)) (local set 1)
|
||||
(local ref 0) (call return 1)
|
||||
(const 2) (bind (a #f 1)) (lexical #t #f set 1)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(unbind)
|
||||
(unbind))
|
||||
(eq? l1 l2)))
|
||||
|
|
@ -429,10 +433,10 @@
|
|||
(with-test-prefix "apply"
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive @apply) (toplevel foo) (toplevel bar))
|
||||
(program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
|
||||
(program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
|
||||
(assert-tree-il->glil/pmatch
|
||||
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
|
||||
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
|
||||
(label ,l4)
|
||||
|
|
@ -440,7 +444,7 @@
|
|||
(and (eq? l1 l3) (eq? l2 l4)))
|
||||
(assert-tree-il->glil
|
||||
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(toplevel ref foo)
|
||||
(toplevel ref bar) (toplevel ref baz) (call apply 2)
|
||||
(call goto/args 1))))
|
||||
|
|
@ -448,10 +452,10 @@
|
|||
(with-test-prefix "call/cc"
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive @call-with-current-continuation) (toplevel foo))
|
||||
(program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
|
||||
(program 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
|
||||
(assert-tree-il->glil/pmatch
|
||||
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
|
||||
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
|
||||
(label ,l4)
|
||||
|
|
@ -460,8 +464,121 @@
|
|||
(assert-tree-il->glil
|
||||
(apply (toplevel foo)
|
||||
(apply (toplevel @call-with-current-continuation) (toplevel bar)))
|
||||
(program 0 0 0 0 ()
|
||||
(program 0 0 0 ()
|
||||
(toplevel ref foo)
|
||||
(toplevel ref bar) (call call/cc 1)
|
||||
(call goto/args 1))))
|
||||
|
||||
|
||||
(with-test-prefix "tree-il-fold"
|
||||
|
||||
(pass-if "empty tree"
|
||||
(let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
|
||||
(and (eq? mark
|
||||
(tree-il-fold (lambda (x y) (set! leaf? #t) y)
|
||||
(lambda (x y) (set! down? #t) y)
|
||||
(lambda (x y) (set! up? #t) y)
|
||||
mark
|
||||
'()))
|
||||
(not leaf?)
|
||||
(not up?)
|
||||
(not down?))))
|
||||
|
||||
(pass-if "lambda and application"
|
||||
(let* ((leaves '()) (ups '()) (downs '())
|
||||
(result (tree-il-fold (lambda (x y)
|
||||
(set! leaves (cons x leaves))
|
||||
(1+ y))
|
||||
(lambda (x y)
|
||||
(set! downs (cons x downs))
|
||||
(1+ y))
|
||||
(lambda (x y)
|
||||
(set! ups (cons x ups))
|
||||
(1+ y))
|
||||
0
|
||||
(parse-tree-il
|
||||
'(lambda (x y) (x1 y1)
|
||||
(apply (toplevel +)
|
||||
(lexical x x1)
|
||||
(lexical y y1)))))))
|
||||
(and (equal? (map strip-source leaves)
|
||||
(list (make-lexical-ref #f 'y 'y1)
|
||||
(make-lexical-ref #f 'x 'x1)
|
||||
(make-toplevel-ref #f '+)))
|
||||
(= (length downs) 2)
|
||||
(equal? (reverse (map strip-source ups))
|
||||
(map strip-source downs))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Warnings.
|
||||
;;;
|
||||
|
||||
;; Make sure we get English messages.
|
||||
(setlocale LC_ALL "C")
|
||||
|
||||
(define (call-with-warnings thunk)
|
||||
(let ((port (open-output-string)))
|
||||
(with-fluid* *current-warning-port* port
|
||||
thunk)
|
||||
(let ((warnings (get-output-string port)))
|
||||
(string-tokenize warnings
|
||||
(char-set-complement (char-set #\newline))))))
|
||||
|
||||
(define %opts-w-unused
|
||||
'(#:warnings (unused-variable)))
|
||||
|
||||
|
||||
(with-test-prefix "warnings"
|
||||
|
||||
(pass-if "unknown warning type"
|
||||
(let ((w (call-with-warnings
|
||||
(lambda ()
|
||||
(compile #t #:opts '(#:warnings (does-not-exist)))))))
|
||||
(and (= (length w) 1)
|
||||
(number? (string-contains (car w) "unknown warning")))))
|
||||
|
||||
(with-test-prefix "unused-variable"
|
||||
|
||||
(pass-if "quiet"
|
||||
(null? (call-with-warnings
|
||||
(lambda ()
|
||||
(compile '(lambda (x y) (+ x y))
|
||||
#:opts %opts-w-unused)))))
|
||||
|
||||
(pass-if "let/unused"
|
||||
(let ((w (call-with-warnings
|
||||
(lambda ()
|
||||
(compile '(lambda (x)
|
||||
(let ((y (+ x 2)))
|
||||
x))
|
||||
#:opts %opts-w-unused)))))
|
||||
(and (= (length w) 1)
|
||||
(number? (string-contains (car w) "unused variable `y'")))))
|
||||
|
||||
(pass-if "shadowed variable"
|
||||
(let ((w (call-with-warnings
|
||||
(lambda ()
|
||||
(compile '(lambda (x)
|
||||
(let ((y x))
|
||||
(let ((y (+ x 2)))
|
||||
(+ x y))))
|
||||
#:opts %opts-w-unused)))))
|
||||
(and (= (length w) 1)
|
||||
(number? (string-contains (car w) "unused variable `y'")))))
|
||||
|
||||
(pass-if "letrec"
|
||||
(null? (call-with-warnings
|
||||
(lambda ()
|
||||
(compile '(lambda ()
|
||||
(letrec ((x (lambda () (y)))
|
||||
(y (lambda () (x))))
|
||||
y))
|
||||
#:opts %opts-w-unused)))))
|
||||
|
||||
(pass-if "unused argument"
|
||||
;; Unused arguments should not be reported.
|
||||
(null? (call-with-warnings
|
||||
(lambda ()
|
||||
(compile '(lambda (x y z) #t)
|
||||
#:opts %opts-w-unused)))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue