suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

v360.2, almost

Browse Source 
svn: r4922
This commit is contained in:
Matthew Flatt 2006-11-23 01:47:39 +00:00
parent ed651fd381
commit 08c1c5f608
29 changed files with 4180 additions and 3834 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/mzscheme/include/mzscheme.exp
View File

@ -387,6 +387,7 @@ scheme_path_to_directory_path
scheme_make_path
scheme_make_sized_path
scheme_make_sized_offset_path
scheme_make_sized_offset_kind_path
scheme_make_path_without_copying
scheme_alloc_fdset_array
scheme_init_fdset_array

1
src/mzscheme/include/mzscheme3m.exp
View File

@ -394,6 +394,7 @@ scheme_path_to_directory_path
scheme_make_path
scheme_make_sized_path
scheme_make_sized_offset_path
scheme_make_sized_offset_kind_path
scheme_make_path_without_copying
scheme_alloc_fdset_array
scheme_init_fdset_array

1
src/mzscheme/include/mzwin.def
View File

@ -379,6 +379,7 @@ EXPORTS
scheme_make_path
scheme_make_sized_path
scheme_make_sized_offset_path
scheme_make_sized_offset_kind_path
scheme_make_path_without_copying
scheme_alloc_fdset_array
scheme_init_fdset_array

17
src/mzscheme/include/scheme.h
View File

@ -395,12 +395,16 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
#define SCHEME_MUTABLE_BYTE_STRINGP(obj) (SCHEME_BYTE_STRINGP(obj) && SCHEME_MUTABLEP(obj))
#define SCHEME_IMMUTABLE_BYTE_STRINGP(obj) (SCHEME_BYTE_STRINGP(obj) && SCHEME_IMMUTABLEP(obj))
#define SCHEME_PATHP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_path_type)
#define SCHEME_PATHP(obj) SAME_TYPE(SCHEME_TYPE(obj), SCHEME_PLATFORM_PATH_KIND)
#define SCHEME_GENERAL_PATHP(obj) ((SCHEME_TYPE(obj) >= scheme_unix_path_type) && (SCHEME_TYPE(obj) <= scheme_windows_path_type))
/* A path is guranteed to have the same shape as a byte string */
#define SCHEME_PATH_STRINGP(x) (SCHEME_CHAR_STRINGP(x) || SCHEME_PATHP(x))
#define SCHEME_PATH_STRING_STR "path or string"
#define SCHEME_GENERAL_PATH_STRINGP(x) (SCHEME_CHAR_STRINGP(x) || SCHEME_GENERAL_PATHP(x))
#define SCHEME_GENERAL_PATH_STRING_STR "path (for any platform) or string"
#define SCHEME_SYMBOLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_symbol_type)
#define SCHEME_KEYWORDP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_keyword_type)
@ -471,6 +475,17 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
#define GUARANTEE_STRSYM(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_STRSYMP, "string or symbol")
#define GUARANTEE_SYMBOL(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_SYMBOLP, "symbol")
#define SCHEME_UNIX_PATH_KIND scheme_unix_path_type
#define SCHEME_WINDOWS_PATH_KIND scheme_windows_path_type
#ifdef DOS_FILE_SYSTEM
# define SCHEME_PLATFORM_PATH_KIND SCHEME_WINDOWS_PATH_KIND
#else
# define SCHEME_PLATFORM_PATH_KIND SCHEME_UNIX_PATH_KIND
#endif
#define SCHEME_PATH_KIND(p) SCHEME_TYPE(p)
/*========================================================================*/
/* basic Scheme accessors */
/*========================================================================*/

2
src/mzscheme/src/bool.c
View File

@ -266,7 +266,7 @@ int scheme_equal (Scheme_Object *obj1, Scheme_Object *obj2)
# include "mzeqchk.inc"
return vector_equal(obj1, obj2);
} else if (SCHEME_BYTE_STRINGP(obj1)
|| SCHEME_PATHP(obj1)) {
|| SCHEME_GENERAL_PATHP(obj1)) {
int l1, l2;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);

5176
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

2
src/mzscheme/src/dynext.c
View File

@ -198,7 +198,7 @@ static Scheme_Object *do_load_extension(const char *filename,
void *handle;
int comppath;
comppath = scheme_is_complete_path(filename, strlen(filename));
comppath = scheme_is_complete_path(filename, strlen(filename), SCHEME_PLATFORM_PATH_KIND);
reload_f = NULL;
modname_f = NULL;

2086
src/mzscheme/src/file.c
View File

File diff suppressed because it is too large Load Diff

6
src/mzscheme/src/hash.c
View File

@ -923,7 +923,8 @@ static long equal_hash_key(Scheme_Object *o, long k)
break;
}
case scheme_byte_string_type:
case scheme_path_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
int i = SCHEME_BYTE_STRLEN_VAL(o);
char *s = SCHEME_BYTE_STR_VAL(o);
@ -1146,7 +1147,8 @@ long scheme_equal_hash_key2(Scheme_Object *o)
return k;
}
case scheme_byte_string_type:
case scheme_path_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
int k = 0, i = SCHEME_BYTE_STRLEN_VAL(o);
char *s = SCHEME_BYTE_STR_VAL(o);

53
src/mzscheme/src/network.c
View File

@ -259,8 +259,8 @@ void scheme_init_network(Scheme_Env *env)
scheme_add_global_constant("tcp-addresses",
scheme_make_prim_w_arity2(tcp_addresses,
"tcp-addresses",
1, 1,
2, 2),
1, 2,
2, 4),
env);
scheme_add_global_constant("tcp-abandon-port",
scheme_make_prim_w_arity(tcp_abandon_port,
@ -2269,12 +2269,22 @@ void scheme_getnameinfo(void *sa, int salen,
#endif
}
static int extract_svc_value(char *svc_buf)
{
int id = 0, j;
for (j = 0; svc_buf[j]; j++) {
id = (id * 10) + (svc_buf[j] - '0');
}
return id;
}
static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
{
#ifdef USE_TCP
Scheme_Tcp *tcp = NULL;
int closed = 0;
Scheme_Object *result[2];
Scheme_Object *result[4];
int with_ports = 0;
if (SCHEME_OUTPORTP(argv[0])) {
Scheme_Output_Port *op;
@ -2290,6 +2300,9 @@ static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
closed = ip->closed;
}
if (argc > 1)
with_ports = SCHEME_TRUEP(argv[1]);
if (!tcp)
scheme_wrong_type("tcp-addresses", "tcp-port", 0, argc, argv);
@ -2302,6 +2315,7 @@ static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
unsigned int l;
char here[MZ_SOCK_NAME_MAX_LEN], there[MZ_SOCK_NAME_MAX_LEN];
char host_buf[MZ_SOCK_HOST_NAME_MAX_LEN];
char svc_buf[MZ_SOCK_SVC_NAME_MAX_LEN];
unsigned int here_len, there_len;
l = sizeof(here);
@ -2322,22 +2336,38 @@ static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
scheme_getnameinfo((struct sockaddr *)here, here_len,
host_buf, sizeof(host_buf),
NULL, 0);
(with_ports ? svc_buf : NULL),
(with_ports ? sizeof(svc_buf) : 0));
result[0] = scheme_make_utf8_string(host_buf);
if (with_ports) {
l = extract_svc_value(svc_buf);
result[1] = scheme_make_integer(l);
}
scheme_getnameinfo((struct sockaddr *)there, there_len,
host_buf, sizeof(host_buf),
NULL, 0);
result[1] = scheme_make_utf8_string(host_buf);
(with_ports ? svc_buf : NULL),
(with_ports ? sizeof(svc_buf) : 0));
result[with_ports ? 2 : 1] = scheme_make_utf8_string(host_buf);
if (with_ports) {
l = extract_svc_value(svc_buf);
result[3] = scheme_make_integer(l);
}
}
# else
result[0] = scheme_make_utf8_string("0.0.0.0");
result[1] = result[1];
if (with_ports) {
result[1] = scheme_make_integer(1);
result[2] = result[0];
result[3] = result[1];
} else {
result[1] = result[0];
}
# endif
return scheme_values(2, result);
return scheme_values(with_ports ? 4 : 2, result);
#else
/* First arg can't possible be right! */
/* First arg can't possibly be right! */
scheme_wrong_type("tcp-addresses", "tcp-port", 0, argc, argv);
#endif
}
@ -3156,10 +3186,7 @@ static int do_udp_recv(const char *name, Scheme_UDP *udp, char *bstr, long start
udp->previous_from_addr = v[1];
}
id = 0;
for (j = 0; svc_buf[j]; j++) {
id = (id * 10) + (svc_buf[j] - '0');
}
id = extract_svc_value(svc_buf);
v[2] = scheme_make_integer(id);

58
src/mzscheme/src/number.c
View File

@ -65,6 +65,7 @@ static Scheme_Object *even_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *bitwise_or (int argc, Scheme_Object *argv[]);
static Scheme_Object *bitwise_xor (int argc, Scheme_Object *argv[]);
static Scheme_Object *bitwise_not (int argc, Scheme_Object *argv[]);
static Scheme_Object *integer_length (int argc, Scheme_Object *argv[]);
static Scheme_Object *gcd (int argc, Scheme_Object *argv[]);
static Scheme_Object *lcm (int argc, Scheme_Object *argv[]);
static Scheme_Object *floor_prim (int argc, Scheme_Object *argv[]);
@ -284,6 +285,12 @@ scheme_init_number (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("arithmetic-shift", p, env);
scheme_add_global_constant("integer-length",
scheme_make_folding_prim(integer_length,
"integer-length",
1, 1, 1),
env);
scheme_add_global_constant("gcd",
scheme_make_folding_prim(gcd,
"gcd",
@ -2424,3 +2431,54 @@ scheme_bitwise_shift(int argc, Scheme_Object *argv[])
return scheme_bignum_shift(v, shift);
}
static Scheme_Object *
integer_length(int argc, Scheme_Object *argv[])
{
Scheme_Object *o = argv[0];
unsigned long n;
int base;
if (SCHEME_INTP(o)) {
long a = SCHEME_INT_VAL(o);
if (a < 0)
a = ~a;
n = a;
base = 0;
} else if (_SCHEME_TYPE(o) == scheme_bignum_type) {
bigdig d;
if (!SCHEME_BIGPOS(o)) {
/* Maybe we could do better... */
o = scheme_bignum_not(o);
}
base = ((Scheme_Bignum *)o)->len;
d = ((Scheme_Bignum *)o)->digits[base - 1];
base = (base - 1) * (sizeof(bigdig) * 8);
#ifdef USE_LONG_LONG_FOR_BIGDIG
n = (unsigned long)d;
if ((bigdig)n != d) {
/* Must have been overflow */
d >>= (sizeof(unsigned long) * 8);
base += (sizeof(unsigned long) * 8);
n = (unsigned long)d;
}
#else
n = d;
#endif
} else {
scheme_wrong_type("integer-length", "exact integer", 0, argc, argv);
ESCAPED_BEFORE_HERE;
}
while (n) {
n >>= 1;
base++;
}
return scheme_make_integer(base);
}

4
src/mzscheme/src/port.c
View File

@ -3422,10 +3422,10 @@ static void filename_exn(char *name, char *msg, char *filename, int err)
len = strlen(filename);
if (scheme_is_relative_path(filename, len)) {
if (scheme_is_relative_path(filename, len, SCHEME_PLATFORM_PATH_KIND)) {
dir = scheme_os_getcwd(NULL, 0, NULL, 1);
drive = NULL;
} else if (scheme_is_complete_path(filename, len)) {
} else if (scheme_is_complete_path(filename, len, SCHEME_PLATFORM_PATH_KIND)) {
dir = NULL;
drive = NULL;
} else {

2
src/mzscheme/src/portfun.c
View File

@ -4400,7 +4400,7 @@ static Scheme_Object *abs_directory_p(const char *name, int argc, Scheme_Object
s = SCHEME_BYTE_STR_VAL(ed);
len = SCHEME_BYTE_STRTAG_VAL(ed);
if (!scheme_is_complete_path(s, len))
if (!scheme_is_complete_path(s, len, SCHEME_PLATFORM_PATH_KIND))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: not a complete path: \"%q\"",
name,

21
src/mzscheme/src/print.c
View File

@ -1624,9 +1624,9 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
closed = 1;
}
else if (SCHEME_PATHP(obj))
else if (SCHEME_GENERAL_PATHP(obj))
{
if (compact) {
if (compact && SCHEME_PATHP(obj)) {
/* Needed for srclocs in procedure names */
Scheme_Object *idx;
int l;
@ -1661,8 +1661,21 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
} else if (!pp->print_unreadable) {
cannot_print(pp, notdisplay, obj, ht, compact);
} else {
if (notdisplay)
print_utf8_string(pp, "#<path:", 0, 7);
if (notdisplay) {
if (SCHEME_PATHP(obj)) {
print_utf8_string(pp, "#<path:", 0, 7);
} else {
switch (SCHEME_TYPE(obj)) {
case scheme_windows_path_type:
print_utf8_string(pp, "#<windows-path:", 0, 15);
break;
default:
case scheme_unix_path_type:
print_utf8_string(pp, "#<unix-path:", 0, 12);
break;
}
}
}
{
Scheme_Object *str;
str = scheme_path_to_char_string(obj);

5
src/mzscheme/src/read.c
View File

@ -2504,7 +2504,8 @@ honu_add_module_wrapper(Scheme_Object *list, Scheme_Object *stxsrc, Scheme_Objec
if (SCHEME_PATHP(name)) {
Scheme_Object *base;
int isdir, i;
name = scheme_split_path(SCHEME_BYTE_STR_VAL(name), SCHEME_BYTE_STRLEN_VAL(name), &base, &isdir);
name = scheme_split_path(SCHEME_BYTE_STR_VAL(name), SCHEME_BYTE_STRLEN_VAL(name), &base, &isdir,
SCHEME_PLATFORM_PATH_KIND);
for (i = SCHEME_BYTE_STRLEN_VAL(name); i--; ) {
if (SCHEME_BYTE_STR_VAL(name)[i] == '.')
break;
@ -4373,7 +4374,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
v = scheme_make_sized_path(s, l, l < BLK_BUF_SIZE);
l = read_compact_number(port); /* symtab index */
if (scheme_is_relative_path(SCHEME_PATH_VAL(v), SCHEME_PATH_LEN(v))) {
if (scheme_is_relative_path(SCHEME_PATH_VAL(v), SCHEME_PATH_LEN(v), SCHEME_PLATFORM_PATH_KIND)) {
/* Resolve relative path using the current load-relative directory: */
Scheme_Object *dir;
dir = scheme_get_param(scheme_current_config(), MZCONFIG_LOAD_DIRECTORY);

3
src/mzscheme/src/schemef.h
View File

@ -774,13 +774,14 @@ MZ_EXTERN char *scheme_os_getcwd(char *buf, int buflen, int *actlen, int noexn);
MZ_EXTERN int scheme_os_setcwd(char *buf, int noexn);
MZ_EXTERN char *scheme_getdrive(void);
MZ_EXTERN Scheme_Object *scheme_split_path(const char *path, int len, Scheme_Object **base, int *isdir);
MZ_EXTERN Scheme_Object *scheme_split_path(const char *path, int len, Scheme_Object **base, int *isdir, int kind);
MZ_EXTERN Scheme_Object *scheme_build_path(int argc, Scheme_Object **argv);
MZ_EXTERN Scheme_Object *scheme_path_to_directory_path(Scheme_Object *p);
MZ_EXTERN Scheme_Object *scheme_make_path(const char *chars);
MZ_EXTERN Scheme_Object *scheme_make_sized_path(char *chars, long len, int copy);
MZ_EXTERN Scheme_Object *scheme_make_sized_offset_path(char *chars, long d, long len, int copy);
MZ_EXTERN Scheme_Object *scheme_make_sized_offset_kind_path(char *chars, long d, long len, int copy, int kind);
MZ_EXTERN Scheme_Object *scheme_make_path_without_copying(char *chars);
#ifdef MACINTOSH_EVENTS

3
src/mzscheme/src/schemex.h
View File

@ -646,12 +646,13 @@ char *(*scheme_expand_string_filename)(Scheme_Object *f, const char *errorin, in
char *(*scheme_os_getcwd)(char *buf, int buflen, int *actlen, int noexn);
int (*scheme_os_setcwd)(char *buf, int noexn);
char *(*scheme_getdrive)(void);
Scheme_Object *(*scheme_split_path)(const char *path, int len, Scheme_Object **base, int *isdir);
Scheme_Object *(*scheme_split_path)(const char *path, int len, Scheme_Object **base, int *isdir, int kind);
Scheme_Object *(*scheme_build_path)(int argc, Scheme_Object **argv);
Scheme_Object *(*scheme_path_to_directory_path)(Scheme_Object *p);
Scheme_Object *(*scheme_make_path)(const char *chars);
Scheme_Object *(*scheme_make_sized_path)(char *chars, long len, int copy);
Scheme_Object *(*scheme_make_sized_offset_path)(char *chars, long d, long len, int copy);
Scheme_Object *(*scheme_make_sized_offset_kind_path)(char *chars, long d, long len, int copy, int kind);
Scheme_Object *(*scheme_make_path_without_copying)(char *chars);
#ifdef MACINTOSH_EVENTS
char *(*scheme_mac_spec_to_path)(mzFSSpec *spec);

1
src/mzscheme/src/schemex.inc
View File

@ -432,6 +432,7 @@
scheme_extension_table->scheme_make_path = scheme_make_path;
scheme_extension_table->scheme_make_sized_path = scheme_make_sized_path;
scheme_extension_table->scheme_make_sized_offset_path = scheme_make_sized_offset_path;
scheme_extension_table->scheme_make_sized_offset_kind_path = scheme_make_sized_offset_kind_path;
scheme_extension_table->scheme_make_path_without_copying = scheme_make_path_without_copying;
#ifdef MACINTOSH_EVENTS
scheme_extension_table->scheme_mac_spec_to_path = scheme_mac_spec_to_path;

1
src/mzscheme/src/schemexm.h
View File

@ -432,6 +432,7 @@
#define scheme_make_path (scheme_extension_table->scheme_make_path)
#define scheme_make_sized_path (scheme_extension_table->scheme_make_sized_path)
#define scheme_make_sized_offset_path (scheme_extension_table->scheme_make_sized_offset_path)
#define scheme_make_sized_offset_kind_path (scheme_extension_table->scheme_make_sized_offset_kind_path)
#define scheme_make_path_without_copying (scheme_extension_table->scheme_make_path_without_copying)
#ifdef MACINTOSH_EVENTS
#define scheme_mac_spec_to_path (scheme_extension_table->scheme_mac_spec_to_path)

2
src/mzscheme/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 878
#define EXPECTED_PRIM_COUNT 884
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

9
src/mzscheme/src/schpriv.h
View File

@ -264,6 +264,8 @@ extern Scheme_Object *scheme_stack_dump_key;
extern Scheme_Object *scheme_default_prompt_tag;
extern Scheme_Object *scheme_system_idle_channel;
/*========================================================================*/
/* thread state and maintenance */
/*========================================================================*/
@ -593,7 +595,6 @@ void scheme_drop_first_rib_rename(Scheme_Object *ro);
Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename);
Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib);
Scheme_Object *scheme_add_mark_barrier(Scheme_Object *o);
Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to);
@ -1163,6 +1164,8 @@ extern Scheme_Object *scheme_always_ready_evt;
void scheme_get_outof_line(Scheme_Channel_Syncer *ch_w);
void scheme_post_syncing_nacks(Syncing *syncing);
int scheme_try_channel_get(Scheme_Object *ch);
/*========================================================================*/
/* numbers */
/*========================================================================*/
@ -2409,8 +2412,8 @@ Scheme_Object *scheme_get_native_arity(Scheme_Object *closure);
/* filesystem utilities */
/*========================================================================*/
int scheme_is_relative_path(const char *s, long len);
int scheme_is_complete_path(const char *s, long len);
int scheme_is_relative_path(const char *s, long len, int kind);
int scheme_is_complete_path(const char *s, long len, int kind);
Scheme_Object *scheme_get_file_directory(const char *filename);

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 360
#define MZSCHEME_VERSION_MINOR 1
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION "360.1" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "360.2" _MZ_SPECIAL_TAG

35
src/mzscheme/src/sema.c
View File

@ -23,6 +23,7 @@
#ifndef NO_SCHEME_THREADS
Scheme_Object *scheme_always_ready_evt;
Scheme_Object *scheme_system_idle_channel;
static Scheme_Object *make_sema(int n, Scheme_Object **p);
static Scheme_Object *semap(int n, Scheme_Object **p);
@ -37,6 +38,7 @@ static Scheme_Object *make_channel_put(int n, Scheme_Object **p);
static Scheme_Object *channel_p(int n, Scheme_Object **p);
static Scheme_Object *make_alarm(int n, Scheme_Object **p);
static Scheme_Object *make_sys_idle(int n, Scheme_Object **p);
static int channel_get_ready(Scheme_Object *ch, Scheme_Schedule_Info *sinfo);
static int channel_put_ready(Scheme_Object *ch, Scheme_Schedule_Info *sinfo);
@ -49,6 +51,8 @@ static int pending_break(Scheme_Thread *p);
int scheme_main_was_once_suspended;
static Scheme_Object *system_idle_put_evt;
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
@ -137,6 +141,12 @@ void scheme_init_sema(Scheme_Env *env)
1, 1),
env);
scheme_add_global_constant("system-idle-evt",
scheme_make_prim_w_arity(make_sys_idle,
"system-idle-evt",
0, 0),
env);
REGISTER_SO(scheme_always_ready_evt);
scheme_always_ready_evt = scheme_alloc_small_object();
scheme_always_ready_evt->type = scheme_always_evt_type;
@ -146,6 +156,9 @@ void scheme_init_sema(Scheme_Env *env)
o->type = scheme_never_evt_type;
scheme_add_global_constant("never-evt", o, env);
REGISTER_SO(scheme_system_idle_channel);
scheme_system_idle_channel = scheme_make_channel();
scheme_add_evt(scheme_sema_type, sema_ready, NULL, NULL, 0);
scheme_add_evt_through_sema(scheme_semaphore_repost_type, sema_for_repost, NULL);
scheme_add_evt(scheme_channel_type, (Scheme_Ready_Fun)channel_get_ready, NULL, NULL, 1);
@ -943,6 +956,14 @@ static int channel_syncer_ready(Scheme_Object *ch_w, Scheme_Schedule_Info *sinfo
return 0;
}
int scheme_try_channel_get(Scheme_Object *ch)
{
if (try_channel((Scheme_Sema *)ch, NULL, -1, NULL)) {
return 1;
}
return 0;
}
/**********************************************************************/
/* alarms */
/**********************************************************************/
@ -989,6 +1010,20 @@ static int never_ready(Scheme_Object *w)
return 0;
}
static Scheme_Object *make_sys_idle(int n, Scheme_Object **p)
{
if (!system_idle_put_evt) {
Scheme_Object *a[2];
REGISTER_SO(system_idle_put_evt);
system_idle_put_evt = scheme_make_channel_put_evt(scheme_system_idle_channel,
scheme_void);
a[0] = system_idle_put_evt;
a[1] = scheme_void_proc;
system_idle_put_evt = scheme_wrap_evt(2, a);
}
return system_idle_put_evt;
}
/**********************************************************************/
/* Precise GC */

54
src/mzscheme/src/startup.inc
View File

@ -1383,6 +1383,7 @@
"(datum->syntax-object stx"
" v"
" stx"
" stx"
" stx)"
" v)))"
" . ,(cddr t)))"
@ -1393,6 +1394,7 @@
"(datum->syntax-object stx"
" v"
" stx"
" stx"
" stx)"
" v)))"
" ,@(cddr h) "
@ -1404,6 +1406,7 @@
"(datum->syntax-object stx"
" expr"
" stx"
" stx"
" stx)"
" expr)))"
" `(pattern-substitute"
@ -1608,7 +1611,7 @@
"(-define(datum->syntax-object/shape orig datum)"
"(if(syntax? datum)"
" datum"
"(let((stx(datum->syntax-object orig datum orig)))"
"(let((stx(datum->syntax-object orig datum orig #f orig)))"
"(let((shape(syntax-property orig 'paren-shape)))"
"(if shape"
"(syntax-property stx 'paren-shape shape)"
@ -1718,9 +1721,7 @@
"(let((new-e(loop(syntax-e stx))))"
"(if(eq?(syntax-e stx) new-e)"
" stx"
"(syntax-recertify"
"(datum->syntax-object/shape stx new-e)"
" stx sub-insp #f))))"
"(datum->syntax-object/shape stx new-e))))"
"((vector? stx)"
"(list->vector(map loop(vector->list stx))))"
"((box? stx)(box(loop(unbox stx))))"
@ -1996,7 +1997,6 @@
"(else"
"(cons(quote-syntax list*) r))))))))))))"
" x)))"
"(-define sub-insp(current-code-inspector))"
"(provide syntax-case** syntax))"
);
EVAL_ONE_STR(
@ -2013,14 +2013,13 @@
"(syntax-case** #f #t stx() module-identifier=?"
"((_ stxe kl clause ...)"
"(syntax(syntax-case** _ #f stxe kl module-identifier=? clause ...))))))"
"(-define loc-insp(current-code-inspector))"
"(-define(relocate loc stx)"
"(if(syntax-source loc)"
"(let-values(((new-stx)(datum->syntax-object"
" stx"
"(datum->syntax-object stx"
"(syntax-e stx)"
" loc)))"
"(syntax-recertify new-stx stx loc-insp #f))"
" loc"
" #f"
" stx)"
" stx))"
"(-define-syntax syntax/loc"
"(lambda(stx)"
@ -2853,44 +2852,49 @@
"(absolute-path? s)))))"
" (define -re:suffix #rx#\"([.][^.]*|)$\")"
"(define(path-replace-suffix s sfx)"
"(unless(path-string? s)"
" (raise-type-error 'path-replace-suffix \"path or valid-path string\" 0 s sfx))"
"(unless(or(path-for-some-system? s)"
"(path-string? s))"
" (raise-type-error 'path-replace-suffix \"path (for any system) or valid-path string\" 0 s sfx))"
"(unless(or(string? sfx)(bytes? sfx))"
" (raise-type-error 'path-replace-suffix \"string or byte string\" 1 s sfx))"
"(let-values(((base name dir?)(split-path s)))"
"(when(not base)"
" (raise-mismatch-error 'path-replace-suffix \"cannot add a suffix to a root path: \" s))"
"(let((new-name(bytes->path"
"(let((new-name(bytes->path-element"
"(regexp-replace -re:suffix "
"(path->bytes name)"
"(path-element->bytes name)"
"(if(string? sfx)"
"(string->bytes/locale sfx(char->integer #\\?))"
" sfx)))))"
" sfx))"
"(if(path-for-some-system? s)"
"(path-convention-type s)"
"(system-path-convention-type)))))"
"(if(path? base)"
"(build-path base new-name)"
" new-name))))"
"(define bsbs(string #\\u5C #\\u5C))"
"(define(normal-case-path s)"
"(unless(path-string? s)"
" (raise-type-error 'normal-path-case \"path or valid-path string\" s))"
"(unless(or(path-for-some-system? s)"
"(path-string? s))"
" (raise-type-error 'normal-path-case \"path (for any system) or valid-path string\" s))"
"(cond"
"((eq?(system-type) 'windows)"
"(let((str(if(string? s) s(path->string s))))"
"((if(path-for-some-system? s)"
"(eq?(path-convention-type s) 'windows)"
"(eq?(system-type) 'windows))"
"(let((str(if(string? s) s(bytes->string/locale(path->bytes s)))))"
" (if (regexp-match-positions #rx\"^[\\u5C][\\u5C][?][\\u5C]\" str)"
"(if(string? s)"
"(string->path s)"
" s)"
"(let((s(string-locale-downcase str)))"
"(string->path "
"(bytes->path "
"(string->bytes/locale"
" (regexp-replace* #rx\"/\" "
" (if (regexp-match-positions #rx\"[/\\u5C][. ]+[/\\u5C]*$\" s)"
" s"
" (regexp-replace* #rx\"\\u5B .\\u5D+([/\\u5C]*)$\" s \"\\u005C1\"))"
" bsbs))))))"
"((eq?(system-type) 'macos)"
"(string->path(string-locale-downcase(if(string? s)"
" s"
"(path->string s)))))"
" bsbs))"
" 'windows)))))"
"((string? s)(string->path s))"
"(else s)))"
"(define rationalize"

73
src/mzscheme/src/startup.ss
View File

@ -1626,7 +1626,8 @@
(datum->syntax-object stx
v
stx
stx)
stx
stx)
v)))
. ,(cddr t))]
[(and (pair? h)
@ -1637,7 +1638,8 @@
(datum->syntax-object stx
v
stx
stx)
stx
stx)
v)))
,@(cddr h) ;; <-- WARNING: potential quadratic expansion
. ,(cddr t))]
@ -1649,7 +1651,8 @@
(datum->syntax-object stx
expr
stx
stx)
stx
stx)
expr)])
`(pattern-substitute
(quote-syntax ,expr)
@ -1894,7 +1897,7 @@
(-define (datum->syntax-object/shape orig datum)
(if (syntax? datum)
datum
(let ([stx (datum->syntax-object orig datum orig)])
(let ([stx (datum->syntax-object orig datum orig #f orig)])
(let ([shape (syntax-property orig 'paren-shape)])
(if shape
(syntax-property stx 'paren-shape shape)
@ -2014,9 +2017,7 @@
(let ([new-e (loop (syntax-e stx))])
(if (eq? (syntax-e stx) new-e)
stx
(syntax-recertify
(datum->syntax-object/shape stx new-e)
stx sub-insp #f)))]
(datum->syntax-object/shape stx new-e)))]
[(vector? stx)
(list->vector (map loop (vector->list stx)))]
[(box? stx) (box (loop (unbox stx)))]
@ -2312,8 +2313,6 @@
(cons (quote-syntax list*) r)]))))))))))
x)))
(-define sub-insp (current-code-inspector))
(provide syntax-case** syntax))
;;----------------------------------------------------------------------
@ -2337,14 +2336,13 @@
[(_ stxe kl clause ...)
(syntax (syntax-case** _ #f stxe kl module-identifier=? clause ...))])))
(-define loc-insp (current-code-inspector))
(-define (relocate loc stx)
(if (syntax-source loc)
(let-values ([(new-stx) (datum->syntax-object
stx
(syntax-e stx)
loc)])
(syntax-recertify new-stx stx loc-insp #f))
(datum->syntax-object stx
(syntax-e stx)
loc
#f
stx)
stx))
;; Like syntax, but also takes a syntax object
@ -3288,19 +3286,23 @@
(define -re:suffix #rx#"([.][^.]*|)$")
(define (path-replace-suffix s sfx)
(unless (path-string? s)
(raise-type-error 'path-replace-suffix "path or valid-path string" 0 s sfx))
(unless (or (path-for-some-system? s)
(path-string? s))
(raise-type-error 'path-replace-suffix "path (for any system) or valid-path string" 0 s sfx))
(unless (or (string? sfx) (bytes? sfx))
(raise-type-error 'path-replace-suffix "string or byte string" 1 s sfx))
(let-values ([(base name dir?) (split-path s)])
(when (not base)
(raise-mismatch-error 'path-replace-suffix "cannot add a suffix to a root path: " s))
(let ([new-name (bytes->path
(let ([new-name (bytes->path-element
(regexp-replace -re:suffix
(path->bytes name)
(path-element->bytes name)
(if (string? sfx)
(string->bytes/locale sfx (char->integer #\?))
sfx)))])
sfx))
(if (path-for-some-system? s)
(path-convention-type s)
(system-path-convention-type)))])
(if (path? base)
(build-path base new-name)
new-name))))
@ -3308,27 +3310,28 @@
(define bsbs (string #\u5C #\u5C))
(define (normal-case-path s)
(unless (path-string? s)
(raise-type-error 'normal-path-case "path or valid-path string" s))
(unless (or (path-for-some-system? s)
(path-string? s))
(raise-type-error 'normal-path-case "path (for any system) or valid-path string" s))
(cond
[(eq? (system-type) 'windows)
(let ([str (if (string? s) s (path->string s))])
[(if (path-for-some-system? s)
(eq? (path-convention-type s) 'windows)
(eq? (system-type) 'windows))
(let ([str (if (string? s) s (bytes->string/locale (path->bytes s)))])
(if (regexp-match-positions #rx"^[\u5C][\u5C][?][\u5C]" str)
(if (string? s)
(string->path s)
s)
(let ([s (string-locale-downcase str)])
(string->path
(regexp-replace* #rx"/"
(if (regexp-match-positions #rx"[/\u5C][. ]+[/\u5C]*$" s)
;; Just "." or ".." in last path element - don't remove
s
(regexp-replace* #rx"\u5B .\u5D+([/\u5C]*)$" s "\u005C1"))
bsbs)))))]
[(eq? (system-type) 'macos)
(string->path (string-locale-downcase (if (string? s)
s
(path->string s))))]
(bytes->path
(string->bytes/locale
(regexp-replace* #rx"/"
(if (regexp-match-positions #rx"[/\u5C][. ]+[/\u5C]*$" s)
;; Just "." or ".." in last path element - don't remove
s
(regexp-replace* #rx"\u5B .\u5D+([/\u5C]*)$" s "\u005C1"))
bsbs))
'windows))))]
[(string? s) (string->path s)]
[else s]))

62
src/mzscheme/src/stxobj.c
View File

@ -72,8 +72,6 @@ static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv);
static Scheme_Object *barrier_symbol;
static Scheme_Object *source_symbol; /* uninterned! */
static Scheme_Object *share_symbol; /* uninterned! */
static Scheme_Object *origin_symbol;
@ -218,10 +216,6 @@ static Module_Renames *krn;
second <midx>; the <export-registry> part is for finding
modules to unmarshal import renamings
- A wrap-elem '* is a mark barrier, which is applied to the
result of an expansion so that top-level marks do not
break re-expansions
[Don't add a pair case, because sometimes we test for element
versus list-of-element.]
@ -360,7 +354,7 @@ void scheme_init_stx(Scheme_Env *env)
REGISTER_SO(scheme_datum_to_syntax_proc);
scheme_datum_to_syntax_proc = scheme_make_folding_prim(datum_to_syntax,
"datum->syntax-object",
2, 4, 1);
2, 5, 1);
scheme_add_global_constant("datum->syntax-object",
scheme_datum_to_syntax_proc,
env);
@ -488,9 +482,6 @@ void scheme_init_stx(Scheme_Env *env)
4, 4),
env);
REGISTER_SO(barrier_symbol);
barrier_symbol = scheme_intern_symbol("*");
REGISTER_SO(source_symbol);
REGISTER_SO(share_symbol);
REGISTER_SO(origin_symbol);
@ -1399,11 +1390,6 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib)
return scheme_add_rename(o, rib);
}
Scheme_Object *scheme_add_mark_barrier(Scheme_Object *o)
{
return scheme_add_rename(o, barrier_symbol);
}
Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_midx, Scheme_Object *new_midx,
Scheme_Hash_Table *export_registry)
{
@ -2455,10 +2441,10 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
/* stx comparison */
/*========================================================================*/
XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, int ignore_barrier,
XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl,
Scheme_Object *barrier_env, Scheme_Object *ignore_rib)
/* Compares the marks in two wraps lists. A result of 2 means that the
result depended on a mark barrier or barrier env. Use #f for barrier_env
result depended on a barrier env. Use #f for barrier_env
to treat no rib envs as barriers; we check for barrier_env only in ribs
because simpliciation eliminates the need for these checks(?). */
{
@ -2487,9 +2473,6 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, int ignore_
acur_mark = WRAP_POS_FIRST(awl);
WRAP_POS_INC(awl);
}
} else if (!ignore_barrier && SAME_OBJ(WRAP_POS_FIRST(awl), barrier_symbol)) {
WRAP_POS_INIT_END(awl);
used_barrier = 1;
} else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) {
if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(awl))) {
WRAP_POS_INC(awl);
@ -2529,9 +2512,6 @@ XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, int ignore_
bcur_mark = WRAP_POS_FIRST(bwl);
WRAP_POS_INC(bwl);
}
} else if (!ignore_barrier && SAME_OBJ(WRAP_POS_FIRST(bwl), barrier_symbol)) {
WRAP_POS_INIT_END(bwl);
used_barrier = 1;
} else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) {
if (SAME_OBJ(ignore_rib, WRAP_POS_FIRST(bwl))) {
WRAP_POS_INC(bwl);
@ -3017,7 +2997,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
{
WRAP_POS w2;
WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps);
same = same_marks(&w2, &wraps, SCHEME_FALSEP(other_env), other_env, WRAP_POS_FIRST(wraps));
same = same_marks(&w2, &wraps, other_env, WRAP_POS_FIRST(wraps));
}
}
@ -3057,8 +3037,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
rib = rib->next; /* First rib record has no rename */
}
}
} else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))
|| SAME_OBJ(WRAP_POS_FIRST(wraps), barrier_symbol)) {
} else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) {
did_rib = NULL;
} else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) {
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps);
@ -3328,7 +3307,7 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u
WRAP_POS bw;
WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps);
if (!same_marks(&aw, &bw, SCHEME_FALSEP(ae), ae, NULL))
if (!same_marks(&aw, &bw, ae, NULL))
return 0;
}
@ -3482,7 +3461,7 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *re
WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps);
if (!same_marks(&aw, &bw, 0, NULL, NULL)) {
if (!same_marks(&aw, &bw, NULL, NULL)) {
return prune_marks((Scheme_Stx *)a,
scheme_stx_extract_marks(relative_to));
}
@ -3818,7 +3797,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
/* Check marks (now that we have the correct barriers). */
WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
if (!same_marks(&w2, &w, SCHEME_FALSEP(other_env), other_env, (Scheme_Object *)init_rib)) {
if (!same_marks(&w2, &w, other_env, (Scheme_Object *)init_rib)) {
other_env = NULL;
}
@ -3851,7 +3830,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
ok = NULL;
} else {
WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
if (same_marks(&w2, &w, 1, scheme_false, (Scheme_Object *)init_rib))
if (same_marks(&w2, &w, scheme_false, (Scheme_Object *)init_rib))
ok = SCHEME_VEC_ELS(v)[0];
else
ok = NULL;
@ -5487,7 +5466,7 @@ static int pos_exact_or_false_p(Scheme_Object *o)
static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
{
Scheme_Object *src = scheme_false, *properties = NULL;
Scheme_Object *src = scheme_false, *properties = NULL, *certs = NULL;
if (!SCHEME_FALSEP(argv[0]) && !SCHEME_STXP(argv[0]))
scheme_wrong_type("datum->syntax-object", "syntax or #f", 0, argc, argv);
@ -5513,6 +5492,14 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
scheme_wrong_type("datum->syntax-object", "syntax or #f", 3, argc, argv);
properties = ((Scheme_Stx *)argv[3])->props;
}
if (argc > 4) {
if (!SCHEME_FALSEP(argv[4])) {
if (!SCHEME_STXP(argv[4]))
scheme_wrong_type("datum->syntax-object", "syntax or #f", 4, argc, argv);
certs = (Scheme_Object *)INACTIVE_CERTS((Scheme_Stx *)argv[4]);
}
}
}
if (ll == 5) {
@ -5549,11 +5536,18 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
}
}
if (SCHEME_STXP(argv[1]))
return argv[1];
src = scheme_datum_to_syntax(argv[1], src, argv[0], 1, 0);
if (properties) {
if (!((Scheme_Stx *)src)->props)
((Scheme_Stx *)src)->props = properties;
((Scheme_Stx *)src)->props = properties;
}
if (certs) {
certs = scheme_make_raw_pair(NULL, certs);
((Scheme_Stx *)src)->certs = certs;
}
return src;
@ -5683,7 +5677,7 @@ static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv)
WRAP_POS_INIT(awl, stx->wraps);
WRAP_POS_INIT_END(ewl);
if (same_marks(&awl, &ewl, 1, scheme_false, NULL))
if (same_marks(&awl, &ewl, scheme_false, NULL))
return scheme_true;
else
return scheme_false;

315
src/mzscheme/src/stypes.h
View File

@ -61,167 +61,168 @@ enum {
scheme_complex_type, /* 43 */
scheme_char_string_type, /* 44 */
scheme_byte_string_type, /* 45 */
scheme_path_type, /* 46 */
scheme_symbol_type, /* 47 */
scheme_keyword_type, /* 48 */
scheme_null_type, /* 49 */
scheme_pair_type, /* 50 */
scheme_vector_type, /* 51 */
scheme_inspector_type, /* 52 */
scheme_input_port_type, /* 53 */
scheme_output_port_type, /* 54 */
scheme_eof_type, /* 55 */
scheme_true_type, /* 56 */
scheme_false_type, /* 57 */
scheme_void_type, /* 58 */
scheme_syntax_compiler_type, /* 59 */
scheme_macro_type, /* 60 */
scheme_box_type, /* 61 */
scheme_thread_type, /* 62 */
scheme_stx_offset_type, /* 63 */
scheme_cont_mark_set_type, /* 64 */
scheme_sema_type, /* 65 */
scheme_hash_table_type, /* 66 */
scheme_cpointer_type, /* 67 */
scheme_weak_box_type, /* 68 */
scheme_ephemeron_type, /* 69 */
scheme_struct_type_type, /* 70 */
scheme_module_index_type, /* 71 */
scheme_set_macro_type, /* 72 */
scheme_listener_type, /* 73 */
scheme_namespace_type, /* 74 */
scheme_config_type, /* 75 */
scheme_stx_type, /* 76 */
scheme_will_executor_type, /* 77 */
scheme_custodian_type, /* 78 */
scheme_random_state_type, /* 79 */
scheme_regexp_type, /* 80 */
scheme_bucket_type, /* 81 */
scheme_bucket_table_type, /* 82 */
scheme_subprocess_type, /* 83 */
scheme_compilation_top_type, /* 84 */
scheme_wrap_chunk_type, /* 85 */
scheme_eval_waiting_type, /* 86 */
scheme_tail_call_waiting_type, /* 87 */
scheme_undefined_type, /* 88 */
scheme_struct_property_type, /* 89 */
scheme_multiple_values_type, /* 90 */
scheme_placeholder_type, /* 91 */
scheme_case_lambda_sequence_type, /* 92 */
scheme_begin0_sequence_type, /* 93 */
scheme_rename_table_type, /* 94 */
scheme_module_type, /* 95 */
scheme_svector_type, /* 96 */
scheme_lazy_macro_type, /* 97 */
scheme_resolve_prefix_type, /* 98 */
scheme_security_guard_type, /* 99 */
scheme_indent_type, /* 100 */
scheme_udp_type, /* 101 */
scheme_udp_evt_type, /* 102 */
scheme_tcp_accept_evt_type, /* 103 */
scheme_id_macro_type, /* 104 */
scheme_evt_set_type, /* 105 */
scheme_wrap_evt_type, /* 106 */
scheme_handle_evt_type, /* 107 */
scheme_nack_guard_evt_type, /* 108 */
scheme_semaphore_repost_type, /* 109 */
scheme_channel_type, /* 110 */
scheme_channel_put_type, /* 111 */
scheme_thread_resume_type, /* 112 */
scheme_thread_suspend_type, /* 113 */
scheme_thread_dead_type, /* 114 */
scheme_poll_evt_type, /* 115 */
scheme_nack_evt_type, /* 116 */
scheme_module_registry_type, /* 117 */
scheme_thread_set_type, /* 118 */
scheme_string_converter_type, /* 119 */
scheme_alarm_type, /* 120 */
scheme_thread_cell_type, /* 121 */
scheme_channel_syncer_type, /* 122 */
scheme_special_comment_type, /* 123 */
scheme_write_evt_type, /* 124 */
scheme_always_evt_type, /* 125 */
scheme_never_evt_type, /* 126 */
scheme_progress_evt_type, /* 127 */
scheme_certifications_type, /* 128 */
scheme_already_comp_type, /* 129 */
scheme_readtable_type, /* 130 */
scheme_intdef_context_type, /* 131 */
scheme_lexical_rib_type, /* 132 */
scheme_thread_cell_values_type, /* 133 */
scheme_global_ref_type, /* 134 */
scheme_cont_mark_chain_type, /* 135 */
scheme_raw_pair_type, /* 136 */
scheme_prompt_type, /* 137 */
scheme_prompt_tag_type, /* 138 */
scheme_unix_path_type, /* 46 */
scheme_windows_path_type, /* 47 */
scheme_symbol_type, /* 48 */
scheme_keyword_type, /* 49 */
scheme_null_type, /* 50 */
scheme_pair_type, /* 51 */
scheme_vector_type, /* 52 */
scheme_inspector_type, /* 53 */
scheme_input_port_type, /* 54 */
scheme_output_port_type, /* 55 */
scheme_eof_type, /* 56 */
scheme_true_type, /* 57 */
scheme_false_type, /* 58 */
scheme_void_type, /* 59 */
scheme_syntax_compiler_type, /* 60 */
scheme_macro_type, /* 61 */
scheme_box_type, /* 62 */
scheme_thread_type, /* 63 */
scheme_stx_offset_type, /* 64 */
scheme_cont_mark_set_type, /* 65 */
scheme_sema_type, /* 66 */
scheme_hash_table_type, /* 67 */
scheme_cpointer_type, /* 68 */
scheme_weak_box_type, /* 69 */
scheme_ephemeron_type, /* 70 */
scheme_struct_type_type, /* 71 */
scheme_module_index_type, /* 72 */
scheme_set_macro_type, /* 73 */
scheme_listener_type, /* 74 */
scheme_namespace_type, /* 75 */
scheme_config_type, /* 76 */
scheme_stx_type, /* 77 */
scheme_will_executor_type, /* 78 */
scheme_custodian_type, /* 79 */
scheme_random_state_type, /* 80 */
scheme_regexp_type, /* 81 */
scheme_bucket_type, /* 82 */
scheme_bucket_table_type, /* 83 */
scheme_subprocess_type, /* 84 */
scheme_compilation_top_type, /* 85 */
scheme_wrap_chunk_type, /* 86 */
scheme_eval_waiting_type, /* 87 */
scheme_tail_call_waiting_type, /* 88 */
scheme_undefined_type, /* 89 */
scheme_struct_property_type, /* 90 */
scheme_multiple_values_type, /* 91 */
scheme_placeholder_type, /* 92 */
scheme_case_lambda_sequence_type, /* 93 */
scheme_begin0_sequence_type, /* 94 */
scheme_rename_table_type, /* 95 */
scheme_module_type, /* 96 */
scheme_svector_type, /* 97 */
scheme_lazy_macro_type, /* 98 */
scheme_resolve_prefix_type, /* 99 */
scheme_security_guard_type, /* 100 */
scheme_indent_type, /* 101 */
scheme_udp_type, /* 102 */
scheme_udp_evt_type, /* 103 */
scheme_tcp_accept_evt_type, /* 104 */
scheme_id_macro_type, /* 105 */
scheme_evt_set_type, /* 106 */
scheme_wrap_evt_type, /* 107 */
scheme_handle_evt_type, /* 108 */
scheme_nack_guard_evt_type, /* 109 */
scheme_semaphore_repost_type, /* 110 */
scheme_channel_type, /* 111 */
scheme_channel_put_type, /* 112 */
scheme_thread_resume_type, /* 113 */
scheme_thread_suspend_type, /* 114 */
scheme_thread_dead_type, /* 115 */
scheme_poll_evt_type, /* 116 */
scheme_nack_evt_type, /* 117 */
scheme_module_registry_type, /* 118 */
scheme_thread_set_type, /* 119 */
scheme_string_converter_type, /* 120 */
scheme_alarm_type, /* 121 */
scheme_thread_cell_type, /* 122 */
scheme_channel_syncer_type, /* 123 */
scheme_special_comment_type, /* 124 */
scheme_write_evt_type, /* 125 */
scheme_always_evt_type, /* 126 */
scheme_never_evt_type, /* 127 */
scheme_progress_evt_type, /* 128 */
scheme_certifications_type, /* 129 */
scheme_already_comp_type, /* 130 */
scheme_readtable_type, /* 131 */
scheme_intdef_context_type, /* 132 */
scheme_lexical_rib_type, /* 133 */
scheme_thread_cell_values_type, /* 134 */
scheme_global_ref_type, /* 135 */
scheme_cont_mark_chain_type, /* 136 */
scheme_raw_pair_type, /* 137 */
scheme_prompt_type, /* 138 */
scheme_prompt_tag_type, /* 139 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 139 */
_scheme_last_normal_type_, /* 140 */
scheme_rt_weak_array, /* 140 */
scheme_rt_weak_array, /* 141 */
scheme_rt_comp_env, /* 141 */
scheme_rt_constant_binding, /* 142 */
scheme_rt_resolve_info, /* 143 */
scheme_rt_optimize_info, /* 144 */
scheme_rt_compile_info, /* 145 */
scheme_rt_cont_mark, /* 146 */
scheme_rt_saved_stack, /* 147 */
scheme_rt_reply_item, /* 148 */
scheme_rt_closure_info, /* 149 */
scheme_rt_overflow, /* 150 */
scheme_rt_overflow_jmp, /* 151 */
scheme_rt_meta_cont, /* 152 */
scheme_rt_dyn_wind_cell, /* 153 */
scheme_rt_dyn_wind_info, /* 154 */
scheme_rt_dyn_wind, /* 155 */
scheme_rt_dup_check, /* 156 */
scheme_rt_thread_memory, /* 157 */
scheme_rt_input_file, /* 158 */
scheme_rt_input_fd, /* 159 */
scheme_rt_oskit_console_input, /* 160 */
scheme_rt_tested_input_file, /* 161 */
scheme_rt_tested_output_file, /* 162 */
scheme_rt_indexed_string, /* 163 */
scheme_rt_output_file, /* 164 */
scheme_rt_load_handler_data, /* 165 */
scheme_rt_pipe, /* 166 */
scheme_rt_beos_process, /* 167 */
scheme_rt_system_child, /* 168 */
scheme_rt_tcp, /* 169 */
scheme_rt_write_data, /* 170 */
scheme_rt_tcp_select_info, /* 171 */
scheme_rt_namespace_option, /* 172 */
scheme_rt_param_data, /* 173 */
scheme_rt_will, /* 174 */
scheme_rt_will_registration, /* 175 */
scheme_rt_struct_proc_info, /* 176 */
scheme_rt_linker_name, /* 177 */
scheme_rt_param_map, /* 178 */
scheme_rt_finalization, /* 179 */
scheme_rt_finalizations, /* 180 */
scheme_rt_cpp_object, /* 181 */
scheme_rt_cpp_array_object, /* 182 */
scheme_rt_stack_object, /* 183 */
scheme_rt_preallocated_object, /* 184 */
scheme_thread_hop_type, /* 185 */
scheme_rt_srcloc, /* 186 */
scheme_rt_evt, /* 187 */
scheme_rt_syncing, /* 188 */
scheme_rt_comp_prefix, /* 189 */
scheme_rt_user_input, /* 190 */
scheme_rt_user_output, /* 191 */
scheme_rt_compact_port, /* 192 */
scheme_rt_read_special_dw, /* 193 */
scheme_rt_regwork, /* 194 */
scheme_rt_buf_holder, /* 195 */
scheme_rt_parameterization, /* 196 */
scheme_rt_print_params, /* 197 */
scheme_rt_read_params, /* 198 */
scheme_rt_native_code, /* 199 */
scheme_rt_native_code_plus_case, /* 200 */
scheme_rt_jitter_data, /* 201 */
scheme_rt_module_exports, /* 202 */
scheme_rt_comp_env, /* 142 */
scheme_rt_constant_binding, /* 143 */
scheme_rt_resolve_info, /* 144 */
scheme_rt_optimize_info, /* 145 */
scheme_rt_compile_info, /* 146 */
scheme_rt_cont_mark, /* 147 */
scheme_rt_saved_stack, /* 148 */
scheme_rt_reply_item, /* 149 */
scheme_rt_closure_info, /* 150 */
scheme_rt_overflow, /* 151 */
scheme_rt_overflow_jmp, /* 152 */
scheme_rt_meta_cont, /* 153 */
scheme_rt_dyn_wind_cell, /* 154 */
scheme_rt_dyn_wind_info, /* 155 */
scheme_rt_dyn_wind, /* 156 */
scheme_rt_dup_check, /* 157 */
scheme_rt_thread_memory, /* 158 */
scheme_rt_input_file, /* 159 */
scheme_rt_input_fd, /* 160 */
scheme_rt_oskit_console_input, /* 161 */
scheme_rt_tested_input_file, /* 162 */
scheme_rt_tested_output_file, /* 163 */
scheme_rt_indexed_string, /* 164 */
scheme_rt_output_file, /* 165 */
scheme_rt_load_handler_data, /* 166 */
scheme_rt_pipe, /* 167 */
scheme_rt_beos_process, /* 168 */
scheme_rt_system_child, /* 169 */
scheme_rt_tcp, /* 170 */
scheme_rt_write_data, /* 171 */
scheme_rt_tcp_select_info, /* 172 */
scheme_rt_namespace_option, /* 173 */
scheme_rt_param_data, /* 174 */
scheme_rt_will, /* 175 */
scheme_rt_will_registration, /* 176 */
scheme_rt_struct_proc_info, /* 177 */
scheme_rt_linker_name, /* 178 */
scheme_rt_param_map, /* 179 */
scheme_rt_finalization, /* 180 */
scheme_rt_finalizations, /* 181 */
scheme_rt_cpp_object, /* 182 */
scheme_rt_cpp_array_object, /* 183 */
scheme_rt_stack_object, /* 184 */
scheme_rt_preallocated_object, /* 185 */
scheme_thread_hop_type, /* 186 */
scheme_rt_srcloc, /* 187 */
scheme_rt_evt, /* 188 */
scheme_rt_syncing, /* 189 */
scheme_rt_comp_prefix, /* 190 */
scheme_rt_user_input, /* 191 */
scheme_rt_user_output, /* 192 */
scheme_rt_compact_port, /* 193 */
scheme_rt_read_special_dw, /* 194 */
scheme_rt_regwork, /* 195 */
scheme_rt_buf_holder, /* 196 */
scheme_rt_parameterization, /* 197 */
scheme_rt_print_params, /* 198 */
scheme_rt_read_params, /* 199 */
scheme_rt_native_code, /* 200 */
scheme_rt_native_code_plus_case, /* 201 */
scheme_rt_jitter_data, /* 202 */
scheme_rt_module_exports, /* 203 */
#endif
_scheme_last_type_

11
src/mzscheme/src/thread.c
View File

@ -3157,6 +3157,11 @@ void scheme_cancel_sleep()
needs_sleep_cancelled = 1;
}
static int post_system_idle()
{
return scheme_try_channel_get(scheme_system_idle_channel);
}
void scheme_check_threads(void)
/* Signals should be suspended. */
{
@ -3663,8 +3668,10 @@ void scheme_thread_block(float sleep_time)
scheme_on_atomic_timeout();
} else {
/* If all processes are blocked, check for total process sleeping: */
if (p->block_descriptor != NOT_BLOCKED)
check_sleep(1, 1);
if (p->block_descriptor != NOT_BLOCKED) {
if (!post_system_idle())
check_sleep(1, 1);
}
}
if (p->block_descriptor == SLEEP_BLOCKED) {

6
src/mzscheme/src/type.c
View File

@ -127,7 +127,8 @@ scheme_init_type (Scheme_Env *env)
set_name(scheme_thread_type, "<thread>");
set_name(scheme_char_string_type, "<string>");
set_name(scheme_byte_string_type, "<byte-string>");
set_name(scheme_path_type, "<path>");
set_name(scheme_unix_path_type, "<unix-path>");
set_name(scheme_windows_path_type, "<windows-path>");
set_name(scheme_struct_property_type, "<struct-property>");
set_name(scheme_structure_type, "<struct>");
#ifdef USE_SENORA_GC
@ -456,7 +457,8 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_complex_type, complex_obj);
GC_REG_TRAV(scheme_char_string_type, string_obj);
GC_REG_TRAV(scheme_byte_string_type, bstring_obj);
GC_REG_TRAV(scheme_path_type, bstring_obj);
GC_REG_TRAV(scheme_unix_path_type, bstring_obj);
GC_REG_TRAV(scheme_windows_path_type, bstring_obj);
GC_REG_TRAV(scheme_symbol_type, symbol_obj);
GC_REG_TRAV(scheme_keyword_type, symbol_obj);
GC_REG_TRAV(scheme_null_type, char_obj); /* small */