mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-02 02:10:19 +02:00
Greg's smob patch
This commit is contained in:
Mikael Djurfeldt
parent
8ac40ce887
commit
23a621512f
25 changed files with 183 additions and 408 deletions
|
|
@ -78,9 +78,7 @@ SCM
|
|||
scm_make_arbiter (name)
|
||||
SCM name;
|
||||
{
|
||||
SCM z;
|
||||
SCM_NEWSMOB (z, scm_tc16_arbiter, name);
|
||||
return z;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_arbiter, name);
|
||||
}
|
||||
|
||||
SCM_PROC(s_try_arbiter, "try-arbiter", 1, 0, 0, scm_try_arbiter);
|
||||
|
|
@ -121,9 +119,7 @@ scm_release_arbiter (arb)
|
|||
void
|
||||
scm_init_arbiters ()
|
||||
{
|
||||
scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0);
|
||||
scm_set_smob_mark (scm_tc16_arbiter, scm_markcdr);
|
||||
scm_set_smob_print (scm_tc16_arbiter, prinarb);
|
||||
|
||||
scm_tc16_arbiter = scm_make_smob_type_mfpe ("arbiter", 0,
|
||||
scm_markcdr, NULL, prinarb, NULL);
|
||||
#include "arbiters.x"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -282,13 +282,11 @@ SCM
|
|||
scm_async (thunk)
|
||||
SCM thunk;
|
||||
{
|
||||
SCM it;
|
||||
struct scm_async * async
|
||||
= (struct scm_async *) scm_must_malloc (sizeof (*async), s_async);
|
||||
async->got_it = 0;
|
||||
async->thunk = thunk;
|
||||
SCM_NEWSMOB (it, scm_tc16_async, async);
|
||||
return it;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_async, async);
|
||||
}
|
||||
|
||||
SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async);
|
||||
|
|
@ -301,12 +299,8 @@ scm_system_async (thunk)
|
|||
SCM list;
|
||||
|
||||
it = scm_async (thunk);
|
||||
SCM_NEWCELL (list);
|
||||
SCM_DEFER_INTS;
|
||||
SCM_SETCAR (list, it);
|
||||
SCM_SETCDR (list, scm_asyncs);
|
||||
SCM_NEWSMOB (list, it, scm_asyncs);
|
||||
scm_asyncs = list;
|
||||
SCM_ALLOW_INTS;
|
||||
return it;
|
||||
}
|
||||
|
||||
|
|
@ -473,8 +467,8 @@ void
|
|||
scm_init_async ()
|
||||
{
|
||||
SCM a_thunk;
|
||||
scm_tc16_async = scm_make_smob_type ("async", sizeof (struct scm_async));
|
||||
scm_set_smob_mark (scm_tc16_async, mark_async);
|
||||
scm_tc16_async = scm_make_smob_type_mfpe ("async", sizeof (struct scm_async),
|
||||
mark_async, NULL, NULL, NULL);
|
||||
scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F);
|
||||
a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk);
|
||||
scm_gc_async = scm_system_async (a_thunk);
|
||||
|
|
|
|||
|
|
@ -55,45 +55,6 @@ size_t scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
|
|||
|
||||
coop_m scm_critical_section_mutex;
|
||||
|
||||
#ifdef __STDC__
|
||||
static size_t
|
||||
scm_threads_free_thread (SCM t)
|
||||
#else
|
||||
static size_t
|
||||
scm_threads_free_thread (t)
|
||||
SCM t;
|
||||
#endif
|
||||
{
|
||||
scm_must_free (SCM_THREAD_DATA (t));
|
||||
return sizeof (coop_t);
|
||||
}
|
||||
|
||||
#ifdef __STDC__
|
||||
static size_t
|
||||
scm_threads_free_mutex (SCM m)
|
||||
#else
|
||||
static size_t
|
||||
scm_threads_free_mutex (m)
|
||||
SCM m;
|
||||
#endif
|
||||
{
|
||||
scm_must_free (SCM_MUTEX_DATA (m));
|
||||
return sizeof (coop_m);
|
||||
}
|
||||
|
||||
#ifdef __STDC__
|
||||
static size_t
|
||||
scm_threads_free_condvar (SCM c)
|
||||
#else
|
||||
static size_t
|
||||
scm_threads_free_condvar (c)
|
||||
SCM c;
|
||||
#endif
|
||||
{
|
||||
scm_must_free (SCM_CONDVAR_DATA (c));
|
||||
return sizeof (coop_c);
|
||||
}
|
||||
|
||||
#ifdef __STDC__
|
||||
void
|
||||
scm_threads_init (SCM_STACKITEM *i)
|
||||
|
|
@ -474,11 +435,8 @@ scm_make_mutex ()
|
|||
{
|
||||
SCM m;
|
||||
coop_m *data = (coop_m *) scm_must_malloc (sizeof (coop_m), "mutex");
|
||||
SCM_NEWCELL (m);
|
||||
SCM_DEFER_INTS;
|
||||
SCM_SETCAR (m, scm_tc16_mutex);
|
||||
SCM_SETCDR (m, data);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
SCM_NEWSMOB (m, scm_tc16_mutex, data);
|
||||
coop_mutex_init (data);
|
||||
return m;
|
||||
}
|
||||
|
|
@ -526,11 +484,7 @@ scm_make_condition_variable ()
|
|||
{
|
||||
SCM c;
|
||||
coop_c *data = (coop_c *) scm_must_malloc (sizeof (coop_c), "condvar");
|
||||
SCM_NEWCELL (c);
|
||||
SCM_DEFER_INTS;
|
||||
SCM_SETCAR (c, scm_tc16_condvar);
|
||||
SCM_SETCDR (c, data);
|
||||
SCM_ALLOW_INTS;
|
||||
SCM_NEWSMOB (c, scm_tc16_condvar, data);
|
||||
coop_condition_variable_init (SCM_CONDVAR_DATA (c));
|
||||
return c;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -164,9 +164,6 @@ prinmemoized (obj, port, pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns memoizedsmob =
|
||||
{scm_markcdr, scm_free0, prinmemoized, 0};
|
||||
|
||||
SCM_PROC (s_memoized_p, "memoized?", 1, 0, 0, scm_memoized_p);
|
||||
|
||||
SCM
|
||||
|
|
@ -184,12 +181,8 @@ scm_make_memoized (exp, env)
|
|||
/* *fixme* Check that env is a valid environment. */
|
||||
register SCM z, ans;
|
||||
SCM_ENTER_A_SECTION;
|
||||
SCM_NEWCELL (z);
|
||||
SCM_SETCDR (z, env);
|
||||
SCM_SETCAR (z, exp);
|
||||
SCM_NEWCELL (ans);
|
||||
SCM_SETCDR (ans, z);
|
||||
SCM_SETCAR (ans, scm_tc16_memoized);
|
||||
SCM_NEWSMOB (z, exp, env);
|
||||
SCM_NEWSMOB (ans, scm_tc16_memoized, z);
|
||||
SCM_EXIT_A_SECTION;
|
||||
return ans;
|
||||
}
|
||||
|
|
@ -589,9 +582,6 @@ prindebugobj (obj, port, pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns debugobjsmob =
|
||||
{0, scm_free0, prindebugobj, 0};
|
||||
|
||||
SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p);
|
||||
|
||||
SCM
|
||||
|
|
@ -638,8 +628,11 @@ scm_init_debug ()
|
|||
{
|
||||
scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
|
||||
|
||||
scm_tc16_memoized = scm_newsmob (&memoizedsmob);
|
||||
scm_tc16_debugobj = scm_newsmob (&debugobjsmob);
|
||||
scm_tc16_memoized = scm_make_smob_type_mfpe ("memoized", 0,
|
||||
scm_markcdr, NULL, prinmemoized, NULL);
|
||||
|
||||
scm_tc16_debugobj = scm_make_smob_type_mfpe ("debug-object", 0,
|
||||
NULL, NULL, prindebugobj, NULL);
|
||||
|
||||
scm_i_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED));
|
||||
scm_i_more = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED));
|
||||
|
|
|
|||
|
|
@ -332,12 +332,6 @@ print_dynl_obj (exp, port, pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns dynl_obj_smob = {
|
||||
mark_dynl_obj,
|
||||
free_dynl_obj,
|
||||
print_dynl_obj
|
||||
};
|
||||
|
||||
static SCM kw_global;
|
||||
SCM_SYMBOL (sym_global, "-global");
|
||||
|
||||
|
|
@ -496,7 +490,9 @@ scm_dynamic_args_call (func, dobj, args)
|
|||
void
|
||||
scm_init_dynamic_linking ()
|
||||
{
|
||||
scm_tc16_dynamic_obj = scm_newsmob (&dynl_obj_smob);
|
||||
scm_tc16_dynamic_obj = scm_make_smob_type_mfpe ("dynamic-object", sizeof (struct dynl_obj),
|
||||
mark_dynl_obj, free_dynl_obj,
|
||||
print_dynl_obj, NULL);
|
||||
sysdep_dynl_init ();
|
||||
#include "dynl.x"
|
||||
kw_global = scm_make_keyword_from_dash_symbol (sym_global);
|
||||
|
|
|
|||
|
|
@ -118,13 +118,6 @@ printguards (SCM exp, SCM port, scm_print_state *pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns guardsmob = {
|
||||
0,
|
||||
freeguards,
|
||||
printguards,
|
||||
0
|
||||
};
|
||||
|
||||
SCM
|
||||
scm_internal_dynamic_wind (scm_guard_t before,
|
||||
scm_inner_t inner,
|
||||
|
|
@ -135,15 +128,11 @@ scm_internal_dynamic_wind (scm_guard_t before,
|
|||
SCM guards, ans;
|
||||
guardsmem *g;
|
||||
before (guard_data);
|
||||
SCM_NEWCELL (guards);
|
||||
SCM_DEFER_INTS;
|
||||
g = (guardsmem *) scm_must_malloc (sizeof (*g), "guards");
|
||||
g->before = before;
|
||||
g->after = after;
|
||||
g->data = guard_data;
|
||||
SCM_SETCDR (guards, g);
|
||||
SCM_SETCAR (guards, tc16_guards);
|
||||
SCM_ALLOW_INTS;
|
||||
SCM_NEWSMOB (guards, tc16_guards, g);
|
||||
scm_dynwinds = scm_acons (guards, SCM_BOOL_F, scm_dynwinds);
|
||||
ans = inner (inner_data);
|
||||
scm_dynwinds = SCM_CDR (scm_dynwinds);
|
||||
|
|
@ -239,6 +228,7 @@ scm_dowinds (to, delta)
|
|||
void
|
||||
scm_init_dynwind ()
|
||||
{
|
||||
tc16_guards = scm_newsmob (&guardsmob);
|
||||
tc16_guards = scm_make_smob_type_mfpe ("guards", sizeof (struct guardsmem),
|
||||
NULL, freeguards, printguards, NULL);
|
||||
#include "dynwind.x"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -3256,13 +3256,7 @@ SCM
|
|||
scm_makprom (code)
|
||||
SCM code;
|
||||
{
|
||||
register SCM z;
|
||||
SCM_NEWCELL (z);
|
||||
SCM_ENTER_A_SECTION;
|
||||
SCM_SETCDR (z, code);
|
||||
SCM_SETCAR (z, scm_tc16_promise);
|
||||
SCM_EXIT_A_SECTION;
|
||||
return z;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_promise, code);
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -610,19 +610,13 @@ scm_opendir (dirname)
|
|||
SCM dirname;
|
||||
{
|
||||
DIR *ds;
|
||||
SCM dir;
|
||||
SCM_ASSERT (SCM_NIMP (dirname) && SCM_ROSTRINGP (dirname), dirname, SCM_ARG1,
|
||||
s_opendir);
|
||||
SCM_COERCE_SUBSTR (dirname);
|
||||
SCM_NEWCELL (dir);
|
||||
SCM_DEFER_INTS;
|
||||
SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname)));
|
||||
if (ds == NULL)
|
||||
scm_syserror (s_opendir);
|
||||
SCM_SETCAR (dir, scm_tc16_dir | SCM_OPN);
|
||||
SCM_SETCDR (dir, ds);
|
||||
SCM_ALLOW_INTS;
|
||||
return dir;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -704,8 +698,6 @@ scm_dir_free (p)
|
|||
return 0;
|
||||
}
|
||||
|
||||
static scm_smobfuns dir_smob = {0, scm_dir_free, scm_dir_print, 0};
|
||||
|
||||
|
||||
/* {Navigating Directories}
|
||||
*/
|
||||
|
|
@ -1226,7 +1218,8 @@ scm_init_filesys ()
|
|||
{
|
||||
scm_add_feature ("i/o-extensions");
|
||||
|
||||
scm_tc16_dir = scm_newsmob (&dir_smob);
|
||||
scm_tc16_dir = scm_make_smob_type_mfpe ("directory", 0,
|
||||
NULL, scm_dir_free,scm_dir_print, NULL);
|
||||
|
||||
scm_dot_string = scm_permanent_object (scm_makfrom0str ("."));
|
||||
|
||||
|
|
|
|||
|
|
@ -107,12 +107,6 @@ print_fluid (exp, port, pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns fluid_smob = {
|
||||
0,
|
||||
scm_free0,
|
||||
print_fluid
|
||||
};
|
||||
|
||||
static
|
||||
int next_fluid_num ()
|
||||
{
|
||||
|
|
@ -132,17 +126,11 @@ SCM_PROC (s_make_fluid, "make-fluid", 0, 0, 0, scm_make_fluid);
|
|||
SCM
|
||||
scm_make_fluid ()
|
||||
{
|
||||
SCM z;
|
||||
int n;
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
n = next_fluid_num ();
|
||||
SCM_NEWCELL (z);
|
||||
SCM_SETCAR (z, scm_tc16_fluid);
|
||||
SCM_SETCDR (z, n);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
return z;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_fluid, n);
|
||||
}
|
||||
|
||||
SCM_PROC (s_fluid_p, "fluid?", 1, 0, 0, scm_fluid_p);
|
||||
|
|
@ -265,6 +253,7 @@ scm_with_fluids (fluids, vals, thunk)
|
|||
void
|
||||
scm_init_fluids ()
|
||||
{
|
||||
scm_tc16_fluid = scm_newsmob(&fluid_smob);
|
||||
scm_tc16_fluid = scm_make_smob_type_mfpe ("fluid", 0,
|
||||
NULL, NULL, print_fluid, NULL);
|
||||
#include "fluids.x"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -116,13 +116,6 @@ g_mark (SCM ptr)
|
|||
return SCM_BOOL_F;
|
||||
}
|
||||
|
||||
static scm_sizet
|
||||
g_free (SCM ptr)
|
||||
{
|
||||
scm_must_free ((char *) GUARDIAN (ptr));
|
||||
return sizeof (guardian_t);
|
||||
}
|
||||
|
||||
static int
|
||||
g_print (SCM exp, SCM port, scm_print_state *pstate)
|
||||
{
|
||||
|
|
@ -135,13 +128,6 @@ g_print (SCM exp, SCM port, scm_print_state *pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns g_smob = {
|
||||
g_mark,
|
||||
g_free,
|
||||
g_print,
|
||||
0 /* g_equalp */
|
||||
};
|
||||
|
||||
#define CCLO_G(cclo) (SCM_VELTS (cclo)[1])
|
||||
|
||||
static SCM
|
||||
|
|
@ -168,15 +154,11 @@ scm_make_guardian ()
|
|||
SCM z1 = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
|
||||
SCM z2 = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
|
||||
SCM z;
|
||||
SCM_NEWCELL (z);
|
||||
|
||||
SCM_DEFER_INTS;
|
||||
/* A tconc starts out with one tail pair. */
|
||||
g->live.head = g->live.tail = z1;
|
||||
g->zombies.head = g->zombies.tail = z2;
|
||||
SCM_SETCDR (z, g);
|
||||
SCM_SETCAR (z, scm_tc16_guardian);
|
||||
SCM_ALLOW_INTS;
|
||||
|
||||
SCM_NEWSMOB (z, scm_tc16_guardian, g);
|
||||
|
||||
CCLO_G (cclo) = z;
|
||||
|
||||
|
|
@ -277,7 +259,8 @@ scm_get_one_zombie (SCM guardian)
|
|||
void
|
||||
scm_init_guardian()
|
||||
{
|
||||
scm_tc16_guardian = scm_newsmob (&g_smob);
|
||||
scm_tc16_guardian = scm_make_smob_type_mfpe ("guardian", sizeof (guardian_t),
|
||||
g_mark, NULL, g_print, NULL);
|
||||
guard1 = scm_make_subr_opt ("guardian", scm_tc7_subr_2o, guard, 0);
|
||||
|
||||
#include "guardians.x"
|
||||
|
|
|
|||
|
|
@ -48,17 +48,6 @@
|
|||
#include "keywords.h"
|
||||
|
||||
|
||||
|
||||
static scm_sizet free_keyword SCM_P ((SCM obj));
|
||||
|
||||
static scm_sizet
|
||||
free_keyword (obj)
|
||||
SCM obj;
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
static int prin_keyword SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
|
||||
|
||||
static int
|
||||
|
|
@ -78,10 +67,6 @@ int scm_tc16_keyword;
|
|||
Will be removed in next release. */
|
||||
int scm_tc16_kw;
|
||||
|
||||
static scm_smobfuns keyword_smob =
|
||||
{scm_markcdr, free_keyword, prin_keyword, 0};
|
||||
|
||||
|
||||
|
||||
SCM_PROC (s_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, scm_make_keyword_from_dash_symbol);
|
||||
|
||||
|
|
@ -101,9 +86,7 @@ scm_make_keyword_from_dash_symbol (symbol)
|
|||
if (vcell == SCM_BOOL_F)
|
||||
{
|
||||
SCM keyword;
|
||||
SCM_NEWCELL(keyword);
|
||||
SCM_SETCAR (keyword, (SCM)scm_tc16_keyword);
|
||||
SCM_SETCDR (keyword, symbol);
|
||||
SCM_NEWSMOB (keyword, scm_tc16_keyword, symbol);
|
||||
scm_intern_symbol (scm_keyword_obarray, symbol);
|
||||
vcell = scm_sym2ovcell_soft (symbol, scm_keyword_obarray);
|
||||
SCM_SETCDR (vcell, keyword);
|
||||
|
|
@ -155,7 +138,8 @@ scm_keyword_dash_symbol (keyword)
|
|||
void
|
||||
scm_init_keywords ()
|
||||
{
|
||||
scm_tc16_keyword = scm_newsmob (&keyword_smob);
|
||||
scm_tc16_keyword = scm_make_smob_type_mfpe ("keyword", 0,
|
||||
scm_markcdr, NULL, prin_keyword, NULL);
|
||||
scm_tc16_kw = scm_tc16_keyword;
|
||||
scm_keyword_obarray = scm_make_vector (SCM_MAKINUM (256), SCM_EOL);
|
||||
#include "keywords.x"
|
||||
|
|
|
|||
|
|
@ -47,21 +47,15 @@
|
|||
|
||||
long scm_tc16_macro;
|
||||
|
||||
static const scm_smobfuns macrosmob = {scm_markcdr, scm_free0};
|
||||
|
||||
SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro);
|
||||
|
||||
SCM
|
||||
scm_makacro (code)
|
||||
SCM code;
|
||||
{
|
||||
register SCM z;
|
||||
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (code)),
|
||||
code, SCM_ARG1, s_makacro);
|
||||
SCM_NEWCELL (z);
|
||||
SCM_SETCDR (z, code);
|
||||
SCM_SETCAR (z, scm_tc16_macro);
|
||||
return z;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_macro, code);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -71,13 +65,9 @@ SCM
|
|||
scm_makmacro (code)
|
||||
SCM code;
|
||||
{
|
||||
register SCM z;
|
||||
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (code)),
|
||||
code, SCM_ARG1, s_makmacro);
|
||||
SCM_NEWCELL (z);
|
||||
SCM_SETCDR (z, code);
|
||||
SCM_SETCAR (z, scm_tc16_macro | (1L << 16));
|
||||
return z;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_macro | (1L << 16), code);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -87,13 +77,9 @@ SCM
|
|||
scm_makmmacro (code)
|
||||
SCM code;
|
||||
{
|
||||
register SCM z;
|
||||
SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (code)),
|
||||
code, SCM_ARG1, s_makmmacro);
|
||||
SCM_NEWCELL (z);
|
||||
SCM_SETCDR (z, code);
|
||||
SCM_SETCAR (z, scm_tc16_macro | (2L << 16));
|
||||
return z;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_macro | (2L << 16), code);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -179,6 +165,7 @@ scm_make_synt (name, macroizer, fcn)
|
|||
void
|
||||
scm_init_macros ()
|
||||
{
|
||||
scm_tc16_macro = scm_newsmob (¯osmob);
|
||||
scm_tc16_macro = scm_make_smob_type_mfpe ("macro", 0,
|
||||
scm_markcdr, NULL, NULL, NULL);
|
||||
#include "macros.x"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -66,8 +66,6 @@ prinmalloc (exp, port, pstate)
|
|||
|
||||
|
||||
int scm_tc16_malloc;
|
||||
static scm_smobfuns mallocsmob = {0, fmalloc, prinmalloc, 0};
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -75,11 +73,8 @@ SCM
|
|||
scm_malloc_obj (n)
|
||||
scm_sizet n;
|
||||
{
|
||||
SCM answer;
|
||||
SCM mem;
|
||||
|
||||
SCM_NEWCELL (answer);
|
||||
SCM_DEFER_INTS;
|
||||
mem = (n
|
||||
? (SCM)malloc (n)
|
||||
: 0);
|
||||
|
|
@ -88,10 +83,7 @@ scm_malloc_obj (n)
|
|||
SCM_ALLOW_INTS;
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
SCM_SETCDR (answer, mem);
|
||||
SCM_SETCAR (answer, scm_tc16_malloc);
|
||||
SCM_ALLOW_INTS;
|
||||
return answer;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_malloc, mem);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -100,6 +92,6 @@ scm_malloc_obj (n)
|
|||
void
|
||||
scm_init_mallocs ()
|
||||
{
|
||||
scm_tc16_malloc = scm_newsmob (&mallocsmob);
|
||||
scm_tc16_malloc = scm_make_smob_type_mfpe ("malloc", 0,
|
||||
NULL, fmalloc, prinmalloc, NULL);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -405,11 +405,7 @@ scm_make_mutex ()
|
|||
{
|
||||
SCM m;
|
||||
pthread_mutex_t *data = (pthread_mutex_t *) scm_must_malloc (sizeof (pthread_mutex_t), "mutex");
|
||||
SCM_NEWCELL (m);
|
||||
SCM_DEFER_INTS;
|
||||
SCM_SETCAR (m, scm_tc16_mutex);
|
||||
SCM_SETCDR (m, data);
|
||||
SCM_ALLOW_INTS;
|
||||
SCM_NEWSMOB (m,scm_tc16_mutex, data);
|
||||
pthread_mutex_init (SCM_MUTEX_DATA (m), NULL);
|
||||
return m;
|
||||
}
|
||||
|
|
@ -452,11 +448,7 @@ scm_make_condition_variable ()
|
|||
{
|
||||
SCM c;
|
||||
pthread_cond_t *data = (pthread_cond_t *) scm_must_malloc (sizeof (pthread_cond_t), "condvar");
|
||||
SCM_NEWCELL (c);
|
||||
SCM_DEFER_INTS;
|
||||
SCM_SETCAR (c, scm_tc16_condvar);
|
||||
SCM_SETCDR (c, data);
|
||||
SCM_ALLOW_INTS;
|
||||
SCM_NEWSMOB (c, scm_tc16_condvar, data);
|
||||
pthread_cond_init (SCM_CONDVAR_DATA (c), NULL);
|
||||
return c;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@
|
|||
#include "genio.h"
|
||||
#include "unif.h"
|
||||
#include "feature.h"
|
||||
#include "smob.h"
|
||||
|
||||
#include "numbers.h"
|
||||
|
||||
|
|
@ -2450,7 +2451,6 @@ scm_makdbl (x, y)
|
|||
SCM z;
|
||||
if ((y == 0.0) && (x == 0.0))
|
||||
return scm_flo0;
|
||||
SCM_NEWCELL (z);
|
||||
SCM_DEFER_INTS;
|
||||
if (y == 0.0)
|
||||
{
|
||||
|
|
@ -2460,20 +2460,17 @@ scm_makdbl (x, y)
|
|||
if ((-FLTMAX < x) && (x < FLTMAX) && (fx == x))
|
||||
#endif
|
||||
{
|
||||
SCM_SETCAR (z, scm_tc_flo);
|
||||
SCM_NEWSMOB(z,scm_tc_flo,NULL);
|
||||
SCM_FLO (z) = x;
|
||||
SCM_ALLOW_INTS;
|
||||
return z;
|
||||
}
|
||||
#endif /* def SCM_SINGLES */
|
||||
SCM_SETCDR (z, (SCM) scm_must_malloc (1L * sizeof (double), "real"));
|
||||
SCM_SETCAR (z, scm_tc_dblr);
|
||||
SCM_NEWSMOB(z,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
|
||||
}
|
||||
else
|
||||
{
|
||||
SCM_SETCDR (z, (SCM) scm_must_malloc (2L * sizeof (double), "complex"));
|
||||
SCM_SETCAR (z, scm_tc_dblc);
|
||||
SCM_IMAG (z) = y;
|
||||
SCM_NEWSMOB(z,scm_tc_dblc,scm_must_malloc (2L * sizeof (double), "comkplex"));
|
||||
}
|
||||
SCM_REAL (z) = x;
|
||||
SCM_ALLOW_INTS;
|
||||
|
|
@ -4805,14 +4802,11 @@ scm_init_numbers ()
|
|||
{
|
||||
#ifdef SCM_FLOATS
|
||||
scm_add_feature("inexact");
|
||||
SCM_NEWCELL (scm_flo0);
|
||||
#ifdef SCM_SINGLES
|
||||
SCM_SETCAR (scm_flo0, scm_tc_flo);
|
||||
SCM_FLO (scm_flo0) = 0.0;
|
||||
SCM_NEWSMOB(scm_flo0,scm_tc_flo,NULL);
|
||||
#else
|
||||
SCM_SETCDR (scm_flo0, (SCM) scm_must_malloc (1L * sizeof (double), "real"));
|
||||
SCM_NEWSMOB(scm_flo0,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
|
||||
SCM_REAL (scm_flo0) = 0.0;
|
||||
SCM_SETCAR (scm_flo0, scm_tc_dblr);
|
||||
#endif
|
||||
#ifdef DBL_DIG
|
||||
scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
|
||||
|
|
|
|||
|
|
@ -320,22 +320,7 @@ long scm_tc16_rstate;
|
|||
static SCM
|
||||
make_rstate (scm_rstate *state)
|
||||
{
|
||||
SCM cell;
|
||||
SCM_NEWCELL (cell);
|
||||
SCM_ENTER_A_SECTION;
|
||||
SCM_SETCDR (cell, state);
|
||||
SCM_SETCAR (cell, scm_tc16_rstate);
|
||||
SCM_EXIT_A_SECTION;
|
||||
return cell;
|
||||
}
|
||||
|
||||
static int
|
||||
print_rstate (SCM rstate, SCM port, scm_print_state *pstate)
|
||||
{
|
||||
scm_puts ("#<random-state ", port);
|
||||
scm_intprint ((long) SCM_RSTATE (rstate), 16, port);
|
||||
scm_putc ('>', port);
|
||||
return 1;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_rstate, state);
|
||||
}
|
||||
|
||||
static scm_sizet
|
||||
|
|
@ -345,8 +330,6 @@ free_rstate (SCM rstate)
|
|||
return scm_the_rng.rstate_size;
|
||||
}
|
||||
|
||||
static scm_smobfuns rstate_smob = { 0, free_rstate, print_rstate, 0};
|
||||
|
||||
/*
|
||||
* Scheme level interface.
|
||||
*/
|
||||
|
|
@ -564,7 +547,8 @@ scm_init_random ()
|
|||
};
|
||||
scm_the_rng = rng;
|
||||
|
||||
scm_tc16_rstate = scm_newsmob (&rstate_smob);
|
||||
scm_tc16_rstate = scm_make_smob_type_mfpe ("random-state", 0,
|
||||
NULL, free_rstate, NULL, NULL);
|
||||
|
||||
for (m = 1; m <= 0x100; m <<= 1)
|
||||
for (i = m >> 1; i < m; ++i)
|
||||
|
|
|
|||
|
|
@ -144,7 +144,7 @@ SCM_PROC (s_make_regexp, "make-regexp", 1, 0, 1, scm_make_regexp);
|
|||
SCM
|
||||
scm_make_regexp (SCM pat, SCM flags)
|
||||
{
|
||||
SCM result, flag;
|
||||
SCM flag;
|
||||
regex_t *rx;
|
||||
int status, cflags;
|
||||
|
||||
|
|
@ -179,8 +179,7 @@ scm_make_regexp (SCM pat, SCM flags)
|
|||
SCM_BOOL_F);
|
||||
/* never returns */
|
||||
}
|
||||
SCM_NEWSMOB (result, scm_tc16_regex, rx);
|
||||
return result;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_regex, rx);
|
||||
}
|
||||
|
||||
SCM_PROC (s_regexp_exec, "regexp-exec", 2, 2, 0, scm_regexp_exec);
|
||||
|
|
@ -252,8 +251,8 @@ scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags)
|
|||
void
|
||||
scm_init_regex_posix ()
|
||||
{
|
||||
scm_tc16_regex = scm_make_smob_type ("regexp", sizeof (regex_t));
|
||||
scm_set_smob_free (scm_tc16_regex, free_regex);
|
||||
scm_tc16_regex = scm_make_smob_type_mfpe ("regexp", sizeof (regex_t),
|
||||
NULL, free_regex, NULL, NULL);
|
||||
|
||||
/* Compilation flags. */
|
||||
scm_sysintern ("regexp/basic", scm_long2num (REG_BASIC));
|
||||
|
|
|
|||
|
|
@ -97,15 +97,6 @@ mark_root (root)
|
|||
return SCM_ROOT_STATE (root) -> parent;
|
||||
}
|
||||
|
||||
static scm_sizet free_root SCM_P ((SCM));
|
||||
|
||||
static scm_sizet
|
||||
free_root (root)
|
||||
SCM root;
|
||||
{
|
||||
scm_must_free ((char *) SCM_ROOT_STATE (root));
|
||||
return sizeof (scm_root_state);
|
||||
}
|
||||
|
||||
static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
|
||||
|
||||
|
|
@ -121,13 +112,6 @@ print_root (exp, port, pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns root_smob =
|
||||
{
|
||||
mark_root,
|
||||
free_root,
|
||||
print_root,
|
||||
0
|
||||
};
|
||||
|
||||
|
||||
|
||||
|
|
@ -150,10 +134,8 @@ scm_make_root (parent)
|
|||
{
|
||||
root_state->parent = SCM_BOOL_F;
|
||||
}
|
||||
SCM_NEWCELL (root);
|
||||
SCM_REDEFER_INTS;
|
||||
SCM_SETCAR (root, scm_tc16_root);
|
||||
SCM_SETCDR (root, root_state);
|
||||
SCM_NEWSMOB (root, scm_tc16_root, root_state);
|
||||
root_state->handle = root;
|
||||
SCM_REALLOW_INTS;
|
||||
return root;
|
||||
|
|
@ -411,6 +393,8 @@ scm_call_catching_errors (thunk, err_filter, closure)
|
|||
void
|
||||
scm_init_root ()
|
||||
{
|
||||
scm_tc16_root = scm_newsmob (&root_smob);
|
||||
scm_tc16_root = scm_make_smob_type_mfpe ("root", sizeof (struct scm_root_state),
|
||||
mark_root, NULL, print_root, NULL);
|
||||
|
||||
#include "root.x"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -153,6 +153,18 @@ scm_make_smob_type (char *name, scm_sizet size)
|
|||
return scm_tc7_smob + (scm_numsmob - 1) * 256;
|
||||
}
|
||||
|
||||
long
|
||||
scm_make_smob_type_mfpe (char *name, scm_sizet size,
|
||||
SCM (*mark) (SCM),
|
||||
scm_sizet (*free) (SCM),
|
||||
int (*print) (SCM, SCM, scm_print_state *),
|
||||
SCM (*equalp) (SCM, SCM))
|
||||
{
|
||||
long answer = scm_make_smob_type (name, size);
|
||||
scm_set_smob_mfpe (answer, mark, free, print, equalp);
|
||||
return answer;
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_mark (long tc, SCM (*mark) (SCM))
|
||||
{
|
||||
|
|
@ -177,7 +189,21 @@ scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM))
|
|||
scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
|
||||
}
|
||||
|
||||
/* Deprecated function - use scm_make_smob_type instead. */
|
||||
void
|
||||
scm_set_smob_mfpe (long tc,
|
||||
SCM (*mark) (SCM),
|
||||
scm_sizet (*free) (SCM),
|
||||
int (*print) (SCM, SCM, scm_print_state *),
|
||||
SCM (*equalp) (SCM, SCM))
|
||||
{
|
||||
if (mark) scm_set_smob_mark (tc, mark);
|
||||
if (free) scm_set_smob_free (tc, free);
|
||||
if (print) scm_set_smob_print (tc, print);
|
||||
if (equalp) scm_set_smob_equalp (tc, equalp);
|
||||
}
|
||||
|
||||
/* Deprecated function - use scm_make_smob_type, or scm_make_smob_type_mfpe
|
||||
instead. */
|
||||
long
|
||||
scm_newsmob (const scm_smobfuns *smob)
|
||||
{
|
||||
|
|
@ -232,21 +258,20 @@ freeprint (SCM exp,
|
|||
void
|
||||
scm_smob_prehistory ()
|
||||
{
|
||||
long tc;
|
||||
scm_numsmob = 0;
|
||||
scm_smobs = ((scm_smob_descriptor *)
|
||||
malloc (7 * sizeof (scm_smob_descriptor)));
|
||||
|
||||
/* WARNING: These scm_make_smob_type calls must be done in this order */
|
||||
tc = scm_make_smob_type ("free", 0);
|
||||
scm_set_smob_print (tc, freeprint);
|
||||
tc = scm_make_smob_type ("flo", 0); /* freed in gc */
|
||||
scm_set_smob_print (tc, scm_floprint);
|
||||
scm_set_smob_equalp (tc, scm_floequal);
|
||||
tc = scm_make_smob_type ("bigpos", 0); /* freed in gc */
|
||||
scm_set_smob_print (tc, scm_bigprint);
|
||||
scm_set_smob_equalp (tc, scm_bigequal);
|
||||
tc = scm_make_smob_type ("bigneg", 0);
|
||||
scm_set_smob_print (tc, scm_bigprint);
|
||||
scm_set_smob_equalp (tc, scm_bigequal);
|
||||
scm_make_smob_type_mfpe ("free", 0,
|
||||
NULL, NULL, freeprint, NULL);
|
||||
|
||||
scm_make_smob_type_mfpe ("flo", 0, /* freed in gc */
|
||||
NULL, NULL, scm_floprint, scm_floequal);
|
||||
|
||||
scm_make_smob_type_mfpe ("bigpos", 0, /* freed in gc */
|
||||
NULL, NULL, scm_bigprint, scm_bigequal);
|
||||
|
||||
scm_make_smob_type_mfpe ("bigneg", 0,
|
||||
NULL, NULL, scm_bigprint, scm_bigequal);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -72,11 +72,18 @@ typedef struct scm_smobfuns
|
|||
|
||||
|
||||
#define SCM_NEWSMOB(z, tc, data) \
|
||||
{ \
|
||||
do { \
|
||||
SCM_NEWCELL (z); \
|
||||
SCM_SETCDR (z, data); \
|
||||
SCM_SETCAR (z, tc); \
|
||||
} \
|
||||
} while (0)
|
||||
|
||||
#define SCM_RETURN_NEWSMOB(tc, data) \
|
||||
do { SCM __SCM_smob_answer; \
|
||||
SCM_NEWSMOB (__SCM_smob_answer, tc, data); \
|
||||
return __SCM_smob_answer; \
|
||||
} while (0)
|
||||
|
||||
|
||||
#define SCM_SMOB_DATA(x) SCM_CDR (x)
|
||||
#define SCM_SET_SMOB_DATA(x, data) SCM_SETCDR (x, data)
|
||||
|
|
@ -94,13 +101,40 @@ extern SCM scm_markcdr SCM_P ((SCM ptr));
|
|||
extern scm_sizet scm_free0 SCM_P ((SCM ptr));
|
||||
extern scm_sizet scm_smob_free (SCM obj);
|
||||
extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);
|
||||
|
||||
/* These next two functions are the supported way to create new SMOB types.
|
||||
|
||||
scm_make_smob_type is useful if there are no special smob functions
|
||||
and the defaults work for mark,free,print,equal_p, or you want to use
|
||||
scm_set_smob_{mark,free,print,equalp}, below.
|
||||
|
||||
scm_make_smob_type_mfpe is ideal if you need to set one or more of
|
||||
the special smob functions-- use NULL for when the default function
|
||||
is fine
|
||||
*/
|
||||
|
||||
extern long scm_make_smob_type (char *name, scm_sizet size);
|
||||
|
||||
extern long scm_make_smob_type_mfpe (char *name, scm_sizet size,
|
||||
SCM (*mark) (SCM),
|
||||
scm_sizet (*free) (SCM),
|
||||
int (*print) (SCM, SCM, scm_print_state*),
|
||||
SCM (*equalp) (SCM, SCM));
|
||||
|
||||
extern void scm_set_smob_mark (long tc, SCM (*mark) (SCM));
|
||||
extern void scm_set_smob_free (long tc, scm_sizet (*free) (SCM));
|
||||
extern void scm_set_smob_print (long tc, int (*print) (SCM,
|
||||
SCM,
|
||||
scm_print_state*));
|
||||
extern void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM));
|
||||
/* convenience function for registering multiple handler fns */
|
||||
extern void scm_set_smob_mfpe (long tc,
|
||||
SCM (*mark) (SCM),
|
||||
scm_sizet (*free) (SCM),
|
||||
int (*print) (SCM, SCM, scm_print_state*),
|
||||
SCM (*equalp) (SCM, SCM));
|
||||
|
||||
|
||||
extern SCM scm_make_smob (long tc);
|
||||
extern void scm_smob_prehistory (void);
|
||||
|
||||
|
|
|
|||
|
|
@ -122,9 +122,6 @@ prinsrcprops (obj, port, pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns srcpropssmob =
|
||||
{marksrcprops, freesrcprops, prinsrcprops, 0};
|
||||
|
||||
|
||||
SCM
|
||||
scm_make_srcprops (line, col, filename, copy, plist)
|
||||
|
|
@ -134,7 +131,6 @@ scm_make_srcprops (line, col, filename, copy, plist)
|
|||
SCM copy;
|
||||
SCM plist;
|
||||
{
|
||||
register SCM ans;
|
||||
register scm_srcprops *ptr;
|
||||
SCM_DEFER_INTS;
|
||||
if ((ptr = srcprops_freelist) != NULL)
|
||||
|
|
@ -156,15 +152,11 @@ scm_make_srcprops (line, col, filename, copy, plist)
|
|||
*(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
|
||||
srcprops_freelist = (scm_srcprops *) &ptr[1];
|
||||
}
|
||||
SCM_NEWCELL (ans);
|
||||
SCM_SETCAR (ans, scm_tc16_srcprops);
|
||||
ptr->pos = SRCPROPMAKPOS (line, col);
|
||||
ptr->fname = filename;
|
||||
ptr->copy = copy;
|
||||
ptr->plist = plist;
|
||||
SCM_SETCDR (ans, (SCM) ptr);
|
||||
SCM_ALLOW_INTS;
|
||||
return ans;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -349,7 +341,8 @@ scm_set_source_property_x (obj, key, datum)
|
|||
void
|
||||
scm_init_srcprop ()
|
||||
{
|
||||
scm_tc16_srcprops = scm_newsmob (&srcpropssmob);
|
||||
scm_tc16_srcprops = scm_make_smob_type_mfpe ("srcprops", 0,
|
||||
marksrcprops, freesrcprops, prinsrcprops, NULL);
|
||||
scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047));
|
||||
|
||||
scm_i_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED));
|
||||
|
|
|
|||
|
|
@ -101,66 +101,6 @@ SCM_PROC(s_signal_condition_variable, "signal-condition-variable", 1, 0, 0, scm_
|
|||
#include "coop-threads.c"
|
||||
#endif
|
||||
|
||||
static int
|
||||
print_thread (exp, port, pstate)
|
||||
SCM exp;
|
||||
SCM port;
|
||||
scm_print_state *pstate;
|
||||
{
|
||||
scm_puts ("#<thread ", port);
|
||||
scm_intprint (SCM_CDR (exp), 16, port);
|
||||
scm_putc ('>', port);
|
||||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns thread_smob =
|
||||
{
|
||||
0,
|
||||
scm_threads_free_thread,
|
||||
print_thread,
|
||||
0
|
||||
};
|
||||
|
||||
static int
|
||||
print_mutex (exp, port, pstate)
|
||||
SCM exp;
|
||||
SCM port;
|
||||
scm_print_state *pstate;
|
||||
{
|
||||
scm_puts ("#<mutex ", port);
|
||||
scm_intprint (SCM_CDR (exp), 16, port);
|
||||
scm_putc ('>', port);
|
||||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns mutex_smob =
|
||||
{
|
||||
0,
|
||||
scm_threads_free_mutex,
|
||||
print_mutex,
|
||||
0
|
||||
};
|
||||
|
||||
static int
|
||||
print_condvar (exp, port, pstate)
|
||||
SCM exp;
|
||||
SCM port;
|
||||
scm_print_state *pstate;
|
||||
{
|
||||
scm_puts ("#<condition-variable ", port);
|
||||
scm_intprint (SCM_CDR (exp), 16, port);
|
||||
scm_putc ('>', port);
|
||||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns condvar_smob =
|
||||
{
|
||||
0,
|
||||
scm_threads_free_condvar,
|
||||
print_condvar,
|
||||
0
|
||||
};
|
||||
|
||||
|
||||
|
||||
#ifdef __STDC__
|
||||
|
|
@ -172,9 +112,10 @@ scm_init_threads (i)
|
|||
SCM_STACKITEM *i;
|
||||
#endif
|
||||
{
|
||||
scm_tc16_thread = scm_newsmob (&thread_smob);
|
||||
scm_tc16_mutex = scm_newsmob (&mutex_smob);
|
||||
scm_tc16_condvar = scm_newsmob (&condvar_smob);
|
||||
scm_tc16_thread = scm_make_smob_type ("thread", sizeof (coop_t));
|
||||
scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (coop_m));
|
||||
scm_tc16_condvar = scm_make_smob_type ("condition-variable", sizeof (coop_c));
|
||||
|
||||
#include "threads.x"
|
||||
/* Initialize implementation specific details of the threads support */
|
||||
scm_threads_init (i);
|
||||
|
|
|
|||
|
|
@ -102,30 +102,22 @@ printjb (exp, port, pstate)
|
|||
return 1 ;
|
||||
}
|
||||
|
||||
static scm_smobfuns jbsmob = {
|
||||
0,
|
||||
#ifdef DEBUG_EXTENSIONS
|
||||
freejb,
|
||||
#else
|
||||
scm_free0,
|
||||
#endif
|
||||
printjb,
|
||||
0
|
||||
};
|
||||
|
||||
static SCM make_jmpbuf SCM_P ((void));
|
||||
static SCM
|
||||
make_jmpbuf ()
|
||||
{
|
||||
SCM answer;
|
||||
SCM_NEWCELL (answer);
|
||||
SCM_REDEFER_INTS;
|
||||
{
|
||||
#ifdef DEBUG_EXTENSIONS
|
||||
char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
|
||||
SCM_SETCDR (answer, (SCM) mem);
|
||||
#endif
|
||||
SCM_SETCAR (answer, scm_tc16_jmpbuffer);
|
||||
#ifdef DEBUG_EXTENSIONS
|
||||
SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, mem);
|
||||
#else
|
||||
SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, 0);
|
||||
#endif
|
||||
SETJBJMPBUF(answer, (jmp_buf *)0);
|
||||
DEACTIVATEJB(answer);
|
||||
}
|
||||
|
|
@ -279,10 +271,6 @@ print_lazy_catch (SCM closure, SCM port, scm_print_state *pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static scm_smobfuns lazy_catch_funs = {
|
||||
0, scm_free0, print_lazy_catch, 0
|
||||
};
|
||||
|
||||
|
||||
/* Given a pointer to a lazy catch structure, return a smob for it,
|
||||
suitable for inclusion in the wind list. ("Ah yes, a Château
|
||||
|
|
@ -290,13 +278,7 @@ static scm_smobfuns lazy_catch_funs = {
|
|||
static SCM
|
||||
make_lazy_catch (struct lazy_catch *c)
|
||||
{
|
||||
SCM smob;
|
||||
|
||||
SCM_NEWCELL (smob);
|
||||
SCM_SETCDR (smob, c);
|
||||
SCM_SETCAR (smob, tc16_lazy_catch);
|
||||
|
||||
return smob;
|
||||
SCM_RETURN_NEWSMOB (tc16_lazy_catch, c);
|
||||
}
|
||||
|
||||
#define SCM_LAZY_CATCH_P(obj) \
|
||||
|
|
@ -749,7 +731,26 @@ scm_ithrow (key, args, noreturn)
|
|||
void
|
||||
scm_init_throw ()
|
||||
{
|
||||
scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
|
||||
tc16_lazy_catch = scm_newsmob (&lazy_catch_funs);
|
||||
#ifdef DEBUG_EXTENSIONS
|
||||
scm_tc16_jmpbuffer = scm_make_smob_type_mfpe ("jmpbuffer",
|
||||
sizeof (scm_cell),
|
||||
NULL, /* mark */
|
||||
freejb,
|
||||
printjb,
|
||||
NULL);
|
||||
#else
|
||||
scm_tc16_jmpbuffer = scm_make_smob_type_mfpe ("jmpbuffer",
|
||||
0,
|
||||
NULL, /* mark */
|
||||
NULL
|
||||
printjb,
|
||||
NULL);
|
||||
#endif
|
||||
|
||||
tc16_lazy_catch = scm_make_smob_type_mfpe ("lazy-catch", 0,
|
||||
NULL,
|
||||
NULL,
|
||||
print_lazy_catch,
|
||||
NULL);
|
||||
#include "throw.x"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -504,9 +504,9 @@ scm_make_ra (ndim)
|
|||
SCM ra;
|
||||
SCM_NEWCELL (ra);
|
||||
SCM_DEFER_INTS;
|
||||
SCM_SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
|
||||
SCM_NEWSMOB(ra, ((long) ndim << 17) + scm_tc16_array,
|
||||
scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
|
||||
"array"));
|
||||
SCM_SETCAR (ra, ((long) ndim << 17) + scm_tc16_array);
|
||||
SCM_ARRAY_V (ra) = scm_nullvect;
|
||||
SCM_ALLOW_INTS;
|
||||
return ra;
|
||||
|
|
@ -2595,18 +2595,18 @@ freera (ptr)
|
|||
return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
|
||||
}
|
||||
|
||||
static scm_smobfuns rasmob =
|
||||
{markra, freera, scm_raprin1, scm_array_equal_p};
|
||||
|
||||
|
||||
/* This must be done after scm_init_scl() */
|
||||
|
||||
void
|
||||
scm_init_unif ()
|
||||
{
|
||||
#include "unif.x"
|
||||
scm_tc16_array = scm_newsmob (&rasmob);
|
||||
scm_tc16_array = scm_make_smob_type_mfpe ("array", 0,
|
||||
markra,
|
||||
freera,
|
||||
scm_raprin1,
|
||||
scm_array_equal_p);
|
||||
scm_add_feature ("array");
|
||||
#include "unif.x"
|
||||
}
|
||||
|
||||
#else /* ARRAYS */
|
||||
|
|
|
|||
|
|
@ -49,17 +49,6 @@
|
|||
#include "variable.h"
|
||||
|
||||
|
||||
static scm_sizet free_var SCM_P ((SCM obj));
|
||||
|
||||
static scm_sizet
|
||||
free_var (obj)
|
||||
SCM obj;
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
|
||||
static int prin_var SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
|
||||
|
||||
static int
|
||||
|
|
@ -106,7 +95,6 @@ var_equal (var1, var2)
|
|||
}
|
||||
|
||||
int scm_tc16_variable;
|
||||
static scm_smobfuns variable_smob = {scm_markvar, free_var, prin_var, var_equal};
|
||||
|
||||
|
||||
static SCM anonymous_variable_sym;
|
||||
|
|
@ -118,13 +106,7 @@ static SCM
|
|||
make_vcell_variable (vcell)
|
||||
SCM vcell;
|
||||
{
|
||||
SCM answer;
|
||||
SCM_NEWCELL(answer);
|
||||
SCM_REDEFER_INTS;
|
||||
SCM_SETCAR (answer, scm_tc16_variable);
|
||||
SCM_SETCDR (answer, vcell);
|
||||
SCM_REALLOW_INTS;
|
||||
return answer;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_variable, vcell);
|
||||
}
|
||||
|
||||
SCM_PROC(s_make_variable, "make-variable", 1, 1, 0, scm_make_variable);
|
||||
|
|
@ -250,7 +232,8 @@ scm_variable_bound_p (var)
|
|||
void
|
||||
scm_init_variable ()
|
||||
{
|
||||
scm_tc16_variable = scm_newsmob (&variable_smob);
|
||||
scm_tc16_variable = scm_make_smob_type_mfpe ("variable", 0,
|
||||
scm_markvar, NULL, prin_var, var_equal);
|
||||
anonymous_variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED));
|
||||
#include "variable.x"
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue