mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-09 15:10:29 +02:00
*** empty log message ***
This commit is contained in:
Mikael Djurfeldt
parent
e1f2bf99e9
commit
98fae09612
6 changed files with 207 additions and 3 deletions
|
|
@ -93,6 +93,9 @@ char *alloca ();
|
|||
#include "feature.h"
|
||||
|
||||
#include "eval.h"
|
||||
|
||||
void (*scm_memoize_method) (SCM, SCM);
|
||||
|
||||
|
||||
|
||||
/* The evaluator contains a plethora of EVAL symbols.
|
||||
|
|
@ -1975,6 +1978,55 @@ dispatch:
|
|||
ENTER_APPLY;
|
||||
goto evap1;
|
||||
|
||||
case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
|
||||
{
|
||||
int i, end, mask;
|
||||
mask = -1;
|
||||
proc = SCM_CDR (x);
|
||||
i = 0;
|
||||
end = SCM_LENGTH (proc);
|
||||
find_method:
|
||||
do
|
||||
{
|
||||
t.arg1 = SCM_CDDAR (env);
|
||||
arg2 = SCM_VELTS (proc)[i];
|
||||
do
|
||||
{
|
||||
if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (arg2))
|
||||
goto next_method;
|
||||
t.arg1 = SCM_CDR (t.arg1);
|
||||
arg2 = SCM_CDR (arg2);
|
||||
}
|
||||
while (SCM_NIMP (t.arg1));
|
||||
x = SCM_CAR (arg2);
|
||||
env = scm_cons (SCM_CAR (env), SCM_CDR (arg2));
|
||||
goto begin;
|
||||
next_method:
|
||||
i = (i + 1) & mask;
|
||||
} while (i != end);
|
||||
memoize_method:
|
||||
scm_memoize_method (x, SCM_CDAR (env));
|
||||
goto loop;
|
||||
|
||||
case (SCM_ISYMNUM (SCM_IM_HASH_DISPATCH)):
|
||||
{
|
||||
int hashset = SCM_INUM (SCM_CADR (x));
|
||||
mask = SCM_INUM (SCM_CADDR (x));
|
||||
proc = SCM_CDDDR (x);
|
||||
i = 0;
|
||||
t.arg1 = SCM_CDDAR (env);
|
||||
do
|
||||
{
|
||||
i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1)))[scm_si_hashsets + hashset];
|
||||
t.arg1 = SCM_CDR (t.arg1);
|
||||
}
|
||||
while (SCM_NIMP (t.arg1));
|
||||
i &= mask;
|
||||
end = i;
|
||||
}
|
||||
goto find_method;
|
||||
}
|
||||
|
||||
default:
|
||||
goto badfun;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1113,11 +1113,21 @@ scm_gc_sweep ()
|
|||
if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
|
||||
{
|
||||
SCM *p = (SCM *) SCM_GCCDR (scmptr);
|
||||
if (((SCM*) vcell)[scm_vtable_index_layout]
|
||||
& SCM_STRUCTF_LIGHT)
|
||||
{
|
||||
SCM layout = ((SCM*)vcell)[scm_vtable_index_layout];
|
||||
m += SCM_LENGTH (layout) / 2;
|
||||
free ((char *) p);
|
||||
}
|
||||
else
|
||||
{
|
||||
m += p[scm_struct_i_n_words] * sizeof (SCM);
|
||||
/* I feel like I'm programming in BCPL here... */
|
||||
free ((char *) p[scm_struct_i_ptr]);
|
||||
}
|
||||
}
|
||||
}
|
||||
break;
|
||||
case scm_tcs_cons_imcar:
|
||||
case scm_tcs_cons_nimcar:
|
||||
|
|
|
|||
|
|
@ -49,6 +49,8 @@
|
|||
|
||||
#include "struct.h"
|
||||
#include "procprop.h"
|
||||
#include "chars.h"
|
||||
#include "kw.h"
|
||||
|
||||
#include "objects.h"
|
||||
|
||||
|
|
@ -56,6 +58,124 @@
|
|||
SCM scm_metaclass_standard;
|
||||
SCM scm_metaclass_operator;
|
||||
|
||||
/* These variables are filled in by the object system when loaded. */
|
||||
SCM scm_class_boolean, scm_class_char, scm_class_pair;
|
||||
SCM scm_class_procedure, scm_class_string, scm_class_symbol;
|
||||
SCM scm_class_vector, scm_class_null;
|
||||
SCM scm_class_real, scm_class_complex, scm_class_integer;
|
||||
SCM scm_class_keyword, scm_class_unknown;
|
||||
|
||||
void (*scm_change_object_class) (SCM, SCM, SCM);
|
||||
|
||||
/* This function is used for efficient type dispatch. */
|
||||
SCM
|
||||
scm_class_of (SCM x)
|
||||
{
|
||||
switch (SCM_ITAG3 (x))
|
||||
{
|
||||
case scm_tc3_int_1:
|
||||
case scm_tc3_int_2:
|
||||
return scm_class_integer;
|
||||
|
||||
case scm_tc3_imm24:
|
||||
if (SCM_ICHRP (x))
|
||||
return scm_class_char;
|
||||
else
|
||||
{
|
||||
switch (SCM_ISYMNUM (x))
|
||||
{
|
||||
case SCM_ISYMNUM (SCM_BOOL_F):
|
||||
case SCM_ISYMNUM (SCM_BOOL_T):
|
||||
return scm_class_boolean;
|
||||
case SCM_ISYMNUM (SCM_EOL):
|
||||
return scm_class_null;
|
||||
default:
|
||||
return scm_class_unknown;
|
||||
}
|
||||
}
|
||||
|
||||
case scm_tc3_cons:
|
||||
switch (SCM_TYP7 (x))
|
||||
{
|
||||
case scm_tcs_cons_nimcar:
|
||||
return scm_class_pair;
|
||||
case scm_tcs_closures:
|
||||
return scm_class_procedure;
|
||||
case scm_tcs_symbols:
|
||||
return scm_class_symbol;
|
||||
case scm_tc7_vector:
|
||||
case scm_tc7_wvect:
|
||||
case scm_tc7_bvect:
|
||||
case scm_tc7_byvect:
|
||||
case scm_tc7_svect:
|
||||
case scm_tc7_ivect:
|
||||
case scm_tc7_uvect:
|
||||
case scm_tc7_fvect:
|
||||
case scm_tc7_dvect:
|
||||
case scm_tc7_cvect:
|
||||
return scm_class_vector;
|
||||
case scm_tc7_string:
|
||||
case scm_tc7_substring:
|
||||
return scm_class_string;
|
||||
case scm_tc7_asubr:
|
||||
case scm_tc7_subr_0:
|
||||
case scm_tc7_subr_1:
|
||||
case scm_tc7_cxr:
|
||||
case scm_tc7_subr_3:
|
||||
case scm_tc7_subr_2:
|
||||
case scm_tc7_rpsubr:
|
||||
case scm_tc7_subr_1o:
|
||||
case scm_tc7_subr_2o:
|
||||
case scm_tc7_lsubr_2:
|
||||
case scm_tc7_lsubr:
|
||||
return scm_class_procedure;
|
||||
|
||||
case scm_tc7_port:
|
||||
return scm_class_unknown;
|
||||
case scm_tc7_smob:
|
||||
{
|
||||
SCM type = SCM_TYP16 (x);
|
||||
if (type == scm_tc16_flo)
|
||||
{
|
||||
if (SCM_CAR (x) & SCM_IMAG_PART)
|
||||
return scm_class_complex;
|
||||
else
|
||||
return scm_class_real;
|
||||
}
|
||||
else if (type == scm_tc16_bigpos || type == scm_tc16_bigneg)
|
||||
return scm_class_integer;
|
||||
else if (type == scm_tc16_kw)
|
||||
return scm_class_keyword;
|
||||
else
|
||||
return scm_class_unknown;
|
||||
}
|
||||
case scm_tcs_cons_gloc:
|
||||
/* must be a struct */
|
||||
if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
|
||||
{
|
||||
if (CLASS_REDEF (SCM_CLASS_OF (x)) != SCM_BOOL_F)
|
||||
scm_change_object_class (x,
|
||||
SCM_CLASS_OF (x),
|
||||
CLASS_REDEF (SCM_CLASS_OF (x)));
|
||||
return SCM_CLASS_OF (x);
|
||||
}
|
||||
default:
|
||||
if (SCM_CONSP (x))
|
||||
return scm_class_pair;
|
||||
else
|
||||
return scm_class_unknown;
|
||||
}
|
||||
|
||||
case scm_tc3_cons_gloc:
|
||||
case scm_tc3_tc7_1:
|
||||
case scm_tc3_tc7_2:
|
||||
case scm_tc3_closure:
|
||||
/* Never reached */
|
||||
break;
|
||||
}
|
||||
return scm_class_unknown;
|
||||
}
|
||||
|
||||
SCM_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p);
|
||||
|
||||
SCM
|
||||
|
|
|
|||
|
|
@ -159,9 +159,27 @@ struct scm_metaclass_operator {
|
|||
*/
|
||||
#define SCM_ENTITY_LAYOUT ""
|
||||
|
||||
/* The following three definitions are Goops dependencies needed by
|
||||
scm_class_of. */
|
||||
#define SCM_CLASSF_GOOPS (0x10 << 24)
|
||||
#define scm_si_redefined 17
|
||||
#define scm_si_hashsets 19
|
||||
#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
|
||||
|
||||
#define CLASS_REDEF(c) (SCM_STRUCT_DATA(c)[scm_si_redefined])
|
||||
|
||||
extern SCM scm_metaclass_standard;
|
||||
extern SCM scm_metaclass_operator;
|
||||
extern SCM scm_class_boolean, scm_class_char, scm_class_pair;
|
||||
extern SCM scm_class_procedure, scm_class_string, scm_class_symbol;
|
||||
extern SCM scm_class_vector, scm_class_null;
|
||||
extern SCM scm_class_real, scm_class_complex, scm_class_integer;
|
||||
extern SCM scm_class_keyword, scm_class_unknown;
|
||||
|
||||
extern void (*scm_change_object_class) (SCM, SCM, SCM);
|
||||
extern void (*scm_memoize_method) (SCM x, SCM args);
|
||||
|
||||
extern SCM scm_class_of (SCM obj);
|
||||
extern SCM scm_entity_p (SCM obj);
|
||||
extern SCM scm_set_object_procedure_x (SCM obj, SCM procs);
|
||||
extern SCM scm_make_class_object (SCM metaclass, SCM layout);
|
||||
|
|
|
|||
|
|
@ -65,6 +65,8 @@
|
|||
#define scm_vtable_offset_user 4 /* Where do user fields start? */
|
||||
|
||||
#define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */
|
||||
#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
|
||||
(no hidden words) */
|
||||
|
||||
#define SCM_STRUCTP(X) (SCM_TYP3(X) == scm_tc3_cons_gloc)
|
||||
#define SCM_STRUCT_DATA(X) ((SCM*)(SCM_CDR(X)))
|
||||
|
|
|
|||
|
|
@ -472,6 +472,8 @@ enum scm_tags
|
|||
#define SCM_EOF_VAL SCM_MAKIFLAG(19)
|
||||
#define SCM_EOL SCM_MAKIFLAG(20)
|
||||
#define SCM_UNSPECIFIED SCM_MAKIFLAG(21)
|
||||
#define SCM_IM_DISPATCH SCM_MAKISYM(22)
|
||||
#define SCM_IM_HASH_DISPATCH SCM_MAKISYM(23)
|
||||
|
||||
|
||||
#define SCM_UNBNDP(x) (SCM_UNDEFINED==(x))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue