1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-09 23:40:29 +02:00

*** empty log message ***

This commit is contained in:
Mikael Djurfeldt 1999-01-05 09:25:59 +00:00
parent e1f2bf99e9
commit 98fae09612
6 changed files with 207 additions and 3 deletions

View file

@ -93,6 +93,9 @@ char *alloca ();
#include "feature.h" #include "feature.h"
#include "eval.h" #include "eval.h"
void (*scm_memoize_method) (SCM, SCM);
/* The evaluator contains a plethora of EVAL symbols. /* The evaluator contains a plethora of EVAL symbols.
@ -1975,6 +1978,55 @@ dispatch:
ENTER_APPLY; ENTER_APPLY;
goto evap1; 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: default:
goto badfun; goto badfun;
} }

View file

@ -1113,11 +1113,21 @@ scm_gc_sweep ()
if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1)) if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
{ {
SCM *p = (SCM *) SCM_GCCDR (scmptr); 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); m += p[scm_struct_i_n_words] * sizeof (SCM);
/* I feel like I'm programming in BCPL here... */ /* I feel like I'm programming in BCPL here... */
free ((char *) p[scm_struct_i_ptr]); free ((char *) p[scm_struct_i_ptr]);
} }
} }
}
break; break;
case scm_tcs_cons_imcar: case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar: case scm_tcs_cons_nimcar:

View file

@ -49,6 +49,8 @@
#include "struct.h" #include "struct.h"
#include "procprop.h" #include "procprop.h"
#include "chars.h"
#include "kw.h"
#include "objects.h" #include "objects.h"
@ -56,6 +58,124 @@
SCM scm_metaclass_standard; SCM scm_metaclass_standard;
SCM scm_metaclass_operator; 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_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p);
SCM SCM

View file

@ -159,9 +159,27 @@ struct scm_metaclass_operator {
*/ */
#define SCM_ENTITY_LAYOUT "" #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_standard;
extern SCM scm_metaclass_operator; 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_entity_p (SCM obj);
extern SCM scm_set_object_procedure_x (SCM obj, SCM procs); extern SCM scm_set_object_procedure_x (SCM obj, SCM procs);
extern SCM scm_make_class_object (SCM metaclass, SCM layout); extern SCM scm_make_class_object (SCM metaclass, SCM layout);

View file

@ -65,6 +65,8 @@
#define scm_vtable_offset_user 4 /* Where do user fields start? */ #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_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_STRUCTP(X) (SCM_TYP3(X) == scm_tc3_cons_gloc)
#define SCM_STRUCT_DATA(X) ((SCM*)(SCM_CDR(X))) #define SCM_STRUCT_DATA(X) ((SCM*)(SCM_CDR(X)))

View file

@ -472,6 +472,8 @@ enum scm_tags
#define SCM_EOF_VAL SCM_MAKIFLAG(19) #define SCM_EOF_VAL SCM_MAKIFLAG(19)
#define SCM_EOL SCM_MAKIFLAG(20) #define SCM_EOL SCM_MAKIFLAG(20)
#define SCM_UNSPECIFIED SCM_MAKIFLAG(21) #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)) #define SCM_UNBNDP(x) (SCM_UNDEFINED==(x))