summaryrefslogtreecommitdiff
path: root/libguile/objects.c
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>1999-03-14 16:50:47 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>1999-03-14 16:50:47 +0000
commited6e0c83f585a684f23758d2fa54f267056272e6 (patch)
treefdb8892727f25a9f041af7a582c0cfab268eb04f /libguile/objects.c
parentfca7570884203ec1734db78001d0001e0d407a96 (diff)
downloadguile-ed6e0c83f585a684f23758d2fa54f267056272e6.tar.gz
* objects.c: #include "smob.h";
(scm_class_keyword): Removed. (Class is automatically created by make_smob_classes.) (scm_smob_class): Array of smob classes indexed by smobnum. (scm_make_extended_class): "Plugin" function pointer for creation of wrapper classes for smob and struct types. (scm_class_of): Handle compiled closures. (Currently regarded as <procedure>.); Use scm_smob_class to handle smob types; Handle scm_tc16_bigpos, scm_tc16_bigneg, and, scm_tc16_keyword through scm_smob_class; Handle structs. * Makefile.am, init.c, libguile.h, objects.c, root.h: Replaced "kw" --> "keywords" everywhere. (I doubt that this will cause big compatibility problems since the application interface is unaffected.)
Diffstat (limited to 'libguile/objects.c')
-rw-r--r--libguile/objects.c51
1 files changed, 37 insertions, 14 deletions
diff --git a/libguile/objects.c b/libguile/objects.c
index f66b47ded..44547dd76 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -51,6 +51,7 @@
#include "procprop.h"
#include "chars.h"
#include "kw.h"
+#include "smob.h"
#include "objects.h"
@@ -63,9 +64,12 @@ SCM scm_class_boolean, scm_class_char, scm_class_pair;
SCM scm_class_procedure, scm_class_string, scm_class_symbol;
SCM scm_class_procedure_with_setter;
SCM scm_class_vector, scm_class_null;
-SCM scm_class_real, scm_class_complex, scm_class_integer;
-SCM scm_class_keyword, scm_class_unknown;
+SCM scm_class_integer, scm_class_real, scm_class_complex;
+SCM scm_class_unknown;
+SCM *scm_smob_class = 0;
+
+SCM (*scm_make_extended_class) (char *type_name);
void (*scm_change_object_class) (SCM, SCM, SCM);
/* This function is used for efficient type dispatch. */
@@ -129,6 +133,7 @@ scm_class_of (SCM x)
case scm_tc7_subr_2o:
case scm_tc7_lsubr_2:
case scm_tc7_lsubr:
+ case scm_tc7_cclo:
return scm_class_procedure;
case scm_tc7_pws:
return scm_class_procedure_with_setter;
@@ -145,23 +150,36 @@ scm_class_of (SCM x)
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;
+ return scm_smob_class[SCM_TC2SMOBNUM (type)];
}
case scm_tcs_cons_gloc:
/* must be a struct */
if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
- {
- if (SCM_OBJ_CLASS_REDEF (x) != SCM_BOOL_F)
- scm_change_object_class (x,
- SCM_CLASS_OF (x), /* old */
- SCM_OBJ_CLASS_REDEF (x)); /* new */
- return SCM_CLASS_OF (x);
- }
+ {
+ /* Goops object */
+ if (SCM_OBJ_CLASS_REDEF (x) != SCM_BOOL_F)
+ scm_change_object_class (x,
+ SCM_CLASS_OF (x), /* old */
+ SCM_OBJ_CLASS_REDEF (x)); /* new */
+ return SCM_CLASS_OF (x);
+ }
+ else
+ {
+ /* ordinary struct */
+ SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
+ if (SCM_NFALSEP (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
+ return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
+ else
+ {
+ SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
+ SCM class = scm_make_extended_class (SCM_NFALSEP (name)
+ ? SCM_ROCHARS (name)
+ : 0);
+ SCM_SET_STRUCT_TABLE_CLASS (handle, class);
+ return class;
+ }
+ }
default:
if (SCM_CONSP (x))
return scm_class_pair;
@@ -283,6 +301,11 @@ scm_set_object_procedure_x (SCM obj, SCM procs)
return SCM_UNSPECIFIED;
}
+/* The following procedures are not a part of Goops but a minimal
+ * object system built upon structs. They are here for those who
+ * want to implement their own object system.
+ */
+
SCM
scm_i_make_class_object (SCM meta,
SCM layout_string,