Commit | Line | Data |
---|---|---|
dbb605f5 | 1 | /* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. |
1d9ee7c7 | 2 | * |
73be1d9e MV |
3 | * This library is free software; you can redistribute it and/or |
4 | * modify it under the terms of the GNU Lesser General Public | |
5 | * License as published by the Free Software Foundation; either | |
6 | * version 2.1 of the License, or (at your option) any later version. | |
1d9ee7c7 | 7 | * |
73be1d9e MV |
8 | * This library is distributed in the hope that it will be useful, |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | * Lesser General Public License for more details. | |
1d9ee7c7 | 12 | * |
73be1d9e MV |
13 | * You should have received a copy of the GNU Lesser General Public |
14 | * License along with this library; if not, write to the Free Software | |
92205699 | 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 16 | */ |
1bbd0b84 | 17 | |
1bbd0b84 | 18 | |
1d9ee7c7 MD |
19 | \f |
20 | ||
da7f71d7 MD |
21 | /* This file and objects.h contains those minimal pieces of the Guile |
22 | * Object Oriented Programming System which need to be included in | |
23 | * libguile. See the comments in objects.h. | |
1d9ee7c7 MD |
24 | */ |
25 | ||
dbb605f5 LC |
26 | #ifdef HAVE_CONFIG_H |
27 | # include <config.h> | |
28 | #endif | |
29 | ||
a0599745 MD |
30 | #include "libguile/_scm.h" |
31 | ||
32 | #include "libguile/struct.h" | |
33 | #include "libguile/procprop.h" | |
34 | #include "libguile/chars.h" | |
35 | #include "libguile/keywords.h" | |
36 | #include "libguile/smob.h" | |
37 | #include "libguile/eval.h" | |
38 | #include "libguile/alist.h" | |
39 | #include "libguile/ports.h" | |
40 | #include "libguile/strings.h" | |
41 | #include "libguile/vectors.h" | |
42 | ||
43 | #include "libguile/validate.h" | |
44 | #include "libguile/objects.h" | |
38c9cccb MV |
45 | #include "libguile/goops.h" |
46 | ||
1d9ee7c7 MD |
47 | \f |
48 | ||
49 | SCM scm_metaclass_standard; | |
da7f71d7 | 50 | SCM scm_metaclass_operator; |
1d9ee7c7 | 51 | |
5843e5c9 DH |
52 | /* The cache argument for scm_mcache_lookup_cmethod has one of two possible |
53 | * formats: | |
54 | * | |
55 | * Format #1: | |
56 | * (SCM_IM_DISPATCH ARGS N-SPECIALIZED | |
a12be546 MD |
57 | * #((TYPE1 ... ENV FORMALS FORM ...) ...) |
58 | * GF) | |
59 | * | |
5843e5c9 | 60 | * Format #2: |
a12be546 MD |
61 | * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK |
62 | * #((TYPE1 ... ENV FORMALS FORM ...) ...) | |
63 | * GF) | |
64 | * | |
65 | * ARGS is either a list of expressions, in which case they | |
66 | * are interpreted as the arguments of an application, or | |
67 | * a non-pair, which is interpreted as a single expression | |
68 | * yielding all arguments. | |
69 | * | |
70 | * SCM_IM_DISPATCH expressions in generic functions always | |
71 | * have ARGS = the symbol `args' or the iloc #@0-0. | |
72 | * | |
73 | * Need FORMALS in order to support varying arity. This | |
74 | * also avoids the need for renaming of bindings. | |
75 | * | |
76 | * We should probably not complicate this mechanism by | |
77 | * introducing "optimizations" for getters and setters or | |
78 | * primitive methods. Getters and setter will normally be | |
79 | * compiled into @slot-[ref|set!] or a procedure call. | |
80 | * They rely on the dispatch performed before executing | |
81 | * the code which contains them. | |
82 | * | |
83 | * We might want to use a more efficient representation of | |
84 | * this form in the future, perhaps after we have introduced | |
85 | * low-level support for syntax-case macros. | |
86 | */ | |
87 | ||
9de33deb MD |
88 | SCM |
89 | scm_mcache_lookup_cmethod (SCM cache, SCM args) | |
90 | { | |
e11e83f3 | 91 | unsigned long i, mask, n, end; |
9de33deb | 92 | SCM ls, methods, z = SCM_CDDR (cache); |
e11e83f3 | 93 | n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */ |
9de33deb MD |
94 | methods = SCM_CADR (z); |
95 | ||
4057a3e0 | 96 | if (scm_is_simple_vector (methods)) |
e11e83f3 MV |
97 | { |
98 | /* cache format #1: prepare for linear search */ | |
99 | mask = -1; | |
100 | i = 0; | |
4057a3e0 | 101 | end = SCM_SIMPLE_VECTOR_LENGTH (methods); |
e11e83f3 MV |
102 | } |
103 | else | |
9de33deb | 104 | { |
5843e5c9 | 105 | /* cache format #2: compute a hash value */ |
e11e83f3 | 106 | unsigned long hashset = scm_to_ulong (methods); |
c014a02e | 107 | long j = n; |
bab246f3 | 108 | z = SCM_CDDR (z); |
e11e83f3 | 109 | mask = scm_to_ulong (SCM_CAR (z)); |
9de33deb MD |
110 | methods = SCM_CADR (z); |
111 | i = 0; | |
112 | ls = args; | |
d2e53ed6 | 113 | if (!scm_is_null (ls)) |
a12be546 MD |
114 | do |
115 | { | |
d8c40b9f DH |
116 | i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls))) |
117 | [scm_si_hashsets + hashset]; | |
a12be546 MD |
118 | ls = SCM_CDR (ls); |
119 | } | |
d2e53ed6 | 120 | while (j-- && !scm_is_null (ls)); |
9de33deb MD |
121 | i &= mask; |
122 | end = i; | |
123 | } | |
124 | ||
125 | /* Search for match */ | |
126 | do | |
127 | { | |
c014a02e | 128 | long j = n; |
4057a3e0 | 129 | z = SCM_SIMPLE_VECTOR_REF (methods, i); |
9de33deb | 130 | ls = args; /* list of arguments */ |
d2e53ed6 | 131 | if (!scm_is_null (ls)) |
a12be546 MD |
132 | do |
133 | { | |
134 | /* More arguments than specifiers => CLASS != ENV */ | |
bc36d050 | 135 | if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z))) |
a12be546 MD |
136 | goto next_method; |
137 | ls = SCM_CDR (ls); | |
138 | z = SCM_CDR (z); | |
139 | } | |
d2e53ed6 | 140 | while (j-- && !scm_is_null (ls)); |
9de33deb | 141 | /* Fewer arguments than specifiers => CAR != ENV */ |
d2e53ed6 | 142 | if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z))) |
5843e5c9 | 143 | return z; |
9de33deb MD |
144 | next_method: |
145 | i = (i + 1) & mask; | |
146 | } while (i != end); | |
147 | return SCM_BOOL_F; | |
148 | } | |
149 | ||
150 | SCM | |
a12be546 | 151 | scm_mcache_compute_cmethod (SCM cache, SCM args) |
9de33deb MD |
152 | { |
153 | SCM cmethod = scm_mcache_lookup_cmethod (cache, args); | |
7888309b | 154 | if (scm_is_false (cmethod)) |
9de33deb MD |
155 | /* No match - memoize */ |
156 | return scm_memoize_method (cache, args); | |
157 | return cmethod; | |
158 | } | |
159 | ||
160 | SCM | |
a12be546 | 161 | scm_apply_generic (SCM gf, SCM args) |
9de33deb | 162 | { |
a12be546 | 163 | SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args); |
9de33deb MD |
164 | return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)), |
165 | SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)), | |
166 | args, | |
167 | SCM_CMETHOD_ENV (cmethod))); | |
168 | } | |
169 | ||
170 | SCM | |
a12be546 | 171 | scm_call_generic_0 (SCM gf) |
9de33deb | 172 | { |
a12be546 | 173 | return scm_apply_generic (gf, SCM_EOL); |
9de33deb MD |
174 | } |
175 | ||
176 | SCM | |
a12be546 | 177 | scm_call_generic_1 (SCM gf, SCM a1) |
9de33deb | 178 | { |
1afff620 | 179 | return scm_apply_generic (gf, scm_list_1 (a1)); |
9de33deb MD |
180 | } |
181 | ||
182 | SCM | |
a12be546 MD |
183 | scm_call_generic_2 (SCM gf, SCM a1, SCM a2) |
184 | { | |
1afff620 | 185 | return scm_apply_generic (gf, scm_list_2 (a1, a2)); |
a12be546 MD |
186 | } |
187 | ||
188 | SCM | |
189 | scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) | |
9de33deb | 190 | { |
1afff620 | 191 | return scm_apply_generic (gf, scm_list_3 (a1, a2, a3)); |
9de33deb MD |
192 | } |
193 | ||
a1ec6916 | 194 | SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, |
1bbd0b84 | 195 | (SCM obj), |
99ca0a7f | 196 | "Return @code{#t} if @var{obj} is an entity.") |
1bbd0b84 | 197 | #define FUNC_NAME s_scm_entity_p |
19c0dec2 | 198 | { |
7888309b | 199 | return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj)); |
19c0dec2 | 200 | } |
1bbd0b84 | 201 | #undef FUNC_NAME |
19c0dec2 | 202 | |
a1ec6916 | 203 | SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0, |
1bbd0b84 | 204 | (SCM obj), |
99ca0a7f | 205 | "Return @code{#t} if @var{obj} is an operator.") |
1bbd0b84 | 206 | #define FUNC_NAME s_scm_operator_p |
a43a8375 | 207 | { |
7888309b | 208 | return scm_from_bool(SCM_STRUCTP (obj) |
1bbd0b84 GB |
209 | && SCM_I_OPERATORP (obj) |
210 | && !SCM_I_ENTITYP (obj)); | |
a43a8375 | 211 | } |
1bbd0b84 | 212 | #undef FUNC_NAME |
a43a8375 | 213 | |
cec0d28c MV |
214 | /* XXX - What code requires the object procedure to be only of certain |
215 | types? */ | |
216 | ||
217 | SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0, | |
218 | (SCM proc), | |
219 | "Return @code{#t} iff @var{proc} is a procedure that can be used " | |
220 | "with @code{set-object-procedure}. It is always valid to use " | |
221 | "a closure constructed by @code{lambda}.") | |
222 | #define FUNC_NAME s_scm_valid_object_procedure_p | |
223 | { | |
224 | if (SCM_IMP (proc)) | |
225 | return SCM_BOOL_F; | |
226 | switch (SCM_TYP7 (proc)) | |
227 | { | |
228 | default: | |
229 | return SCM_BOOL_F; | |
230 | case scm_tcs_closures: | |
231 | case scm_tc7_subr_1: | |
232 | case scm_tc7_subr_2: | |
233 | case scm_tc7_subr_3: | |
234 | case scm_tc7_lsubr_2: | |
235 | return SCM_BOOL_T; | |
236 | } | |
237 | } | |
238 | #undef FUNC_NAME | |
239 | ||
a1ec6916 | 240 | SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, |
1bbd0b84 | 241 | (SCM obj, SCM proc), |
cec0d28c | 242 | "Set the object procedure of @var{obj} to @var{proc}.\n" |
99ca0a7f | 243 | "@var{obj} must be either an entity or an operator.") |
1bbd0b84 | 244 | #define FUNC_NAME s_scm_set_object_procedure_x |
47b21050 | 245 | { |
0c95b57d | 246 | SCM_ASSERT (SCM_STRUCTP (obj) |
c1a6fd8f MD |
247 | && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) |
248 | || (SCM_I_ENTITYP (obj) | |
249 | && !(SCM_OBJ_CLASS_FLAGS (obj) | |
250 | & SCM_CLASSF_PURE_GENERIC))), | |
47b21050 MD |
251 | obj, |
252 | SCM_ARG1, | |
1bbd0b84 | 253 | FUNC_NAME); |
cec0d28c | 254 | SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME); |
a12be546 | 255 | if (SCM_I_ENTITYP (obj)) |
d8c40b9f | 256 | SCM_SET_ENTITY_PROCEDURE (obj, proc); |
a12be546 MD |
257 | else |
258 | SCM_OPERATOR_CLASS (obj)->procedure = proc; | |
47b21050 MD |
259 | return SCM_UNSPECIFIED; |
260 | } | |
1bbd0b84 | 261 | #undef FUNC_NAME |
47b21050 | 262 | |
a43a8375 | 263 | #ifdef GUILE_DEBUG |
a1ec6916 | 264 | SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0, |
1bbd0b84 | 265 | (SCM obj), |
99ca0a7f MG |
266 | "Return the object procedure of @var{obj}. @var{obj} must be\n" |
267 | "an entity or an operator.") | |
1bbd0b84 | 268 | #define FUNC_NAME s_scm_object_procedure |
a43a8375 | 269 | { |
0c95b57d | 270 | SCM_ASSERT (SCM_STRUCTP (obj) |
a12be546 MD |
271 | && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) |
272 | || SCM_I_ENTITYP (obj)), | |
1bbd0b84 | 273 | obj, SCM_ARG1, FUNC_NAME); |
a43a8375 | 274 | return (SCM_I_ENTITYP (obj) |
a12be546 MD |
275 | ? SCM_ENTITY_PROCEDURE (obj) |
276 | : SCM_OPERATOR_CLASS (obj)->procedure); | |
a43a8375 | 277 | } |
1bbd0b84 | 278 | #undef FUNC_NAME |
a43a8375 MD |
279 | #endif /* GUILE_DEBUG */ |
280 | ||
ed6e0c83 MD |
281 | /* The following procedures are not a part of Goops but a minimal |
282 | * object system built upon structs. They are here for those who | |
283 | * want to implement their own object system. | |
284 | */ | |
285 | ||
036737fc MD |
286 | SCM |
287 | scm_i_make_class_object (SCM meta, | |
288 | SCM layout_string, | |
c014a02e | 289 | unsigned long flags) |
47b21050 MD |
290 | { |
291 | SCM c; | |
036737fc | 292 | SCM layout = scm_make_struct_layout (layout_string); |
47b21050 MD |
293 | c = scm_make_struct (meta, |
294 | SCM_INUM0, | |
1afff620 | 295 | scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL)); |
47b21050 MD |
296 | SCM_SET_CLASS_FLAGS (c, flags); |
297 | return c; | |
298 | } | |
299 | ||
a1ec6916 | 300 | SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, |
1bbd0b84 | 301 | (SCM metaclass, SCM layout), |
99ca0a7f MG |
302 | "Create a new class object of class @var{metaclass}, with the\n" |
303 | "slot layout specified by @var{layout}.") | |
1bbd0b84 | 304 | #define FUNC_NAME s_scm_make_class_object |
47b21050 | 305 | { |
c014a02e | 306 | unsigned long flags = 0; |
34d19ef6 HWN |
307 | SCM_VALIDATE_STRUCT (1, metaclass); |
308 | SCM_VALIDATE_STRING (2, layout); | |
bc36d050 | 309 | if (scm_is_eq (metaclass, scm_metaclass_operator)) |
47b21050 | 310 | flags = SCM_CLASSF_OPERATOR; |
036737fc | 311 | return scm_i_make_class_object (metaclass, layout, flags); |
47b21050 | 312 | } |
1bbd0b84 | 313 | #undef FUNC_NAME |
47b21050 | 314 | |
a1ec6916 | 315 | SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, |
1bbd0b84 | 316 | (SCM class, SCM layout), |
99ca0a7f MG |
317 | "Create a subclass object of @var{class}, with the slot layout\n" |
318 | "specified by @var{layout}.") | |
1bbd0b84 | 319 | #define FUNC_NAME s_scm_make_subclass_object |
47b21050 MD |
320 | { |
321 | SCM pl; | |
34d19ef6 HWN |
322 | SCM_VALIDATE_STRUCT (1, class); |
323 | SCM_VALIDATE_STRING (2, layout); | |
d8c40b9f | 324 | pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]); |
cc95e00a | 325 | pl = scm_symbol_to_string (pl); |
036737fc | 326 | return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), |
1afff620 | 327 | scm_string_append (scm_list_2 (pl, layout)), |
036737fc | 328 | SCM_CLASS_FLAGS (class)); |
47b21050 | 329 | } |
1bbd0b84 | 330 | #undef FUNC_NAME |
47b21050 | 331 | |
1d9ee7c7 MD |
332 | void |
333 | scm_init_objects () | |
334 | { | |
cc95e00a | 335 | SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT); |
3ce4544c | 336 | SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0, |
1afff620 | 337 | scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); |
1d9ee7c7 | 338 | |
cc95e00a | 339 | SCM os = scm_from_locale_string (SCM_METACLASS_OPERATOR_LAYOUT); |
3ce4544c | 340 | SCM ot = scm_make_vtable_vtable (os, SCM_INUM0, |
1afff620 | 341 | scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); |
da7f71d7 | 342 | |
cc95e00a | 343 | SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT); |
1d9ee7c7 MD |
344 | SCM el = scm_make_struct_layout (es); |
345 | SCM et = scm_make_struct (mt, SCM_INUM0, | |
1afff620 | 346 | scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); |
1d9ee7c7 | 347 | |
86d31dfe | 348 | scm_c_define ("<class>", mt); |
1d9ee7c7 | 349 | scm_metaclass_standard = mt; |
86d31dfe | 350 | scm_c_define ("<operator-class>", ot); |
da7f71d7 MD |
351 | scm_metaclass_operator = ot; |
352 | SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); | |
86d31dfe | 353 | scm_c_define ("<entity>", et); |
47b21050 | 354 | |
a0599745 | 355 | #include "libguile/objects.x" |
1d9ee7c7 | 356 | } |
89e00824 ML |
357 | |
358 | /* | |
359 | Local Variables: | |
360 | c-file-style: "gnu" | |
361 | End: | |
362 | */ |