mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 11:34:09 +02:00
Code Activity

Merge branch 'master' of git://git.savannah.gnu.org/guile into elisp

Browse source
This commit is contained in:
Daniel Kraft 2009-07-31 17:18:34 +02:00
commit a43df0ae47
42 changed files with 1767 additions and 1099 deletions
Download patch file Download diff file Expand all files Collapse all files

209
libguile/chars.c
View file

@ -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;
}

30
libguile/chars.h
View file

@ -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 */

12
libguile/frames.c
View file

@ -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),
"")

19
libguile/frames.h
View file

@ -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);

8
libguile/numbers.c
View file

@ -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

10
libguile/numbers.h
View file

@ -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);

2
libguile/objcodes.c
View file

@ -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);

5
libguile/objcodes.h
View file

@ -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)

41
libguile/print.c
View file

@ -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);

50
libguile/programs.c
View file

@ -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

9
libguile/programs.h
View file

@ -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);

9
libguile/read.c
View file

@ -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
libguile/vm-engine.c
View file

@ -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
/*

68
libguile/vm-engine.h
View file

@ -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"

24
libguile/vm-i-loader.c
View file

@ -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)))

136
libguile/vm-i-scheme.c
View file

@ -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)))

372
libguile/vm-i-system.c
View file

@ -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"

55
libguile/vm.c
View file

@ -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);
}