/*========================================================================*/
void scheme_init_place(Scheme_Env *env)
{
Scheme_Env *plenv;
#ifdef MZ_PRECISE_GC
register_traversers();
#endif
plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env);
PLACE_PRIM_W_ARITY("place", scheme_place, 2, 2, plenv);
PLACE_PRIM_W_ARITY("place-sleep", scheme_place_sleep, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-wait", scheme_place_wait, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place?", scheme_place_p, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel", scheme_place_channel, 0, 0, plenv);
PLACE_PRIM_W_ARITY("place-channel-send", scheme_place_send, 1, 2, plenv);
PLACE_PRIM_W_ARITY("place-channel-recv", scheme_place_recv, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel?", scheme_place_channel_p, 1, 1, plenv);
#ifdef MZ_USE_PLACES
REGISTER_SO(scheme_def_place_exit_proc);
scheme_def_place_exit_proc = scheme_make_prim_w_arity(def_place_exit_handler_proc, "default-place-exit-handler", 1, 1);
#endif
scheme_finish_primitive_module(plenv);
}
static char *get_init_filename(Scheme_Env *env)
{
Scheme_Object *f;
Scheme_Thread * volatile p;
mz_jmp_buf * volatile save, newbuf;
p = scheme_get_current_thread();
save = p->error_buf;
p->error_buf = &newbuf;
if (!scheme_setjmp(newbuf)) {
f = scheme_builtin_value("find-system-path");
if (f) {
Scheme_Object *a[1];
a[0] = scheme_intern_symbol("init-file");
f = _scheme_apply(f, 1, a);
if (SCHEME_PATHP(f)) {
p->error_buf = save;
return SCHEME_PATH_VAL(f);
}
}
}
p->error_buf = save;
return NULL;
}
Scheme_Object *scheme_reload(Scheme_Env *env)
{
Scheme_Object *proc;
Scheme_Env *mod_env;
mod_env = scheme_primitive_module(scheme_intern_symbol("midi_extension"),env);
// make sure we start with a clean slate
midi_io.finalise();
proc=scheme_make_prim_w_arity(list_devices,"list-midi-devices",0,0);
scheme_add_global("list-midi-devices",proc,mod_env);
proc=scheme_make_prim_w_arity(set_input_device,"set-midi-input",1,1);
scheme_add_global("set-midi-input",proc,mod_env);
proc=scheme_make_prim_w_arity(set_output_device,"set-midi-output",1,1);
scheme_add_global("set-midi-output",proc,mod_env);
proc=scheme_make_prim_w_arity(startmidi,"start-midi-io",0,0);
scheme_add_global("start-midi-io",proc,mod_env);
proc=scheme_make_prim_w_arity(stopmidi,"stop-midi-io",0,0);
scheme_add_global("stop-midi-io",proc,mod_env);
proc=scheme_make_prim_w_arity(note_on,"note-on",3,3);
scheme_add_global("note-on",proc,mod_env);
proc=scheme_make_prim_w_arity(note_off,"note-off",3,3);
scheme_add_global("note-off",proc,mod_env);
proc=scheme_make_prim_w_arity(read_event,"read-midi-event",0,0);
scheme_add_global("read-midi-event",proc,mod_env);
scheme_finish_primitive_module(mod_env);
return scheme_void;
} // scheme_reload()
static void init_console_in()
{
if (!console_in) {
console_in = GetStdHandle(STD_INPUT_HANDLE);
MZ_REGISTER_STATIC(console_inport);
console_inport = scheme_make_fd_input_port((int)console_in, scheme_intern_symbol("stdin"), 0, 0);
}
}
static void init_exn_catching_apply()
{
if (!exn_catching_apply) {
char *e =
"(lambda (thunk) "
"(with-handlers ([void (lambda (exn) (cons #f exn))]) "
"(cons #t (thunk))))";
/* make sure we have a namespace with the standard bindings: */
Scheme_Env *env = (Scheme_Env *)scheme_make_namespace(0, NULL);
scheme_register_extension_global(&exn_catching_apply, sizeof(Scheme_Object *));
scheme_register_extension_global(&exn_p, sizeof(Scheme_Object *));
scheme_register_extension_global(&exn_message, sizeof(Scheme_Object *));
exn_catching_apply = scheme_eval_string(e, env);
exn_p = scheme_lookup_global(scheme_intern_symbol("exn?"), env);
exn_message = scheme_lookup_global(scheme_intern_symbol("exn-message"), env);
}
}
static Scheme_Linklet *eval_linklet_string(const char *str, intptr_t len, int extract)
{
Scheme_Object *port, *expr;
if (len < 0)
len = strlen(str);
port = scheme_make_sized_byte_string_input_port(str, -len); /* negative means it's constant */
expr = scheme_internal_read(port, 1, 1, -1, scheme_init_load_on_demand ? scheme_true : scheme_false);
if (extract) {
/* expr is a linklet bundle; 'startup is mapped to the linklet */
return (Scheme_Linklet *)scheme_hash_tree_get((Scheme_Hash_Tree *)SCHEME_PTR_VAL(expr),
scheme_intern_symbol("startup"));
} else {
return scheme_compile_and_optimize_linklet(scheme_datum_to_syntax(expr, scheme_false, 0),
scheme_intern_symbol("startup"));
}
}
Scheme_Object* scm_last_system_event( int argc, Scheme_Object * argv[] )
{
int n = (int) g_last_event_type;
g_hotkey_available = 0;
if ( ( n > EVENT_TYPE_NONE ) && ( n < EVENT_TYPE_LAST ) )
{
return scheme_intern_symbol( g_event_types[n] );
}
return scheme_false;
}
Scheme_Object *scheme_reload(Scheme_Env *env)
{
Scheme_Env *menv;
menv = scheme_primitive_module(scheme_intern_symbol("embed-me8"),
env);
scheme_add_global("ex", scheme_make_prim_w_arity(ex, "ex", 0, 0), menv);
scheme_finish_primitive_module(menv);
return scheme_void;
}
Scheme_Object *scheme_reload(Scheme_Env *env)
{
Scheme_Env *mod_env;
mod_env = scheme_primitive_module(scheme_intern_symbol("make-gl-info-helper"), env);
scheme_add_global("gl-byte-size",
scheme_make_integer_value(sizeof(GLbyte)),
mod_env);
scheme_add_global("gl-ubyte-size",
scheme_make_integer_value(sizeof(GLubyte)),
mod_env);
scheme_add_global("gl-short-size",
scheme_make_integer_value(sizeof(GLshort)),
mod_env);
scheme_add_global("gl-ushort-size",
scheme_make_integer_value(sizeof(GLushort)),
mod_env);
scheme_add_global("gl-int-size",
scheme_make_integer_value(sizeof(GLint)),
mod_env);
scheme_add_global("gl-uint-size",
scheme_make_integer_value(sizeof(GLuint)),
mod_env);
scheme_add_global("gl-float-size",
scheme_make_integer_value(sizeof(GLfloat)),
mod_env);
scheme_add_global("gl-double-size",
scheme_make_integer_value(sizeof(GLdouble)),
mod_env);
scheme_add_global("gl-boolean-size",
scheme_make_integer_value(sizeof(GLboolean)),
mod_env);
scheme_add_global("gl-sizei-size",
scheme_make_integer_value(sizeof(GLsizei)),
mod_env);
scheme_add_global("gl-clampf-size",
scheme_make_integer_value(sizeof(GLclampf)),
mod_env);
scheme_add_global("gl-clampd-size",
scheme_make_integer_value(sizeof(GLclampd)),
mod_env);
scheme_add_global("gl-enum-size",
scheme_make_integer_value(sizeof(GLenum)),
mod_env);
scheme_add_global("gl-bitfield-size",
scheme_make_integer_value(sizeof(GLbitfield)),
mod_env);
scheme_finish_primitive_module(mod_env);
return scheme_void;
}
Scheme_Object* scheme_initialize(Scheme_Env *env)
{
Scheme_Env* menv;
menv = scheme_primitive_module(scheme_intern_symbol("ext"), env);
scheme_add_global("EAGAIN", scheme_make_integer(EAGAIN), menv);
scheme_add_global("zmq_poll*",
scheme_make_prim_w_arity(zpoll, "zmq_poll*", 3, 3), menv);
scheme_finish_primitive_module(menv);
return scheme_void;
}
static Scheme_Object *char_general_category (int argc, Scheme_Object *argv[])
{
mzchar c;
int cat;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_type("char-general-category", "character", 0, argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
cat = scheme_general_category(c);
if (!general_category_symbols[cat]) {
Scheme_Object *s;
s = scheme_intern_symbol(general_category_names[cat]);
general_category_symbols[cat] = s;
}
return general_category_symbols[cat];
}
Scheme_Object *
scheme_reload (Scheme_Env *env)
{
Scheme_Env *menv = NULL; // The module's environment
Scheme_Object *proc = NULL; // A Procedure we're adding
// Annotations for the garbage collector
MZ_GC_DECL_REG (2);
MZ_GC_VAR_IN_REG (0, env);
MZ_GC_VAR_IN_REG (1, menv);
MZ_GC_REG ();
// Build the module environment.
menv = scheme_primitive_module (scheme_intern_symbol ("loudbus"),
env);
// Build the procedures
proc = scheme_make_prim_w_arity (loudbus_call, "loudbus-call", 2, -1);
scheme_add_global ("loudbus-call", proc, menv);
proc = scheme_make_prim_w_arity (loudbus_import, "loudbus-import", 3, 3),
scheme_add_global ("loudbus-import", proc, menv);
proc = scheme_make_prim_w_arity (loudbus_init, "loudbus-init", 1, 1),
scheme_add_global ("loudbus-init", proc, menv);
proc = scheme_make_prim_w_arity (loudbus_methods, "loudbus-methods", 1, 1),
scheme_add_global ("loudbus-methods", proc, menv);
proc = scheme_make_prim_w_arity (loudbus_proxy, "loudbus-proxy", 3, 3),
scheme_add_global ("loudbus-proxy", proc, menv);
// And we're done.
scheme_finish_primitive_module (menv);
MZ_GC_UNREG ();
return scheme_void;
} // scheme_reload
Scheme_Object *
scheme_reload (Scheme_Env *env)
{
Scheme_Env *menv = NULL; // The module's environment.
Scheme_Object *proc = NULL; // A procedure that we're adding.
// Annotations for the garbage collector
MZ_GC_DECL_REG (2);
MZ_GC_VAR_IN_REG (0, env);
MZ_GC_VAR_IN_REG (1, menv);
MZ_GC_REG ();
// Build the module environment
menv = scheme_primitive_module (scheme_intern_symbol ("irgb"), env);
// Add the procedures
proc = scheme_make_prim_w_arity (irgb_alpha, "irgb-alpha", 1, 1);
scheme_add_global ("irgb-alpha", proc, menv);
proc = scheme_make_prim_w_arity (irgb_blue, "irgb-blue", 1, 1);
scheme_add_global ("irgb-blue", proc, menv);
proc = scheme_make_prim_w_arity (irgb_green, "irgb-green", 1, 1);
scheme_add_global ("irgb-green", proc, menv);
proc = scheme_make_prim_w_arity (irgb_new, "irgb-new", 3, 3);
scheme_add_global ("irgb-new", proc, menv);
proc = scheme_make_prim_w_arity (irgb_red, "irgb-red", 1, 1);
scheme_add_global ("irgb-red", proc, menv);
proc = scheme_make_prim_w_arity (irgba_new, "irgba-new", 4, 4);
scheme_add_global ("irgba-new", proc, menv);
// Clean up
scheme_finish_primitive_module (menv);
MZ_GC_UNREG ();
// And we're done
return scheme_void;
} // scheme_reload
Scheme_Object *
scheme_module_name ()
{
/* This extension defines a module named `idmodule': */
return scheme_intern_symbol ("idmodule");
} // scheme_module_name
void scheme_init_char (Scheme_Env *env)
{
Scheme_Object *p;
int i;
REGISTER_SO(scheme_char_constants);
REGISTER_SO(general_category_symbols);
scheme_char_constants =
(Scheme_Object **)scheme_malloc_eternal(256 * sizeof(Scheme_Object*));
for (i = 0; i < 256; i++) {
Scheme_Object *sc;
sc = scheme_alloc_eternal_small_object();
sc->type = scheme_char_type;
SCHEME_CHAR_VAL(sc) = i;
scheme_char_constants[i] = sc;
}
for (i = 0; i < NUM_GENERAL_CATEGORIES; i++) {
Scheme_Object *s;
s = scheme_intern_symbol(general_category_names[i]);
general_category_symbols[i] = s;
}
p = scheme_make_folding_prim(char_p, "char?", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("char?", p, env);
p = scheme_make_folding_prim(char_eq, "char=?", 2, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("char=?", p, env);
GLOBAL_FOLDING_PRIM("char<?", char_lt, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char>?", char_gt, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char<=?", char_lt_eq, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char>=?", char_gt_eq, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci=?", char_eq_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci<?", char_lt_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci>?", char_gt_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci<=?", char_lt_eq_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-ci>=?", char_gt_eq_ci, 2, -1, 1, env);
GLOBAL_FOLDING_PRIM("char-alphabetic?", char_alphabetic, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-numeric?", char_numeric, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-symbolic?", char_symbolic, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-graphic?", char_graphic, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-whitespace?", char_whitespace, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-blank?", char_blank, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-iso-control?", char_control, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-punctuation?", char_punctuation, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-upper-case?", char_upper_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-lower-case?", char_lower_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-title-case?", char_title_case, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char->integer", char_to_integer, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("integer->char", integer_to_char, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-upcase", char_upcase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-downcase", char_downcase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-titlecase", char_titlecase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-foldcase", char_foldcase, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-general-category", char_general_category, 1, 1, 1, env);
GLOBAL_FOLDING_PRIM("char-utf-8-length", char_utf8_length, 1, 1, 1, env);
GLOBAL_IMMED_PRIM("make-known-char-range-list", char_map_list, 0, 0, env);
}
Scheme_Object *
scheme_module_name (void)
{
return scheme_intern_symbol ("irgb");
} // scheme_module_name
Scheme_Object *scheme_module_name()
{
return scheme_intern_symbol("embed-me8");
}
Scheme_Object* scheme_module_name()
{
return scheme_intern_symbol( "system-events" );
}
Scheme_Object *scheme_module_name(void)
{
return scheme_intern_symbol("make-gl-info-helper");
}
/*
* Get the init filename for the system
* * First look to see if <addon-dir>/interactive.rkt exists
* * Otherwise check config file for location
*/
static Scheme_Object *get_init_filename(Scheme_Env *env,
char *init_filename_sym,
char *default_init_module,
char *user_init_module)
{
Scheme_Object *f, *a[2], *build_path;
Scheme_Thread * volatile p;
mz_jmp_buf * volatile save, newbuf;
p = scheme_get_current_thread();
save = p->error_buf;
p->error_buf = &newbuf;
if(!scheme_setjmp(newbuf)) {
build_path = scheme_builtin_value("build-path");
/* First test to see if user init file exists */
f = scheme_builtin_value("find-system-path");
a[0] = scheme_intern_symbol("addon-dir");
a[0] = _scheme_apply(f, 1, a);
a[1] = scheme_make_path(user_init_module);
f = _scheme_apply(build_path, 2, a);
if (SCHEME_PATHP(f)) {
char *filename;
filename = scheme_expand_filename(SCHEME_PATH_VAL(f), -1, "startup", NULL, SCHEME_GUARD_FILE_EXISTS);
if(scheme_file_exists(filename)) {
p->error_buf = save;
return scheme_make_path(filename);
}
}
/* Failed, next check config.rkt fo system init file */
f = scheme_builtin_value("find-main-config");
a[0] = _scheme_apply(f, 0, NULL);
a[1] = scheme_make_path("config.rktd");
f = _scheme_apply(build_path, 2, a);
if (SCHEME_PATHP(f)) {
char *filename;
filename = scheme_expand_filename(SCHEME_PATH_VAL(f), -1, "startup", NULL,
SCHEME_GUARD_FILE_EXISTS | SCHEME_GUARD_FILE_READ);
if(scheme_file_exists(filename)) {
Scheme_Object * port;
port = scheme_open_input_file(SCHEME_PATH_VAL(f), "get-init-filename");
f = scheme_read(port);
scheme_close_input_port(port);
if(SCHEME_HASHTRP(f)) {
f = scheme_hash_tree_get((Scheme_Hash_Tree *)f, scheme_intern_symbol(init_filename_sym));
if(f) {
p->error_buf = save;
return f;
}
}
}
}
/* Failed to load custom init file, load racket/interactive */
f = scheme_intern_symbol(default_init_module);
p->error_buf = save;
return f;
}
p->error_buf = save;
return NULL;
}
Scheme_Object *scheme_module_name()
{
return scheme_intern_symbol("ext");
}
// called when the extension is loaded to satisfy a require declaration
Scheme_Object *scheme_module_name()
{
return scheme_intern_symbol("midi_extension");
} // scheme_module_name()
void
scheme_init_list (Scheme_Env *env)
{
scheme_null->type = scheme_null_type;
scheme_add_global_constant ("null", scheme_null, env);
scheme_add_global_constant ("pair?",
scheme_make_folding_prim(pair_p_prim,
"pair?",
1, 1, 1),
env);
scheme_add_global_constant ("cons",
scheme_make_prim_w_arity(cons_prim,
"cons",
2, 2),
env);
scheme_add_global_constant ("car",
scheme_make_prim_w_arity(car_prim,
"car",
1, 1),
env);
scheme_add_global_constant ("cdr",
scheme_make_prim_w_arity(cdr_prim,
"cdr",
1, 1),
env);
scheme_add_global_constant ("set-car!",
scheme_make_prim_w_arity(set_car_prim,
"set-car!",
2, 2),
env);
scheme_add_global_constant ("set-cdr!",
scheme_make_prim_w_arity(set_cdr_prim,
"set-cdr!",
2, 2),
env);
scheme_add_global_constant ("cons-immutable",
scheme_make_prim_w_arity(cons_immutable,
"cons-immutable",
2, 2),
env);
scheme_add_global_constant ("null?",
scheme_make_folding_prim(null_p_prim,
"null?",
1, 1, 1),
env);
scheme_add_global_constant ("list?",
scheme_make_prim_w_arity(list_p_prim,
"list?",
1, 1),
env);
scheme_add_global_constant ("list",
scheme_make_prim_w_arity(list_prim,
"list",
0, -1),
env);
scheme_add_global_constant ("list-immutable",
scheme_make_prim_w_arity(list_immutable_prim,
"list-immutable",
0, -1),
env);
scheme_add_global_constant ("list*",
scheme_make_prim_w_arity(list_star_prim,
"list*",
1, -1),
env);
scheme_add_global_constant ("list*-immutable",
scheme_make_prim_w_arity(list_star_immutable_prim,
"list*-immutable",
1, -1),
env);
scheme_add_global_constant("immutable?",
scheme_make_folding_prim(immutablep,
"immutable?",
1, 1, 1),
env);
scheme_add_global_constant ("length",
scheme_make_prim_w_arity(length_prim,
"length",
1, 1),
env);
scheme_add_global_constant ("append",
scheme_make_prim_w_arity(append_prim,
"append",
0, -1),
env);
scheme_add_global_constant ("append!",
scheme_make_prim_w_arity(append_bang_prim,
"append!",
0, -1),
env);
scheme_add_global_constant ("reverse",
scheme_make_prim_w_arity(reverse_prim,
"reverse",
1, 1),
env);
scheme_add_global_constant ("reverse!",
scheme_make_prim_w_arity(reverse_bang_prim,
"reverse!",
1, 1),
env);
scheme_add_global_constant ("list-tail",
scheme_make_prim_w_arity(list_tail_prim,
"list-tail",
2, 2),
env);
scheme_add_global_constant ("list-ref",
scheme_make_prim_w_arity(list_ref_prim,
"list-ref",
2, 2),
env);
scheme_add_global_constant ("memq",
scheme_make_prim_w_arity(memq,
"memq",
2, 2),
env);
scheme_add_global_constant ("memv",
scheme_make_prim_w_arity(memv,
"memv",
2, 2),
env);
scheme_add_global_constant ("member",
scheme_make_prim_w_arity(member,
"member",
2, 2),
env);
scheme_add_global_constant ("assq",
scheme_make_prim_w_arity(assq,
"assq",
2, 2),
env);
scheme_add_global_constant ("assv",
scheme_make_prim_w_arity(assv,
"assv",
2, 2),
env);
scheme_add_global_constant ("assoc",
scheme_make_prim_w_arity(assoc,
"assoc",
2, 2),
env);
scheme_add_global_constant ("caar",
scheme_make_prim_w_arity(caar_prim,
"caar",
1, 1),
env);
scheme_add_global_constant ("cadr",
scheme_make_prim_w_arity(cadr_prim,
"cadr",
1, 1),
env);
scheme_add_global_constant ("cdar",
scheme_make_prim_w_arity(cdar_prim,
"cdar",
1, 1),
env);
scheme_add_global_constant ("cddr",
scheme_make_prim_w_arity(cddr_prim,
"cddr",
1, 1),
env);
scheme_add_global_constant ("caaar",
scheme_make_prim_w_arity(caaar_prim,
"caaar",
1, 1),
env);
scheme_add_global_constant ("caadr",
scheme_make_prim_w_arity(caadr_prim,
"caadr",
1, 1),
env);
scheme_add_global_constant ("cadar",
scheme_make_prim_w_arity(cadar_prim,
"cadar",
1, 1),
env);
scheme_add_global_constant ("cdaar",
scheme_make_prim_w_arity(cdaar_prim,
"cdaar",
1, 1),
env);
scheme_add_global_constant ("cdadr",
scheme_make_prim_w_arity(cdadr_prim,
"cdadr",
1, 1),
env);
scheme_add_global_constant ("cddar",
scheme_make_prim_w_arity(cddar_prim,
"cddar",
1, 1),
env);
scheme_add_global_constant ("caddr",
scheme_make_prim_w_arity(caddr_prim,
"caddr",
1, 1),
env);
scheme_add_global_constant ("cdddr",
scheme_make_prim_w_arity(cdddr_prim,
"cdddr",
1, 1),
env);
scheme_add_global_constant ("cddddr",
scheme_make_prim_w_arity(cddddr_prim,
"cddddr",
1, 1),
env);
scheme_add_global_constant ("cadddr",
scheme_make_prim_w_arity(cadddr_prim,
"cadddr",
1, 1),
env);
scheme_add_global_constant ("cdaddr",
scheme_make_prim_w_arity(cdaddr_prim,
"cdaddr",
1, 1),
env);
scheme_add_global_constant ("cddadr",
scheme_make_prim_w_arity(cddadr_prim,
"cddadr",
1, 1),
env);
scheme_add_global_constant ("cdddar",
scheme_make_prim_w_arity(cdddar_prim,
"cdddar",
1, 1),
env);
scheme_add_global_constant ("caaddr",
scheme_make_prim_w_arity(caaddr_prim,
"caaddr",
1, 1),
env);
scheme_add_global_constant ("cadadr",
scheme_make_prim_w_arity(cadadr_prim,
"cadadr",
1, 1),
env);
scheme_add_global_constant ("caddar",
scheme_make_prim_w_arity(caddar_prim,
"caddar",
1, 1),
env);
scheme_add_global_constant ("cdaadr",
scheme_make_prim_w_arity(cdaadr_prim,
"cdaadr",
1, 1),
env);
scheme_add_global_constant ("cdadar",
scheme_make_prim_w_arity(cdadar_prim,
"cdadar",
1, 1),
env);
scheme_add_global_constant ("cddaar",
scheme_make_prim_w_arity(cddaar_prim,
"cddaar",
1, 1),
env);
scheme_add_global_constant ("cdaaar",
scheme_make_prim_w_arity(cdaaar_prim,
"cdaaar",
1, 1),
env);
scheme_add_global_constant ("cadaar",
scheme_make_prim_w_arity(cadaar_prim,
"cadaar",
1, 1),
env);
scheme_add_global_constant ("caadar",
scheme_make_prim_w_arity(caadar_prim,
"caadar",
1, 1),
env);
scheme_add_global_constant ("caaadr",
scheme_make_prim_w_arity(caaadr_prim,
"caaadr",
1, 1),
env);
scheme_add_global_constant ("caaaar",
scheme_make_prim_w_arity(caaaar_prim,
"caaaar",
1, 1),
env);
scheme_add_global_constant(BOX,
scheme_make_prim_w_arity(box,
BOX,
1, 1),
env);
scheme_add_global_constant("box-immutable",
scheme_make_prim_w_arity(immutable_box,
"box-immutable",
1, 1),
env);
scheme_add_global_constant(BOXP,
scheme_make_folding_prim(box_p,
BOXP,
1, 1, 1),
env);
scheme_add_global_constant(UNBOX,
scheme_make_prim_w_arity(unbox,
UNBOX,
1, 1),
env);
scheme_add_global_constant(SETBOX,
scheme_make_prim_w_arity(set_box,
SETBOX,
2, 2),
env);
scheme_add_global_constant("make-hash-table",
scheme_make_prim_w_arity(make_hash_table,
"make-hash-table",
0, 2),
env);
scheme_add_global_constant("make-immutable-hash-table",
scheme_make_prim_w_arity(make_immutable_hash_table,
"make-immutable-hash-table",
1, 2),
env);
scheme_add_global_constant("hash-table?",
scheme_make_folding_prim(hash_table_p,
"hash-table?",
1, 3, 1),
env);
scheme_add_global_constant("hash-table-count",
scheme_make_prim_w_arity(hash_table_count,
"hash-table-count",
1, 1),
env);
scheme_add_global_constant("hash-table-copy",
scheme_make_prim_w_arity(hash_table_copy,
"hash-table-copy",
1, 1),
env);
scheme_add_global_constant("hash-table-put!",
scheme_make_prim_w_arity(hash_table_put,
"hash-table-put!",
3, 3),
env);
scheme_add_global_constant("hash-table-get",
scheme_make_prim_w_arity(hash_table_get,
"hash-table-get",
2, 3),
env);
scheme_add_global_constant("hash-table-remove!",
scheme_make_prim_w_arity(hash_table_remove,
"hash-table-remove!",
2, 2),
env);
scheme_add_global_constant("hash-table-map",
scheme_make_prim_w_arity(hash_table_map,
"hash-table-map",
2, 2),
env);
scheme_add_global_constant("hash-table-for-each",
scheme_make_prim_w_arity(hash_table_for_each,
"hash-table-for-each",
2, 2),
env);
scheme_add_global_constant("eq-hash-code",
scheme_make_prim_w_arity(eq_hash_code,
"eq-hash-code",
1, 1),
env);
scheme_add_global_constant("equal-hash-code",
scheme_make_prim_w_arity(equal_hash_code,
"equal-hash-code",
1, 1),
env);
scheme_add_global_constant("make-weak-box",
scheme_make_prim_w_arity(make_weak_box,
"make-weak-box",
1, 1),
env);
scheme_add_global_constant("weak-box-value",
scheme_make_prim_w_arity(weak_box_value,
"weak-box-value",
1, 1),
env);
scheme_add_global_constant("weak-box?",
scheme_make_folding_prim(weak_boxp,
"weak-box?",
1, 1, 1),
env);
REGISTER_SO(weak_symbol);
REGISTER_SO(equal_symbol);
weak_symbol = scheme_intern_symbol("weak");
equal_symbol = scheme_intern_symbol("equal");
}
Scheme_Object *scheme_dump_gc_stats(int c, Scheme_Object *p[])
{
Scheme_Object *result = scheme_void;
#ifdef USE_TAGGED_ALLOCATION
void *initial_trace_root = NULL;
int (*inital_root_skip)(void *, size_t) = NULL;
#endif
scheme_start_atomic();
scheme_console_printf("Begin Dump\n");
if (scheme_external_dump_arg)
scheme_external_dump_arg(c ? p[0] : NULL);
#ifdef USE_TAGGED_ALLOCATION
trace_path_type = -1;
obj_type = -1;
if (c && SCHEME_SYMBOLP(p[0])) {
Scheme_Object *sym;
char *s;
int i, maxpos, just_objects;
sym = p[0];
s = scheme_symbol_val(sym);
maxpos = scheme_num_types();
if (maxpos > NUM_TYPE_SLOTS-1)
maxpos = NUM_TYPE_SLOTS-1;
just_objects = ((c > 1)
&& SCHEME_SYMBOLP(p[1])
&& !strcmp(SCHEME_SYM_VAL(p[1]), "objects"));
for (i = 0; i < maxpos; i++) {
void *tn = scheme_get_type_name(i);
if (tn && !strcmp(tn, s)) {
if (just_objects)
obj_type = i;
else
trace_path_type = i;
break;
}
}
if (SAME_OBJ(p[0], scheme_intern_symbol("stack"))) {
trace_path_type = -2;
}
if ((c > 2)
&& SCHEME_SYMBOLP(p[1])
&& !strcmp(SCHEME_SYM_VAL(p[1]), "from")) {
initial_trace_root = p[2];
if (SCHEME_THREADP(p[2])) {
local_thread = p[2];
local_thread_size = 0;
inital_root_skip = skip_foreign_thread;
}
}
}
{
int i;
int stack_c, roots_c, uncollectable_c, final_c;
long total_count = 0, total_size = 0;
long total_actual_count = 0, total_actual_size = 0;
long traced;
int no_walk = 0;
no_walk = 1 /* (!c || !SAME_OBJ(p[0], scheme_true)) */;
for (i = 0; i < NUM_TYPE_SLOTS; i++) {
scheme_memory_count[i] = scheme_memory_size[i] = 0;
scheme_memory_actual_size[i] = scheme_memory_actual_count[i] = 0;
scheme_memory_hi[i] = scheme_memory_lo[i] = 0;
}
scheme_envunbox_count = scheme_envunbox_size = 0;
bad_seeds = 0;
for (i = 0; i <= NUM_RECORDED_APP_SIZES; i++) {
app_sizes[i] = 0;
}
{
int j, k;
for (i = 0; i < NUM_RECORDED_APP_SIZES; i++) {
for (j = 0; j <= i; j++) {
for (k = 0; k <= 4; k++) {
app_arg_kinds[i][j][k] = 0;
}
}
}
}
traced = GC_trace_count(&stack_c, &roots_c, &uncollectable_c, &final_c);
GC_dump();
scheme_console_printf("\ntraced: %ld\n", traced);
tagged = tagged_while_counting;
if (!no_walk)
smc_ht = scheme_make_hash_table(SCHEME_hash_ptr);
if (tagged)
GC_for_each_element(real_tagged, count_tagged, NULL);
if (tagged_eternal)
GC_for_each_element(tagged_eternal, count_tagged, NULL);
if (tagged_uncollectable)
GC_for_each_element(tagged_uncollectable, count_tagged, NULL);
if (tagged_atomic)
GC_for_each_element(tagged_atomic, count_tagged, NULL);
if (envunbox)
GC_for_each_element(envunbox, count_envunbox, NULL);
tagged = real_tagged;
scheme_console_printf("Begin MzScheme\n");
scheme_console_printf("%30.30s %10s %10s %10s %8s - %8s\n",
"TYPE", "COUNT", "ESTM-SIZE", "TRACE-SIZE",
"LO-LOC", "HI-LOC");
for (i = 0; i < NUM_TYPE_SLOTS; i++) {
if (scheme_memory_count[i] || scheme_memory_actual_count[i]) {
scheme_console_printf("%30.30s %10ld %10ld %10ld %8lx - %8lx\n",
(i < NUM_TYPE_SLOTS-1)
? scheme_get_type_name(i)
: "other",
scheme_memory_actual_count[i],
scheme_memory_size[i],
scheme_memory_actual_size[i],
scheme_memory_lo[i],
scheme_memory_hi[i]);
if (scheme_memory_actual_count[i] != scheme_memory_count[i]) {
scheme_console_printf("%30.30s reach count: %10ld\n",
"", scheme_memory_count[i]);
}
total_count += scheme_memory_count[i];
total_size += scheme_memory_size[i];
total_actual_count += scheme_memory_actual_count[i];
total_actual_size += scheme_memory_actual_size[i];
}
}
scheme_console_printf("%30.30s %10ld %10ld -\n",
"envunbox", scheme_envunbox_count, scheme_envunbox_size);
total_count += scheme_envunbox_count;
total_size += scheme_envunbox_size;
scheme_console_printf("%30.30s - %10ld -\n",
"miscellaneous",
scheme_misc_count + scheme_type_table_count);
total_size += scheme_misc_count + scheme_type_table_count;
scheme_console_printf("%30.30s - - %10ld\n",
"roots", roots_c);
total_actual_size += roots_c;
scheme_console_printf("%30.30s - - %10ld\n",
"stack", stack_c);
total_actual_size += stack_c;
scheme_console_printf("%30.30s - - %10ld\n",
"unreached-uncollectable", uncollectable_c);
total_actual_size += uncollectable_c;
scheme_console_printf("%30.30s - - %10ld\n",
"finalization", final_c);
total_actual_size += final_c;
scheme_console_printf("%30.30s %10ld %10ld %10ld\n",
"total", total_count, total_size,
total_actual_size);
scheme_console_printf("End MzScheme\n");
scheme_console_printf("Begin Apps\n");
for (i = 0; i < NUM_RECORDED_APP_SIZES; i++) {
int j, k;
scheme_console_printf(" %d%s: %d", i,
(i == NUM_RECORDED_APP_SIZES ? "+" : ""),
app_sizes[i]);
for (j = 0; j <= i; j++) {
scheme_console_printf(" (");
for (k = 0; k <= 4; k++) {
if (k)
scheme_console_printf(",");
scheme_console_printf("%d", app_arg_kinds[i][j][k]);
}
scheme_console_printf(")");
}
scheme_console_printf("\n");
}
scheme_console_printf("End Apps\n");
{
Scheme_Custodian *m = (Scheme_Custodian *)scheme_get_param(scheme_current_config(), MZCONFIG_CUSTODIAN);
int c = 0, a = 0, u = 0, t = 0, ipt = 0, opt = 0, th = 0;
while (*m->parent)
m = *m->parent;
count_managed(m, &c, &a, &u, &t, &ipt, &opt, &th);
scheme_console_printf("custodians: %d managed: actual: %d breadth: %d room: %d\n"
" input-ports: %d output-ports: %d threads: %d\n"
"stacks: %d\n",
t, u, c, a, ipt, opt, th,
scheme_num_copied_stacks);
}
if (bad_seeds)
scheme_console_printf("ERROR: %ld illegal tags found\n", bad_seeds);
smc_ht = NULL;
}
#else
# if MZ_PRECISE_GC_TRACE
GC_trace_for_tag = -1;
if (c && SCHEME_SYMBOLP(p[0])) {
Scheme_Object *sym;
char *s;
int i, maxpos;
sym = p[0];
s = scheme_symbol_val(sym);
maxpos = scheme_num_types();
for (i = 0; i < maxpos; i++) {
void *tn;
tn = scheme_get_type_name(i);
if (tn && !strcmp(tn, s)) {
GC_trace_for_tag = i;
break;
}
}
} else if (SCHEME_INTP(p[0])) {
GC_trace_for_tag = SCHEME_INT_VAL(p[0]);
}
if ((c > 1) && SCHEME_INTP(p[1]))
GC_path_length_limit = SCHEME_INT_VAL(p[1]);
else
GC_path_length_limit = 1000;
#endif
GC_dump();
#endif
if (scheme_external_dump_info)
scheme_external_dump_info();
#ifdef USE_TAGGED_ALLOCATION
{
void **ps = NULL;
int l;
int max_w;
Scheme_Object *w;
GC_inital_root_skip = inital_root_skip;
GC_initial_trace_root = initial_trace_root;
GC_trace_path();
GC_inital_root_skip = NULL;
GC_initial_trace_root = NULL;
w = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_WIDTH);
if (SCHEME_INTP(w))
max_w = SCHEME_INT_VAL(w);
else
max_w = 10000;
scheme_console_printf("Begin Paths\n");
while ((ps = GC_get_next_path(ps, &l))) {
int i, j;
if (l)
scheme_console_printf("$%s", ps[0]);
for (i = 1, j = 2; i < l; i++, j += 2) {
void *v = ps[j];
unsigned long diff = (unsigned long)ps[j + 1];
struct GC_Set *home;
home = GC_set(v);
if (home
&& ((home == real_tagged)
|| (home == tagged_atomic)
|| (home == tagged_uncollectable)
|| (home == tagged_eternal))) {
scheme_print_tagged_value("\n ->", v, 0, diff, max_w, "");
} else
scheme_print_tagged_value("\n ->", v, 1, diff, max_w, "");
}
scheme_console_printf("\n");
}
GC_clear_paths();
scheme_console_printf("End Paths\n");
}
scheme_console_printf("Begin Help\n");
scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym.\n");
scheme_console_printf(" Examples: (dump-memory-stats '<pair>), (dump-memory-stats 'frame).\n");
scheme_console_printf(" If sym is 'stack, prints paths to thread stacks.\n");
scheme_console_printf(" (dump-memory-stats sym 'objects) - prints all instances of type named by sym.\n");
scheme_console_printf(" (dump-memory-stats sym 'from from-v) - prints paths, paths through from-v first.\n");
scheme_console_printf("End Help\n");
if (obj_type >= 0) {
result = scheme_null;
while (obj_buffer_pos--) {
result = scheme_make_pair((Scheme_Object *)(obj_buffer[obj_buffer_pos]), result);
}
}
#endif
# if MZ_PRECISE_GC_TRACE
scheme_console_printf("Begin Help\n");
scheme_console_printf(" (dump-memory-stats sym) - prints paths to instances of type named by sym.\n");
scheme_console_printf(" Example: (dump-memory-stats '<pair>)\n");
scheme_console_printf(" (dump-memory-stats num) - prints paths to objects with tag num.\n");
scheme_console_printf(" (dump-memory-stats -num) - prints paths to objects of size num.\n");
scheme_console_printf(" (dump-memory-stats sym/num len) - limits path to size len.\n");
scheme_console_printf("End Help\n");
# endif
scheme_console_printf("End Dump\n");
scheme_end_atomic();
return result;
}
