Example #1
0
File: bool.c Project: SamB/racket
void scheme_init_bool (Scheme_Env *env)
{
  Scheme_Object *p;

  REGISTER_SO(scheme_not_prim);
  REGISTER_SO(scheme_eq_prim);
  REGISTER_SO(scheme_eqv_prim);
  REGISTER_SO(scheme_equal_prim);

  p = scheme_make_folding_prim(not_prim, "not", 1, 1, 1);
  scheme_not_prim = p;
  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
                                | SCHEME_PRIM_IS_OMITABLE);
  scheme_add_global_constant("not", p, env);

  p = scheme_make_folding_prim(boolean_p_prim, "boolean?", 1, 1, 1);
  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
                                | SCHEME_PRIM_IS_OMITABLE);
  scheme_add_global_constant("boolean?", p, env);

  p = scheme_make_folding_prim(eq_prim, "eq?", 2, 2, 1);
  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
                                | SCHEME_PRIM_IS_OMITABLE);
  scheme_eq_prim = p;
  scheme_add_global_constant("eq?", p, env);

  p = scheme_make_folding_prim(eqv_prim, "eqv?", 2, 2, 1);
  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
                                | SCHEME_PRIM_IS_OMITABLE);
  scheme_eqv_prim = p;
  scheme_add_global_constant("eqv?", scheme_eqv_prim, env);
  
  p = scheme_make_prim_w_arity(equal_prim, "equal?", 2, 2);
  SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
  scheme_equal_prim = p;
  scheme_add_global_constant("equal?", scheme_equal_prim, env);

  scheme_add_global_constant("equal?/recur", 
                             scheme_make_prim_w_arity(equalish_prim, "equal?/recur", 3, 3), 
                             env);

  p = scheme_make_immed_prim(chaperone_p, "chaperone?", 1, 1);
  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
                                | SCHEME_PRIM_IS_OMITABLE);
  scheme_add_global_constant("chaperone?", p, env);

  p = scheme_make_immed_prim(impersonator_p, "impersonator?", 1, 1);
  SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
                                | SCHEME_PRIM_IS_OMITABLE);
  scheme_add_global_constant("impersonator?", p, env);

  scheme_add_global_constant("chaperone-of?",
                             scheme_make_prim_w_arity(chaperone_of, "chaperone-of?", 2, 2),
                             env);
  scheme_add_global_constant("impersonator-of?",
                             scheme_make_prim_w_arity(impersonator_of, "impersonator-of?", 2, 2),
                             env);
}
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()
Example #3
0
Scheme_Object* scheme_initialize( Scheme_Env * env )
{
	DWORD threadID;
	Scheme_Env * menv;
	Scheme_Small_Object * hotkey_event;
	
	g_native_semaphore = CreateSemaphore( NULL, 0, 500, SEMA_NAME );
	
	CreateThread( NULL, 0, ThreadProc, NULL, 0, &threadID );
	
	menv = scheme_primitive_module( scheme_module_name(), env );

	g_hotkey_event_type 		= scheme_make_type("<system-event>");	
	hotkey_event 				= (Scheme_Small_Object*) scheme_malloc( sizeof(Scheme_Small_Object) );
	hotkey_event->iso.so.type	= g_hotkey_event_type;
	hotkey_event->u.int_val 	= (long)g_native_semaphore;	

	scheme_register_extension_global( hotkey_event, sizeof(Scheme_Small_Object) );
	
	scheme_add_evt( g_hotkey_event_type,
			(Scheme_Ready_Fun) scheme_hotkey_inactive,
			(Scheme_Needs_Wakeup_Fun) scheme_hotkey_needs_wakeup,
			NULL, 0);
	
	scheme_add_global( "system-events-event", (Scheme_Object*) hotkey_event, menv );
				 
	scheme_add_global( "last-system-event",  
	                  scheme_make_prim_w_arity( scm_last_system_event, "last-system-event", 0, 0 ),
	                  menv );
	
	scheme_finish_primitive_module( menv );

	return scheme_void;
}
Example #4
0
/*========================================================================*/
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);

  GLOBAL_PRIM_W_ARITY("place-enabled?",    scheme_place_enabled,   0, 0, plenv);
  GLOBAL_PRIM_W_ARITY("place-shared?",     scheme_place_shared,    1, 1, plenv);
  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);

}
Example #5
0
Scheme_Object *scheme_reload (Scheme_Env *env)
{
  Scheme_Env *menv;
  Scheme_Object *proc1;
  Scheme_Object *proc2;
  Scheme_Object *proc3;
  // Converting a C procedure to a scheme procedure.
  proc1 = scheme_make_prim_w_arity (pardbus_get_object, "rdbus-get-object", 3, -1);
  proc2 = scheme_make_prim_w_arity (pardbus_call_method, "rdbus-call-method", 3,-1);
  proc3 = scheme_make_prim_w_arity (pardbus_init, "rdbus_init", 0,0);

  // Add the new procedures to the shared object for Racket to use
  scheme_add_global ("rdbus-get-object", proc1, env);
  scheme_add_global ("rdbus-call-method", proc2, env);
  scheme_add_global ("rdbus_init", proc3, env);
  
  return scheme_void;
} // scheme_reload
Example #6
0
/**
 * Register a scheme function.  Provides a slightly more concise interface
 * to a few lines that we type regularly.
 */
static void
register_function (Scheme_Prim *prim, gchar *name, 
                   int minarity, int maxarity,
                   Scheme_Env *menv)
{
  Scheme_Object *proc = 
    scheme_make_prim_w_arity (prim, name, minarity, maxarity);
  scheme_add_global (name, proc, menv);
} // register_function
Example #7
0
Scheme_Object *scheme_reload(Scheme_Env *env)
{
  scheme_add_global("eval-string/catch-error",
		    scheme_make_prim_w_arity(catch_eval_error,
					     "eval-string/catch-error", 
					     1, 1),
		    env);

  return scheme_void;
}
Example #8
0
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;
}
Example #9
0
Scheme_Object *scheme_reload(Scheme_Env *env)
{
  scheme_add_global("long-long-size", 
		    scheme_make_prim_w_arity(llsize, "long-long-size", 0, 0),
		    env);

  scheme_add_global("integer->long-long-bytes", 
		    scheme_make_prim_w_arity(toll, "integer->long-long-bytes", 1, 1),
		    env);
  scheme_add_global("integer->unsigned-long-long-bytes", 
		    scheme_make_prim_w_arity(toull, "integer->unsigned-long-long-bytes", 1, 1),
		    env);

  scheme_add_global("long-long-bytes->integer", 
		    scheme_make_prim_w_arity(fromll, "long-long-bytes->integer", 1, 1),
		    env);
  scheme_add_global("unsigned-long-long-bytes->integer", 
		    scheme_make_prim_w_arity(fromull, "unsigned-long-long-bytes->integer", 1, 1),
		    env);

  return scheme_void;
}
Example #10
0
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
Example #11
0
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;
}
Example #12
0
Scheme_Object *scheme_reload(Scheme_Env *env)
{
  Scheme_Object *proc;

  /* The MZ_GC... lines are for for 3m, because env is live across an
     allocating call. They're not needed for plain old (conservatively
     collected) Mzscheme. See makeadder3m.c for more info. */
  MZ_GC_DECL_REG(1);
  MZ_GC_VAR_IN_REG(0, env);
  MZ_GC_REG();

  /* Package the C implementation of fmod into a Scheme procedure
     value: */
  proc = scheme_make_prim_w_arity(sch_fmod, "fmod", 2, 2);
  /*               Requires at least two args ------^  ^ */
  /*                  Accepts no more than two args ---| */

  /* Define `fmod' as a global :*/
  scheme_add_global("fmod", proc, env);

  MZ_GC_UNREG();

  return scheme_void;
}
Example #13
0
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
Example #14
0
File: sema.c Project: sindoc/racket
void scheme_init_sema(Scheme_Env *env)
{
  Scheme_Object *o;

#ifdef MZ_PRECISE_GC
  register_traversers();
#endif

  scheme_add_global_constant("make-semaphore", 
			     scheme_make_prim_w_arity(make_sema,
						      "make-semaphore", 
						      0, 1), 
			     env);
  scheme_add_global_constant("semaphore?", 
			     scheme_make_folding_prim(semap,
						      "semaphore?", 
						      1, 1, 1), 
			     env);
  scheme_add_global_constant("semaphore-post", 
			     scheme_make_prim_w_arity(hit_sema, 
						      "semaphore-post", 
						      1, 1), 
			     env);
  scheme_add_global_constant("semaphore-try-wait?", 
			     scheme_make_prim_w_arity(block_sema_p, 
						      "semaphore-try-wait?", 
						      1, 1), 
			     env);
  scheme_add_global_constant("semaphore-wait", 
			     scheme_make_prim_w_arity(block_sema, 
						      "semaphore-wait", 
						      1, 1), 
			     env);
  scheme_add_global_constant("semaphore-wait/enable-break", 
			     scheme_make_prim_w_arity(block_sema_breakable, 
						      "semaphore-wait/enable-break", 
						      1, 1), 
			     env);

  scheme_add_global_constant("semaphore-peek-evt", 
			     scheme_make_prim_w_arity(make_sema_repost,
						      "semaphore-peek-evt", 
						      1, 1), 
			     env);

  scheme_add_global_constant("make-channel", 
			     scheme_make_prim_w_arity(make_channel,
						      "make-channel",
						      0, 0), 
			     env);
  scheme_add_global_constant("channel-put-evt", 
			     scheme_make_prim_w_arity(make_channel_put,
						      "channel-put-evt",
						      2, 2), 
			     env);
  scheme_add_global_constant("channel?", 
			     scheme_make_folding_prim(channel_p,
						      "channel?",
						      1, 1, 1), 
			     env);  

  scheme_add_global_constant("thread-send", 
			     scheme_make_prim_w_arity(thread_send,
						      "thread-send", 
						      2, 3), 
			     env);
  scheme_add_global_constant("thread-receive", 
			     scheme_make_prim_w_arity(thread_receive,
						      "thread-receive", 
						      0, 0), 
			     env);
  scheme_add_global_constant("thread-try-receive", 
			     scheme_make_prim_w_arity(thread_try_receive,
						      "thread-try-receive", 
						      0, 0), 
			     env);
  scheme_add_global_constant("thread-receive-evt", 
			     scheme_make_prim_w_arity(thread_receive_evt,
						      "thread-receive-evt", 
						      0, 0), 
			     env);
  scheme_add_global_constant("thread-rewind-receive", 
			     scheme_make_prim_w_arity(thread_rewind_receive,
						      "thread-rewind-receive", 
						      1, 1), 
			     env);

  scheme_add_global_constant("alarm-evt", 
			     scheme_make_prim_w_arity(make_alarm,
						      "alarm-evt",
						      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;
  scheme_add_global_constant("always-evt", scheme_always_ready_evt, env);

  o = scheme_alloc_small_object();
  o->type = scheme_never_evt_type;
  scheme_add_global_constant("never-evt", o, env);

  REGISTER_SO(thread_recv_evt);
  o = scheme_alloc_small_object();
  o->type = scheme_thread_recv_evt_type;
  thread_recv_evt = o;

  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);
  scheme_add_evt(scheme_channel_put_type, (Scheme_Ready_Fun)channel_put_ready, NULL, NULL, 1);
  scheme_add_evt(scheme_channel_syncer_type, (Scheme_Ready_Fun)channel_syncer_ready, NULL, NULL, 0);
  scheme_add_evt(scheme_alarm_type, (Scheme_Ready_Fun)alarm_ready, NULL, NULL, 0);
  scheme_add_evt(scheme_always_evt_type, always_ready, NULL, NULL, 0);
  scheme_add_evt(scheme_never_evt_type, never_ready, NULL, NULL, 0);
  scheme_add_evt(scheme_thread_recv_evt_type, (Scheme_Ready_Fun)thread_recv_ready, NULL, NULL, 0);
}
Example #15
0
void
scheme_init_vector (Scheme_Env *env)
{
    Scheme_Object *p;

    REGISTER_SO(scheme_vector_p_proc);
    p = scheme_make_folding_prim(vector_p, "vector?", 1, 1, 1);
    SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                 | SCHEME_PRIM_IS_OMITABLE);
    scheme_add_global_constant("vector?", p, env);
    scheme_vector_p_proc = p;

    REGISTER_SO(scheme_make_vector_proc);
    p = scheme_make_immed_prim(scheme_checked_make_vector, "make-vector", 1, 2);
    SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                 | SCHEME_PRIM_IS_BINARY_INLINED);
    scheme_add_global_constant("make-vector", p, env);
    scheme_make_vector_proc = p;

    REGISTER_SO(scheme_vector_proc);
    p = scheme_make_immed_prim(vector, "vector", 0, -1);
    scheme_vector_proc = p;
    SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                 | SCHEME_PRIM_IS_BINARY_INLINED
                                 | SCHEME_PRIM_IS_NARY_INLINED
                                 | SCHEME_PRIM_IS_OMITABLE_ALLOCATION);
    scheme_add_global_constant("vector", p, env);

    REGISTER_SO(scheme_vector_immutable_proc);
    p = scheme_make_immed_prim(vector_immutable, "vector-immutable", 0, -1);
    scheme_vector_immutable_proc = p;
    SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                 | SCHEME_PRIM_IS_BINARY_INLINED
                                 | SCHEME_PRIM_IS_NARY_INLINED
                                 | SCHEME_PRIM_IS_OMITABLE_ALLOCATION);
    scheme_add_global_constant("vector-immutable", p, env);

    p = scheme_make_folding_prim(vector_length, "vector-length", 1, 1, 1);
    SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                 | SCHEME_PRIM_PRODUCES_FIXNUM);
    scheme_add_global_constant("vector-length", p, env);

    REGISTER_SO(scheme_vector_ref_proc);
    p = scheme_make_noncm_prim(scheme_checked_vector_ref,
                               "vector-ref",
                               2, 2);
    scheme_vector_ref_proc = p;
    SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
    scheme_add_global_constant("vector-ref", p, env);

    REGISTER_SO(scheme_vector_set_proc);
    p = scheme_make_noncm_prim(scheme_checked_vector_set,
                               "vector-set!",
                               3, 3);
    scheme_vector_set_proc = p;
    SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
    scheme_add_global_constant("vector-set!", p, env);

    scheme_add_global_constant("vector->list",
                               scheme_make_immed_prim(vector_to_list,
                                       "vector->list",
                                       1, 1),
                               env);

    REGISTER_SO(scheme_list_to_vector_proc);
    p = scheme_make_immed_prim(list_to_vector,
                               "list->vector",
                               1, 1);
    scheme_list_to_vector_proc = p;
    scheme_add_global_constant("list->vector", p, env);

    scheme_add_global_constant("vector-fill!",
                               scheme_make_immed_prim(vector_fill,
                                       "vector-fill!",
                                       2, 2),
                               env);
    scheme_add_global_constant("vector-copy!",
                               scheme_make_immed_prim(vector_copy_bang,
                                       "vector-copy!",
                                       3, 5),
                               env);
    scheme_add_global_constant("vector->immutable-vector",
                               scheme_make_immed_prim(vector_to_immutable,
                                       "vector->immutable-vector",
                                       1, 1),
                               env);
    scheme_add_global_constant("vector->values",
                               scheme_make_prim_w_arity2(vector_to_values,
                                       "vector->values",
                                       1, 3,
                                       0, -1),
                               env);

    scheme_add_global_constant("chaperone-vector",
                               scheme_make_prim_w_arity(chaperone_vector,
                                       "chaperone-vector",
                                       3, -1),
                               env);
    scheme_add_global_constant("impersonate-vector",
                               scheme_make_prim_w_arity(impersonate_vector,
                                       "impersonate-vector",
                                       3, -1),
                               env);
}
Example #16
0
void
scheme_init_unsafe_vector (Scheme_Startup_Env *env)
{
  Scheme_Object *p;

  REGISTER_SO(scheme_unsafe_vector_length_proc);
  p = scheme_make_immed_prim(unsafe_vector_len, "unsafe-vector-length", 1, 1);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
                                                            | SCHEME_PRIM_PRODUCES_FIXNUM);
  scheme_addto_prim_instance("unsafe-vector-length", p, env);
  scheme_unsafe_vector_length_proc = p;

  REGISTER_SO(scheme_unsafe_vector_star_length_proc);
  p = scheme_make_immed_prim(unsafe_vector_star_len, "unsafe-vector*-length", 1, 1);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
                                                            | SCHEME_PRIM_PRODUCES_FIXNUM);
  scheme_addto_prim_instance("unsafe-vector*-length", p, env);
  scheme_unsafe_vector_star_length_proc = p;

  p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_OMITABLE
                                                            | SCHEME_PRIM_IS_OMITABLE);
  scheme_addto_prim_instance("unsafe-vector-ref", p, env);

  REGISTER_SO(scheme_unsafe_vector_star_ref_proc);
  p = scheme_make_immed_prim(unsafe_vector_star_ref, "unsafe-vector*-ref", 2, 2);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_OMITABLE
                                                            | SCHEME_PRIM_IS_OMITABLE);
  scheme_addto_prim_instance("unsafe-vector*-ref", p, env);
  scheme_unsafe_vector_star_ref_proc = p;

  p = scheme_make_immed_prim(unsafe_vector_set, "unsafe-vector-set!", 3, 3);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
  scheme_addto_prim_instance("unsafe-vector-set!", p, env);  

  REGISTER_SO(scheme_unsafe_vector_star_set_proc);
  p = scheme_make_immed_prim(unsafe_vector_star_set, "unsafe-vector*-set!", 3, 3);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
  scheme_addto_prim_instance("unsafe-vector*-set!", p, env);
  scheme_unsafe_vector_star_set_proc = p;

  p = scheme_make_immed_prim(unsafe_vector_star_cas, "unsafe-vector*-cas!", 4, 4);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
  scheme_addto_prim_instance("unsafe-vector*-cas!", p, env);

  REGISTER_SO(scheme_unsafe_struct_ref_proc);
  p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2);
  scheme_unsafe_struct_ref_proc = p;
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_OMITABLE
                                                            | SCHEME_PRIM_IS_OMITABLE);
  scheme_addto_prim_instance("unsafe-struct-ref", p, env);

  REGISTER_SO(scheme_unsafe_struct_ref_proc);
  p = scheme_make_immed_prim(unsafe_struct_star_ref, "unsafe-struct*-ref", 2, 2);
  scheme_unsafe_struct_star_ref_proc = p;
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_OMITABLE
                                                            | SCHEME_PRIM_IS_OMITABLE);
  scheme_addto_prim_instance("unsafe-struct*-ref", p, env);

  REGISTER_SO(scheme_unsafe_struct_set_proc);
  p = scheme_make_immed_prim(unsafe_struct_set, "unsafe-struct-set!", 3, 3);
  scheme_unsafe_struct_set_proc = p;
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
  scheme_addto_prim_instance("unsafe-struct-set!", p, env);

  REGISTER_SO(scheme_unsafe_struct_star_set_proc);
  p = scheme_make_immed_prim(unsafe_struct_star_set, "unsafe-struct*-set!", 3, 3);
  scheme_unsafe_struct_star_set_proc = p;
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
  scheme_addto_prim_instance("unsafe-struct*-set!", p, env);

  p = scheme_make_immed_prim(unsafe_struct_star_cas, "unsafe-struct*-cas!", 4, 4);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
  scheme_addto_prim_instance("unsafe-struct*-cas!", p, env);

  REGISTER_SO(scheme_unsafe_string_length_proc);
  p = scheme_make_immed_prim(unsafe_string_len, "unsafe-string-length", 1, 1);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
                                                            | SCHEME_PRIM_PRODUCES_FIXNUM);
  scheme_addto_prim_instance("unsafe-string-length", p, env);
  scheme_unsafe_string_length_proc = p;

  REGISTER_SO(scheme_unsafe_string_ref_proc);
  p = scheme_make_immed_prim(unsafe_string_ref, "unsafe-string-ref", 2, 2);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_OMITABLE
                                                            | SCHEME_PRIM_IS_OMITABLE);
  scheme_addto_prim_instance("unsafe-string-ref", p, env);
  scheme_unsafe_string_ref_proc = p;

  REGISTER_SO(scheme_unsafe_string_set_proc);
  p = scheme_make_immed_prim(unsafe_string_set, "unsafe-string-set!", 3, 3);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
  scheme_addto_prim_instance("unsafe-string-set!", p, env);
  scheme_unsafe_string_set_proc = p;

  REGISTER_SO(scheme_unsafe_byte_string_length_proc);
  p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL
                                                            | SCHEME_PRIM_PRODUCES_FIXNUM);
  scheme_addto_prim_instance("unsafe-bytes-length", p, env);
  scheme_unsafe_byte_string_length_proc = p;

  REGISTER_SO(scheme_unsafe_bytes_ref_proc);
  p = scheme_make_immed_prim(unsafe_bytes_ref, "unsafe-bytes-ref", 2, 2);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED
                                                            | SCHEME_PRIM_IS_UNSAFE_OMITABLE
                                                            | SCHEME_PRIM_IS_OMITABLE
                                                            | SCHEME_PRIM_PRODUCES_FIXNUM);
  scheme_addto_prim_instance("unsafe-bytes-ref", p, env);
  scheme_unsafe_bytes_ref_proc = p;

  REGISTER_SO(scheme_unsafe_bytes_set_proc);
  p = scheme_make_immed_prim(unsafe_bytes_set, "unsafe-bytes-set!", 3, 3);
  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_NARY_INLINED);
  scheme_addto_prim_instance("unsafe-bytes-set!", p, env);
  scheme_unsafe_bytes_set_proc = p;

  scheme_addto_prim_instance("unsafe-impersonate-vector",
			     scheme_make_prim_w_arity(unsafe_impersonate_vector,
						      "unsafe-impersonate-vector",
						      2, -1),
			     env);

  scheme_addto_prim_instance("unsafe-chaperone-vector",
			     scheme_make_prim_w_arity(unsafe_chaperone_vector,
						      "unsafe-chaperone-vector",
						      2, -1),
			     env);
}
Example #17
0
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");
}