mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 01:00:20 +02:00
Code Activity

* procs.c, procs.h (scm_subr_entry): New type: Stores data

Browse source 
associated with subrs.
(SCM_SUBRNUM, SCM_SUBR_ENTRY, SCM_SUBR_GENERIC, SCM_SUBR_PROPS,
SCM_SUBR_DOC): New macros.
(scm_subr_table): New variable.
(scm_mark_subr_table): New function.

* init.c (scm_boot_guile_1): Call scm_init_subr_table.

* gc.c (scm_gc_mark): Don't mark subr names here.
(scm_igc): Call scm_mark_subr_table.

* snarf.h (SCM_GPROC, SCM_GPROC1): New macros.

* procs.c, procs.h (scm_subr_p): New function (used internally).

* gsubr.c, gsubr.h (scm_make_gsubr_with_generic): New function.

* objects.c, objects.h (scm_primitive_generic): New class.

* objects.h (SCM_CMETHOD_CODE, SCM_CMETHOD_ENV): New macros.

* print.c (scm_iprin1): Print primitive-generics.

* __scm.h (SCM_WTA_DISPATCH_1, SCM_GASSERT1,
SCM_WTA_DISPATCH_2, SCM_GASSERT2): New macros.

* eval.c (SCM_CEVAL, SCM_APPLY): Replace scm_wta -->
SCM_WTA_DISPATCH_1 for scm_cxr's (unary floating point
primitives).  NOTE: This means that it is now *required* to use
SCM_GPROC1 when creating float scm_cxr's (float scm_cxr's is an
obscured representation that will be removed in the future anyway,
so backward compatibility is no problem here).

* numbers.c: Converted most numeric primitives (all but bit
comparison operations and bit operations) to dispatch on generic
if args don't match.

* eval.c, eval.h (scm_eval_body): New function.

* objects.c (scm_call_generic_0, scm_call_generic_1,
scm_call_generic_2, scm_call_generic_3, scm_apply_generic): New
functions.

* eval.c (SCM_CEVAL): Apply the cmethod directly after having
called scm_memoize_method instead of doing a second lookup.

* objects.h (scm_memoize_method): Now returns the memoized cmethod.

* procs.c (scm_make_subr_opt): Use scm_sysintern0 instead of
scm_sysintern so that the binding connected with the subr name
isn't cleared when we give set = 0.
This commit is contained in:
Mikael Djurfeldt 1999-08-26 04:24:42 +00:00
parent 52235e7173
commit 9de33deb2e
15 changed files with 614 additions and 128 deletions
Download patch file Download diff file Expand all files Collapse all files

103
libguile/procs.c
View file

@ -52,6 +52,12 @@
/* {Procedures}
*/
scm_subr_entry *scm_subr_table;
/* libguile contained approx. 700 primitive procedures 990824. */
int scm_subr_table_size = 0;
int scm_subr_table_room = 750;
SCM
scm_make_subr_opt (name, type, fcn, set)
@ -61,21 +67,51 @@ scm_make_subr_opt (name, type, fcn, set)
int set;
{
SCM symcell;
long tmp;
register SCM z;
symcell = scm_sysintern (name, SCM_UNDEFINED);
tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8);
if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org))
tmp = 0;
int entry;
if (scm_subr_table_size == scm_subr_table_room)
{
scm_sizet new_size = scm_port_table_room * 3 / 2;
void *new_table = scm_must_realloc ((char *) scm_subr_table,
scm_subr_table_room,
new_size,
"scm_make_subr_opt");
scm_subr_table = new_table;
scm_subr_table_room = new_size;
}
SCM_NEWCELL (z);
symcell = set ? scm_sysintern0 (name) : scm_intern0 (name);
entry = scm_subr_table_size;
scm_subr_table[entry].handle = z;
scm_subr_table[entry].name = SCM_CAR (symcell);
scm_subr_table[entry].generic = 0;
scm_subr_table[entry].properties = SCM_EOL;
scm_subr_table[entry].documentation = SCM_BOOL_F;
SCM_SUBRF (z) = fcn;
SCM_SETCAR (z, tmp + type);
SCM_SETCAR (z, (entry << 8) + type);
scm_subr_table_size++;
if (set)
SCM_SETCDR (symcell, z);
return z;
}
/* This function isn't currently used since subrs are never freed. */
/* *fixme* Need mutex here. */
void
scm_free_subr_entry (SCM subr)
{
int entry = SCM_SUBRNUM (subr);
/* Move last entry in table to the free position */
scm_subr_table[entry] = scm_subr_table[scm_subr_table_size - 1];
SCM_SET_SUBRNUM (scm_subr_table[entry].handle, entry);
scm_subr_table_size--;
}
SCM
scm_make_subr (name, type, fcn)
@ -86,8 +122,32 @@ scm_make_subr (name, type, fcn)
return scm_make_subr_opt (name, type, fcn, 1);
}
#ifdef CCLO
SCM
scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf)
{
SCM subr = scm_make_subr_opt (name, type, fcn, 1);
scm_subr_table[scm_subr_table_size - 1].generic = gf;
return subr;
}
void
scm_mark_subr_table ()
{
int i;
for (i = 0; i < scm_subr_table_size; ++i)
{
SCM_SETGC8MARK (scm_subr_table[i].name);
if (scm_subr_table[i].generic && *scm_subr_table[i].generic)
scm_gc_mark (*scm_subr_table[i].generic);
if (SCM_NIMP (scm_subr_table[i].properties))
scm_gc_mark (scm_subr_table[i].properties);
if (SCM_NIMP (scm_subr_table[i].documentation))
scm_gc_mark (scm_subr_table[i].documentation);
}
}
#ifdef CCLO
SCM
scm_makcclo (proc, len)
SCM proc;
@ -194,6 +254,21 @@ scm_thunk_p (obj)
return SCM_BOOL_F;
}
/* Only used internally. */
int
scm_subr_p (SCM obj)
{
if (SCM_NIMP (obj))
switch (SCM_TYP7 (obj))
{
case scm_tcs_subrs:
return 1;
default:
;
}
return 0;
}
SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
SCM
@ -293,6 +368,7 @@ scm_setter (SCM proc)
return 0;
}
void
scm_init_iprocs(subra, type)
const scm_iproc *subra;
@ -305,12 +381,17 @@ scm_init_iprocs(subra, type)
}
void
scm_init_subr_table ()
{
scm_subr_table
= ((scm_subr_entry *)
scm_must_malloc (sizeof (scm_subr_entry) * scm_subr_table_room,
"scm_subr_table"));
}
void
scm_init_procs ()
{
#include "procs.x"
}