Commit | Line | Data |
---|---|---|
74b6d6e4 | 1 | /* Copyright (C) 1995,1996,1999,2000,2001, 2003 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 | |
15 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
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 | ||
a0599745 MD |
26 | #include "libguile/_scm.h" |
27 | ||
28 | #include "libguile/struct.h" | |
29 | #include "libguile/procprop.h" | |
30 | #include "libguile/chars.h" | |
31 | #include "libguile/keywords.h" | |
32 | #include "libguile/smob.h" | |
33 | #include "libguile/eval.h" | |
34 | #include "libguile/alist.h" | |
35 | #include "libguile/ports.h" | |
36 | #include "libguile/strings.h" | |
37 | #include "libguile/vectors.h" | |
38 | ||
39 | #include "libguile/validate.h" | |
40 | #include "libguile/objects.h" | |
1d9ee7c7 MD |
41 | \f |
42 | ||
43 | SCM scm_metaclass_standard; | |
da7f71d7 | 44 | SCM scm_metaclass_operator; |
1d9ee7c7 | 45 | |
ab7288bc MD |
46 | /* These variables are filled in by the object system when loaded. */ |
47 | SCM scm_class_boolean, scm_class_char, scm_class_pair; | |
48 | SCM scm_class_procedure, scm_class_string, scm_class_symbol; | |
9de33deb | 49 | SCM scm_class_procedure_with_setter, scm_class_primitive_generic; |
ab7288bc | 50 | SCM scm_class_vector, scm_class_null; |
f92e85f7 | 51 | SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction; |
ed6e0c83 | 52 | SCM scm_class_unknown; |
ab7288bc | 53 | |
d0efbe61 | 54 | SCM *scm_port_class = 0; |
ed6e0c83 MD |
55 | SCM *scm_smob_class = 0; |
56 | ||
9de33deb MD |
57 | SCM scm_no_applicable_method; |
58 | ||
ab7288bc | 59 | /* This function is used for efficient type dispatch. */ |
398d8ee1 KN |
60 | SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, |
61 | (SCM x), | |
99ca0a7f | 62 | "Return the class of @var{x}.") |
398d8ee1 | 63 | #define FUNC_NAME s_scm_class_of |
ab7288bc MD |
64 | { |
65 | switch (SCM_ITAG3 (x)) | |
66 | { | |
67 | case scm_tc3_int_1: | |
68 | case scm_tc3_int_2: | |
69 | return scm_class_integer; | |
70 | ||
71 | case scm_tc3_imm24: | |
7866a09b | 72 | if (SCM_CHARP (x)) |
ab7288bc | 73 | return scm_class_char; |
7888309b | 74 | else if (scm_is_bool (x)) |
e17d318f DH |
75 | return scm_class_boolean; |
76 | else if (SCM_NULLP (x)) | |
77 | return scm_class_null; | |
ab7288bc | 78 | else |
e17d318f | 79 | return scm_class_unknown; |
ab7288bc MD |
80 | |
81 | case scm_tc3_cons: | |
82 | switch (SCM_TYP7 (x)) | |
83 | { | |
84 | case scm_tcs_cons_nimcar: | |
85 | return scm_class_pair; | |
86 | case scm_tcs_closures: | |
87 | return scm_class_procedure; | |
28b06554 | 88 | case scm_tc7_symbol: |
ab7288bc MD |
89 | return scm_class_symbol; |
90 | case scm_tc7_vector: | |
91 | case scm_tc7_wvect: | |
b645bf74 | 92 | #if SCM_HAVE_ARRAYS |
ab7288bc MD |
93 | case scm_tc7_bvect: |
94 | case scm_tc7_byvect: | |
95 | case scm_tc7_svect: | |
96 | case scm_tc7_ivect: | |
97 | case scm_tc7_uvect: | |
98 | case scm_tc7_fvect: | |
99 | case scm_tc7_dvect: | |
100 | case scm_tc7_cvect: | |
afe5177e | 101 | #endif |
ab7288bc MD |
102 | return scm_class_vector; |
103 | case scm_tc7_string: | |
ab7288bc | 104 | return scm_class_string; |
534c55a9 DH |
105 | case scm_tc7_number: |
106 | switch SCM_TYP16 (x) { | |
107 | case scm_tc16_big: | |
108 | return scm_class_integer; | |
109 | case scm_tc16_real: | |
110 | return scm_class_real; | |
111 | case scm_tc16_complex: | |
112 | return scm_class_complex; | |
f92e85f7 MV |
113 | case scm_tc16_fraction: |
114 | return scm_class_fraction; | |
534c55a9 | 115 | } |
ab7288bc MD |
116 | case scm_tc7_asubr: |
117 | case scm_tc7_subr_0: | |
118 | case scm_tc7_subr_1: | |
14b18ed6 | 119 | case scm_tc7_dsubr: |
ab7288bc MD |
120 | case scm_tc7_cxr: |
121 | case scm_tc7_subr_3: | |
122 | case scm_tc7_subr_2: | |
123 | case scm_tc7_rpsubr: | |
124 | case scm_tc7_subr_1o: | |
125 | case scm_tc7_subr_2o: | |
126 | case scm_tc7_lsubr_2: | |
127 | case scm_tc7_lsubr: | |
9de33deb MD |
128 | if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x)) |
129 | return scm_class_primitive_generic; | |
130 | else | |
131 | return scm_class_procedure; | |
ed6e0c83 | 132 | case scm_tc7_cclo: |
ab7288bc MD |
133 | return scm_class_procedure; |
134 | case scm_tc7_pws: | |
135 | return scm_class_procedure_with_setter; | |
136 | ||
ab7288bc MD |
137 | case scm_tc7_smob: |
138 | { | |
5843e5c9 | 139 | scm_t_bits type = SCM_TYP16 (x); |
950cc72b | 140 | if (type != scm_tc16_port_with_ps) |
ed6e0c83 | 141 | return scm_smob_class[SCM_TC2SMOBNUM (type)]; |
55d54750 MD |
142 | x = SCM_PORT_WITH_PS_PORT (x); |
143 | /* fall through to ports */ | |
ab7288bc | 144 | } |
55d54750 | 145 | case scm_tc7_port: |
206d3de3 DH |
146 | return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x) |
147 | ? (SCM_RDNG & SCM_CELL_WORD_0 (x) | |
55d54750 MD |
148 | ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x) |
149 | : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x)) | |
150 | : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))]; | |
904a077d | 151 | case scm_tcs_struct: |
7151229d MD |
152 | if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID) |
153 | return SCM_CLASS_OF (x); | |
154 | else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS) | |
ed6e0c83 MD |
155 | { |
156 | /* Goops object */ | |
7888309b | 157 | if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x))) |
ed6e0c83 MD |
158 | scm_change_object_class (x, |
159 | SCM_CLASS_OF (x), /* old */ | |
160 | SCM_OBJ_CLASS_REDEF (x)); /* new */ | |
161 | return SCM_CLASS_OF (x); | |
162 | } | |
163 | else | |
164 | { | |
165 | /* ordinary struct */ | |
166 | SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x)); | |
7888309b | 167 | if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)))) |
ed6e0c83 MD |
168 | return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle)); |
169 | else | |
170 | { | |
171 | SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle)); | |
7888309b | 172 | SCM class = scm_make_extended_class (scm_is_true (name) |
b24b5e13 | 173 | ? SCM_SYMBOL_CHARS (name) |
74b6d6e4 MD |
174 | : 0, |
175 | SCM_I_OPERATORP (x)); | |
11f2a643 | 176 | SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); |
ed6e0c83 MD |
177 | return class; |
178 | } | |
179 | } | |
ab7288bc MD |
180 | default: |
181 | if (SCM_CONSP (x)) | |
182 | return scm_class_pair; | |
183 | else | |
184 | return scm_class_unknown; | |
185 | } | |
186 | ||
904a077d | 187 | case scm_tc3_struct: |
ab7288bc MD |
188 | case scm_tc3_tc7_1: |
189 | case scm_tc3_tc7_2: | |
190 | case scm_tc3_closure: | |
191 | /* Never reached */ | |
192 | break; | |
193 | } | |
194 | return scm_class_unknown; | |
195 | } | |
398d8ee1 | 196 | #undef FUNC_NAME |
ab7288bc | 197 | |
5843e5c9 DH |
198 | /* The cache argument for scm_mcache_lookup_cmethod has one of two possible |
199 | * formats: | |
200 | * | |
201 | * Format #1: | |
202 | * (SCM_IM_DISPATCH ARGS N-SPECIALIZED | |
a12be546 MD |
203 | * #((TYPE1 ... ENV FORMALS FORM ...) ...) |
204 | * GF) | |
205 | * | |
5843e5c9 | 206 | * Format #2: |
a12be546 MD |
207 | * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK |
208 | * #((TYPE1 ... ENV FORMALS FORM ...) ...) | |
209 | * GF) | |
210 | * | |
211 | * ARGS is either a list of expressions, in which case they | |
212 | * are interpreted as the arguments of an application, or | |
213 | * a non-pair, which is interpreted as a single expression | |
214 | * yielding all arguments. | |
215 | * | |
216 | * SCM_IM_DISPATCH expressions in generic functions always | |
217 | * have ARGS = the symbol `args' or the iloc #@0-0. | |
218 | * | |
219 | * Need FORMALS in order to support varying arity. This | |
220 | * also avoids the need for renaming of bindings. | |
221 | * | |
222 | * We should probably not complicate this mechanism by | |
223 | * introducing "optimizations" for getters and setters or | |
224 | * primitive methods. Getters and setter will normally be | |
225 | * compiled into @slot-[ref|set!] or a procedure call. | |
226 | * They rely on the dispatch performed before executing | |
227 | * the code which contains them. | |
228 | * | |
229 | * We might want to use a more efficient representation of | |
230 | * this form in the future, perhaps after we have introduced | |
231 | * low-level support for syntax-case macros. | |
232 | */ | |
233 | ||
9de33deb MD |
234 | SCM |
235 | scm_mcache_lookup_cmethod (SCM cache, SCM args) | |
236 | { | |
e11e83f3 | 237 | unsigned long i, mask, n, end; |
9de33deb | 238 | SCM ls, methods, z = SCM_CDDR (cache); |
e11e83f3 | 239 | n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */ |
9de33deb MD |
240 | methods = SCM_CADR (z); |
241 | ||
e11e83f3 MV |
242 | if (SCM_VECTORP (methods)) |
243 | { | |
244 | /* cache format #1: prepare for linear search */ | |
245 | mask = -1; | |
246 | i = 0; | |
247 | end = SCM_VECTOR_LENGTH (methods); | |
248 | } | |
249 | else | |
9de33deb | 250 | { |
5843e5c9 | 251 | /* cache format #2: compute a hash value */ |
e11e83f3 | 252 | unsigned long hashset = scm_to_ulong (methods); |
c014a02e | 253 | long j = n; |
bab246f3 | 254 | z = SCM_CDDR (z); |
e11e83f3 | 255 | mask = scm_to_ulong (SCM_CAR (z)); |
9de33deb MD |
256 | methods = SCM_CADR (z); |
257 | i = 0; | |
258 | ls = args; | |
5843e5c9 | 259 | if (!SCM_NULLP (ls)) |
a12be546 MD |
260 | do |
261 | { | |
d8c40b9f DH |
262 | i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls))) |
263 | [scm_si_hashsets + hashset]; | |
a12be546 MD |
264 | ls = SCM_CDR (ls); |
265 | } | |
5843e5c9 | 266 | while (j-- && !SCM_NULLP (ls)); |
9de33deb MD |
267 | i &= mask; |
268 | end = i; | |
269 | } | |
270 | ||
271 | /* Search for match */ | |
272 | do | |
273 | { | |
c014a02e | 274 | long j = n; |
9de33deb MD |
275 | z = SCM_VELTS (methods)[i]; |
276 | ls = args; /* list of arguments */ | |
5843e5c9 | 277 | if (!SCM_NULLP (ls)) |
a12be546 MD |
278 | do |
279 | { | |
280 | /* More arguments than specifiers => CLASS != ENV */ | |
bc36d050 | 281 | if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z))) |
a12be546 MD |
282 | goto next_method; |
283 | ls = SCM_CDR (ls); | |
284 | z = SCM_CDR (z); | |
285 | } | |
5843e5c9 | 286 | while (j-- && !SCM_NULLP (ls)); |
9de33deb | 287 | /* Fewer arguments than specifiers => CAR != ENV */ |
5843e5c9 DH |
288 | if (SCM_NULLP (SCM_CAR (z)) || SCM_CONSP (SCM_CAR (z))) |
289 | return z; | |
9de33deb MD |
290 | next_method: |
291 | i = (i + 1) & mask; | |
292 | } while (i != end); | |
293 | return SCM_BOOL_F; | |
294 | } | |
295 | ||
296 | SCM | |
a12be546 | 297 | scm_mcache_compute_cmethod (SCM cache, SCM args) |
9de33deb MD |
298 | { |
299 | SCM cmethod = scm_mcache_lookup_cmethod (cache, args); | |
7888309b | 300 | if (scm_is_false (cmethod)) |
9de33deb MD |
301 | /* No match - memoize */ |
302 | return scm_memoize_method (cache, args); | |
303 | return cmethod; | |
304 | } | |
305 | ||
306 | SCM | |
a12be546 | 307 | scm_apply_generic (SCM gf, SCM args) |
9de33deb | 308 | { |
a12be546 | 309 | SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args); |
9de33deb MD |
310 | return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)), |
311 | SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)), | |
312 | args, | |
313 | SCM_CMETHOD_ENV (cmethod))); | |
314 | } | |
315 | ||
316 | SCM | |
a12be546 | 317 | scm_call_generic_0 (SCM gf) |
9de33deb | 318 | { |
a12be546 | 319 | return scm_apply_generic (gf, SCM_EOL); |
9de33deb MD |
320 | } |
321 | ||
322 | SCM | |
a12be546 | 323 | scm_call_generic_1 (SCM gf, SCM a1) |
9de33deb | 324 | { |
1afff620 | 325 | return scm_apply_generic (gf, scm_list_1 (a1)); |
9de33deb MD |
326 | } |
327 | ||
328 | SCM | |
a12be546 MD |
329 | scm_call_generic_2 (SCM gf, SCM a1, SCM a2) |
330 | { | |
1afff620 | 331 | return scm_apply_generic (gf, scm_list_2 (a1, a2)); |
a12be546 MD |
332 | } |
333 | ||
334 | SCM | |
335 | scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) | |
9de33deb | 336 | { |
1afff620 | 337 | return scm_apply_generic (gf, scm_list_3 (a1, a2, a3)); |
9de33deb MD |
338 | } |
339 | ||
a1ec6916 | 340 | SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, |
1bbd0b84 | 341 | (SCM obj), |
99ca0a7f | 342 | "Return @code{#t} if @var{obj} is an entity.") |
1bbd0b84 | 343 | #define FUNC_NAME s_scm_entity_p |
19c0dec2 | 344 | { |
7888309b | 345 | return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj)); |
19c0dec2 | 346 | } |
1bbd0b84 | 347 | #undef FUNC_NAME |
19c0dec2 | 348 | |
a1ec6916 | 349 | SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0, |
1bbd0b84 | 350 | (SCM obj), |
99ca0a7f | 351 | "Return @code{#t} if @var{obj} is an operator.") |
1bbd0b84 | 352 | #define FUNC_NAME s_scm_operator_p |
a43a8375 | 353 | { |
7888309b | 354 | return scm_from_bool(SCM_STRUCTP (obj) |
1bbd0b84 GB |
355 | && SCM_I_OPERATORP (obj) |
356 | && !SCM_I_ENTITYP (obj)); | |
a43a8375 | 357 | } |
1bbd0b84 | 358 | #undef FUNC_NAME |
a43a8375 | 359 | |
cec0d28c MV |
360 | /* XXX - What code requires the object procedure to be only of certain |
361 | types? */ | |
362 | ||
363 | SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0, | |
364 | (SCM proc), | |
365 | "Return @code{#t} iff @var{proc} is a procedure that can be used " | |
366 | "with @code{set-object-procedure}. It is always valid to use " | |
367 | "a closure constructed by @code{lambda}.") | |
368 | #define FUNC_NAME s_scm_valid_object_procedure_p | |
369 | { | |
370 | if (SCM_IMP (proc)) | |
371 | return SCM_BOOL_F; | |
372 | switch (SCM_TYP7 (proc)) | |
373 | { | |
374 | default: | |
375 | return SCM_BOOL_F; | |
376 | case scm_tcs_closures: | |
377 | case scm_tc7_subr_1: | |
378 | case scm_tc7_subr_2: | |
379 | case scm_tc7_subr_3: | |
380 | case scm_tc7_lsubr_2: | |
381 | return SCM_BOOL_T; | |
382 | } | |
383 | } | |
384 | #undef FUNC_NAME | |
385 | ||
a1ec6916 | 386 | SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0, |
1bbd0b84 | 387 | (SCM obj, SCM proc), |
cec0d28c | 388 | "Set the object procedure of @var{obj} to @var{proc}.\n" |
99ca0a7f | 389 | "@var{obj} must be either an entity or an operator.") |
1bbd0b84 | 390 | #define FUNC_NAME s_scm_set_object_procedure_x |
47b21050 | 391 | { |
0c95b57d | 392 | SCM_ASSERT (SCM_STRUCTP (obj) |
c1a6fd8f MD |
393 | && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) |
394 | || (SCM_I_ENTITYP (obj) | |
395 | && !(SCM_OBJ_CLASS_FLAGS (obj) | |
396 | & SCM_CLASSF_PURE_GENERIC))), | |
47b21050 MD |
397 | obj, |
398 | SCM_ARG1, | |
1bbd0b84 | 399 | FUNC_NAME); |
cec0d28c | 400 | SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME); |
a12be546 | 401 | if (SCM_I_ENTITYP (obj)) |
d8c40b9f | 402 | SCM_SET_ENTITY_PROCEDURE (obj, proc); |
a12be546 MD |
403 | else |
404 | SCM_OPERATOR_CLASS (obj)->procedure = proc; | |
47b21050 MD |
405 | return SCM_UNSPECIFIED; |
406 | } | |
1bbd0b84 | 407 | #undef FUNC_NAME |
47b21050 | 408 | |
a43a8375 | 409 | #ifdef GUILE_DEBUG |
a1ec6916 | 410 | SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0, |
1bbd0b84 | 411 | (SCM obj), |
99ca0a7f MG |
412 | "Return the object procedure of @var{obj}. @var{obj} must be\n" |
413 | "an entity or an operator.") | |
1bbd0b84 | 414 | #define FUNC_NAME s_scm_object_procedure |
a43a8375 | 415 | { |
0c95b57d | 416 | SCM_ASSERT (SCM_STRUCTP (obj) |
a12be546 MD |
417 | && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) |
418 | || SCM_I_ENTITYP (obj)), | |
1bbd0b84 | 419 | obj, SCM_ARG1, FUNC_NAME); |
a43a8375 | 420 | return (SCM_I_ENTITYP (obj) |
a12be546 MD |
421 | ? SCM_ENTITY_PROCEDURE (obj) |
422 | : SCM_OPERATOR_CLASS (obj)->procedure); | |
a43a8375 | 423 | } |
1bbd0b84 | 424 | #undef FUNC_NAME |
a43a8375 MD |
425 | #endif /* GUILE_DEBUG */ |
426 | ||
ed6e0c83 MD |
427 | /* The following procedures are not a part of Goops but a minimal |
428 | * object system built upon structs. They are here for those who | |
429 | * want to implement their own object system. | |
430 | */ | |
431 | ||
036737fc MD |
432 | SCM |
433 | scm_i_make_class_object (SCM meta, | |
434 | SCM layout_string, | |
c014a02e | 435 | unsigned long flags) |
47b21050 MD |
436 | { |
437 | SCM c; | |
036737fc | 438 | SCM layout = scm_make_struct_layout (layout_string); |
47b21050 MD |
439 | c = scm_make_struct (meta, |
440 | SCM_INUM0, | |
1afff620 | 441 | scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL)); |
47b21050 MD |
442 | SCM_SET_CLASS_FLAGS (c, flags); |
443 | return c; | |
444 | } | |
445 | ||
a1ec6916 | 446 | SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0, |
1bbd0b84 | 447 | (SCM metaclass, SCM layout), |
99ca0a7f MG |
448 | "Create a new class object of class @var{metaclass}, with the\n" |
449 | "slot layout specified by @var{layout}.") | |
1bbd0b84 | 450 | #define FUNC_NAME s_scm_make_class_object |
47b21050 | 451 | { |
c014a02e | 452 | unsigned long flags = 0; |
34d19ef6 HWN |
453 | SCM_VALIDATE_STRUCT (1, metaclass); |
454 | SCM_VALIDATE_STRING (2, layout); | |
bc36d050 | 455 | if (scm_is_eq (metaclass, scm_metaclass_operator)) |
47b21050 | 456 | flags = SCM_CLASSF_OPERATOR; |
036737fc | 457 | return scm_i_make_class_object (metaclass, layout, flags); |
47b21050 | 458 | } |
1bbd0b84 | 459 | #undef FUNC_NAME |
47b21050 | 460 | |
a1ec6916 | 461 | SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, |
1bbd0b84 | 462 | (SCM class, SCM layout), |
99ca0a7f MG |
463 | "Create a subclass object of @var{class}, with the slot layout\n" |
464 | "specified by @var{layout}.") | |
1bbd0b84 | 465 | #define FUNC_NAME s_scm_make_subclass_object |
47b21050 MD |
466 | { |
467 | SCM pl; | |
34d19ef6 HWN |
468 | SCM_VALIDATE_STRUCT (1, class); |
469 | SCM_VALIDATE_STRING (2, layout); | |
d8c40b9f | 470 | pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]); |
036737fc | 471 | /* Convert symbol->string */ |
36284627 | 472 | pl = scm_mem2string (SCM_SYMBOL_CHARS (pl), SCM_SYMBOL_LENGTH (pl)); |
036737fc | 473 | return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), |
1afff620 | 474 | scm_string_append (scm_list_2 (pl, layout)), |
036737fc | 475 | SCM_CLASS_FLAGS (class)); |
47b21050 | 476 | } |
1bbd0b84 | 477 | #undef FUNC_NAME |
47b21050 | 478 | |
1d9ee7c7 MD |
479 | void |
480 | scm_init_objects () | |
481 | { | |
482 | SCM ms = scm_makfrom0str (SCM_METACLASS_STANDARD_LAYOUT); | |
3ce4544c | 483 | SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0, |
1afff620 | 484 | scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); |
1d9ee7c7 | 485 | |
da7f71d7 | 486 | SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT); |
3ce4544c | 487 | SCM ot = scm_make_vtable_vtable (os, SCM_INUM0, |
1afff620 | 488 | scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); |
da7f71d7 | 489 | |
1d9ee7c7 MD |
490 | SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT); |
491 | SCM el = scm_make_struct_layout (es); | |
492 | SCM et = scm_make_struct (mt, SCM_INUM0, | |
1afff620 | 493 | scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); |
1d9ee7c7 | 494 | |
86d31dfe | 495 | scm_c_define ("<class>", mt); |
1d9ee7c7 | 496 | scm_metaclass_standard = mt; |
86d31dfe | 497 | scm_c_define ("<operator-class>", ot); |
da7f71d7 MD |
498 | scm_metaclass_operator = ot; |
499 | SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); | |
135e76f8 | 500 | SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity); |
86d31dfe | 501 | scm_c_define ("<entity>", et); |
47b21050 | 502 | |
a0599745 | 503 | #include "libguile/objects.x" |
1d9ee7c7 | 504 | } |
89e00824 ML |
505 | |
506 | /* | |
507 | Local Variables: | |
508 | c-file-style: "gnu" | |
509 | End: | |
510 | */ |