1 /*-
2 * Copyright (c) 2005-2019 Michael Scholz <mi-scholz@users.sourceforge.net>
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 * 1. Redistributions of source code must retain the above copyright
9 * notice, this list of conditions and the following disclaimer.
10 * 2. Redistributions in binary form must reproduce the above copyright
11 * notice, this list of conditions and the following disclaimer in the
12 * documentation and/or other materials provided with the distribution.
13 *
14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24 * SUCH DAMAGE.
25 *
26 * @(#)object.c 2.6 2/1/19
27 */
28
29 #if defined(HAVE_CONFIG_H)
30 #include "config.h"
31 #endif
32
33 #include "fth.h"
34 #include "utils.h"
35
36 #if defined(HAVE_SYS_TIME_H)
37 #include <sys/time.h>
38 #endif
39 #if defined(HAVE_TIME_H)
40 #include <time.h>
41 #endif
42
43 /* === OBJECT === */
44
45 typedef enum {
46 OBJ_INSPECT,
47 OBJ_TO_STRING,
48 OBJ_DUMP
49 } fth_inspect_type_t;
50
51 #define FTH_INSPECT_P(Obj) FTH_INSTANCE_REF_OBJ(Obj)->inspect
52 #define FTH_TO_STRING_P(Obj) FTH_INSTANCE_REF_OBJ(Obj)->to_string
53 #define FTH_DUMP_P(Obj) FTH_INSTANCE_REF_OBJ(Obj)->dump
54 #define FTH_TO_ARRAY_P(Obj) FTH_INSTANCE_REF_OBJ(Obj)->to_array
55 #define FTH_COPY_P(Obj) FTH_INSTANCE_REF_OBJ(Obj)->copy
56 #define FTH_VALUE_REF_P(Obj) FTH_INSTANCE_REF_OBJ(Obj)->value_ref
57 #define FTH_VALUE_SET_P(Obj) FTH_INSTANCE_REF_OBJ(Obj)->value_set
58 #define FTH_EQUAL_P_P(Obj) FTH_INSTANCE_REF_OBJ(Obj)->equal_p
59 #define FTH_LENGTH_P(Obj) FTH_INSTANCE_REF_OBJ(Obj)->length
60
61 #define FTH_INSPECT(Obj) (*FTH_INSPECT_P(Obj))(Obj)
62 #define FTH_TO_STRING(Obj) (*FTH_TO_STRING_P(Obj))(Obj)
63 #define FTH_DUMP(Obj) (*FTH_DUMP_P(Obj))(Obj)
64 #define FTH_TO_ARRAY(Obj) (*FTH_TO_ARRAY_P(Obj))(Obj)
65 #define FTH_COPY(Obj) (*FTH_COPY_P(Obj))(Obj)
66 #define FTH_VALUE_REF(Obj, Idx) (*FTH_VALUE_REF_P(Obj))(Obj, Idx)
67 #define FTH_VALUE_SET(Obj, Idx, Val) \
68 (*FTH_VALUE_SET_P(Obj))(Obj, Idx, Val)
69 #define FTH_EQUAL_P(Obj1, Obj2) (*FTH_EQUAL_P_P(Obj1))(Obj1, Obj2)
70 #define FTH_LENGTH(Obj) (*FTH_LENGTH_P(Obj))(Obj)
71
72 #define OBJ_CHUNK_SIZE 64
73 #define GC_CHUNK_SIZE (1024 * 8)
74 #define GC_MAX_OBJECTS (GC_CHUNK_SIZE * 4)
75
76 #define GC_FREED 1
77 #define GC_MARK 2
78 #define GC_PROTECT 4
79 #define GC_PERMANENT 8
80
81 #define GC_MARK_SET(inst) ((inst)->gc_mark |= GC_MARK)
82 #define GC_MARK_CLR(inst) ((inst)->gc_mark &= ~GC_MARK)
83 #define GC_PROTECT_SET(inst) ((inst)->gc_mark |= GC_PROTECT)
84 #define GC_PROTECT_CLR(inst) ((inst)->gc_mark &= ~GC_PROTECT)
85 #define GC_PERMANENT_SET(inst) ((inst)->gc_mark |= GC_PERMANENT)
86 #define GC_ANY_MARK_P(inst) ((inst)->gc_mark > GC_FREED)
87 #define GC_MARKED_P(inst) ((inst)->gc_mark & GC_MARK)
88 #define GC_PROTECTED_P(inst) ((inst)->gc_mark & GC_PROTECT)
89 #define GC_PERMANENT_P(inst) ((inst)->gc_mark & GC_PERMANENT)
90
91 #define GC_FREED_SET(inst) ((inst)->gc_mark = GC_FREED)
92 #define GC_FREED_P(inst) ((inst)->gc_mark == GC_FREED)
93
94 #define gc_frame_level FTH_FICL_VM()->gc_frame_level
95 #define GC_FRAME_WORD(Idx) FTH_FICL_VM()->gc_word[Idx]
96 #define GC_FRAME_INST(Idx) FTH_FICL_VM()->gc_inst[Idx]
97 #define GC_FRAME_CURRENT_WORD() GC_FRAME_WORD(gc_frame_level)
98 #define GC_FRAME_CURRENT_INST() GC_FRAME_INST(gc_frame_level)
99
100 static void ficl_add_store_object(ficlVm *);
101 static void ficl_backtrace(ficlVm *);
102 static void ficl_boolean_p(ficlVm *);
103 static void ficl_cycle_pos_0(ficlVm *);
104 static void ficl_cycle_pos_ref(ficlVm *);
105 static void ficl_cycle_pos_set(ficlVm *);
106 static void ficl_div_store_object(ficlVm *);
107 static void ficl_false_p(ficlVm *);
108 static void ficl_first_object_ref(ficlVm *);
109 static void ficl_first_object_set(ficlVm *);
110 static void ficl_frame_depth(ficlVm *);
111 static void ficl_gc_mark(ficlVm *);
112 static void ficl_gc_marked_p(ficlVm *);
113 static void ficl_gc_permanent_objects(ficlVm *);
114 static void ficl_gc_permanent_p(ficlVm *);
115 static void ficl_gc_protected_objects(ficlVm *);
116 static void ficl_gc_protected_p(ficlVm *);
117 static void ficl_gc_run(ficlVm *);
118 static void ficl_gc_stats(ficlVm *);
119 static void ficl_gc_unmark(ficlVm *);
120 static void ficl_instance_gen_ref(ficlVm *);
121 static void ficl_instance_obj_ref(ficlVm *);
122 static void ficl_instance_p(ficlVm *);
123 static void ficl_last_object_ref(ficlVm *);
124 static void ficl_last_object_set(ficlVm *);
125 static void ficl_make_instance(ficlVm *);
126 static void ficl_make_object_type(ficlVm *);
127 static void ficl_mul_store_object(ficlVm *);
128 static void ficl_nil_p(ficlVm *);
129 static void ficl_object_cycle_set(ficlVm *);
130 static void ficl_object_debug_hook(ficlVm *);
131 static void ficl_object_empty_p(ficlVm *);
132 static void ficl_object_equal_p(ficlVm *);
133 static void ficl_object_is_instance_of(ficlVm *);
134 static void ficl_object_length(ficlVm *);
135 static void ficl_object_member_p(ficlVm *);
136 static void ficl_object_name(ficlVm *);
137 static void ficl_object_range_p(ficlVm *);
138 static void ficl_object_ref(ficlVm *);
139 static void ficl_object_set(ficlVm *);
140 static void ficl_object_type_p(ficlVm *);
141 static void ficl_object_type_ref(ficlVm *);
142 static void ficl_object_types(ficlVm *);
143 static void ficl_print_inspect(ficlVm *);
144 static void ficl_print_length(ficlVm *);
145 static void ficl_print_object_name(ficlVm *);
146 static void ficl_second_object_ref(ficlVm *);
147 static void ficl_second_object_set(ficlVm *);
148 static void ficl_set_apply(ficlVm *);
149 static void ficl_set_print_length(ficlVm *);
150 static void ficl_sub_store_object(ficlVm *);
151 static void ficl_third_object_ref(ficlVm *);
152 static void ficl_third_object_set(ficlVm *);
153 static void ficl_true_p(ficlVm *);
154 static void ficl_undef_p(ficlVm *);
155 static void ficl_xmobj_p(ficlVm *);
156 static FInstance *gc_next_instance(void);
157 static FInstance *gc_run(void);
158 static FTH print_object(FTH, fth_inspect_type_t);
159 static int xmobj_p(FTH);
160 static FTH xmobj_to_string(FTH);
161
162 #define h_list_of_object_functions "\
163 *** OBJECT PRIMITIVES ***\n\
164 backtrace ( -- )\n\
165 bt alias for backtrace\n\
166 frame-depth ( -- n )\n\
167 object-print-length ( -- n )\n\
168 set-object-print-length ( n -- )\n\
169 stack-level alias for frame-depth\n\
170 *** garbage collection:\n\
171 gc-mark ( obj -- obj )\n\
172 gc-marked? ( obj -- f )\n\
173 gc-off ( -- )\n\
174 gc-on ( -- )\n\
175 gc-permanent-objects ( -- ary )\n\
176 gc-permanent? ( obj -- f )\n\
177 gc-protect ( obj -- obj )\n\
178 gc-protected-objects ( -- ary )\n\
179 gc-protected? ( obj -- f )\n\
180 gc-run ( -- )\n\
181 gc-stats ( -- )\n\
182 gc-unmark ( obj -- obj )\n\
183 gc-unprotect ( obj -- obj )\n\
184 *** object type and instance words:\n\
185 instance-gen-ref ( obj -- gen )\n\
186 instance-obj-ref ( obj -- gen )\n\
187 instance-of? ( obj type -- f )\n\
188 instance? ( obj -- f )\n\
189 make-instance ( gen obj -- instance )\n\
190 make-object-type ( name -- object-type )\n\
191 object-type-ref ( object-type -- struct )\n\
192 object-type? ( obj -- f )\n\
193 object-types ( -- ary )\n\
194 *** object set words:\n\
195 set-object->array ( xt obj -- )\n\
196 set-object->string ( xt obj -- )\n\
197 set-object-apply ( xt obj arity -- )\n\
198 set-object-copy ( xt obj -- )\n\
199 set-object-dump ( xt obj -- )\n\
200 set-object-equal-p ( xt obj -- )\n\
201 set-object-free ( xt obj -- )\n\
202 set-object-inspect ( xt obj -- )\n\
203 set-object-length ( xt obj -- )\n\
204 set-object-mark ( xt obj -- )\n\
205 set-object-value-ref ( xt obj -- )\n\
206 set-object-value-set ( xt obj -- )\n\
207 *** general object words:\n\
208 .inspect ( obj -- )\n\
209 .object-name ( obj -- )\n\
210 apply alias for object-apply\n\
211 cycle-ref ( obj -- val )\n\
212 cycle-set! ( obj val -- )\n\
213 cycle-start! ( obj index -- )\n\
214 cycle-start0 ( obj -- )\n\
215 cycle-start@ ( obj -- index )\n\
216 detect alias for object-find\n\
217 empty? alias for object-empty?\n\
218 equal? alias for object-equal?\n\
219 first-ref ( obj -- val )\n\
220 first-set! ( obj val -- )\n\
221 hash-id ( obj -- id )\n\
222 index alias for object-index\n\
223 last-ref ( obj -- val )\n\
224 last-set! ( obj val -- )\n\
225 length alias for object-length\n\
226 member? alias for object-member?\n\
227 object->array ( obj -- ary )\n\
228 object->string ( obj -- str )\n\
229 object-apply ( obj args -- result )\n\
230 object-copy ( obj1 -- obj2 )\n\
231 object-debug-hook ( obj -- hook|#f )\n\
232 object-dump ( obj -- str )\n\
233 object-empty? ( obj -- f )\n\
234 object-equal? ( obj1 obj2 -- f )\n\
235 object-find ( obj key -- value|#f )\n\
236 object-id ( obj -- id )\n\
237 object-index ( obj key -- index|-1 )\n\
238 object-inspect ( obj -- str )\n\
239 object-length ( obj -- len )\n\
240 object-member? ( obj key -- f )\n\
241 object-name ( obj -- name )\n\
242 object-range? ( obj index -- f )\n\
243 object-ref ( obj index -- val )\n\
244 object-set! ( obj index value -- )\n\
245 object-set*! ( obj index value -- )\n\
246 object-set+! ( obj index value -- )\n\
247 object-set-! ( obj index value -- )\n\
248 object-set/! ( obj index value -- )\n\
249 object-sort ( obj cmp-xt -- ary )\n\
250 range? alias for object-range?\n\
251 second-ref ( obj -- val )\n\
252 second-set! ( obj val -- )\n\
253 sort alias for object-sort\n\
254 third-ref ( obj -- val )\n\
255 third-set! ( obj val -- )\n\
256 xmobj? ( obj -- f )\n\
257 *** predicates:\n\
258 boolean? ( obj -- f )\n\
259 false? ( obj -- f )\n\
260 nil? ( obj -- f )\n\
261 true? ( obj -- f )\n\
262 undef? ( obj -- f )"
263
264 void
gc_push(ficlWord * word)265 gc_push(ficlWord *word)
266 {
267 if (++gc_frame_level >= GC_FRAME_SIZE) {
268 #if defined(FTH_DEBUG)
269 fprintf(stderr, "#<GC_FRAME (gc_push): above max?>\n");
270 #endif
271 gc_frame_level = GC_FRAME_SIZE - 1;
272 }
273 GC_FRAME_CURRENT_WORD() = word;
274 GC_FRAME_CURRENT_INST() = NULL;
275 }
276
277 void
gc_pop(void)278 gc_pop(void)
279 {
280 if (--gc_frame_level < 0) {
281 #if defined(FTH_DEBUG)
282 fprintf(stderr, "#<GC_FRAME (gc_pop): below zero?>\n");
283 #endif
284 gc_frame_level = 0;
285 }
286 }
287
288 void
gc_loop_reset(void)289 gc_loop_reset(void)
290 {
291 GC_FRAME_CURRENT_INST() = NULL;
292 }
293
294 void
init_gc(void)295 init_gc(void)
296 {
297 int i;
298
299 for (i = 0; i < GC_FRAME_SIZE; i++)
300 GC_FRAME_INST(i) = NULL;
301
302 GC_FRAME_WORD(0) = NULL;
303 gc_frame_level = 0;
304 }
305
306 static void
ficl_frame_depth(ficlVm * vm)307 ficl_frame_depth(ficlVm *vm)
308 {
309 #define h_frame_depth "( -- n ) return frame depth\n\
310 frame-depth => 0\n\
311 Internal global variable. \
312 Return the current frame depth."
313 ficlStackPushInteger(vm->dataStack, (ficlInteger) gc_frame_level);
314 }
315
316 static simple_array *last_frames = NULL;
317
318 void
fth_set_backtrace(FTH exception)319 fth_set_backtrace(FTH exception)
320 {
321 char *exc;
322 int i;
323 ficlVm *vm;
324 ficlWord *word;
325 FTH fs;
326
327 vm = FTH_FICL_VM();
328
329 if (vm->state == FICL_VM_STATE_COMPILE)
330 return;
331
332 exc = fth_exception_ref(exception);
333 word = vm->runningWord;
334
335 if (last_frames == NULL)
336 last_frames = make_simple_array(16);
337 else
338 simple_array_clear(last_frames);
339
340 if (exc == NULL)
341 exc = "break";
342
343 /*
344 * First line: repeat exception
345 */
346 fs = fth_make_string(exc);
347
348 if (FICL_WORD_P(word))
349 fth_string_sformat(fs, " in %s", FICL_WORD_NAME(word));
350
351 simple_array_push(last_frames, (void *) fs);
352
353 /*
354 * Second line: last line from terminal input buffer (TIB)
355 */
356 if (vm->tib.text == NULL)
357 fs = fth_make_string("empty");
358 else
359 fs = fth_string_chomp(fth_make_string(vm->tib.text));
360
361 simple_array_push(last_frames, (void *) fs);
362
363 /*
364 * Rest: last called words
365 */
366 for (i = 0; i < 16 && word != NULL; i++) {
367 fs = fth_word_inspect((FTH) word);
368 simple_array_push(last_frames, (void *) fs);
369 if (word == word->current_word)
370 break;
371 word = word->current_word;
372 }
373 }
374
375 void
fth_show_backtrace(int verbose)376 fth_show_backtrace(int verbose)
377 {
378 int len, i;
379 FTH fs;
380
381 len = simple_array_length(last_frames);
382
383 if (len <= 0)
384 return;
385
386 i = 0;
387
388 /*
389 * First line: repeat exception
390 */
391 fs = (FTH) simple_array_ref(last_frames, i++);
392 fth_errorf("#<bt: %S>\n", fs);
393
394 /*
395 * Second line: last line from terminal input buffer (TIB)
396 */
397 fs = (FTH) simple_array_ref(last_frames, i++);
398 fth_errorf("#<bt: TIB %S>\n", fs);
399
400 if (!verbose && FTH_FALSE_P(fth_variable_ref("*fth-verbose*")))
401 return;
402
403 /*
404 * Rest: last called words
405 */
406 for (; i < len; i++) {
407 fs = (FTH) simple_array_ref(last_frames, i);
408 fth_errorf("#<bt[%d]: %S>\n", i - 2, fs);
409 }
410 }
411
412 static void
ficl_backtrace(ficlVm * vm)413 ficl_backtrace(ficlVm *vm)
414 {
415 #define h_backtrace "( -- ) print simple backtrace\n\
416 backtrace =>\n\
417 #<break in backtrace>\n\
418 #<TIB: backtrace >\n\
419 #<bt 0: at repl-eval:2>\n\
420 Print last word list from stack frame to error output.\n\
421 TIB: last line in Terminal Input Buffer before backtrace call\n\
422 BT: level of backtrace, here 0\n\
423 AT: filename:line number, source filename and line number of definition. \
424 filename here is the REPL."
425 FTH_STACK_CHECK(vm, 0, 0);
426 if (last_frames == NULL)
427 fth_set_backtrace(fth_last_exception);
428 fth_show_backtrace(1);
429 }
430
431 static void
ficl_print_length(ficlVm * vm)432 ficl_print_length(ficlVm *vm)
433 {
434 #define h_print_length "( -- n ) return object print length\n\
435 object-print-length => 12\n\
436 Return the number of objects to print for objects like array, list, hash. \
437 Default value is 12.\n\
438 See also set-object-print-length."
439 FTH_STACK_CHECK(vm, 0, 1);
440 ficlStackPushInteger(vm->dataStack, (ficlInteger) fth_print_length);
441 }
442
443 static void
ficl_set_print_length(ficlVm * vm)444 ficl_set_print_length(ficlVm *vm)
445 {
446 #define h_set_print_length "( n -- ) set object print length\n\
447 128 set-object-print-length\n\
448 Set number of objects to print for objects like array, list, hash to N. \
449 If N is negative, print all elements of a given object.\n\
450 See also object-print-length."
451 FTH_STACK_CHECK(vm, 1, 0);
452 fth_print_length = (int) ficlStackPopInteger(vm->dataStack);
453 }
454
455 /* === GC === */
456
457 static FObject *obj_minmem = (void *) 1;
458 static FObject *obj_maxmem = NULL;
459 static FObject **obj_types;
460 static int last_object = 0;
461
462 static FInstance *inst_free_list = NULL;
463 static FInstance *inst_minmem = (void *) 1;
464 static FInstance *inst_maxmem = NULL;
465 static FInstance **instances;
466 static int last_instance = 0;
467
468 #define OBJECT_P(Obj) (((FTH)(Obj)) & ~FTH_NIL)
469
470 #define OBJECT_TYPE_P(Obj) \
471 (FTH_OBJECT_REF(Obj) >= obj_minmem && \
472 FTH_OBJECT_REF(Obj) <= obj_maxmem)
473
474 #define INSTANCE0_P(Obj) \
475 (FTH_INSTANCE_REF(Obj) >= inst_minmem && \
476 FTH_INSTANCE_REF(Obj) <= inst_maxmem && \
477 OBJECT_TYPE_P(FTH_INSTANCE_REF_OBJ(Obj)) && \
478 !GC_FREED_P(FTH_INSTANCE_REF(Obj)))
479
480 #define INSTANCE_P(Obj) (!FICL_WORD_DICT_P(Obj) && INSTANCE0_P(Obj))
481
482 #define OBJECT_MARK(Inst) \
483 if ((Inst)->obj->mark) \
484 (*(Inst)->obj->mark)((FTH)(Inst))
485
486 #define OBJECT_FREE(Inst) do { \
487 if ((Inst)->obj->free) \
488 (*(Inst)->obj->free)((FTH)(Inst)); \
489 else \
490 FTH_FREE((Inst)->gen); \
491 \
492 GC_FREED_SET(Inst); \
493 (Inst)->gen = NULL; \
494 (Inst)->obj = NULL; \
495 (Inst)->properties = 0; \
496 (Inst)->values = 0; \
497 (Inst)->next = inst_free_list; \
498 inst_free_list = (Inst); \
499 } while (0)
500
501 #if 0
502 #define FTH_DEBUG 1
503 #endif
504
505 static FInstance *
gc_run(void)506 gc_run(void)
507 {
508 int i, freed;
509 FInstance *inst, *free_inst = NULL;
510 ficlStack *stack;
511 #if defined(FTH_DEBUG)
512 int stk_marked, frm_marked;
513
514 stk_marked = frm_marked = 0;
515 fprintf(stderr, "\\ gc[%02d:%06d]: marking ... ",
516 gc_frame_level, last_instance);
517 #endif
518 freed = 0;
519 stack = FTH_FICL_STACK();
520
521 /* Mark possible instances on stack. */
522 for (i = -((int) (stack->top - stack->base)); i <= 0; i++) {
523 inst = FTH_INSTANCE_REF(STACK_FTH_INDEX_REF(stack, i));
524
525 if (INSTANCE_P(inst)) {
526 #if defined(FTH_DEBUG)
527 stk_marked++;
528 #endif
529 GC_MARK_SET(inst);
530 }
531 }
532
533 /* Mark collected instances. */
534 for (i = 0; i <= gc_frame_level; i++)
535 for (inst = GC_FRAME_INST(i); inst; inst = inst->next) {
536 #if defined(FTH_DEBUG)
537 frm_marked++;
538 #endif
539 GC_MARK_SET(inst);
540 }
541
542 /* Mark elements of already marked sequences (array etc). */
543 for (i = 1, inst = instances[0];
544 i < last_instance;
545 inst = instances[i++])
546 if (GC_ANY_MARK_P(inst) && inst->obj->mark)
547 (*inst->obj->mark) ((FTH) inst);
548 #if defined(FTH_DEBUG)
549 if (stk_marked)
550 fprintf(stderr, "(stack %d) ", stk_marked);
551
552 if (frm_marked)
553 fprintf(stderr, "(frame %d) ", frm_marked);
554
555 fprintf(stderr, "done (%d)\n", stk_marked + frm_marked);
556 fprintf(stderr, "\\ gc[%02d:%06d]: freeing ... ",
557 gc_frame_level, last_instance);
558 #endif
559 /* Free all unmarked instances. */
560 for (i = 1, inst = instances[0];
561 i < last_instance;
562 inst = instances[i++]) {
563 if (GC_FREED_P(inst))
564 continue;
565 if (GC_ANY_MARK_P(inst)) {
566 GC_MARK_CLR(inst);
567 continue;
568 }
569 OBJECT_FREE(inst);
570 freed++;
571 }
572 #if defined(FTH_DEBUG)
573 fprintf(stderr, "done (%d)\n", freed);
574 #endif
575 free_inst = inst_free_list;
576
577 if (freed > GC_CHUNK_SIZE && free_inst)
578 inst_free_list = inst_free_list->next;
579 else
580 free_inst = NULL;
581
582 return (free_inst);
583 }
584
585 void
gc_free_all(void)586 gc_free_all(void)
587 {
588 int i, last;
589
590 simple_array_free(last_frames);
591
592 if (instances != NULL) {
593 for (i = 0; i < last_instance; i++) {
594 if (!GC_FREED_P(instances[i]))
595 OBJECT_FREE(instances[i]);
596 FTH_FREE(instances[i]);
597 }
598
599 if (last_instance % GC_CHUNK_SIZE != 0)
600 last = (last_instance / GC_CHUNK_SIZE) + 1;
601 else
602 last = last_instance / GC_CHUNK_SIZE;
603
604 last *= GC_CHUNK_SIZE;
605
606 for (i = last_instance; i < last; i++)
607 FTH_FREE(instances[i]);
608
609 FTH_FREE(instances);
610 }
611 if (obj_types != NULL) {
612 if (last_object % OBJ_CHUNK_SIZE != 0)
613 last = (last_object / OBJ_CHUNK_SIZE) + 1;
614 else
615 last = last_object / OBJ_CHUNK_SIZE;
616
617 last *= OBJ_CHUNK_SIZE;
618
619 for (i = 0; i < last; i++)
620 FTH_FREE(obj_types[i]);
621
622 FTH_FREE(obj_types);
623 }
624 }
625
626 /* ARGSUSED */
627 static void
ficl_gc_run(ficlVm * vm)628 ficl_gc_run(ficlVm *vm)
629 {
630 #define h_gc_run "( -- ) run gc\n\
631 gc-run\n\
632 Run garbage collection immediately.\n\
633 See also gc-stats."
634 (void) vm;
635 gc_run();
636 }
637
638 static int fth_gc_on_p;
639
640 /* ARGSUSED */
641 static void
ficl_gc_stats(ficlVm * vm)642 ficl_gc_stats(ficlVm *vm)
643 {
644 #define h_gc_stats "( -- ) print gc stats\n\
645 gc-stats =>\n\
646 \\ gc-stats (gc on):\n\
647 \\ permanent: 3629\n\
648 \\ protected: 51\n\
649 \\ marked: 33\n\
650 \\ freed: 9\n\
651 \\ insts: 53895\n\
652 \\ buffer: 57617\n\
653 \\ gc stack: 0\n\
654 Print garbage collection statistics.\n\
655 PERMANENT: permanent protected objects like constants\n\
656 PROTECTED: temporary protected objects like gc-protected\n\
657 MARKED: marked to protect from next freeing\n\
658 FREED: freed objects\n\
659 INSTS: all other nonfreed objects\n\
660 BUFFER: size of entire allocated buffer-array\n\
661 GC STACK: stack frame level\n\
662 See also gc-run."
663 int i, permanent, protected, marked, freed, rest;
664 FInstance *inst;
665
666 (void) vm;
667 permanent = protected = marked = freed = rest = 0;
668
669 for (i = 1, inst = instances[0];
670 i < last_instance;
671 inst = instances[i++]) {
672 if (GC_MARKED_P(inst))
673 marked++;
674 else if (GC_PERMANENT_P(inst))
675 permanent++;
676 else if (GC_PROTECTED_P(inst))
677 protected++;
678 else if (GC_FREED_P(inst))
679 freed++;
680 else if (INSTANCE_P(inst))
681 rest++;
682 }
683
684 fth_printf("\\ %s (gc %s):\n", RUNNING_WORD(),
685 fth_gc_on_p ? "on" : "off");
686 fth_printf("\\ permanent: %6d\n", permanent);
687 fth_printf("\\ protected: %6d\n", protected);
688 fth_printf("\\ marked: %6d\n", marked);
689 fth_printf("\\ freed: %6d\n", freed);
690 fth_printf("\\ insts: %6d\n", rest);
691 fth_printf("\\ buffer: %6d\n", last_instance - 1);
692 fth_printf("\\ gc stack: %6d", gc_frame_level);
693
694 if (CELL_INT_REF(&FTH_FICL_VM()->sourceId))
695 fth_print("\n");
696 }
697
698 static void
ficl_gc_marked_p(ficlVm * vm)699 ficl_gc_marked_p(ficlVm *vm)
700 {
701 #define h_gc_marked_p "( obj -- f ) test if OBJ is gc-marked\n\
702 #( 0 1 2 ) value a1\n\
703 a1 gc-marked? => #t\n\
704 Return #t if OBJ is an instance and mark flag is set. \
705 All new created objects have mark flag set.\n\
706 See also gc-protected? and gc-permanent?."
707 FInstance *inst;
708 int flag;
709
710 FTH_STACK_CHECK(vm, 1, 1);
711 inst = ficlStackPopPointer(vm->dataStack);
712 flag = INSTANCE_P(inst) && GC_MARKED_P(inst);
713 ficlStackPushBoolean(vm->dataStack, flag);
714 }
715
716 static void
ficl_gc_protected_p(ficlVm * vm)717 ficl_gc_protected_p(ficlVm *vm)
718 {
719 #define h_gc_protected_p "( obj -- f ) test if OBJ is gc-protected\n\
720 #( 0 1 2 ) value a1\n\
721 a1 gc-protected? => #f\n\
722 a1 gc-protect drop\n\
723 a1 gc-protected? => #t\n\
724 a1 gc-unprotect drop\n\
725 a1 gc-protected? => #f\n\
726 Return #t if OBJ is an instance and protected flag is set.\n\
727 See also gc-marked? and gc-permanent?."
728 FInstance *inst;
729 int flag;
730
731 FTH_STACK_CHECK(vm, 1, 1);
732 inst = ficlStackPopPointer(vm->dataStack);
733 flag = INSTANCE_P(inst) && GC_PROTECTED_P(inst);
734 ficlStackPushBoolean(vm->dataStack, flag);
735 }
736
737 static void
ficl_gc_permanent_p(ficlVm * vm)738 ficl_gc_permanent_p(ficlVm *vm)
739 {
740 #define h_gc_permanent_p "( obj -- f ) test if OBJ is permanent\n\
741 #( 0 1 2 ) value a1\n\
742 a1 gc-permanent? => #f\n\
743 #( 0 1 2 ) constant a2\n\
744 a2 gc-permanent? => #t\n\
745 Return #t if OBJ is an instance and permanent flag is set like constants.\n\
746 See also gc-marked? and gc-protected?."
747 FInstance *inst;
748 int flag;
749
750 FTH_STACK_CHECK(vm, 1, 1);
751 inst = ficlStackPopPointer(vm->dataStack);
752 flag = INSTANCE_P(inst) && GC_PERMANENT_P(inst);
753 ficlStackPushBoolean(vm->dataStack, flag);
754 }
755
756 static void
ficl_gc_protected_objects(ficlVm * vm)757 ficl_gc_protected_objects(ficlVm *vm)
758 {
759 #define h_gc_protected_objects "( -- ary ) return all protected objects\n\
760 gc-protected-objects length => 55\n\
761 Return array of all protected objects.\n\
762 See also gc-permanent-objects."
763 FInstance *inst;
764 FTH ary;
765 int i;
766
767 ary = fth_make_empty_array();
768
769 for (i = 1, inst = instances[0];
770 i < last_instance;
771 inst = instances[i++])
772 if (GC_PROTECTED_P(inst))
773 fth_array_push(ary, (FTH) inst);
774
775 ficlStackPushFTH(vm->dataStack, ary);
776 }
777
778 static void
ficl_gc_permanent_objects(ficlVm * vm)779 ficl_gc_permanent_objects(ficlVm *vm)
780 {
781 #define h_gc_permanent_objects "( -- ary ) return all permanent objects\n\
782 gc-permanent-objects length => 3634\n\
783 Return array of all permanent objects.\n\
784 See also gc-protected-objects."
785 FInstance *inst;
786 FTH ary;
787 int i;
788
789 ary = fth_make_empty_array();
790
791 for (i = 1, inst = instances[0];
792 i < last_instance;
793 inst = instances[i++])
794 if (GC_PERMANENT_P(inst))
795 fth_array_push(ary, (FTH) inst);
796
797 ficlStackPushFTH(vm->dataStack, ary);
798 }
799
800 /* gc-on, gc-off are names in snd-xen.c (but they do the same) */
801 FTH
fth_gc_on(void)802 fth_gc_on(void)
803 {
804 #define h_gc_on "( -- #f ) turn gc on\n\
805 gc-on => #f\n\
806 Turn on garbage collection. \
807 The return code is meaningless in Forth.\n\
808 See also gc-off."
809 fth_gc_on_p = 1;
810 return (FTH_FALSE);
811 }
812
813 FTH
fth_gc_off(void)814 fth_gc_off(void)
815 {
816 #define h_gc_off "( -- #f ) turn gc off\n\
817 gc-off => #f\n\
818 Turn off garbage collection. \
819 The return code is meaningless in Forth.\n\
820 See also gc-on."
821 fth_gc_on_p = 0;
822 return (FTH_FALSE);
823 }
824
825 void
fth_gc_mark(FTH obj)826 fth_gc_mark(FTH obj)
827 {
828 if (INSTANCE_P(obj)) {
829 GC_MARK_SET(FTH_INSTANCE_REF(obj));
830 OBJECT_MARK(FTH_INSTANCE_REF(obj));
831 }
832 }
833
834 static void
ficl_gc_mark(ficlVm * vm)835 ficl_gc_mark(ficlVm *vm)
836 {
837 #define h_gc_mark "( obj -- obj ) set gc-mark flag\n\
838 #( 0 1 2 ) value a1\n\
839 a1 gc-mark\n\
840 a1 gc-marked => #t\n\
841 Mark OBJ to protect it from garbage collection on next gc-run.\n\
842 See also gc-unmark."
843 FTH obj;
844
845 FTH_STACK_CHECK(vm, 1, 1);
846 obj = ficlStackPopFTH(vm->dataStack);
847
848 if (INSTANCE_P(obj))
849 GC_MARK_SET(FTH_INSTANCE_REF(obj));
850
851 ficlStackPushFTH(vm->dataStack, obj);
852 }
853
854 void
fth_gc_unmark(FTH obj)855 fth_gc_unmark(FTH obj)
856 {
857 if (INSTANCE_P(obj))
858 GC_MARK_CLR(FTH_INSTANCE_REF(obj));
859 }
860
861 static void
ficl_gc_unmark(ficlVm * vm)862 ficl_gc_unmark(ficlVm *vm)
863 {
864 #define h_gc_unmark "( obj -- obj ) clear gc-mark flag\n\
865 #( 0 1 2 ) value a1\n\
866 a1 gc-marked => #t\n\
867 a1 gc-unmark\n\
868 a1 gc-marked => #f\n\
869 Unmark OBJ to unprotect it from garbage collection on next gc-run.\n\
870 See also gc-mark."
871 FTH obj;
872
873 FTH_STACK_CHECK(vm, 1, 1);
874 obj = ficlStackPopFTH(vm->dataStack);
875
876 if (INSTANCE_P(obj))
877 GC_MARK_CLR(FTH_INSTANCE_REF(obj));
878
879 ficlStackPushFTH(vm->dataStack, obj);
880 }
881
882 /*
883 * Protect OBJ from garbage collection until fth_gc_unprotect.
884 */
885 FTH
fth_gc_protect(FTH obj)886 fth_gc_protect(FTH obj)
887 {
888 #define h_gc_protect "( obj -- obj ) set gc-protect flag\n\
889 #( 0 1 2 ) value a1\n\
890 a1 gc-protect drop\n\
891 a1 gc-protected? => #t\n\
892 Protect OBJ from garbage collection until gc-unprotect.\n\
893 See also gc-unprotect."
894 if (INSTANCE_P(obj))
895 GC_PROTECT_SET(FTH_INSTANCE_REF(obj));
896 return (obj);
897 }
898
899 /*
900 * Unprotect OBJ from garbage collection.
901 */
902 FTH
fth_gc_unprotect(FTH obj)903 fth_gc_unprotect(FTH obj)
904 {
905 #define h_gc_unprotect "( obj -- obj ) clear gc-protect flag\n\
906 #( 0 1 2 ) value a1\n\
907 a1 gc-protect drop\n\
908 a1 gc-protected? => #t\n\
909 a1 gc-unprotect drop\n\
910 a1 gc-protected? => #f\n\
911 Unprotect OBJ from garbage collection.\n\
912 See also gc-protect."
913 if (INSTANCE_P(obj))
914 GC_PROTECT_CLR(FTH_INSTANCE_REF(obj));
915 return (obj);
916 }
917
918 FTH
fth_gc_protect_set(FTH out,FTH in)919 fth_gc_protect_set(FTH out, FTH in)
920 {
921 if (INSTANCE_P(out))
922 GC_PROTECT_CLR(FTH_INSTANCE_REF(out));
923
924 if (INSTANCE_P(in))
925 GC_PROTECT_SET(FTH_INSTANCE_REF(in));
926
927 return (in);
928 }
929
930 FTH
fth_gc_permanent(FTH obj)931 fth_gc_permanent(FTH obj)
932 {
933 if (INSTANCE_P(obj))
934 GC_PERMANENT_SET(FTH_INSTANCE_REF(obj));
935 return (obj);
936 }
937
938 /* === OBJECT-TYPE === */
939
940 int
fth_object_type_p(FTH obj)941 fth_object_type_p(FTH obj)
942 {
943 return (OBJECT_TYPE_P(obj));
944 }
945
946 static void
ficl_object_type_p(ficlVm * vm)947 ficl_object_type_p(ficlVm *vm)
948 {
949 #define h_object_type_p "( obj -- f ) test if OBJ is an Object type\n\
950 \"enved\" make-object-type object-type? => #t\n\
951 Return #t if OBJ is an Object type, otherwise #f.\n\
952 See also make-object-type."
953 FTH obj;
954
955 FTH_STACK_CHECK(vm, 1, 1);
956 obj = ficlStackPopFTH(vm->dataStack);
957 ficlStackPushBoolean(vm->dataStack, OBJECT_TYPE_P(obj));
958 }
959
960 FTH
make_object_type(const char * name,fobj_t type)961 make_object_type(const char *name, fobj_t type)
962 {
963 FObject *current;
964
965 FTH_ASSERT_STRING(name);
966
967 if (last_object % OBJ_CHUNK_SIZE == 0) {
968 int i, size;
969
970 size = OBJ_CHUNK_SIZE + last_object;
971 obj_types = FTH_REALLOC(obj_types,
972 sizeof(FObject *) * (size_t) size);
973
974 for (i = last_object; i < size; i++)
975 obj_types[i] = FTH_CALLOC(1, sizeof(FObject));
976
977 if (last_object == 0)
978 obj_minmem = *obj_types;
979 }
980 current = obj_types[last_object++];
981
982 if (obj_minmem > current)
983 obj_minmem = current;
984
985 if (obj_maxmem < current)
986 obj_maxmem = current;
987
988 current->type = type;
989 fth_strcpy(current->name, sizeof(current->name), name);
990 /*-
991 * constant with class definition, e.g. "fth-Mus":
992 * 10 make-oscil fth-Mus instance-of? => #t
993 * 10 make-array fth-Mus instance-of? => #f
994 * 10 make-array fth-array instance-of? => #t
995 */
996 fth_strcpy(FTH_FICL_VM()->pad, sizeof(FTH_FICL_VM()->pad), "fth-");
997 fth_strcat(FTH_FICL_VM()->pad, sizeof(FTH_FICL_VM()->pad), name);
998 ficlDictionaryAppendConstant(FTH_FICL_DICT(),
999 FTH_FICL_VM()->pad, (ficlInteger) current);
1000 return ((FTH) current);
1001 }
1002
1003 FTH
make_object_type_from(const char * name,fobj_t type,FTH obj)1004 make_object_type_from(const char *name, fobj_t type, FTH obj)
1005 {
1006 FTH new;
1007 FObject *current, *base;
1008
1009 new = make_object_type(name, type);
1010 current = FTH_OBJECT_REF(new);
1011 base = FTH_OBJECT_REF(obj);
1012 current->inspect = base->inspect;
1013 current->to_string = base->to_string;
1014 current->dump = base->dump;
1015 current->to_array = base->to_array;
1016 current->copy = base->copy;
1017 current->value_ref = base->value_ref;
1018 current->value_set = base->value_set;
1019 current->equal_p = base->equal_p;
1020 current->length = base->length;
1021 current->mark = base->mark;
1022 current->free = base->free;
1023 current->inspect_proc = base->inspect_proc;
1024 current->to_string_proc = base->to_string_proc;
1025 current->dump_proc = base->dump_proc;
1026 current->to_array_proc = base->to_array_proc;
1027 current->copy_proc = base->copy_proc;
1028 current->value_ref_proc = base->value_ref_proc;
1029 current->value_set_proc = base->value_set_proc;
1030 current->equal_p_proc = base->equal_p_proc;
1031 current->length_proc = base->length_proc;
1032 current->mark_proc = base->mark_proc;
1033 current->free_proc = base->free_proc;
1034 return (new);
1035 }
1036
1037 static fobj_t object_type_counter = FTH_LAST_ENTRY_T;
1038
1039 /*
1040 * Add NAME to feature environment list, create a constant "fth-NAME"
1041 * of object-type and return new object-type NAME.
1042 */
1043 FTH
fth_make_object_type(const char * name)1044 fth_make_object_type(const char *name)
1045 {
1046 fth_add_feature(name);
1047 return (make_object_type(name, object_type_counter++));
1048 }
1049
1050 FTH
fth_make_object_type_from(const char * name,FTH base)1051 fth_make_object_type_from(const char *name, FTH base)
1052 {
1053 fth_add_feature(name);
1054 return (make_object_type_from(name, object_type_counter++, base));
1055 }
1056
1057 static void
ficl_make_object_type(ficlVm * vm)1058 ficl_make_object_type(ficlVm *vm)
1059 {
1060 #define h_make_object_type "( name -- object-type ) create Object type\n\
1061 \"enved\" make-object-type constant fth-enved\n\
1062 \\ ...\n\
1063 <'> enved-inspect fth-enved set-object-inspect\n\
1064 <'> enved-equal? fth-enved set-object-equal-p\n\
1065 \\ ...\n\
1066 #( 0.0 1.0 1.0 1.0 ) make-enved value enved\n\
1067 enved fth-enved instance-of? => #t\n\
1068 #() fth-enved instance-of? => #f\n\
1069 Create new object type NAME. \
1070 Add NAME to feature environment list, \
1071 create a constant \"fth-NAME\" \
1072 of object-type and return new object-type NAME. \
1073 The new created OBJECT-TYPE can be used to bind functions to it.\n\
1074 See examples/site-lib/enved.fs for examples."
1075 FTH tp, fs;
1076
1077 FTH_STACK_CHECK(vm, 1, 1);
1078 fs = fth_pop_ficl_cell(vm);
1079 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
1080 tp = fth_make_object_type(fth_string_ref(fs));
1081 ficlStackPushFTH(vm->dataStack, tp);
1082 }
1083
1084 static void
ficl_object_type_ref(ficlVm * vm)1085 ficl_object_type_ref(ficlVm *vm)
1086 {
1087 #define h_object_type_ref "( obj -- obj-struct ) return object struct\n\
1088 fth-enved object-type-ref => Object% struct\n\
1089 Return object struct of object-type OBJ.\n\
1090 See also make-object-type."
1091 FTH obj;
1092
1093 FTH_STACK_CHECK(vm, 1, 1);
1094 obj = ficlStackPopFTH(vm->dataStack);
1095 FTH_ASSERT_ARGS(OBJECT_TYPE_P(obj), obj, FTH_ARG1, "an object-type");
1096 ficlStackPushPointer(vm->dataStack, FTH_OBJECT_REF(obj));
1097 }
1098
1099 static void
ficl_object_types(ficlVm * vm)1100 ficl_object_types(ficlVm *vm)
1101 {
1102 #define h_object_types "( -- ary ) return all object names\n\
1103 object-types => #( \"array\" \"list\" \"acell\"... )\n\
1104 Return array of all object names known to the system."
1105 FTH objs;
1106 ficlInteger i;
1107
1108 FTH_STACK_CHECK(vm, 0, 1);
1109 objs = fth_make_array_len((ficlInteger) last_object);
1110
1111 for (i = 0; i < last_object; i++)
1112 fth_array_set(objs, i, fth_make_string(obj_types[i]->name));
1113
1114 ficlStackPushFTH(vm->dataStack, objs);
1115 }
1116
1117 /*
1118 * Return GEN-struct of OBJ.
1119 */
1120 void *
fth_instance_ref_gen(FTH obj)1121 fth_instance_ref_gen(FTH obj)
1122 {
1123 if (INSTANCE_P(obj)) {
1124 GC_MARK_SET(FTH_INSTANCE_REF(obj));
1125 return ((void *) FTH_INSTANCE_REF_GEN(obj, void));
1126 }
1127 return (NULL);
1128 }
1129
1130 /* === INSTANCE === */
1131
1132 static FInstance *
gc_next_instance(void)1133 gc_next_instance(void)
1134 {
1135 FInstance *current;
1136
1137 current = NULL;
1138
1139 if (last_instance && (last_instance % GC_MAX_OBJECTS) == 0) {
1140 current = inst_free_list;
1141 if (current != NULL)
1142 inst_free_list = inst_free_list->next;
1143 else if (fth_gc_on_p && !fth_signal_caught_p)
1144 current = gc_run();
1145 else
1146 current = NULL;
1147 }
1148 if (current == NULL) {
1149 if (last_instance % GC_CHUNK_SIZE == 0) {
1150 int i, size;
1151
1152 size = GC_CHUNK_SIZE + last_instance;
1153 instances = FTH_REALLOC(instances,
1154 sizeof(FInstance *) * (size_t) size);
1155
1156 for (i = last_instance; i < size; i++) {
1157 instances[i] = FTH_CALLOC(1, sizeof(FInstance));
1158 instances[i]->gc_mark = GC_FREED;
1159 }
1160
1161 if (last_instance == 0)
1162 inst_minmem = *instances;
1163 }
1164 current = instances[last_instance++];
1165 }
1166 if (inst_minmem > current)
1167 inst_minmem = current;
1168
1169 if (inst_maxmem < current)
1170 inst_maxmem = current;
1171
1172 return (current);
1173 }
1174
1175 int
fth_instance_type_p(FTH obj,fobj_t type)1176 fth_instance_type_p(FTH obj, fobj_t type)
1177 {
1178 if (obj != 0 && INSTANCE_P(obj)) {
1179 GC_MARK_SET(FTH_INSTANCE_REF(obj));
1180 return (FTH_INSTANCE_TYPE(obj) == type);
1181 }
1182 return (0);
1183 }
1184
1185 int
fth_instance_flag_p(FTH obj,int flag)1186 fth_instance_flag_p(FTH obj, int flag)
1187 {
1188 if (obj != 0 && INSTANCE_P(obj)) {
1189 GC_MARK_SET(FTH_INSTANCE_REF(obj));
1190 return (FTH_INSTANCE_FLAG(obj) & flag);
1191 }
1192 return (0);
1193 }
1194
1195 int
fth_instance_p(FTH obj)1196 fth_instance_p(FTH obj)
1197 {
1198 if (obj != 0 && INSTANCE_P(obj)) {
1199 GC_MARK_SET(FTH_INSTANCE_REF(obj));
1200 return (1);
1201 }
1202 return (0);
1203 }
1204
1205 static void
ficl_instance_p(ficlVm * vm)1206 ficl_instance_p(ficlVm *vm)
1207 {
1208 #define h_instance_p "( obj -- f ) test if OBJ is an Instance\n\
1209 gen fth-enved make-instance instance? => #t\n\
1210 Return #t if OBJ is an instance, otherwise #f.\n\
1211 See also make-instance."
1212 FTH obj;
1213
1214 FTH_STACK_CHECK(vm, 1, 1);
1215 obj = fth_pop_ficl_cell(vm);
1216 ficlStackPushBoolean(vm->dataStack, fth_instance_p(obj));
1217 }
1218
1219 /*
1220 * Return new instance of Object type OBJ with GEN wrapped in.
1221 */
1222 FTH
fth_make_instance(FTH obj,void * gen)1223 fth_make_instance(FTH obj, void *gen)
1224 {
1225 FInstance *inst;
1226
1227 if (!OBJECT_TYPE_P(obj)) {
1228 ficlVmThrowError(FTH_FICL_VM(), "no object type %#x", obj);
1229 /* NOTREACHED */
1230 return (FTH_FALSE);
1231 }
1232 inst = gc_next_instance();
1233 inst->type = FTH_T;
1234 inst->gen = gen;
1235 inst->obj = FTH_OBJECT_REF(obj);
1236 inst->properties = FTH_FALSE;
1237 inst->values = FTH_FALSE;
1238 inst->debug_hook = FTH_FALSE;
1239 inst->changed_p = 1;
1240 inst->extern_p = (FTH_OBJECT_TYPE(obj) >= FTH_LAST_ENTRY_T);
1241 inst->cycle = 0;
1242 inst->gc_mark = GC_MARK;
1243 inst->next = GC_FRAME_CURRENT_INST();
1244 GC_FRAME_CURRENT_INST() = inst;
1245 return ((FTH) inst);
1246 }
1247
1248 static void
ficl_make_instance(ficlVm * vm)1249 ficl_make_instance(ficlVm *vm)
1250 {
1251 #define h_make_instance "( gen obj -- instance ) return new instance\n\
1252 gen fth-enved make-instance value enved\n\
1253 Return new instance of Object type OBJ with GEN wrapped in.\n\
1254 See also instance-gen-ref and instance-obj-ref.\n\
1255 See examples/site-lib/enved.fs for examples."
1256 void *gen;
1257 FTH obj;
1258
1259 FTH_STACK_CHECK(vm, 2, 1);
1260 obj = ficlStackPopFTH(vm->dataStack);
1261 gen = ficlStackPopPointer(vm->dataStack);
1262 ficlStackPushFTH(vm->dataStack, fth_make_instance(obj, gen));
1263 }
1264
1265 static void
ficl_instance_gen_ref(ficlVm * vm)1266 ficl_instance_gen_ref(ficlVm *vm)
1267 {
1268 #define h_instance_gen_ref "( obj -- gen ) return struct of OBJ\n\
1269 gen fth-enved make-instance value enved\n\
1270 enved instance-gen-ref => Enved% struct\n\
1271 Return GEN-struct of OBJ.\n\
1272 See also make-instance and instance-obj-ref.\n\
1273 See examples/site-lib/enved.fs for examples."
1274 FTH obj;
1275
1276 FTH_STACK_CHECK(vm, 1, 1);
1277 obj = ficlStackPopFTH(vm->dataStack);
1278
1279 if (!INSTANCE_P(obj)) {
1280 FTH_ASSERT_ARGS(INSTANCE_P(obj), obj, FTH_ARG1, "an instance");
1281 /* for ccc-analyzer */
1282 /* NOTREACHED */
1283 return;
1284 }
1285 GC_MARK_SET(FTH_INSTANCE_REF(obj));
1286 ficlStackPushPointer(vm->dataStack, FTH_INSTANCE_REF_GEN(obj, void));
1287 }
1288
1289 static void
ficl_instance_obj_ref(ficlVm * vm)1290 ficl_instance_obj_ref(ficlVm *vm)
1291 {
1292 #define h_instance_obj_ref "( obj -- gen ) return object type\n\
1293 gen fth-enved make-instance value enved\n\
1294 enved instance-obj-ref => enved (object-type)\n\
1295 enved instance-obj-ref object-name => \"object-type\"\n\
1296 Return object type of OBJ.\n\
1297 See also instance-gen-ref and instance-obj-ref."
1298 FTH obj;
1299
1300 FTH_STACK_CHECK(vm, 1, 1);
1301 obj = ficlStackPopFTH(vm->dataStack);
1302
1303 if (!INSTANCE_P(obj)) {
1304 FTH_ASSERT_ARGS(INSTANCE_P(obj), obj, FTH_ARG1, "an instance");
1305 /* for ccc-analyzer */
1306 /* NOTREACHED */
1307 return;
1308 }
1309 GC_MARK_SET(FTH_INSTANCE_REF(obj));
1310 ficlStackPushPointer(vm->dataStack, FTH_INSTANCE_REF_OBJ(obj));
1311 }
1312
1313 /*
1314 * Return true if OBJ is an instance of TYPE, otherwise false.
1315 */
1316 int
fth_object_is_instance_of(FTH obj,FTH type)1317 fth_object_is_instance_of(FTH obj, FTH type)
1318 {
1319 if (INSTANCE_P(obj) && OBJECT_TYPE_P(type)) {
1320 GC_MARK_SET(FTH_INSTANCE_REF(obj));
1321 return (FTH_INSTANCE_TYPE(obj) == FTH_OBJECT_TYPE(type));
1322 }
1323 return (0);
1324 }
1325
1326 static void
ficl_object_is_instance_of(ficlVm * vm)1327 ficl_object_is_instance_of(ficlVm *vm)
1328 {
1329 #define h_object_is_instance_of "( obj type -- f ) test if OBJ is of TYPE\n\
1330 #( 0 1 2 ) value a1\n\
1331 a1 fth-array instance-of? => #t\n\
1332 a1 fth-hash instance-of? => #f\n\
1333 Return #t if OBJ is an instance of TYPE, otherwise #f."
1334 FTH obj, type;
1335 int flag;
1336
1337 FTH_STACK_CHECK(vm, 2, 1);
1338 type = ficlStackPopFTH(vm->dataStack);
1339 obj = fth_pop_ficl_cell(vm);
1340 flag = fth_object_is_instance_of(obj, type);
1341 ficlStackPushBoolean(vm->dataStack, flag);
1342 }
1343
1344 /* === Object Set Functions === */
1345
1346 #define SET_OBJECT_FUNC1(Name) \
1347 FTH \
1348 fth_set_object_ ## Name (FTH obj, FTH (*Name)(FTH self)) \
1349 { \
1350 if (OBJECT_TYPE_P(obj)) \
1351 FTH_OBJECT_REF(obj)->Name = Name; \
1352 return (obj); \
1353 } \
1354 static FTH \
1355 ficl_obj_ ## Name (FTH self) \
1356 { \
1357 FTH res, prc; \
1358 \
1359 prc = FTH_INSTANCE_REF_OBJ(self)->Name ## _proc; \
1360 res = fth_proc_call(prc, # Name, 1, self); \
1361 return (res); \
1362 } \
1363 static void \
1364 ficl_set_ ## Name (ficlVm *vm) \
1365 { \
1366 FTH obj, prc; \
1367 ficlWord *word; \
1368 \
1369 FTH_STACK_CHECK(vm, 2, 0); \
1370 obj = ficlStackPopFTH(vm->dataStack); \
1371 word = ficlStackPopPointer(vm->dataStack); \
1372 \
1373 if (OBJECT_TYPE_P(obj)) { \
1374 prc = fth_make_proc(word, 1, 0, 0); \
1375 FTH_OBJECT_REF(obj)->Name = ficl_obj_ ## Name; \
1376 FTH_OBJECT_REF(obj)->Name ## _proc = prc; \
1377 } \
1378 else \
1379 fth_warning("%s: %S seems not to be an object-type", \
1380 # Name, obj); \
1381 }
1382
1383 #define SET_OBJECT_FUNC2(Name) \
1384 FTH \
1385 fth_set_object_ ## Name (FTH obj, FTH (*Name)(FTH self, FTH val)) \
1386 { \
1387 if (OBJECT_TYPE_P(obj)) \
1388 FTH_OBJECT_REF(obj)->Name = Name; \
1389 return (obj); \
1390 } \
1391 static FTH \
1392 ficl_obj_ ## Name (FTH self, FTH val) \
1393 { \
1394 FTH res, prc; \
1395 \
1396 prc = FTH_INSTANCE_REF_OBJ(self)->Name ## _proc; \
1397 res = fth_proc_call(prc, # Name, 2, self, val); \
1398 return (res); \
1399 } \
1400 static void \
1401 ficl_set_ ## Name (ficlVm *vm) \
1402 { \
1403 FTH obj, prc; \
1404 ficlWord *word; \
1405 \
1406 FTH_STACK_CHECK(vm, 2, 0); \
1407 obj = ficlStackPopFTH(vm->dataStack); \
1408 word = ficlStackPopPointer(vm->dataStack); \
1409 \
1410 if (OBJECT_TYPE_P(obj)) { \
1411 prc = fth_make_proc(word, 2, 0, 0); \
1412 FTH_OBJECT_REF(obj)->Name = ficl_obj_ ## Name; \
1413 FTH_OBJECT_REF(obj)->Name ## _proc = prc; \
1414 } \
1415 else \
1416 fth_warning("%s: %S seems not to be an object-type", \
1417 # Name, obj); \
1418 }
1419
1420 #define SET_OBJECT_FUNC3(Name) \
1421 FTH \
1422 fth_set_object_ ## Name (FTH obj, FTH (*Name)(FTH s, FTH o1, FTH o2)) \
1423 { \
1424 if (OBJECT_TYPE_P(obj)) \
1425 FTH_OBJECT_REF(obj)->Name = Name; \
1426 return (obj); \
1427 } \
1428 static FTH \
1429 ficl_obj_ ## Name (FTH self, FTH o1, FTH o2) \
1430 { \
1431 FTH res, prc; \
1432 \
1433 prc = FTH_INSTANCE_REF_OBJ(self)->Name ## _proc; \
1434 res = fth_proc_call(prc, # Name, 3, self, o1, o2); \
1435 return (res); \
1436 } \
1437 static void \
1438 ficl_set_ ## Name (ficlVm *vm) \
1439 { \
1440 FTH obj, prc; \
1441 ficlWord *word; \
1442 \
1443 FTH_STACK_CHECK(vm, 2, 0); \
1444 obj = ficlStackPopFTH(vm->dataStack); \
1445 word = ficlStackPopPointer(vm->dataStack); \
1446 \
1447 if (OBJECT_TYPE_P(obj)) { \
1448 prc = fth_make_proc(word, 3, 0, 0); \
1449 FTH_OBJECT_REF(obj)->Name = ficl_obj_ ## Name; \
1450 FTH_OBJECT_REF(obj)->Name ## _proc = prc; \
1451 } \
1452 else \
1453 fth_warning("%s: %S seems not to be an object-type", \
1454 # Name, obj); \
1455 }
1456
1457 #define SET_OBJECT_FUNCV(Name) \
1458 FTH \
1459 fth_set_object_ ## Name (FTH obj, void (*Name)(FTH self)) \
1460 { \
1461 if (OBJECT_TYPE_P(obj)) \
1462 FTH_OBJECT_REF(obj)->Name = Name; \
1463 return (obj); \
1464 } \
1465 static void \
1466 ficl_obj_ ## Name (FTH self) \
1467 { \
1468 FTH prc; \
1469 \
1470 prc = FTH_INSTANCE_REF_OBJ(self)->Name ## _proc; \
1471 fth_proc_call(prc, # Name, 1, self); \
1472 } \
1473 static void \
1474 ficl_set_ ## Name (ficlVm *vm) \
1475 { \
1476 FTH obj, prc; \
1477 ficlWord *word; \
1478 \
1479 FTH_STACK_CHECK(vm, 2, 0); \
1480 obj = ficlStackPopFTH(vm->dataStack); \
1481 word = ficlStackPopPointer(vm->dataStack); \
1482 \
1483 if (OBJECT_TYPE_P(obj)) { \
1484 prc = fth_make_proc(word, 1, 0, 0); \
1485 FTH_OBJECT_REF(obj)->Name = ficl_obj_ ## Name; \
1486 FTH_OBJECT_REF(obj)->Name ## _proc = prc; \
1487 } \
1488 else \
1489 fth_warning("%s: %S seems not to be an object-type", \
1490 # Name, obj); \
1491 }
1492
1493 SET_OBJECT_FUNC1(inspect)
SET_OBJECT_FUNC1(to_string)1494 SET_OBJECT_FUNC1(to_string)
1495 SET_OBJECT_FUNC1(dump)
1496 SET_OBJECT_FUNC1(to_array)
1497 SET_OBJECT_FUNC1(copy)
1498 SET_OBJECT_FUNC2(value_ref)
1499 SET_OBJECT_FUNC3(value_set)
1500 SET_OBJECT_FUNC2(equal_p)
1501 SET_OBJECT_FUNC1(length)
1502 SET_OBJECT_FUNCV(mark)
1503 SET_OBJECT_FUNCV(free)
1504
1505 #define h_set_insepct "( xt obj -- ) set XT as .inspect function\n\
1506 <'> enved-inspect fth-enved set-object-inspect\n\
1507 Set XT as OBJECT-INSPECT function for OBJ type.\n\
1508 See examples/site-lib/enved.fs for examples."
1509
1510 #define h_set_to_string "( xt obj -- ) set XT as object->string function\n\
1511 <'> enved->string fth-enved set-object->string\n\
1512 Set XT as OBJECT->STRING function for OBJ type.\n\
1513 See examples/site-lib/enved.fs for examples."
1514
1515 #define h_set_dump "( xt obj -- ) set XT as object-dump function\n\
1516 <'> enved->dump fth-enved set-object-dump\n\
1517 Set XT as OBJECT-DUMP function for OBJ type.\n\
1518 See examples/site-lib/enved.fs for examples."
1519
1520 #define h_set_to_array "( xt obj -- ) set XT as object->array function\n\
1521 <'> enved->array fth-enved set-object->array\n\
1522 Set XT as OBJECT->ARRAY function for OBJ type.\n\
1523 See examples/site-lib/enved.fs for examples."
1524
1525 #define h_set_copy "( xt obj -- ) set XT as object-copy function\n\
1526 <'> enved-copy fth-enved set-object-copy\n\
1527 Set XT as OBJECT-COPY function for OBJ type.\n\
1528 See examples/site-lib/enved.fs for examples."
1529
1530 #define h_set_value_ref "( xt obj -- ) set XT as object-ref function\n\
1531 <'> enved-ref fth-enved set-object-value-ref\n\
1532 Set XT as OBJECT-REF function for OBJ type.\n\
1533 See examples/site-lib/enved.fs for examples."
1534
1535 #define h_set_value_set "( xt obj -- ) set XT as object-set! function\n\
1536 <'> enved-set! fth-enved set-object-value-set\n\
1537 Set XT as OBJECT-SET! function for OBJ type.\n\
1538 See examples/site-lib/enved.fs for examples."
1539
1540 #define h_set_equal_p "( xt obj -- ) set XT as object-equal? function\n\
1541 <'> enved-equal? fth-enved set-object-equal-p\n\
1542 Set XT as OBJECT-EQUAL? function for OBJ type.\n\
1543 See examples/site-lib/enved.fs for examples."
1544
1545 #define h_set_length "( xt obj -- ) set XT as object-length function\n\
1546 <'> enved-length fth-enved set-object-length\n\
1547 Set XT as OBJECT-LENGTH function for OBJ type.\n\
1548 See examples/site-lib/enved.fs for examples."
1549
1550 #define h_set_mark "( xt obj -- ) set XT as gc-mark function\n\
1551 <'> enved-mark fth-enved set-object-mark\n\
1552 Set XT as GC mark function for OBJ type.\n\
1553 See examples/site-lib/enved.fs for examples."
1554
1555 #define h_set_free "( xt obj -- ) set XT as gc-free function\n\
1556 <'> enved-free fth-enved set-object-free\n\
1557 Set XT as GC free function for OBJ type.\n\
1558 See examples/site-lib/enved.fs for examples."
1559
1560 /* handles C objects */
1561 FTH
1562 fth_set_object_apply(FTH obj, void *apply, int req, int opt, int rest)
1563 {
1564 if (OBJECT_TYPE_P(obj)) {
1565 FTH prc;
1566
1567 /*
1568 * req + 1: self in addition to args length
1569 */
1570 prc = fth_make_proc_from_func(NULL, (FTH (*) ()) apply,
1571 0, req + 1, opt, rest);
1572 FTH_OBJECT_REF(obj)->apply = prc;
1573 }
1574 return (obj);
1575 }
1576
1577 /* handles Forth objects */
1578 static void
ficl_set_apply(ficlVm * vm)1579 ficl_set_apply(ficlVm *vm)
1580 {
1581 #define h_set_apply "( xt obj arity -- ) set XT as object-apply function\n\
1582 <'> enved-ref fth-enved 1 set-object-apply\n\
1583 Set XT as OBJECT-APPLY function for OBJ type.\n\
1584 See examples/site-lib/enved.fs for examples."
1585 FTH obj, arity;
1586 ficlWord *word;
1587 int req, opt, rest;
1588
1589 FTH_STACK_CHECK(vm, 3, 0);
1590 arity = fth_pop_ficl_cell(vm);
1591 obj = ficlStackPopFTH(vm->dataStack);
1592 word = ficlStackPopPointer(vm->dataStack);
1593 opt = 0;
1594 rest = 0;
1595
1596 /*
1597 * arity + 1: req + self
1598 */
1599 if (fth_array_length(arity) == 3) {
1600 req = FIX_TO_INT32(fth_array_ref(arity, 0L));
1601 opt = FIX_TO_INT32(fth_array_ref(arity, 1L));
1602 rest = FTH_TO_BOOL(fth_array_ref(arity, 2L));
1603 } else
1604 req = FIX_TO_INT32(arity) + 1;
1605
1606 if (OBJECT_TYPE_P(obj)) {
1607 FTH prc;
1608
1609 prc = fth_make_proc(word, req, opt, rest);
1610 FTH_OBJECT_REF(obj)->apply = prc;
1611 } else
1612 fth_warning("%s: %S seems not to be an object-type",
1613 RUNNING_WORD(), obj);
1614 }
1615
1616 /* Very special Snd XM case. */
1617 static int
xmobj_p(FTH obj)1618 xmobj_p(FTH obj)
1619 {
1620 ficlInteger len;
1621
1622 #define X_SYMBOL_P(Obj) \
1623 (FTH_SYMBOL_P(Obj) && isupper((int)(fth_symbol_ref(Obj)[0])))
1624
1625 len = fth_list_length(obj);
1626
1627 /*-
1628 * Xen Object (2|5)
1629 * '( 'Name pointer )
1630 * or
1631 * '( 'Name pointer bool zero zero )
1632 */
1633 if ((len == 2 || len == 5) && fth_unsigned_p(fth_array_ref(obj, 1L)))
1634 return (X_SYMBOL_P(fth_array_ref(obj, 0L)));
1635
1636 /*-
1637 * Xen Object (3) '( 'Name pointer object )
1638 */
1639 if (len == 3 &&
1640 fth_unsigned_p(fth_array_ref(obj, 1L) &&
1641 fth_instance_p(fth_array_ref(obj, 2L))))
1642 return (X_SYMBOL_P(fth_array_ref(obj, 0L)));
1643
1644 /*-
1645 * XEvent '( 'XXxxEvent pointer object 'XEvent )
1646 */
1647 if (len == 4 && X_SYMBOL_P(fth_array_ref(obj, 3L)))
1648 return (strncmp(fth_symbol_ref(fth_array_ref(obj, 3L)),
1649 "XEvent", 6L) == 0);
1650
1651 return (0);
1652 }
1653
1654 static void
ficl_xmobj_p(ficlVm * vm)1655 ficl_xmobj_p(ficlVm *vm)
1656 {
1657 #define h_xmobj_p "( obj -- f ) test if OBJ is a XmObj\n\
1658 nil xmobj? => #f\n\
1659 #( 'Atom 0 ) xmobj? => #t\n\
1660 Return #t if OBJ is an XmObj (xm.c), otherwise #f. \
1661 It is a very special Snd XM test.\n\
1662 See snd(1) for more information."
1663 FTH obj;
1664
1665 FTH_STACK_CHECK(vm, 1, 1);
1666 obj = fth_pop_ficl_cell(vm);
1667 ficlStackPushBoolean(vm->dataStack, xmobj_p(obj));
1668 }
1669
1670 static FTH
xmobj_to_string(FTH obj)1671 xmobj_to_string(FTH obj)
1672 {
1673 ficlInteger len;
1674 char *sym;
1675 void *p;
1676 FTH fs;
1677
1678 if (!xmobj_p(obj))
1679 return (FTH_FALSE);
1680
1681 len = fth_array_length(obj);
1682
1683 if (len < 2)
1684 return (FTH_FALSE);
1685
1686 sym = fth_symbol_ref(fth_array_ref(obj, 0L));
1687 p = (void *) fth_array_ref(obj, 1L);
1688 fs = fth_make_string("#( ");
1689
1690 switch (len) {
1691 case 2:
1692 /* #( symbol addr ) */
1693 fth_string_scat(fs, sym);
1694 fth_string_sformat(fs, " %p", p);
1695 break;
1696 case 3:
1697 /* #( symbol addr xm-obj-from-addr ) */
1698 if (fth_instance_p(fth_array_ref(obj, 2L))) {
1699 fth_string_scat(fs, "XmObj ");
1700 fth_string_scat(fs, sym);
1701 } else {
1702 fth_string_scat(fs, sym);
1703 fth_string_sformat(fs, " %p", p);
1704 }
1705 break;
1706 case 4:
1707 /* #( type addr xm-obj-from-addr symbol ) */
1708 if (fth_instance_p(fth_array_ref(obj, 2L))) {
1709 fth_string_scat(fs, "XEvent ");
1710 fth_string_sformat(fs, "%S", fth_array_ref(obj, 0L));
1711
1712 } else {
1713 fth_string_scat(fs, sym);
1714 fth_string_sformat(fs, " %p", p);
1715 }
1716 break;
1717 case 5:
1718 default:
1719 /* #( symbol code context prop-atom prot-atom ) */
1720 fth_string_scat(fs, "Callback ");
1721 fth_string_scat(fs, fth_symbol_ref(fth_array_ref(obj, 3L)));
1722 break;
1723 }
1724
1725 fth_string_scat(fs, " )");
1726 return (fs);
1727 }
1728
1729 /* === Object Functions === */
1730
1731 FTH
fth_hash_id(FTH obj)1732 fth_hash_id(FTH obj)
1733 {
1734 #define h_hash_id "( obj -- id ) return hash id\n\
1735 \"hello\" hash-id => 3583\n\
1736 \"hello\" hash-id => 3583\n\
1737 Return hash id computed from string representation of OBJ. \
1738 Objects with the same content have the same ID.\n\
1739 See also object-id."
1740 if (FTH_FIXNUM_P(obj))
1741 return (INT_TO_FIX(obj));
1742
1743 if (FICL_WORD_DEFINED_P(obj))
1744 return (INT_TO_FIX(FICL_WORD_REF(obj)->hash));
1745
1746 if (fth_instance_p(obj)) {
1747 char *str;
1748 ficlString s;
1749
1750 str = fth_to_c_string(obj);
1751 FICL_STRING_SET_FROM_CSTRING(s, str);
1752 return (INT_TO_FIX(ficlHashCode(s)));
1753 }
1754 return ((FTH) ((ficlInteger) obj | FIXNUM_FLAG));
1755 }
1756
1757 FTH
fth_object_id(FTH obj)1758 fth_object_id(FTH obj)
1759 {
1760 #define h_object_id "( obj -- id ) return uniq id\n\
1761 \"hello\" object-id => 378357376\n\
1762 \"hello\" object-id => 378358144\n\
1763 Return object id of OBJ, a uniq number.\n\
1764 See also hash-id."
1765 if (IMMEDIATE_P(obj))
1766 return (INT_TO_FIX(obj));
1767
1768 return ((FTH) ((ficlInteger) obj | FIXNUM_FLAG));
1769 }
1770
1771 char *
fth_object_name(FTH obj)1772 fth_object_name(FTH obj)
1773 {
1774 if (obj == 0 || (IMMEDIATE_P(obj) && FIXNUM_P(obj)))
1775 return ("fixnum");
1776
1777 if (INSTANCE_P(obj)) {
1778 if (FTH_ULLONG_P(obj))
1779 return ("unsigned llong");
1780
1781 if (FTH_UNSIGNED_P(obj))
1782 return ("unsigned integer");
1783
1784 return (FTH_INSTANCE_NAME(obj));
1785 }
1786 if (FICL_WORD_DEFINED_P(obj)) {
1787 switch (FICL_WORD_TYPE(obj)) {
1788 case FW_WORD:
1789 return ("word");
1790 break;
1791 case FW_PROC:
1792 return ("proc");
1793 break;
1794 case FW_SYMBOL:
1795 return ("symbol");
1796 break;
1797 case FW_KEYWORD:
1798 return ("keyword");
1799 break;
1800 case FW_EXCEPTION:
1801 return ("exception");
1802 break;
1803 case FW_VARIABLE:
1804 return ("variable");
1805 break;
1806 case FW_TRACE_VAR:
1807 return ("trace-var");
1808 break;
1809 default:
1810 return ("unknown-word-type");
1811 break;
1812 }
1813 }
1814 if (OBJECT_TYPE_P(obj))
1815 return ("object-type");
1816
1817 return ("addr");
1818 }
1819
1820 static void
ficl_object_name(ficlVm * vm)1821 ficl_object_name(ficlVm *vm)
1822 {
1823 #define h_object_name "( obj -- name ) return name of OBJ\n\
1824 #( 0 1 2 ) object-name => \"array\"\n\
1825 1+i object-name => \"complex\"\n\
1826 1 object-name => \"fixnum\"\n\
1827 Return object type name of OBJ as a string.\n\
1828 See also .object-name."
1829 FTH obj;
1830
1831 FTH_STACK_CHECK(vm, 1, 1);
1832 obj = fth_pop_ficl_cell(vm);
1833 push_cstring(vm, fth_object_name(obj));
1834 }
1835
1836 static void
ficl_print_object_name(ficlVm * vm)1837 ficl_print_object_name(ficlVm *vm)
1838 {
1839 #define h_print_object_name "( obj -- ) print name of OBJ\n\
1840 #( 0 1 2 ) .object-name => array\n\
1841 1+i .object-name => complex\n\
1842 1 .object-name => fixnum\n\
1843 Print object name of OBJ to current stdout.\n\
1844 See also object-name."
1845 FTH obj;
1846
1847 FTH_STACK_CHECK(vm, 1, 0);
1848 obj = fth_pop_ficl_cell(vm);
1849 fth_print(fth_object_name(obj));
1850 }
1851
1852 static FTH
print_object(FTH obj,fth_inspect_type_t type)1853 print_object(FTH obj, fth_inspect_type_t type)
1854 {
1855 FTH fs;
1856
1857 fs = FTH_FALSE;
1858
1859 if (obj == 0 || (IMMEDIATE_P(obj) && FIXNUM_P(obj))) {
1860 if (type == OBJ_INSPECT) {
1861 fs = fth_make_string(fth_object_name(obj));
1862 fth_string_sformat(fs, ": %ld", FIX_TO_INT(obj));
1863 } else
1864 fs = fth_make_string_format("%ld", FIX_TO_INT(obj));
1865 } else if (INSTANCE_P(obj)) {
1866 /* xm.c */
1867 if (xmobj_p(obj))
1868 fs = xmobj_to_string(obj);
1869 else {
1870 switch (type) {
1871 case OBJ_INSPECT:
1872 if (FTH_INSPECT_P(obj))
1873 fs = FTH_INSPECT(obj);
1874 else if (FTH_TO_STRING_P(obj))
1875 fs = FTH_TO_STRING(obj);
1876 else if (FTH_DUMP_P(obj))
1877 fs = FTH_DUMP(obj);
1878
1879 if (!fth_hook_empty_p(
1880 FTH_INSTANCE_DEBUG_HOOK(obj)))
1881 fs = fth_run_hook_again(
1882 FTH_INSTANCE_DEBUG_HOOK(obj),
1883 2, fs, obj);
1884 break;
1885 case OBJ_TO_STRING:
1886 if (FTH_TO_STRING_P(obj))
1887 fs = FTH_TO_STRING(obj);
1888 else if (FTH_INSPECT_P(obj))
1889 fs = FTH_INSPECT(obj);
1890 else if (FTH_DUMP_P(obj))
1891 fs = FTH_DUMP(obj);
1892 break;
1893 case OBJ_DUMP:
1894 default:
1895 if (FTH_DUMP_P(obj))
1896 fs = FTH_DUMP(obj);
1897 else if (FTH_TO_STRING_P(obj))
1898 fs = FTH_TO_STRING(obj);
1899 else if (FTH_INSPECT_P(obj))
1900 fs = FTH_INSPECT(obj);
1901 break;
1902 }
1903
1904 if (FTH_FALSE_P(fs)) {
1905 char *s;
1906 void *p;
1907
1908 s = FTH_INSTANCE_NAME(obj);
1909 p = (void *) obj;
1910 fs = fth_make_string_format("%s:%p", s, p);
1911 }
1912 }
1913 } else if (FICL_WORD_DEFINED_P(obj))
1914 switch (type) {
1915 case OBJ_INSPECT:
1916 fs = fth_make_string(fth_object_name(obj));
1917 fth_string_sformat(fs, ": %S", fth_word_inspect(obj));
1918 break;
1919 case OBJ_TO_STRING:
1920 fs = fth_word_to_string(obj);
1921 break;
1922 case OBJ_DUMP:
1923 default:
1924 fs = fth_word_dump(obj);
1925 break;
1926 }
1927 else if (OBJECT_TYPE_P(obj))
1928 switch (type) {
1929 case OBJ_INSPECT:
1930 fs = fth_make_string(fth_object_name(obj));
1931 fth_string_scat(fs, ": ");
1932 fth_string_scat(fs, FTH_OBJECT_NAME(obj));
1933 break;
1934 default:
1935 fs = fth_make_string(FTH_OBJECT_NAME(obj));
1936 break;
1937 }
1938
1939 if (FTH_FALSE_P(fs))
1940 fs = fth_make_string_format("addr %p", obj);
1941
1942 if (type == OBJ_INSPECT) {
1943 if (fth_string_length(fs) < 3 ||
1944 (FTH_TO_CHAR(fth_string_char_ref(fs, 0L)) != (int) '#' &&
1945 FTH_TO_CHAR(fth_string_char_ref(fs, 1L)) != (int) '<'))
1946 fs = fth_make_string_format("#<%S>", fs);
1947 }
1948 return (fs);
1949 }
1950
1951 static void
ficl_print_inspect(ficlVm * vm)1952 ficl_print_inspect(ficlVm *vm)
1953 {
1954 #define h_print_inspect "( obj -- ) print inspect string\n\
1955 #( 0 ) .inspect => #<array[1]: #<fixnum: 0>>\n\
1956 Print inspect string of OBJ.\n\
1957 See also object-inspect, object->string and object-dump."
1958 FTH obj;
1959
1960 FTH_STACK_CHECK(vm, 1, 0);
1961 obj = fth_pop_ficl_cell(vm);
1962 fth_print(fth_to_c_string(print_object(obj, OBJ_INSPECT)));
1963 }
1964
1965 FTH
fth_object_inspect(FTH obj)1966 fth_object_inspect(FTH obj)
1967 {
1968 #define h_object_inspect "( obj -- str ) return inspect string\n\
1969 #( 0 ) object-inspect => \"#<array[1]: #<fixnum: 0>>\"\n\
1970 Return inspect string of OBJ.\n\
1971 See also .inspect, object->string and object-dump."
1972 return (print_object(obj, OBJ_INSPECT));
1973 }
1974
1975 /*
1976 * Return Fth string representation of OBJ.
1977 */
1978 FTH
fth_object_to_string(FTH obj)1979 fth_object_to_string(FTH obj)
1980 {
1981 #define h_object_to_string "( obj -- str ) return OBJ as string\n\
1982 #( 0 ) object->string => \"#( 0 )\"\n\
1983 Return string representation of OBJ.\n\
1984 See also .inspect, object-inspect and object-dump."
1985 return (print_object(obj, OBJ_TO_STRING));
1986 }
1987
1988 /* For object type function obj_to_string. */
1989 FTH
fth_object_to_string_2(FTH obj)1990 fth_object_to_string_2(FTH obj)
1991 {
1992 if (FTH_STRING_P(obj))
1993 return (fth_make_string_format("\"%S\"", obj));
1994
1995 return (print_object(obj, OBJ_TO_STRING));
1996 }
1997
1998 FTH
fth_object_dump(FTH obj)1999 fth_object_dump(FTH obj)
2000 {
2001 #define h_object_dump "( obj -- str ) return OBJ as string\n\
2002 #( 0 ) object-dump => \"#( 0 )\"\n\
2003 #( 0 ) object-dump string-eval value a1\n\
2004 a1 object-name => \"array\"\n\
2005 a1 object->string => \"#( 0 )\"\n\
2006 Return dump string of OBJ which one can eval to get the object back.\n\
2007 See also .inspect, object-inspect and object->string."
2008 return (print_object(obj, OBJ_DUMP));
2009 }
2010
2011 char *
fth_to_c_inspect(FTH obj)2012 fth_to_c_inspect(FTH obj)
2013 {
2014 return (fth_string_ref(print_object(obj, OBJ_INSPECT)));
2015 }
2016
2017 char *
fth_to_c_string(FTH obj)2018 fth_to_c_string(FTH obj)
2019 {
2020 return (fth_string_ref(print_object(obj, OBJ_TO_STRING)));
2021 }
2022
2023 /* For object type function obj_to_string. */
2024 char *
fth_to_c_string_2(FTH obj)2025 fth_to_c_string_2(FTH obj)
2026 {
2027 return (fth_string_ref(fth_object_to_string_2(obj)));
2028 }
2029
2030 char *
fth_to_c_dump(FTH obj)2031 fth_to_c_dump(FTH obj)
2032 {
2033 return (fth_string_ref(print_object(obj, OBJ_DUMP)));
2034 }
2035
2036 FTH
fth_object_to_array(FTH obj)2037 fth_object_to_array(FTH obj)
2038 {
2039 #define h_object_to_array "( obj -- ary ) return OBJ as array\n\
2040 \"foo\" object->array => #( 102 111 111 )\n\
2041 1 object->array => #( 1 )\n\
2042 Return OBJ as array."
2043 if (INSTANCE_P(obj) && FTH_TO_ARRAY_P(obj)) {
2044 FInstance *inst;
2045
2046 GC_MARK_SET(FTH_INSTANCE_REF(obj));
2047 inst = FTH_INSTANCE_REF(obj);
2048
2049 if (inst->changed_p || inst->extern_p) {
2050 inst->values = FTH_TO_ARRAY(obj);
2051 inst->changed_p = 0;
2052 }
2053 return (inst->values);
2054 }
2055 return (fth_make_array_var(1, obj));
2056 }
2057
2058 FTH
fth_object_copy(FTH obj)2059 fth_object_copy(FTH obj)
2060 {
2061 #define h_object_copy "( obj1 -- obj2 ) return copy of OBJ1\n\
2062 #( 0 1 2 ) value a1\n\
2063 a1 object-copy value a2\n\
2064 a1 a2 object-equal? => #t\n\
2065 Return copy of OBJ1. \
2066 Copy any element if OBJ1 is an instance."
2067 if (obj != 0 && INSTANCE_P(obj) && FTH_COPY_P(obj)) {
2068 FTH new;
2069 FInstance *inst, *new_inst;
2070
2071 GC_MARK_SET(FTH_INSTANCE_REF(obj));
2072
2073 if (FTH_BOOLEAN_P(obj) || FTH_NIL_TYPE_P(obj))
2074 return (obj);
2075
2076 new = FTH_COPY(obj);
2077 inst = FTH_INSTANCE_REF(obj);
2078 new_inst = FTH_INSTANCE_REF(new);
2079 new_inst->properties = fth_object_copy(inst->properties);
2080 new_inst->extern_p = inst->extern_p;
2081 new_inst->cycle = inst->cycle;
2082 return (new);
2083 }
2084 return (obj);
2085 }
2086
2087 FTH
fth_object_value_ref(FTH obj,ficlInteger idx)2088 fth_object_value_ref(FTH obj, ficlInteger idx)
2089 {
2090 if (INSTANCE_P(obj) && FTH_VALUE_REF_P(obj)) {
2091 GC_MARK_SET(FTH_INSTANCE_REF(obj));
2092
2093 if (idx < 0)
2094 idx += fth_object_length(obj);
2095
2096 return (FTH_VALUE_REF(obj, fth_make_int(idx)));
2097 }
2098 return (obj);
2099 }
2100
2101 static void
ficl_object_ref(ficlVm * vm)2102 ficl_object_ref(ficlVm *vm)
2103 {
2104 #define h_object_ref "( obj index -- value) return value at INDEX\n\
2105 #( 0 1 2 ) 1 object-ref => 1\n\
2106 1 1 object-ref => 1\n\
2107 Return value at INDEX from OBJ. \
2108 If OBJ is of a type which can have multiple elements, \
2109 an array for example, return value at INDEX. \
2110 If OBJ is of a type which consists of only one element, \
2111 a fixnum for example, ignore INDEX and return OBJ itself.\n\
2112 See also object-set!."
2113 ficlInteger idx;
2114 FTH obj;
2115
2116 FTH_STACK_CHECK(vm, 2, 1);
2117 idx = ficlStackPopInteger(vm->dataStack);
2118 obj = fth_pop_ficl_cell(vm);
2119 fth_push_ficl_cell(vm, fth_object_value_ref(obj, idx));
2120 }
2121
2122 FTH
fth_object_value_set(FTH obj,ficlInteger idx,FTH value)2123 fth_object_value_set(FTH obj, ficlInteger idx, FTH value)
2124 {
2125 if (INSTANCE_P(obj) && FTH_VALUE_SET_P(obj)) {
2126 GC_MARK_SET(FTH_INSTANCE_REF(obj));
2127
2128 if (idx < 0)
2129 idx += fth_object_length(obj);
2130
2131 return (FTH_VALUE_SET(obj, fth_make_int(idx), value));
2132 }
2133 return (value);
2134 }
2135
2136 static void
ficl_object_set(ficlVm * vm)2137 ficl_object_set(ficlVm *vm)
2138 {
2139 #define h_object_set "( obj index value -- ) set VALUE at INDEX\n\
2140 #( 0 1 2 ) value a1\n\
2141 a1 1 \"a\" object-set!\n\
2142 a1 .$ => #( 0 \"a\" 2 )\n\
2143 1 value a2\n\
2144 a2 1 \"a\" object-set!\n\
2145 a2 .$ => 1\n\
2146 Set VALUE at INDEX to OBJ. \
2147 If OBJ is of a type which can have multiple elements, \
2148 an array for example, set VALUE at position INDEX. \
2149 If OBJ is of a type which consists of only one element, \
2150 a fixnum for example, do nothing.\n\
2151 See also object-ref."
2152 ficlInteger idx;
2153 FTH obj;
2154 FTH val;
2155
2156 FTH_STACK_CHECK(vm, 3, 0);
2157 val = fth_pop_ficl_cell(vm);
2158 idx = ficlStackPopInteger(vm->dataStack);
2159 obj = fth_pop_ficl_cell(vm);
2160 fth_object_value_set(obj, idx, val);
2161 }
2162
2163 static void
ficl_add_store_object(ficlVm * vm)2164 ficl_add_store_object(ficlVm *vm)
2165 {
2166 #define h_add_store_object "( obj index value -- ) add VALUE\n\
2167 #( 0 1 2 ) value a1\n\
2168 a1 1 2 object-set+!\n\
2169 a1 .$ => #( 0 3 2 )\n\
2170 Add VALUE to value at INDEX of OBJ. \
2171 Value may be any number (ficlInteger, ficlFloat, ficlRatio, \
2172 or ficlComplex).\n\
2173 See also object-set-!, object-set*! and object-set/!."
2174 ficlInteger idx;
2175 FTH obj;
2176 FTH value;
2177 FTH res;
2178
2179 FTH_STACK_CHECK(vm, 3, 0);
2180 value = fth_pop_ficl_cell(vm);
2181 idx = ficlStackPopInteger(vm->dataStack);
2182 obj = fth_pop_ficl_cell(vm);
2183 res = fth_number_add(fth_object_value_ref(obj, idx), value);
2184 fth_object_value_set(obj, idx, res);
2185 }
2186
2187 static void
ficl_sub_store_object(ficlVm * vm)2188 ficl_sub_store_object(ficlVm *vm)
2189 {
2190 #define h_sub_store_object "( obj index value -- ) subtract VALUE\n\
2191 #( 0 1 2 ) value a1\n\
2192 a1 1 2 object-set-!\n\
2193 a1 .$ => #( 0 -1 2 )\n\
2194 Subtract VALUE from value at INDEX of OBJ. \
2195 Value may be any number (ficlInteger, ficlFloat, ficlRatio, \
2196 or ficlComplex).\n\
2197 See also object-set+!, object-set*! and object-set/!."
2198 ficlInteger idx;
2199 FTH obj;
2200 FTH value;
2201 FTH res;
2202
2203 FTH_STACK_CHECK(vm, 3, 0);
2204 value = fth_pop_ficl_cell(vm);
2205 idx = ficlStackPopInteger(vm->dataStack);
2206 obj = fth_pop_ficl_cell(vm);
2207 res = fth_number_sub(fth_object_value_ref(obj, idx), value);
2208 fth_object_value_set(obj, idx, res);
2209 }
2210
2211 static void
ficl_mul_store_object(ficlVm * vm)2212 ficl_mul_store_object(ficlVm *vm)
2213 {
2214 #define h_mul_store_object "( obj index value -- ) multiply with VALUE\n\
2215 #( 0 1 2 ) value a1\n\
2216 a1 2 2 object-set*!\n\
2217 a1 .$ => #( 0 1 4 )\n\
2218 Multiply VALUE with value at INDEX of OBJ. \
2219 Value may be any number (ficlInteger, ficlFloat, ficlRatioi, \
2220 or ficlComplex).\n\
2221 See also object-set+!, object-set-! and object-set/!."
2222 ficlInteger idx;
2223 FTH obj;
2224 FTH value;
2225 FTH res;
2226
2227 FTH_STACK_CHECK(vm, 3, 0);
2228 value = fth_pop_ficl_cell(vm);
2229 idx = ficlStackPopInteger(vm->dataStack);
2230 obj = fth_pop_ficl_cell(vm);
2231 res = fth_number_mul(fth_object_value_ref(obj, idx), value);
2232 fth_object_value_set(obj, idx, res);
2233 }
2234
2235 static void
ficl_div_store_object(ficlVm * vm)2236 ficl_div_store_object(ficlVm *vm)
2237 {
2238 #define h_div_store_object "( obj index value -- ) divide by VALUE\n\
2239 #( 0 1 2 ) value a1\n\
2240 a1 2 2 object-set/!\n\
2241 a1 .$ => #( 0 1 1 )\n\
2242 Divide value at INDEX of OBJ by VALUE. \
2243 Value may be any number (ficlInteger, ficlFloat, ficlRatio, \
2244 or ficlComplex).\n\
2245 See also object-set+!, object-set-! and object-set*!."
2246 ficlInteger idx;
2247 FTH obj;
2248 FTH value;
2249 FTH res;
2250
2251 FTH_STACK_CHECK(vm, 3, 0);
2252 value = fth_pop_ficl_cell(vm);
2253 idx = ficlStackPopInteger(vm->dataStack);
2254 obj = fth_pop_ficl_cell(vm);
2255 res = fth_number_div(fth_object_value_ref(obj, idx), value);
2256 fth_object_value_set(obj, idx, res);
2257 }
2258
2259 /*
2260 * Test if OBJ1 is equal OBJ2.
2261 */
2262 int
fth_object_equal_p(FTH obj1,FTH obj2)2263 fth_object_equal_p(FTH obj1, FTH obj2)
2264 {
2265 if (obj1 == obj2)
2266 return (1);
2267
2268 if (INSTANCE_P(obj1) && INSTANCE_P(obj2))
2269 if (FTH_INSTANCE_TYPE(obj1) == FTH_INSTANCE_TYPE(obj2))
2270 if (FTH_EQUAL_P_P(obj1))
2271 return (FTH_TO_BOOL(FTH_EQUAL_P(obj1, obj2)));
2272
2273 return (0);
2274 }
2275
2276 static void
ficl_object_equal_p(ficlVm * vm)2277 ficl_object_equal_p(ficlVm *vm)
2278 {
2279 #define h_object_equal_p "( obj1 obj2 -- f ) compare OBJ1 with OBJ2\n\
2280 #( 0 1 2 ) value a1\n\
2281 #( 0 1 2 ) value a2\n\
2282 #{ 0 0 1 1 2 2 } value h1\n\
2283 a1 a2 object-equal? => #t\n\
2284 a1 h1 object-equal? => #f\n\
2285 Return #t if OBJ1 and OBJ2 have equal content, otherwise #f."
2286 int flag;
2287 FTH obj1;
2288 FTH obj2;
2289
2290 FTH_STACK_CHECK(vm, 2, 1);
2291 obj2 = fth_pop_ficl_cell(vm);
2292 obj1 = fth_pop_ficl_cell(vm);
2293 flag = fth_object_equal_p(obj1, obj2);
2294 ficlStackPushBoolean(vm->dataStack, flag);
2295 }
2296
2297 ficlInteger
fth_object_length(FTH obj)2298 fth_object_length(FTH obj)
2299 {
2300 if (INSTANCE_P(obj) && FTH_LENGTH_P(obj)) {
2301 GC_MARK_SET(FTH_INSTANCE_REF(obj));
2302 return (fth_int_ref(FTH_LENGTH(obj)));
2303 }
2304 return (0);
2305 }
2306
2307 static void
ficl_object_length(ficlVm * vm)2308 ficl_object_length(ficlVm *vm)
2309 {
2310 #define h_object_length "( obj -- len ) return length\n\
2311 #( 0 1 2 ) object-length => 3\n\
2312 #{ 0 0 1 1 2 2 } object-length => 3\n\
2313 10 object-length => 0\n\
2314 Return length of OBJ."
2315 ficlInteger len;
2316
2317 FTH_STACK_CHECK(vm, 1, 1);
2318 len = fth_object_length(fth_pop_ficl_cell(vm));
2319 ficlStackPushInteger(vm->dataStack, len);
2320 }
2321
2322 FTH
fth_object_apply(FTH obj,FTH args)2323 fth_object_apply(FTH obj, FTH args)
2324 {
2325 #define h_object_apply "( obj args -- result ) run apply with ARGS\n\
2326 #( 0.3 1.0 2.0 ) value a1\n\
2327 a1 0 array-ref => 0.3\n\
2328 a1 0 object-ref => 0.3\n\
2329 a1 0 object-apply => 0.3\n\
2330 a1 #( 0 ) object-apply => 0.3\n\
2331 Run apply on OBJ with ARGS as arguments. \
2332 ARGS can be an array of arguments or a single argument. \
2333 The number of ARGS must fit apply's definition. \
2334 The next two examples require each 1 argument:\n\
2335 C: fth_set_object_apply(vct_tag, vct_ref, 1, 0, 0);\n\
2336 Forth: <'> enved-ref fth-enved 1 set-object-apply\n\
2337 See examples/site-lib/enved.fs for Forth examples \
2338 and eg. src/array.c for C examples."
2339 FTH prc;
2340 FTH r;
2341
2342 if (!INSTANCE_P(obj))
2343 return (FTH_FALSE);
2344
2345 GC_MARK_SET(FTH_INSTANCE_REF(obj));
2346 prc = FTH_INSTANCE_REF_OBJ(obj)->apply;
2347
2348 if (!FTH_PROC_P(prc))
2349 return (FTH_FALSE);
2350
2351 if (!FTH_ARRAY_P(args)) {
2352 if (FICL_WORD_LENGTH(prc) > 1)
2353 args = fth_make_array_var(1, args);
2354 else
2355 args = fth_make_empty_array();
2356 }
2357 r = fth_proc_apply(prc, fth_array_unshift(args, obj), RUNNING_WORD());
2358 return (r);
2359 }
2360
2361 int
fth_object_empty_p(FTH obj)2362 fth_object_empty_p(FTH obj)
2363 {
2364 return (fth_object_length(obj) == 0);
2365 }
2366
2367 static void
ficl_object_empty_p(ficlVm * vm)2368 ficl_object_empty_p(ficlVm *vm)
2369 {
2370 #define h_object_empty_p "( obj -- f ) test if OBJ is empty\n\
2371 #() object-empty? => #t\n\
2372 #{ 'a 10 } object-empty? => #f\n\
2373 1 object-empty? => #f\n\
2374 Return #t if length of OBJ is zero, otherwise #f."
2375 FTH obj;
2376
2377 FTH_STACK_CHECK(vm, 1, 1);
2378 obj = fth_pop_ficl_cell(vm);
2379 ficlStackPushBoolean(vm->dataStack, fth_object_empty_p(obj));
2380 }
2381
2382 int
fth_object_range_p(FTH obj,ficlInteger idx)2383 fth_object_range_p(FTH obj, ficlInteger idx)
2384 {
2385 return (idx >= 0 && idx < fth_object_length(obj));
2386 }
2387
2388 static void
ficl_object_range_p(ficlVm * vm)2389 ficl_object_range_p(ficlVm *vm)
2390 {
2391 #define h_object_range_p "( obj index -- f ) test if INDEX is in range\n\
2392 #( 0 1 2 ) 0 object-range? => #t\n\
2393 #( 0 1 2 ) 3 object-range? => #f\n\
2394 #( 0 1 2 ) -3 object-range? => #f\n\
2395 Return #t if INDEX is in range of OBJ, otherwise #f. \
2396 If INDEX is negative, return #f."
2397 ficlInteger idx;
2398 FTH obj;
2399
2400 FTH_STACK_CHECK(vm, 2, 1);
2401 idx = ficlStackPopInteger(vm->dataStack);
2402 obj = fth_pop_ficl_cell(vm);
2403 ficlStackPushBoolean(vm->dataStack, fth_object_range_p(obj, idx));
2404 }
2405
2406 int
fth_object_member_p(FTH obj,FTH key)2407 fth_object_member_p(FTH obj, FTH key)
2408 {
2409 ficlInteger i;
2410
2411 for (i = 0; i < fth_object_length(obj); i++) {
2412 FTH val;
2413
2414 val = fth_object_value_ref(obj, i);
2415
2416 if (val == key || fth_object_equal_p(val, key))
2417 return (1);
2418 }
2419
2420 return (0);
2421 }
2422
2423 static void
ficl_object_member_p(ficlVm * vm)2424 ficl_object_member_p(ficlVm *vm)
2425 {
2426 #define h_object_member_p "( obj key -- f ) test if KEY exist\n\
2427 #( \"0\" \"1\" \"2\" ) \"0\" object-member? => #t\n\
2428 #{ 'a 10 'b 20 } #( 'b 20 ) object-member? => #t\n\
2429 #{ 'a 10 'b 20 } 'b object-member? => #f\n\
2430 \"foo\" <char> f object-member? => #t\n\
2431 Return #t if KEY is present in OBJ, otherwise #f.\n\
2432 See also object-find and object-index."
2433 FTH key;
2434 FTH obj;
2435
2436 FTH_STACK_CHECK(vm, 2, 1);
2437 key = fth_pop_ficl_cell(vm);
2438 obj = fth_pop_ficl_cell(vm);
2439 ficlStackPushBoolean(vm->dataStack, fth_object_member_p(obj, key));
2440 }
2441
2442 FTH
fth_object_find(FTH obj,FTH key)2443 fth_object_find(FTH obj, FTH key)
2444 {
2445 #define h_object_find "( obj key -- value|#f ) return value of KEY\n\
2446 #( \"0\" \"1\" \"2\" ) \"0\" object-find => \"0\"\n\
2447 #{ 'a 10 'b 20 } #( 'b 20 ) object-find => '( 'b . 20 )\n\
2448 #{ 'a 10 'b 20 } 'b object-find => #f\n\
2449 \"foo\" <char> f object-find => 102\n\
2450 Search for KEY in OBJ and return corresponding value or #f if not found.\n\
2451 See also object-member? and object-index."
2452 ficlInteger i;
2453
2454 for (i = 0; i < fth_object_length(obj); i++) {
2455 FTH val;
2456
2457 val = fth_object_value_ref(obj, i);
2458
2459 if (val == key || fth_object_equal_p(val, key))
2460 return (val);
2461 }
2462
2463 return (FTH_FALSE);
2464 }
2465
2466 FTH
fth_object_index(FTH obj,FTH key)2467 fth_object_index(FTH obj, FTH key)
2468 {
2469 #define h_object_index "( obj key -- index|-1 ) return index of KEY\n\
2470 #( \"0\" \"1\" \"2\" ) \"0\" object-index => 0\n\
2471 #{ 'a 10 'b 20 } #( 'b 20 ) object-index => 1\n\
2472 #{ 'a 10 'b 20 } 'b object-index => -1\n\
2473 \"foo\" <char> f object-index => 0\n\
2474 Search for KEY in OBJ and return index or -1 if not found.\n\
2475 See also object-member? and object-find."
2476 ficlInteger i;
2477
2478 for (i = 0; i < fth_object_length(obj); i++) {
2479 FTH val;
2480
2481 val = fth_object_value_ref(obj, i);
2482
2483 if (val == key || fth_object_equal_p(val, key))
2484 return (fth_make_int(i));
2485 }
2486
2487 return (FTH_ONE_NEG);
2488 }
2489
2490 FTH
fth_object_sort(FTH obj,FTH proc_or_xt)2491 fth_object_sort(FTH obj, FTH proc_or_xt)
2492 {
2493 #define h_object_sort "( obj cmd-xt -- ary ) sort OBJ\n\
2494 : numb-sort { val1 val2 -- n }\n\
2495 val1 val2 < if\n\
2496 -1\n\
2497 else\n\
2498 val1 val2 > if\n\
2499 1\n\
2500 else\n\
2501 0\n\
2502 then\n\
2503 then\n\
2504 ;\n\
2505 #( 6 2 8 1 ) <'> numb-sort object-sort => #( 1 2 6 8 )\n\
2506 Convert OBJ to an array, sort and return it. \
2507 CMP-XT compares two items A and B and should return \
2508 a negative integer if A < B, \
2509 0 if A == B, and a positive integer if A > B."
2510 return (fth_array_sort(fth_object_to_array(obj), proc_or_xt));
2511 }
2512
2513 /* === Cycle === */
2514
2515 #define FTH_CYCLE_NEXT(obj) \
2516 if ((fth_object_length(obj) - 1) > FTH_INSTANCE_REF(obj)->cycle)\
2517 FTH_INSTANCE_REF(obj)->cycle++; \
2518 else \
2519 FTH_INSTANCE_REF(obj)->cycle = 0
2520
2521 ficlInteger
fth_cycle_pos_ref(FTH obj)2522 fth_cycle_pos_ref(FTH obj)
2523 {
2524 if (INSTANCE_P(obj))
2525 return (FTH_INSTANCE_REF(obj)->cycle);
2526
2527 return (0);
2528 }
2529
2530 ficlInteger
fth_cycle_pos_set(FTH obj,ficlInteger idx)2531 fth_cycle_pos_set(FTH obj, ficlInteger idx)
2532 {
2533 if (!INSTANCE_P(obj))
2534 return (0);
2535
2536 if (idx < 0)
2537 FTH_INSTANCE_REF(obj)->cycle = 0;
2538 else if (idx >= fth_object_length(obj))
2539 FTH_INSTANCE_REF(obj)->cycle = fth_object_length(obj) - 1;
2540 else
2541 FTH_INSTANCE_REF(obj)->cycle = idx;
2542
2543 return (FTH_INSTANCE_REF(obj)->cycle);
2544 }
2545
2546 ficlInteger
fth_cycle_pos_0(FTH obj)2547 fth_cycle_pos_0(FTH obj)
2548 {
2549 if (INSTANCE_P(obj))
2550 return (FTH_INSTANCE_REF(obj)->cycle = 0);
2551
2552 return (0);
2553 }
2554
2555 ficlInteger
fth_cycle_next(FTH obj)2556 fth_cycle_next(FTH obj)
2557 {
2558 if (INSTANCE_P(obj)) {
2559 FTH_CYCLE_NEXT(obj);
2560 return (FTH_INSTANCE_REF(obj)->cycle);
2561 }
2562 return (0);
2563 }
2564
2565 FTH
fth_object_cycle_ref(FTH obj)2566 fth_object_cycle_ref(FTH obj)
2567 {
2568 #define h_object_cycle_ref "( obj -- val ) return next value\n\
2569 #( 0 1 2 ) value a\n\
2570 a cycle-ref => 0\n\
2571 a cycle-ref => 1\n\
2572 a cycle-ref => 2\n\
2573 a cycle-ref => 0\n\
2574 a cycle-ref => 1\n\
2575 Return value at current cycle-index of OBJ and increment cycle-index. \
2576 Cycle through content of OBJ from first to last entry \
2577 and start again at the beginning etc.\n\
2578 See also cycle-set!"
2579 FTH value;
2580
2581 if (!INSTANCE_P(obj))
2582 return (FTH_FALSE);
2583
2584 value = fth_object_value_ref(obj, FTH_INSTANCE_REF(obj)->cycle);
2585 FTH_CYCLE_NEXT(obj);
2586 return (value);
2587 }
2588
2589 FTH
fth_object_cycle_set(FTH obj,FTH value)2590 fth_object_cycle_set(FTH obj, FTH value)
2591 {
2592 if (!INSTANCE_P(obj))
2593 return (value);
2594
2595 fth_object_value_set(obj, FTH_INSTANCE_REF(obj)->cycle, value);
2596 FTH_CYCLE_NEXT(obj);
2597 return (value);
2598 }
2599
2600 static void
ficl_object_cycle_set(ficlVm * vm)2601 ficl_object_cycle_set(ficlVm *vm)
2602 {
2603 #define h_object_cycle_set "( obj value -- ) store VALUE and incr index\n\
2604 #( 0 1 2 ) value a\n\
2605 a .$ => #( 0 1 2 )\n\
2606 a 10 cycle-set!\n\
2607 a 11 cycle-set!\n\
2608 a 12 cycle-set!\n\
2609 a .$ => #( 10 11 12 )\n\
2610 a 13 cycle-set!\n\
2611 a 14 cycle-set!\n\
2612 a .$ => #( 13 14 12 )\n\
2613 Store VALUE at current cycle-index of OBJ and increment cycle-index. \
2614 Cycle through content of OBJ from first to last entry \
2615 and start again at the beginning etc.\n\
2616 See also cycle-ref."
2617 FTH obj;
2618 FTH val;
2619
2620 FTH_STACK_CHECK(vm, 2, 0);
2621 val = fth_pop_ficl_cell(vm);
2622 obj = fth_pop_ficl_cell(vm);
2623 fth_object_cycle_set(obj, val);
2624 }
2625
2626 static void
ficl_cycle_pos_ref(ficlVm * vm)2627 ficl_cycle_pos_ref(ficlVm *vm)
2628 {
2629 #define h_cycle_pos_ref "( obj -- index ) return cycle-index\n\
2630 #( 1 2 3 ) value a\n\
2631 a cycle-start@ => 0\n\
2632 a cycle-ref => 1\n\
2633 a cycle-start@ => 1\n\
2634 a cycle-ref => 2\n\
2635 a cycle-start@ => 2\n\
2636 a cycle-ref => 3\n\
2637 a cycle-start@ => 0\n\
2638 Return current cycle-index of OBJ.\n\
2639 See also cycle-start! and cycle-start0."
2640 ficlInteger pos;
2641
2642 FTH_STACK_CHECK(vm, 1, 1);
2643 pos = fth_cycle_pos_ref(fth_pop_ficl_cell(vm));
2644 ficlStackPushInteger(vm->dataStack, pos);
2645 }
2646
2647 static void
ficl_cycle_pos_set(ficlVm * vm)2648 ficl_cycle_pos_set(ficlVm *vm)
2649 {
2650 #define h_cycle_pos_set "( obj index -- ) set cycle-index\n\
2651 #( 1 2 3 ) value a\n\
2652 a cycle-start@ => 0\n\
2653 a 2 cycle-start!\n\
2654 a cycle-ref => 3\n\
2655 a cycle-start@ => 0\n\
2656 Set cycle-index of OBJ to INDEX.\n\
2657 See also cycle-start@ and cycle-start0."
2658 ficlInteger idx;
2659 FTH obj;
2660
2661 FTH_STACK_CHECK(vm, 2, 0);
2662 idx = ficlStackPopInteger(vm->dataStack);
2663 obj = fth_pop_ficl_cell(vm);
2664 fth_cycle_pos_set(obj, idx);
2665 }
2666
2667 static void
ficl_cycle_pos_0(ficlVm * vm)2668 ficl_cycle_pos_0(ficlVm *vm)
2669 {
2670 #define h_cycle_pos_0 "( obj -- ) set cycle-index to zero\n\
2671 #( 1 2 3 ) value a\n\
2672 a cycle-ref => 1\n\
2673 a cycle-ref => 2\n\
2674 a cycle-start@ => 2\n\
2675 a cycle-start0\n\
2676 a cycle-ref => 1\n\
2677 a cycle-start@ => 1\n\
2678 Set cycle-index of OBJ to zero.\n\
2679 See also cycle-start@ and cycle-start!."
2680 FTH_STACK_CHECK(vm, 1, 0);
2681 fth_cycle_pos_0(fth_pop_ficl_cell(vm));
2682 }
2683
2684 static void
ficl_first_object_ref(ficlVm * vm)2685 ficl_first_object_ref(ficlVm *vm)
2686 {
2687 #define h_first_object_ref "( obj -- val ) return first element\n\
2688 #( 0 1 2 ) first-ref => 0\n\
2689 Return first element of OBJ. \
2690 Raise OUT-OF-RANGE exception if length of OBJ is less than 1.\n\
2691 See also second-ref, third-ref and last-ref."
2692 FTH val;
2693
2694 FTH_STACK_CHECK(vm, 1, 1);
2695 val = fth_object_value_ref(fth_pop_ficl_cell(vm), 0L);
2696 fth_push_ficl_cell(vm, val);
2697 }
2698
2699 static void
ficl_first_object_set(ficlVm * vm)2700 ficl_first_object_set(ficlVm *vm)
2701 {
2702 #define h_first_object_set "( obj value -- ) store VALUE to first element\n\
2703 #( 0 1 2 ) value a1\n\
2704 a1 20 first-set!\n\
2705 a1 .$ => #( 20 1 2 )\n\
2706 Store VALUE to first element of OBJ. \
2707 Raise an OUT-OF-RANGE exception if length of OBJ is less than 1.\n\
2708 See also second-set!, third-set! and last-set!."
2709 FTH obj;
2710 FTH val;
2711
2712 FTH_STACK_CHECK(vm, 2, 0);
2713 val = fth_pop_ficl_cell(vm);
2714 obj = fth_pop_ficl_cell(vm);
2715 fth_object_value_set(obj, 0L, val);
2716 }
2717
2718 static void
ficl_second_object_ref(ficlVm * vm)2719 ficl_second_object_ref(ficlVm *vm)
2720 {
2721 #define h_second_object_ref "( obj -- val ) return second element\n\
2722 #( 0 1 2 ) second-ref => 1\n\
2723 Return second element of OBJ. \
2724 Raise OUT-OF-RANGE exception if length of OBJ is less than 2.\n\
2725 See also first-ref, third-ref and last-ref."
2726 FTH val;
2727
2728 FTH_STACK_CHECK(vm, 1, 1);
2729 val = fth_object_value_ref(fth_pop_ficl_cell(vm), 1L);
2730 fth_push_ficl_cell(vm, val);
2731 }
2732
2733 static void
ficl_second_object_set(ficlVm * vm)2734 ficl_second_object_set(ficlVm *vm)
2735 {
2736 #define h_second_object_set "( obj value -- ) store VALUE to second element\n\
2737 #( 0 1 2 ) value a1\n\
2738 a1 20 second-set!\n\
2739 a1 .$ => #( 0 20 2 )\n\
2740 Store VALUE to second entry of OBJ. \
2741 Raise OUT-OF-RANGE exception if length of OBJ is less than 2.\n\
2742 See also first-set!, third-set! and last-set!."
2743 FTH obj;
2744 FTH val;
2745
2746 FTH_STACK_CHECK(vm, 2, 0);
2747 val = fth_pop_ficl_cell(vm);
2748 obj = fth_pop_ficl_cell(vm);
2749 fth_object_value_set(obj, 1L, val);
2750 }
2751
2752 static void
ficl_third_object_ref(ficlVm * vm)2753 ficl_third_object_ref(ficlVm *vm)
2754 {
2755 #define h_third_object_ref "( obj -- val ) return third element\n\
2756 #( 0 1 2 ) third-ref => 2\n\
2757 Return third entry of OBJ. \
2758 Raise OUT-OF-RANGE exception if length of OBJ is less than 3.\n\
2759 See also first-ref, second-ref and last-ref."
2760 FTH val;
2761
2762 FTH_STACK_CHECK(vm, 1, 1);
2763 val = fth_object_value_ref(fth_pop_ficl_cell(vm), 2L);
2764 fth_push_ficl_cell(vm, val);
2765 }
2766
2767 static void
ficl_third_object_set(ficlVm * vm)2768 ficl_third_object_set(ficlVm *vm)
2769 {
2770 #define h_third_object_set "( obj value -- ) store VALUE to third element\n\
2771 #( 0 1 2 ) value a1\n\
2772 a1 20 third-set!\n\
2773 a1 .$ => #( 0 1 20 )\n\
2774 Store VALUE to third entry of OBJ. \
2775 Raise OUT-OF-RANGE exception if length of OBJ is less than 3.\n\
2776 See also first-set!, second-set! and last-set!."
2777 FTH obj;
2778 FTH val;
2779
2780 FTH_STACK_CHECK(vm, 2, 0);
2781 val = fth_pop_ficl_cell(vm);
2782 obj = fth_pop_ficl_cell(vm);
2783 fth_object_value_set(obj, 2L, val);
2784 }
2785
2786 static void
ficl_last_object_ref(ficlVm * vm)2787 ficl_last_object_ref(ficlVm *vm)
2788 {
2789 #define h_last_object_ref "( obj -- val ) return last element\n\
2790 #( 0 1 2 ) last-ref => 2\n\
2791 Return last entry of OBJ.\n\
2792 Raise OUT-OF-RANGE exception if length of OBJ is less than 1.\n\
2793 See also first-ref, second-ref and third-ref."
2794 FTH val;
2795
2796 FTH_STACK_CHECK(vm, 1, 1);
2797 val = fth_object_value_ref(fth_pop_ficl_cell(vm), -1L);
2798 fth_push_ficl_cell(vm, val);
2799 }
2800
2801 static void
ficl_last_object_set(ficlVm * vm)2802 ficl_last_object_set(ficlVm *vm)
2803 {
2804 #define h_last_object_set "( obj value -- ) store VALUE to last element\n\
2805 #( 0 1 2 ) value a1\n\
2806 a1 20 last-set!\n\
2807 a1 .$ => #( 0 1 20 )\n\
2808 Store VALUE to last entry of OBJ. \
2809 Raise OUT-OF-RANGE exception if length of OBJ is less than 1.\n\
2810 See also first-set!, second-set! and third-set!."
2811 FTH obj;
2812 FTH val;
2813
2814 FTH_STACK_CHECK(vm, 2, 0);
2815 val = fth_pop_ficl_cell(vm);
2816 obj = fth_pop_ficl_cell(vm);
2817 fth_object_value_set(obj, -1L, val);
2818 }
2819
2820 static void
ficl_object_debug_hook(ficlVm * vm)2821 ficl_object_debug_hook(ficlVm *vm)
2822 {
2823 #define h_object_debug_hook "( obj -- hook|#f ) return debug-hook member\n\
2824 #( 0 1 2 ) value ary\n\
2825 ary .inspect => #<array[3]: #<fixnum: 0> #<fixnum: 1> #<fixnum: 2>>\n\
2826 ary object-debug-hook lambda: <{ str obj -- new-str }>\n\
2827 $\" debug-inspect: %s\" #( obj ) string-format\n\
2828 ; add-hook!\n\
2829 ary .inspect => #<debug-inspect: #( 0 1 2 )>\n\
2830 ary object-debug-hook hook-clear\n\
2831 ary .inspect => #<array[3]: #<fixnum: 0> #<fixnum: 1> #<fixnum: 2>>\n\
2832 Return debug-hook member of OBJ if there is any, otherwise #f. \
2833 The hook has the stack effect ( inspect-string obj -- new-str ). \
2834 Every object can set this hook. \
2835 If set, it will be called on inspecting the object \
2836 with the inspect string as first argument. \
2837 If there are more than one hook procedures, \
2838 all of them will be called feeded with the new string previously returned."
2839 FTH obj;
2840
2841 FTH_STACK_CHECK(vm, 1, 1);
2842 obj = fth_pop_ficl_cell(vm);
2843
2844 if (!INSTANCE_P(obj)) {
2845 ficlStackPushBoolean(vm->dataStack, 0);
2846 return;
2847 }
2848 if (!FTH_HOOK_P(FTH_INSTANCE_DEBUG_HOOK(obj)))
2849 FTH_INSTANCE_DEBUG_HOOK(obj) = fth_make_simple_hook(2);
2850
2851 ficlStackPushFTH(vm->dataStack, FTH_INSTANCE_DEBUG_HOOK(obj));
2852 }
2853
2854 /* === Predicates === */
2855
2856 static void
ficl_false_p(ficlVm * vm)2857 ficl_false_p(ficlVm *vm)
2858 {
2859 #define h_false_p "( obj -- f ) test if OBJ is #f\n\
2860 #f false? => #t\n\
2861 -1 false? => #f\n\
2862 0 false? => #f\n\
2863 Return #t if OBJ is #f, otherwise #f.\n\
2864 See also boolean?, true?, nil?, undef?."
2865 FTH obj;
2866
2867 FTH_STACK_CHECK(vm, 1, 1);
2868 obj = fth_pop_ficl_cell(vm);
2869 ficlStackPushBoolean(vm->dataStack, FTH_FALSE_P(obj));
2870 }
2871
2872 static void
ficl_true_p(ficlVm * vm)2873 ficl_true_p(ficlVm *vm)
2874 {
2875 #define h_true_p "( obj -- f ) test if OBJ is #t\n\
2876 #t true? => #t\n\
2877 -1 true? => #f\n\
2878 0 true? => #f\n\
2879 Return #t if OBJ is #t, otherwise #f.\n\
2880 See also false?, boolean?, nil?, undef?."
2881 FTH obj;
2882
2883 FTH_STACK_CHECK(vm, 1, 1);
2884 obj = fth_pop_ficl_cell(vm);
2885 ficlStackPushBoolean(vm->dataStack, FTH_TRUE_P(obj));
2886 }
2887
2888 static void
ficl_nil_p(ficlVm * vm)2889 ficl_nil_p(ficlVm *vm)
2890 {
2891 #define h_nil_p "( obj -- f ) test if OBJ is nil\n\
2892 nil nil? => #t\n\
2893 0 nil? => #f\n\
2894 #() nil? => #f\n\
2895 '() nil? => #t\n\
2896 Return #t if OBJ is nil, otherwise #f.\n\
2897 See also false?, true?, boolean?, undef?."
2898 FTH obj;
2899
2900 FTH_STACK_CHECK(vm, 1, 1);
2901 obj = fth_pop_ficl_cell(vm);
2902 ficlStackPushBoolean(vm->dataStack, FTH_NIL_P(obj));
2903 }
2904
2905 static void
ficl_undef_p(ficlVm * vm)2906 ficl_undef_p(ficlVm *vm)
2907 {
2908 #define h_undef_p "( obj -- f ) test if OBJ is undef\n\
2909 undef undef? => #t\n\
2910 0 undef? => #f\n\
2911 \"\" undef? => #f\n\
2912 Return #t if OBJ is undef, otherwise #f.\n\
2913 See also false?, true?, nil?, boolean?."
2914 FTH obj;
2915
2916 FTH_STACK_CHECK(vm, 1, 1);
2917 obj = fth_pop_ficl_cell(vm);
2918 ficlStackPushBoolean(vm->dataStack, FTH_UNDEF_P(obj));
2919 }
2920
2921 static void
ficl_boolean_p(ficlVm * vm)2922 ficl_boolean_p(ficlVm *vm)
2923 {
2924 #define h_boolean_p "( obj -- f ) test if OBJ is #t or #f\n\
2925 #t boolean? => #t\n\
2926 #f boolean? => #t\n\
2927 nil boolean? => #f\n\
2928 undef boolean? => #f\n\
2929 -1 boolean? => #f\n\
2930 0 boolean? => #f\n\
2931 Return #t if OBJ is #t or #f, otherwise #f.\n\
2932 See also false?, true?, nil?, undef?."
2933 FTH obj;
2934
2935 FTH_STACK_CHECK(vm, 1, 1);
2936 obj = fth_pop_ficl_cell(vm);
2937 ficlStackPushBoolean(vm->dataStack, FTH_BOOLEAN_P(obj));
2938 }
2939
2940 FTH
ficl_to_fth(FTH obj)2941 ficl_to_fth(FTH obj)
2942 {
2943 if (obj != 0 &&
2944 (FICL_WORD_DICT_P(obj) || OBJECT_TYPE_P(obj) || INSTANCE0_P(obj)))
2945 return (obj);
2946
2947 return (fth_make_int((ficlInteger) obj));
2948 }
2949
2950 FTH
fth_pop_ficl_cell(ficlVm * vm)2951 fth_pop_ficl_cell(ficlVm *vm)
2952 {
2953 ficlStack *stack;
2954 FTH obj;
2955
2956 stack = vm->dataStack;
2957 obj = STACK_FTH_REF(stack);
2958 stack->top--;
2959 return (ficl_to_fth(obj));
2960 }
2961
2962 FTH
fth_to_ficl(FTH obj)2963 fth_to_ficl(FTH obj)
2964 {
2965 if (FTH_FIXNUM_P(obj))
2966 return ((FTH) FIX_TO_INT(obj));
2967
2968 return (obj);
2969 }
2970
2971 void
fth_push_ficl_cell(ficlVm * vm,FTH obj)2972 fth_push_ficl_cell(ficlVm *vm, FTH obj)
2973 {
2974 ficlStack *stack;
2975
2976 stack = vm->dataStack;
2977 ++stack->top;
2978
2979 if (FTH_FIXNUM_P(obj))
2980 STACK_INT_SET(stack, FIX_TO_INT(obj));
2981 else
2982 STACK_FTH_SET(stack, obj);
2983 }
2984
2985 void
init_object(void)2986 init_object(void)
2987 {
2988 fth_print_length = 12;
2989 fth_gc_on_p = 1;
2990
2991 /* frame */
2992 FTH_PRI1("frame-depth", ficl_frame_depth, h_frame_depth);
2993 FTH_PRI1("stack-level", ficl_frame_depth, h_frame_depth);
2994 FTH_PRI1("backtrace", ficl_backtrace, h_backtrace);
2995 FTH_PRI1("bt", ficl_backtrace, h_backtrace);
2996 FTH_PRI1("object-print-length", ficl_print_length, h_print_length);
2997 FTH_PRI1("set-object-print-length", ficl_set_print_length,
2998 h_set_print_length);
2999
3000 /* gc */
3001 FTH_PRI1("gc-run", ficl_gc_run, h_gc_run);
3002 FTH_PRI1("gc-stats", ficl_gc_stats, h_gc_stats);
3003 FTH_PRI1("gc-marked?", ficl_gc_marked_p, h_gc_marked_p);
3004 FTH_PRI1("gc-protected?", ficl_gc_protected_p, h_gc_protected_p);
3005 FTH_PRI1("gc-permanent?", ficl_gc_permanent_p, h_gc_permanent_p);
3006 FTH_PRI1("gc-protected-objects", ficl_gc_protected_objects,
3007 h_gc_protected_objects);
3008 FTH_PRI1("gc-permanent-objects", ficl_gc_permanent_objects,
3009 h_gc_permanent_objects);
3010 FTH_PROC("gc-on", fth_gc_on, 0, 0, 0, h_gc_on);
3011 FTH_PROC("gc-off", fth_gc_off, 0, 0, 0, h_gc_off);
3012 FTH_PRI1("gc-mark", ficl_gc_mark, h_gc_mark);
3013 FTH_PRI1("gc-unmark", ficl_gc_unmark, h_gc_unmark);
3014 FTH_PROC("gc-protect", fth_gc_protect, 1, 0, 0, h_gc_protect);
3015 FTH_PROC("gc-unprotect", fth_gc_unprotect, 1, 0, 0, h_gc_unprotect);
3016
3017 /* object-type */
3018 FTH_PRI1("object-type?", ficl_object_type_p, h_object_type_p);
3019 FTH_PRI1("make-object-type", ficl_make_object_type, h_make_object_type);
3020 FTH_PRI1("object-type-ref", ficl_object_type_ref, h_object_type_ref);
3021 FTH_PRI1("object-types", ficl_object_types, h_object_types);
3022
3023 /* instance */
3024 FTH_PRI1("instance?", ficl_instance_p, h_instance_p);
3025 FTH_PRI1("make-instance", ficl_make_instance, h_make_instance);
3026 FTH_PRI1("instance-gen-ref", ficl_instance_gen_ref, h_instance_gen_ref);
3027 FTH_PRI1("instance-obj-ref", ficl_instance_obj_ref, h_instance_obj_ref);
3028 FTH_PRI1("instance-of?", ficl_object_is_instance_of,
3029 h_object_is_instance_of);
3030
3031 /* object set words */
3032 FTH_PRI1("set-object-inspect", ficl_set_inspect, h_set_insepct);
3033 FTH_PRI1("set-object->string", ficl_set_to_string, h_set_to_string);
3034 FTH_PRI1("set-object-dump", ficl_set_dump, h_set_dump);
3035 FTH_PRI1("set-object->array", ficl_set_to_array, h_set_to_array);
3036 FTH_PRI1("set-object-copy", ficl_set_copy, h_set_copy);
3037 FTH_PRI1("set-object-value-ref", ficl_set_value_ref, h_set_value_ref);
3038 FTH_PRI1("set-object-value-set", ficl_set_value_set, h_set_value_set);
3039 FTH_PRI1("set-object-equal-p", ficl_set_equal_p, h_set_equal_p);
3040 FTH_PRI1("set-object-length", ficl_set_length, h_set_length);
3041 FTH_PRI1("set-object-mark", ficl_set_mark, h_set_mark);
3042 FTH_PRI1("set-object-free", ficl_set_free, h_set_free);
3043 FTH_PRI1("set-object-apply", ficl_set_apply, h_set_apply);
3044
3045 /* special xm.c */
3046 FTH_PRI1("xmobj?", ficl_xmobj_p, h_xmobj_p);
3047
3048 /* general object words */
3049 FTH_PROC("hash-id", fth_hash_id, 1, 0, 0, h_hash_id);
3050 FTH_PROC("object-id", fth_object_id, 1, 0, 0, h_object_id);
3051 FTH_PRI1("object-name", ficl_object_name, h_object_name);
3052 FTH_PRI1(".object-name", ficl_print_object_name, h_print_object_name);
3053 FTH_PRI1(".inspect", ficl_print_inspect, h_print_inspect);
3054 FTH_PROC("object-inspect", fth_object_inspect, 1, 0, 0,
3055 h_object_inspect);
3056 FTH_PROC("object->string", fth_object_to_string, 1, 0, 0,
3057 h_object_to_string);
3058 FTH_PROC("object-dump", fth_object_dump, 1, 0, 0,
3059 h_object_dump);
3060 FTH_PROC("object->array", fth_object_to_array, 1, 0, 0,
3061 h_object_to_array);
3062 FTH_PROC("object-copy", fth_object_copy, 1, 0, 0,
3063 h_object_copy);
3064 FTH_PRI1("object-ref", ficl_object_ref, h_object_ref);
3065 FTH_PRI1("object-set!", ficl_object_set, h_object_set);
3066 FTH_PRI1("object-set+!", ficl_add_store_object, h_add_store_object);
3067 FTH_PRI1("object-set-!", ficl_sub_store_object, h_sub_store_object);
3068 FTH_PRI1("object-set*!", ficl_mul_store_object, h_mul_store_object);
3069 FTH_PRI1("object-set/!", ficl_div_store_object, h_div_store_object);
3070 FTH_PRI1("object-equal?", ficl_object_equal_p, h_object_equal_p);
3071 FTH_PRI1("equal?", ficl_object_equal_p, h_object_equal_p);
3072 FTH_PRI1("object-length", ficl_object_length, h_object_length);
3073 FTH_PRI1("length", ficl_object_length, h_object_length);
3074 FTH_PROC("object-apply", fth_object_apply, 2, 0, 0, h_object_apply);
3075 FTH_PROC("apply", fth_object_apply, 2, 0, 0, h_object_apply);
3076 FTH_PRI1("object-empty?", ficl_object_empty_p, h_object_empty_p);
3077 FTH_PRI1("empty?", ficl_object_empty_p, h_object_empty_p);
3078 FTH_PRI1("object-range?", ficl_object_range_p, h_object_range_p);
3079 FTH_PRI1("range?", ficl_object_range_p, h_object_range_p);
3080 FTH_PRI1("object-member?", ficl_object_member_p, h_object_member_p);
3081 FTH_PRI1("member?", ficl_object_member_p, h_object_member_p);
3082 FTH_PROC("object-find", fth_object_find, 2, 0, 0, h_object_find);
3083 FTH_PROC("detect", fth_object_find, 2, 0, 0, h_object_find);
3084 FTH_PROC("object-index", fth_object_index, 2, 0, 0, h_object_index);
3085 FTH_PROC("index", fth_object_index, 2, 0, 0, h_object_index);
3086 FTH_PROC("object-sort", fth_object_sort, 2, 0, 0, h_object_sort);
3087 FTH_PROC("sort", fth_object_sort, 2, 0, 0, h_object_sort);
3088 FTH_PRI1("cycle-start@", ficl_cycle_pos_ref, h_cycle_pos_ref);
3089 FTH_PRI1("cycle-start!", ficl_cycle_pos_set, h_cycle_pos_set);
3090 FTH_PRI1("cycle-start0", ficl_cycle_pos_0, h_cycle_pos_0);
3091 FTH_PROC("cycle-ref", fth_object_cycle_ref, 1, 0, 0,
3092 h_object_cycle_ref);
3093 FTH_PRI1("cycle-set!", ficl_object_cycle_set, h_object_cycle_set);
3094 FTH_PRI1("first-ref", ficl_first_object_ref, h_first_object_ref);
3095 FTH_PRI1("first-set!", ficl_first_object_set, h_first_object_set);
3096 FTH_PRI1("second-ref", ficl_second_object_ref, h_second_object_ref);
3097 FTH_PRI1("second-set!", ficl_second_object_set, h_second_object_set);
3098 FTH_PRI1("third-ref", ficl_third_object_ref, h_third_object_ref);
3099 FTH_PRI1("third-set!", ficl_third_object_set, h_third_object_set);
3100 FTH_PRI1("last-ref", ficl_last_object_ref, h_last_object_ref);
3101 FTH_PRI1("last-set!", ficl_last_object_set, h_last_object_set);
3102 FTH_PRI1("object-debug-hook", ficl_object_debug_hook,
3103 h_object_debug_hook);
3104
3105 /* predicat */
3106 FTH_PRI1("false?", ficl_false_p, h_false_p);
3107 FTH_PRI1("true?", ficl_true_p, h_true_p);
3108 FTH_PRI1("nil?", ficl_nil_p, h_nil_p);
3109 FTH_PRI1("undef?", ficl_undef_p, h_undef_p);
3110 FTH_PRI1("boolean?", ficl_boolean_p, h_boolean_p);
3111 FTH_ADD_FEATURE_AND_INFO(FTH_STR_OBJECT, h_list_of_object_functions);
3112 }
3113
3114 /*
3115 * object.c ends here
3116 */
3117