1 /*-
2 * Copyright (c) 2005-2018 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 * @(#)array.c 2.1 1/2/18
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 /* === ARRAY === */
37
38 static FTH array_tag;
39 static FTH list_tag;
40 static FTH acell_tag;
41
42 typedef struct {
43 int type; /* array, list, assoc */
44 ficlInteger length; /* actual array length */
45 ficlInteger buf_length; /* entire buffer length */
46 ficlInteger top; /* begin of actual array in buffer */
47 FTH *data; /* actual array */
48 FTH *buf; /* entire array buffer */
49 } FArray;
50
51 #define MAKE_ARRAY_MEMBER(Type, Member) MAKE_MEMBER(FArray, ary, Type, Member)
52
53 /*-
54 * Build words for scrutinizing arrays:
55 *
56 * init_ary_length => ary->length
57 * init_ary_buf_length => ary->buf_length
58 * init_ary_top => ary->top
59 */
60 MAKE_ARRAY_MEMBER(Integer, length)
61 MAKE_ARRAY_MEMBER(Integer, buf_length)
62 MAKE_ARRAY_MEMBER(Integer, top)
63
64 #define FTH_ARRAY_OBJECT(Obj) FTH_INSTANCE_REF_GEN(Obj, FArray)
65 #define FTH_ARRAY_TYPE(Obj) FTH_ARRAY_OBJECT(Obj)->type
66 #define FTH_ARRAY_LENGTH(Obj) FTH_ARRAY_OBJECT(Obj)->length
67 #define FTH_ARRAY_BUF_LENGTH(Obj) FTH_ARRAY_OBJECT(Obj)->buf_length
68 #define FTH_ARRAY_TOP(Obj) FTH_ARRAY_OBJECT(Obj)->top
69 #define FTH_ARRAY_DATA(Obj) FTH_ARRAY_OBJECT(Obj)->data
70 #define FTH_ARRAY_BUF(Obj) FTH_ARRAY_OBJECT(Obj)->buf
71
72 #define FTH_ARY_ARRAY 0x01
73 #define FTH_ARY_LIST 0x02
74 #define FTH_ARY_ASSOC 0x04
75
76 #define FTH_ARY_ARRAY_SET(Obj) ((Obj)->type |= FTH_ARY_ARRAY)
77 #define FTH_ARY_LIST_SET(Obj) ((Obj)->type |= FTH_ARY_LIST)
78 #define FTH_LIST_SET(Obj) (FTH_ARRAY_TYPE(Obj) |= FTH_ARY_LIST)
79 #define FTH_ASSOC_SET(Obj) (FTH_ARRAY_TYPE(Obj) |= FTH_ARY_ASSOC)
80 #define FTH_ARRAY_LIST_P(Obj) (FTH_ARRAY_TYPE(Obj) & FTH_ARY_LIST)
81 #define FTH_ARRAY_ASSOC_P(Obj) (FTH_ARRAY_TYPE(Obj) & FTH_ARY_ASSOC)
82
83 /*
84 * Array
85 */
86 static FTH ary_compact_each(FTH, FTH);
87 static FTH ary_copy(FTH);
88 static FTH ary_dump(FTH);
89 static FTH ary_dump_each(FTH, FTH);
90 static FTH ary_equal_p(FTH, FTH);
91 static void ary_free(FTH);
92 static FTH ary_inspect(FTH);
93 static FTH ary_inspect_each(FTH, FTH);
94 static FTH ary_length(FTH);
95 static void ary_mark(FTH);
96 static FTH ary_ref(FTH, FTH);
97 static FTH ary_set(FTH, FTH, FTH);
98 static FTH ary_to_array(FTH);
99 static FTH ary_to_string(FTH);
100 static FTH ary_uniq_each(FTH, FTH);
101 #if defined(HAVE_QSORT)
102 static int cmpit(const void *, const void *);
103 #endif
104 static void ficl_array_compact(ficlVm *);
105 static void ficl_array_copy(ficlVm *);
106 static void ficl_array_delete(ficlVm *);
107 static void ficl_array_equal_p(ficlVm *);
108 static void ficl_array_index(ficlVm *);
109 static void ficl_array_insert(ficlVm *);
110 static void ficl_array_insert_bang(ficlVm *);
111 static void ficl_array_length(ficlVm *);
112 static void ficl_array_member_p(ficlVm *);
113 static void ficl_array_p(ficlVm *);
114 static void ficl_array_ref(ficlVm *);
115 static void ficl_array_reject(ficlVm *);
116 static void ficl_array_reverse(ficlVm *);
117 static void ficl_array_set(ficlVm *);
118 static void ficl_array_sort(ficlVm *);
119 static void ficl_array_subarray(ficlVm *);
120 static void ficl_array_uniq(ficlVm *);
121 static void ficl_make_array(ficlVm *);
122 static void ficl_make_empty_array(ficlVm *);
123 static void ficl_print_array(ficlVm *);
124 static void ficl_values_to_array(ficlVm *);
125 static FArray *make_array(ficlInteger);
126 static FTH make_array_instance(FArray *);
127
128 /*
129 * Acell
130 */
131 static FTH acl_dump(FTH);
132 static FTH acl_inspect(FTH);
133 static FTH acl_to_string(FTH);
134
135 /*
136 * Assoc
137 */
138 static FTH assoc_insert(FTH, FTH, FTH);
139 static void ficl_assoc_p(ficlVm *);
140 static void ficl_values_to_assoc(ficlVm *);
141 static ficlInteger assoc_index(FTH, FTH);
142
143 /*
144 * List
145 */
146 static void ficl_cons_p(ficlVm *);
147 static void ficl_last_pair(ficlVm *);
148 static void ficl_list_append(ficlVm *);
149 static void ficl_list_delete(ficlVm *);
150 static void ficl_list_delete_bang(ficlVm *);
151 static void ficl_list_equal_p(ficlVm *);
152 static void ficl_list_fill(ficlVm *);
153 static void ficl_list_head(ficlVm *);
154 static void ficl_list_index(ficlVm *);
155 static void ficl_list_insert(ficlVm *);
156 static void ficl_list_length(ficlVm *);
157 static void ficl_list_p(ficlVm *);
158 static void ficl_list_ref(ficlVm *);
159 static void ficl_list_set(ficlVm *);
160 static void ficl_list_slice(ficlVm *);
161 static void ficl_list_slice_bang(ficlVm *);
162 static void ficl_list_tail(ficlVm *);
163 static void ficl_make_list(ficlVm *);
164 static void ficl_nil_p(ficlVm *);
165 static void ficl_pair_p(ficlVm *);
166 static void ficl_print_list(ficlVm *);
167 static void ficl_set_car(ficlVm *);
168 static void ficl_set_cdr(ficlVm *);
169 static void ficl_values_to_list(ficlVm *);
170 static FTH ls_append_each(FTH, FTH);
171 static FTH ls_delete_each(FTH, FTH);
172 static FTH make_list_instance(FArray *);
173
174 /*
175 * Alist
176 */
177 static void ficl_values_to_alist(ficlVm *);
178
179 #define h_list_of_array_functions "\
180 *** ARRAY PRIMITIVES ***\n\
181 #() ( -- ary )\n\
182 .array ( ary -- )\n\
183 >array ( vals len -- ary )\n\
184 array->array ( ary1 -- ary2 )\n\
185 array->list ( ary -- lst )\n\
186 array-append ( ary1 ary2 -- ary1+ary2 )\n\
187 array-clear ( ary -- )\n\
188 array-compact ( ary1 prc args -- ary2 )\n\
189 array-compact! ( ary prc args -- ary' )\n\
190 array-concat alias for >array\n\
191 array-copy ( ary1 -- ary2 )\n\
192 array-delete! ( ary idx -- val )\n\
193 array-delete-key ( ary idx -- val )\n\
194 array-fill ( ary val -- )\n\
195 array-find ( ary key -- key )\n\
196 array-index ( ary key -- idx )\n\
197 array-insert ( ary1 idx val -- ary2 )\n\
198 array-insert! ( ary idx val -- ary' )\n\
199 array-join ( ary sep -- str )\n\
200 array-length ( ary -- len )\n\
201 array-member? ( ary key -- f )\n\
202 array-pop ( ary -- val )\n\
203 array-push ( ary val -- ary' )\n\
204 array-ref ( ary idx -- val )\n\
205 array-reject ( ary1 prc args -- ary2 )\n\
206 array-reject! ( ary prc args -- ary' )\n\
207 array-reverse ( ary1 -- ary2 )\n\
208 array-reverse! ( ary -- ary' )\n\
209 array-set! ( ary idx val -- )\n\
210 array-shift ( ary -- val )\n\
211 array-sort ( ary1 cmp-xt -- ary2 )\n\
212 array-sort! ( ary cmp-xt -- ary' )\n\
213 array-subarray ( ary start end -- subary )\n\
214 array-uniq ( ary1 -- ary2 )\n\
215 array-uniq! ( ary -- ary' )\n\
216 array-unshift ( ary val -- ary' )\n\
217 array= ( ary1 ary2 -- f )\n\
218 array? ( obj -- f )\n\
219 make-array ( len :key initial-element -- ary )\n\
220 Assoc arrays:\n\
221 >assoc ( vals len -- ary )\n\
222 array-assoc ( ary key -- ret )\n\
223 array-assoc-ref ( ary key -- val )\n\
224 array-assoc-remove! ( ary key -- 'ary )\n\
225 array-assoc-set! ( ary key val -- 'ary )\n\
226 assoc ( ary key val -- 'ary )\n\
227 assoc? ( obj -- f )"
228
229 FTH
fth_array_each(FTH array,FTH (* fnc)(FTH value,FTH data),FTH data)230 fth_array_each(FTH array, FTH (*fnc) (FTH value, FTH data), FTH data)
231 {
232 ficlInteger i;
233
234 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
235
236 for (i = 0; i < FTH_ARRAY_LENGTH(array); i++)
237 data = (*fnc) (FTH_ARRAY_DATA(array)[i], data);
238
239 return (data);
240 }
241
242 FTH
fth_array_each_with_index(FTH array,FTH (* fnc)(FTH value,FTH data,ficlInteger idx),FTH data)243 fth_array_each_with_index(FTH array, FTH (*fnc) (FTH value, FTH data, ficlInteger idx), FTH data)
244 {
245 ficlInteger i;
246
247 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
248
249 for (i = 0; i < FTH_ARRAY_LENGTH(array); i++)
250 data = (*fnc) (FTH_ARRAY_DATA(array)[i], data, i);
251
252 return (data);
253 }
254
255 /*
256 * Create new array filled with values from FNC.
257 */
258 FTH
fth_array_map(FTH array,FTH (* f)(FTH value,FTH data),FTH data)259 fth_array_map (FTH array, FTH (*f) (FTH value, FTH data), FTH data)
260 {
261 ficlInteger i, len;
262 FTH ary;
263
264 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
265 len = FTH_ARRAY_LENGTH(array);
266 ary = fth_make_array_len(len);
267
268 for (i = 0; i < len; i++)
269 FTH_ARRAY_DATA(ary)[i] = (*f) (FTH_ARRAY_DATA(array)[i], data);
270
271 return (ary);
272 }
273
274 static FTH
ary_inspect_each(FTH value,FTH data)275 ary_inspect_each(FTH value, FTH data)
276 {
277 return (fth_string_sformat(data, " %I", value));
278 }
279
280 static FTH
ary_inspect(FTH self)281 ary_inspect(FTH self)
282 {
283 char *name;
284 ficlInteger len;
285 FTH fs;
286
287 name = FTH_INSTANCE_NAME(self);
288 len = FTH_ARRAY_LENGTH(self);
289
290 if (len == 0)
291 return (fth_make_string_format("%s empty", name));
292
293 fs = fth_make_string_format("%s[%ld]:", name, len);
294 return (fth_array_each(self, ary_inspect_each, fs));
295 }
296
297 static FTH
ary_to_string(FTH self)298 ary_to_string(FTH self)
299 {
300 ficlInteger i, len;
301 FTH fs;
302
303 len = FTH_ARRAY_LENGTH(self);
304
305 /* Negative fth_print_length shows all entries! */
306 if (fth_print_length >= 0 && len > fth_print_length)
307 len = FICL_MIN(len, fth_print_length);
308
309 fs = fth_make_string_format("%c%s(",
310 FTH_ARRAY_LIST_P(self) ? '\'' : '#',
311 FTH_ARRAY_ASSOC_P(self) ? "a" : "");
312
313 if (len > 0) {
314 for (i = 0; i < len; i++)
315 fth_string_sformat(fs, " %M", FTH_ARRAY_DATA(self)[i]);
316
317 if (len < FTH_ARRAY_LENGTH(self))
318 fth_string_sformat(fs, " ...");
319
320 fth_string_sformat(fs, " ");
321 }
322 return (fth_string_sformat(fs, ")"));
323 }
324
325 static FTH
ary_dump_each(FTH value,FTH data)326 ary_dump_each(FTH value, FTH data)
327 {
328 return (fth_string_sformat(data, " %D ", value));
329 }
330
331 static FTH
ary_dump(FTH self)332 ary_dump(FTH self)
333 {
334 FTH fs;
335
336 fs = fth_make_string_format("%c%s(",
337 FTH_ARRAY_LIST_P(self) ? '\'' : '#',
338 FTH_ARRAY_ASSOC_P(self) ? "a" : "");
339
340 if (FTH_ARRAY_LENGTH(self) > 0)
341 fth_array_each(self, ary_dump_each, fs);
342
343 return (fth_string_sformat(fs, ")"));
344 }
345
346 static FTH
ary_to_array(FTH self)347 ary_to_array(FTH self)
348 {
349 ficlInteger len;
350 size_t size;
351 FTH new;
352
353 len = FTH_ARRAY_LENGTH(self);
354 new = fth_make_array_len(len);
355 size = sizeof(FTH) * (size_t) len;
356 memmove(FTH_ARRAY_DATA(new), FTH_ARRAY_DATA(self), size);
357 return (new);
358 }
359
360 static FTH
ary_copy(FTH self)361 ary_copy(FTH self)
362 {
363 ficlInteger i;
364 FTH new, el;
365
366 new = fth_make_array_len(FTH_ARRAY_LENGTH(self));
367
368 for (i = 0; i < FTH_ARRAY_LENGTH(self); i++) {
369 el = fth_object_copy(FTH_ARRAY_DATA(self)[i]);
370 FTH_ARRAY_DATA(new)[i] = el;
371 }
372
373 return (new);
374 }
375
376 static FTH
ary_ref(FTH self,FTH fidx)377 ary_ref(FTH self, FTH fidx)
378 {
379 ficlInteger idx, len;
380
381 idx = FTH_INT_REF(fidx);
382 len = FTH_ARRAY_LENGTH(self);
383
384 if (idx < 0 || idx >= len)
385 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
386
387 return (FTH_ARRAY_DATA(self)[idx]);
388 }
389
390 static FTH
ary_set(FTH self,FTH fidx,FTH value)391 ary_set(FTH self, FTH fidx, FTH value)
392 {
393 ficlInteger idx, len;
394
395 idx = FTH_INT_REF(fidx);
396 len = FTH_ARRAY_LENGTH(self);
397
398 if (idx < 0 || idx >= len)
399 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
400
401 FTH_INSTANCE_CHANGED(self);
402 return (FTH_ARRAY_DATA(self)[idx] = value);
403 }
404
405 static FTH
ary_equal_p(FTH self,FTH obj)406 ary_equal_p(FTH self, FTH obj)
407 {
408 ficlInteger i;
409 FTH a, b;
410
411 if (self == obj)
412 return (FTH_TRUE);
413
414 if (FTH_ARRAY_LENGTH(self) == FTH_ARRAY_LENGTH(obj)) {
415 for (i = 0; i < FTH_ARRAY_LENGTH(self); i++) {
416 a = FTH_ARRAY_DATA(self)[i];
417 b = FTH_ARRAY_DATA(obj)[i];
418
419 if (!fth_object_equal_p(a, b))
420 return (FTH_FALSE);
421 }
422
423 return (FTH_TRUE);
424 }
425 return (FTH_FALSE);
426 }
427
428 static FTH
ary_length(FTH self)429 ary_length(FTH self)
430 {
431 return (fth_make_int(FTH_ARRAY_LENGTH(self)));
432 }
433
434 static void
ary_mark(FTH self)435 ary_mark(FTH self)
436 {
437 ficlInteger i;
438
439 for (i = 0; i < FTH_ARRAY_LENGTH(self); i++)
440 fth_gc_mark(FTH_ARRAY_DATA(self)[i]);
441 }
442
443 static void
ary_free(FTH self)444 ary_free(FTH self)
445 {
446 FTH_FREE(FTH_ARRAY_BUF(self));
447 FTH_FREE(FTH_ARRAY_OBJECT(self));
448 }
449
450 /*
451 * If OBJ is an Array object, return its length, otherwise -1.
452 */
453 ficlInteger
fth_array_length(FTH obj)454 fth_array_length(FTH obj)
455 {
456 if (FTH_ARRAY_P(obj))
457 return (FTH_ARRAY_LENGTH(obj));
458 return (-1);
459 }
460
461 static void
ficl_array_length(ficlVm * vm)462 ficl_array_length(ficlVm *vm)
463 {
464 #define h_array_length "( obj -- len ) return array length\n\
465 #( 0 1 2 ) array-length => 3\n\
466 5 array-length => -1\n\
467 If OBJ is an array object, return its length, otherwise -1."
468 ficlInteger len;
469
470 FTH_STACK_CHECK(vm, 1, 1);
471 len = fth_array_length(fth_pop_ficl_cell(vm));
472 ficlStackPushInteger(vm->dataStack, len);
473 }
474
475 /*
476 * |---------buf_length (buf)-----|
477 * |---top----|-length (data)-|
478 * v v v
479 * |----------****************----|
480 *
481 * buf + top --> start of data
482 */
483 static FArray *
make_array(ficlInteger len)484 make_array(ficlInteger len)
485 {
486 FArray *ary;
487 ficlInteger buf_len, top_len;
488
489 if (len < 0)
490 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "negative");
491
492 top_len = NEW_SEQ_LENGTH(len) / 3;
493 buf_len = NEW_SEQ_LENGTH(len + top_len);
494
495 if (buf_len > MAX_SEQ_LENGTH)
496 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
497
498 ary = FTH_MALLOC(sizeof(FArray));
499 ary->type = 0;
500 ary->length = len;
501 ary->buf_length = buf_len;
502 ary->top = top_len;
503 ary->buf = FTH_CALLOC(ary->buf_length, sizeof(FTH));
504 ary->data = ary->buf + ary->top;
505 return (ary);
506 }
507
508 static FTH
make_array_instance(FArray * ary)509 make_array_instance(FArray *ary)
510 {
511 FTH_ARY_ARRAY_SET(ary);
512 return (fth_make_instance(array_tag, ary));
513 }
514
515 FTH
fth_make_array_var(int len,...)516 fth_make_array_var(int len,...)
517 {
518 int i;
519 FArray *ary;
520 va_list list;
521
522 ary = make_array((ficlInteger) len);
523 va_start(list, len);
524
525 for (i = 0; i < len; i++)
526 ary->data[i] = va_arg(list, FTH);
527
528 va_end(list);
529 return (make_array_instance(ary));
530 }
531
532 FTH
fth_make_array_len(ficlInteger len)533 fth_make_array_len(ficlInteger len)
534 {
535 return (make_array_instance(make_array(len)));
536 }
537
538 /*
539 * Return Array with LEN entries each initialized to INIT.
540 */
541 FTH
fth_make_array_with_init(ficlInteger len,FTH init)542 fth_make_array_with_init(ficlInteger len, FTH init)
543 {
544 ficlInteger i;
545 FArray *ary;
546
547 ary = make_array(len);
548
549 for (i = 0; i < ary->length; i++)
550 ary->data[i] = init;
551
552 return (make_array_instance(ary));
553 }
554
555 FTH
fth_make_empty_array(void)556 fth_make_empty_array(void)
557 {
558 return (fth_make_array_len(0L));
559 }
560
561 static void
ficl_array_p(ficlVm * vm)562 ficl_array_p(ficlVm *vm)
563 {
564 #define h_array_p "( obj -- f ) test if OBJ is an array\n\
565 #( 0 1 2 ) array? => #t\n\
566 nil array? => #f\n\
567 Return #t if OBJ is an array object, otherwise #f."
568 FTH obj;
569
570 FTH_STACK_CHECK(vm, 1, 1);
571 obj = fth_pop_ficl_cell(vm);
572 ficlStackPushBoolean(vm->dataStack, FTH_ARRAY_P(obj));
573 }
574
575 static void
ficl_make_array(ficlVm * vm)576 ficl_make_array(ficlVm *vm)
577 {
578 #define h_make_array "( len :key initial-element nil -- ary ) return array\n\
579 0 make-array => #()\n\
580 3 make-array => #( nil nil nil )\n\
581 3 :initial-element 10 make-array => #( 10 10 10 )\n\
582 Return array of length LEN filled with keyword INITIAL-ELEMENT values. \
583 INITIAL-ELEMENT defaults to nil if not specified. \
584 Raise OUT-OF-RANGE exception if LEN < 0."
585 FTH size, init, ary;
586
587 init = fth_get_optkey(FTH_KEYWORD_INIT, FTH_NIL);
588 FTH_STACK_CHECK(vm, 1, 1);
589 size = fth_pop_ficl_cell(vm);
590 FTH_ASSERT_ARGS(FTH_INTEGER_P(size), size, FTH_ARG1, "an integer");
591 ary = fth_make_array_with_init(FTH_INT_REF(size), init);
592 ficlStackPushFTH(vm->dataStack, ary);
593 }
594
595 static void
ficl_values_to_array(ficlVm * vm)596 ficl_values_to_array(ficlVm *vm)
597 {
598 #define h_values_to_array "( vals len -- ary ) return array\n\
599 0 1 2 3 >array => #( 0 1 2 )\n\
600 Return array object with LEN objects found on parameter stack. \
601 Raise OUT-OF-RANGE exception if LEN < 0."
602 ficlInteger i, len;
603 FTH array;
604
605 FTH_STACK_CHECK(vm, 1, 0);
606 len = ficlStackPopInteger(vm->dataStack);
607
608 if (len < 0)
609 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
610
611 if (len > MAX_SEQ_LENGTH)
612 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
613
614 FTH_STACK_CHECK(vm, len, 1);
615 array = fth_make_array_len(len);
616
617 for (i = len - 1; i >= 0; i--)
618 FTH_ARRAY_DATA(array)[i] = fth_pop_ficl_cell(vm);
619
620 ficlStackPushFTH(vm->dataStack, array);
621 }
622
623 static void
ficl_make_empty_array(ficlVm * vm)624 ficl_make_empty_array(ficlVm *vm)
625 {
626 #define h_empty_array "( -- empty-ary ) return empty array\n\
627 #() value ary\n\
628 ary 0 array-push => #( 0 )\n\
629 ary 1 array-push => #( 0 1 )\n\
630 ary 2 array-push => #( 0 1 2 )\n\
631 ary => #( 0 1 2 )\n\
632 Return array of length 0 for array-append, array-push etc."
633 FTH_STACK_CHECK(vm, 0, 1);
634 ficlStackPushFTH(vm->dataStack, fth_make_empty_array());
635 }
636
637 static void
ficl_print_array(ficlVm * vm)638 ficl_print_array(ficlVm *vm)
639 {
640 #define h_print_array "( ary -- ) print array\n\
641 #( 0 1 2 ) .array => #( 0 1 2 )\n\
642 Print array object ARY to current output."
643 FTH obj;
644
645 FTH_STACK_CHECK(vm, 1, 0);
646 obj = fth_pop_ficl_cell(vm);
647 FTH_ASSERT_ARGS(FTH_ARRAY_P(obj), obj, FTH_ARG1, "an array");
648 fth_print(fth_string_ref(ary_to_string(obj)));
649 }
650
651 int
fth_array_equal_p(FTH obj1,FTH obj2)652 fth_array_equal_p(FTH obj1, FTH obj2)
653 {
654 if (FTH_ARRAY_P(obj1) && FTH_ARRAY_P(obj2))
655 return (FTH_TO_BOOL(ary_equal_p(obj1, obj2)));
656 return (0);
657 }
658
659 static void
ficl_array_equal_p(ficlVm * vm)660 ficl_array_equal_p(ficlVm *vm)
661 {
662 #define h_array_equal_p "( ary1 ary2 -- f ) compare arrays\n\
663 #( 0 1 2 ) value a1\n\
664 #( 0 1 2 ) value a2\n\
665 #( 0 1 3 ) value a3\n\
666 a1 a1 array= #t\n\
667 a1 a2 array= #t\n\
668 a1 a3 array= #f\n\
669 Return #t if ARY1 and ARY2 are array objects of same length and content, \
670 otherwise #f."
671 FTH obj1, obj2;
672
673 FTH_STACK_CHECK(vm, 2, 1);
674 obj2 = fth_pop_ficl_cell(vm);
675 obj1 = fth_pop_ficl_cell(vm);
676 ficlStackPushBoolean(vm->dataStack, fth_array_equal_p(obj1, obj2));
677 }
678
679 FTH
fth_array_to_array(FTH array)680 fth_array_to_array(FTH array)
681 {
682 #define h_array_to_array "( ary1 -- ary2 ) return array\n\
683 #( 0 #{ 'foo 10 } 2 ) value ary1\n\
684 ary1 array->array value ary2\n\
685 ary1 1 array-ref 'foo 30 hash-set!\n\
686 ary1 => #( 0 #{ 'foo 30 } 2 )\n\
687 ary2 => #( 0 #{ 'foo 30 } 2 )\n\
688 Return copy of ARY1 only with references of each element \
689 in contrary to array-copy. \
690 If ARY1 is not an array, return #( ary1 ).\n\
691 See also array-copy."
692 if (FTH_ARRAY_P(array))
693 return (ary_to_array(array));
694 return (fth_make_array_var(1, array));
695 }
696
697 /*
698 * Return OBJ as List object.
699 */
700 FTH
fth_array_to_list(FTH obj)701 fth_array_to_list(FTH obj)
702 {
703 #define h_array_to_list "( ary -- lst ) return list\n\
704 #( 0 #{ 'foo 10 } 2 ) value ary1\n\
705 ary1 array->list value lst1\n\
706 ary1 1 array-ref 'foo 30 hash-set!\n\
707 ary1 => #( 0 #{ 'foo 30 } 2 )\n\
708 lst1 => '( 0 #{ 'foo 30 } 2 )\n\
709 Return copy of ARY as list only with references of each element \
710 in contrary to array-copy. \
711 If ARY is not an array, return '( ary ).\n\
712 See also array-copy."
713 FTH ls;
714 ficlInteger i;
715
716 if (FTH_ARRAY_P(obj)) {
717 ls = fth_make_list_len(FTH_ARRAY_LENGTH(obj));
718
719 for (i = 0; i < FTH_ARRAY_LENGTH(obj); i++)
720 FTH_ARRAY_DATA(ls)[i] = FTH_ARRAY_DATA(obj)[i];
721 } else
722 ls = fth_make_list_var(1, obj);
723
724 return (ls);
725 }
726
727 FTH
fth_array_copy(FTH array)728 fth_array_copy(FTH array)
729 {
730 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
731 return (ary_copy(array));
732 }
733
734 static void
ficl_array_copy(ficlVm * vm)735 ficl_array_copy(ficlVm *vm)
736 {
737 #define h_array_copy "( ary1 -- ary2 ) duplicate array\n\
738 #( 0 #{ 'foo 10 } 2 ) value ary1\n\
739 ary1 array-copy value ary2\n\
740 ary1 1 array-ref 'foo 30 hash-set!\n\
741 ary1 => #( 0 #{ 'foo 30 } 2 )\n\
742 ary2 => #( 0 #{ 'foo 10 } 2 )\n\
743 Return copy of ARY1 with all elements new created \
744 in contrary to array->array.\n\
745 See also array->array."
746 FTH obj;
747
748 FTH_STACK_CHECK(vm, 1, 1);
749 obj = fth_pop_ficl_cell(vm);
750 ficlStackPushFTH(vm->dataStack, fth_array_copy(obj));
751 }
752
753 /*
754 * Return element at position IDX. Negative IDX counts from backward.
755 * Raise OUT_OF_RANGE exception if IDX is not in ARRAY's range.
756 */
757 FTH
fth_array_ref(FTH array,ficlInteger idx)758 fth_array_ref(FTH array, ficlInteger idx)
759 {
760 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
761
762 if (idx < 0)
763 idx += FTH_ARRAY_LENGTH(array);
764
765 return (ary_ref(array, fth_make_int(idx)));
766 }
767
768 /* Dangerous! No check for array or array bounds. */
769 FTH
fth_array_fast_ref(FTH array,ficlInteger idx)770 fth_array_fast_ref(FTH array, ficlInteger idx)
771 {
772 return (FTH_ARRAY_DATA(array)[idx]);
773 }
774
775 static void
ficl_array_ref(ficlVm * vm)776 ficl_array_ref(ficlVm *vm)
777 {
778 #define h_array_ref "( ary idx -- val ) return value at IDX\n\
779 #( 'a 'b 'c ) 1 array-ref => 'b\n\
780 Return element at position IDX. \
781 Negative index counts from backward. \
782 Raise OUT-OF-RANGE exception if IDX is not in ARY's range."
783 ficlInteger idx;
784 FTH ary;
785
786 FTH_STACK_CHECK(vm, 2, 1);
787 idx = ficlStackPopInteger(vm->dataStack);
788 ary = fth_pop_ficl_cell(vm);
789 fth_push_ficl_cell(vm, fth_array_ref(ary, idx));
790 }
791
792 /*
793 * Store VALUE at position IDX and return VALUE. Negative index counts
794 * from backward. Raise OUT_OF_RANGE exception if IDX is not in ARRAY's
795 * range.
796 */
797 FTH
fth_array_set(FTH array,ficlInteger idx,FTH value)798 fth_array_set(FTH array, ficlInteger idx, FTH value)
799 {
800 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
801
802 if (idx < 0)
803 idx += FTH_ARRAY_LENGTH(array);
804
805 return (ary_set(array, fth_make_int(idx), value));
806 }
807
808 /* Dangerous! No check for array or array bounds. */
809 FTH
fth_array_fast_set(FTH array,ficlInteger idx,FTH value)810 fth_array_fast_set(FTH array, ficlInteger idx, FTH value)
811 {
812 FTH_INSTANCE_CHANGED(array);
813 return (FTH_ARRAY_DATA(array)[idx] = value);
814 }
815
816 static void
ficl_array_set(ficlVm * vm)817 ficl_array_set(ficlVm *vm)
818 {
819 #define h_array_set "( ary idx val -- ) set value at IDX\n\
820 #( 'a 'b 'c ) value ary\n\
821 ary 1 'e array-set!\n\
822 ary => #( 'a 'e 'c )\n\
823 Store VAL at position IDX. \
824 Negative index counts from backward. \
825 Raise OUT-OF-RANGE exception if IDX is not in ARY's range."
826 ficlInteger idx;
827 FTH value;
828
829 FTH_STACK_CHECK(vm, 3, 0);
830 value = fth_pop_ficl_cell(vm);
831 idx = ficlStackPopInteger(vm->dataStack);
832 fth_array_set(fth_pop_ficl_cell(vm), idx, value);
833 }
834
835 FTH
fth_array_push(FTH array,FTH value)836 fth_array_push(FTH array, FTH value)
837 {
838 #define h_array_push "( ary val -- ary' ) append VAL\n\
839 #( 0 1 2 ) 10 array-push => #( 0 1 2 10 )\n\
840 Append VAL to ARY.\n\
841 See also array-pop, array-unshift, array-shift."
842 ficlInteger new_buf_len, lenp1;
843
844 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
845 /* HINT: top + length + 1 is the new length (thanks Bill!) */
846 lenp1 = FTH_ARRAY_LENGTH(array) + 1;
847 new_buf_len = FTH_ARRAY_TOP(array) + lenp1;
848
849 if (new_buf_len > FTH_ARRAY_BUF_LENGTH(array)) {
850 ficlInteger len;
851 size_t size;
852
853 len = NEW_SEQ_LENGTH(new_buf_len);
854
855 if (len > MAX_SEQ_LENGTH)
856 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
857
858 FTH_ARRAY_BUF_LENGTH(array) = len;
859 size = sizeof(FTH) * (size_t) len;
860 FTH_ARRAY_BUF(array) = FTH_REALLOC(FTH_ARRAY_BUF(array), size);
861 FTH_ARRAY_DATA(array) = FTH_ARRAY_BUF(array) +
862 FTH_ARRAY_TOP(array);
863 }
864 FTH_ARRAY_DATA(array)[FTH_ARRAY_LENGTH(array)] = value;
865 FTH_ARRAY_LENGTH(array)++;
866 FTH_INSTANCE_CHANGED(array);
867 return (array);
868 }
869
870 FTH
fth_array_pop(FTH array)871 fth_array_pop(FTH array)
872 {
873 #define h_array_pop "( ary -- val ) remove last entry\n\
874 #( 0 1 2 ) value ary\n\
875 ary array-pop => 2\n\
876 ary array-pop => 1\n\
877 ary array-pop => 0\n\
878 ary array-pop => #f\n\
879 Remove and return last element from ARY. \
880 If ARY is empty, return #f.\n\
881 See also array-push, array-unshift, array-shift."
882 FTH result;
883 ficlInteger len;
884
885 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
886
887 if (FTH_ARRAY_LENGTH(array) == 0)
888 return (FTH_FALSE);
889
890 FTH_ARRAY_LENGTH(array)--;
891 result = FTH_ARRAY_DATA(array)[FTH_ARRAY_LENGTH(array)];
892 len = NEW_SEQ_LENGTH(FTH_ARRAY_TOP(array) + FTH_ARRAY_LENGTH(array));
893
894 if (len < FTH_ARRAY_BUF_LENGTH(array)) {
895 size_t size;
896
897 FTH_ARRAY_BUF_LENGTH(array) = len;
898 size = sizeof(FTH) * (size_t) len;
899 FTH_ARRAY_BUF(array) = FTH_REALLOC(FTH_ARRAY_BUF(array), size);
900 FTH_ARRAY_DATA(array) = FTH_ARRAY_BUF(array) +
901 FTH_ARRAY_TOP(array);
902 }
903 FTH_INSTANCE_CHANGED(array);
904 return (result);
905 }
906
907 FTH
fth_array_unshift(FTH array,FTH value)908 fth_array_unshift(FTH array, FTH value)
909 {
910 #define h_array_unshift "( ary val -- ary' ) prepend VAL\n\
911 #( 0 1 2 ) value ary\n\
912 ary 10 array-unshift drop\n\
913 ary 20 array-unshift drop\n\
914 ary => #( 20 10 0 1 2 )\n\
915 Prepend VAL to ARY.\n\
916 See also array-push, array-pop, array-shift."
917 ficlInteger len, new_top, new_len, new_buf_len;
918 size_t size;
919
920 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
921 new_top = FTH_ARRAY_TOP(array) - 1;
922 new_len = FTH_ARRAY_LENGTH(array) + 1;
923 new_buf_len = new_top + new_len;
924
925 if (new_top < 1) {
926 new_top = FTH_ARRAY_BUF_LENGTH(array) / 3;
927 new_buf_len = new_top + new_len;
928
929 if (new_buf_len > FTH_ARRAY_BUF_LENGTH(array)) {
930 len = NEW_SEQ_LENGTH(new_buf_len);
931
932 if (len > MAX_SEQ_LENGTH)
933 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len,
934 "too long");
935
936 FTH_ARRAY_BUF_LENGTH(array) = len;
937 size = sizeof(FTH) * (size_t) len;
938 FTH_ARRAY_BUF(array) = FTH_REALLOC(FTH_ARRAY_BUF(array),
939 size);
940 FTH_ARRAY_DATA(array) = FTH_ARRAY_BUF(array) +
941 FTH_ARRAY_TOP(array);
942 }
943 memmove(FTH_ARRAY_BUF(array) + new_top + 1,
944 FTH_ARRAY_DATA(array),
945 sizeof(FTH) * (size_t) FTH_ARRAY_LENGTH(array));
946 } else if (new_buf_len > FTH_ARRAY_BUF_LENGTH(array)) {
947 len = NEW_SEQ_LENGTH(new_buf_len);
948
949 if (len > MAX_SEQ_LENGTH)
950 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
951
952 FTH_ARRAY_BUF_LENGTH(array) = len;
953 size = sizeof(FTH) * (size_t) len;
954 FTH_ARRAY_BUF(array) = FTH_REALLOC(FTH_ARRAY_BUF(array), size);
955 FTH_ARRAY_DATA(array) = FTH_ARRAY_BUF(array) +
956 FTH_ARRAY_TOP(array);
957 }
958 FTH_ARRAY_TOP(array) = new_top;
959 FTH_ARRAY_LENGTH(array) = new_len;
960 FTH_ARRAY_DATA(array) = FTH_ARRAY_BUF(array) + FTH_ARRAY_TOP(array);
961 FTH_ARRAY_DATA(array)[0] = value;
962 FTH_INSTANCE_CHANGED(array);
963 return (array);
964 }
965
966 FTH
fth_array_shift(FTH array)967 fth_array_shift(FTH array)
968 {
969 #define h_array_shift "( ary -- val ) remove first element\n\
970 #( 0 1 2 ) value ary\n\
971 ary array-shift => 0\n\
972 ary array-shift => 1\n\
973 ary array-shift => 2\n\
974 ary array-shift => #f\n\
975 Remove and return first element from ARY. \
976 If ARY is empty, return #f.\n\
977 See also array-push, array-pop, array-unshift."
978 FTH result;
979 ficlInteger len;
980
981 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
982
983 if (FTH_ARRAY_LENGTH(array) == 0)
984 return (FTH_FALSE);
985
986 result = FTH_ARRAY_DATA(array)[0];
987
988 if ((FTH_ARRAY_TOP(array) + 1) > (FTH_ARRAY_BUF_LENGTH(array) / 2)) {
989 FTH_ARRAY_TOP(array) = FTH_ARRAY_BUF_LENGTH(array) / 3;
990 memmove(FTH_ARRAY_BUF(array) + FTH_ARRAY_TOP(array),
991 FTH_ARRAY_DATA(array),
992 sizeof(FTH) * (size_t) FTH_ARRAY_LENGTH(array));
993 }
994 FTH_ARRAY_LENGTH(array)--;
995 len = NEW_SEQ_LENGTH(FTH_ARRAY_TOP(array) + FTH_ARRAY_LENGTH(array));
996 FTH_ARRAY_TOP(array)++;
997
998 if (len < FTH_ARRAY_BUF_LENGTH(array)) {
999 size_t size;
1000
1001 FTH_ARRAY_BUF_LENGTH(array) = len;
1002 size = sizeof(FTH) * (size_t) len;
1003 FTH_ARRAY_BUF(array) = FTH_REALLOC(FTH_ARRAY_BUF(array), size);
1004 }
1005 FTH_ARRAY_DATA(array) = FTH_ARRAY_BUF(array) + FTH_ARRAY_TOP(array);
1006 FTH_INSTANCE_CHANGED(array);
1007 return (result);
1008 }
1009
1010 FTH
fth_array_append(FTH array,FTH value)1011 fth_array_append(FTH array, FTH value)
1012 {
1013 #define h_array_append "( ary1 ary2 -- ary3 ) append ARY2 to ARY1\n\
1014 #( 0 1 2 ) value ary1\n\
1015 #( 3 4 5 ) value ary2\n\
1016 ary1 ary2 array-append value ary3\n\
1017 ary1 => #( 0 1 2 )\n\
1018 ary2 => #( 3 4 5 )\n\
1019 ary3 => #( 0 1 2 3 4 5 )\n\
1020 ary1 10 array-append => #( 0 1 2 10 )\n\
1021 Append two arrays and return new one. \
1022 If ARY2 is not an array, append it as a single element.\n\
1023 See also array-concat (alias >array) and array-push."
1024 ficlInteger i, j, alen, vlen;
1025 FTH result;
1026
1027 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1028 alen = FTH_ARRAY_LENGTH(array);
1029
1030 if (!FTH_ARRAY_P(value)) {
1031 result = fth_make_array_len(alen + 1);
1032
1033 for (i = 0; i < alen; i++)
1034 FTH_ARRAY_DATA(result)[i] = FTH_ARRAY_DATA(array)[i];
1035
1036 FTH_ARRAY_DATA(result)[i] = value;
1037 return (result);
1038 }
1039 vlen = FTH_ARRAY_LENGTH(value);
1040 result = fth_make_array_len(alen + vlen);
1041
1042 for (i = 0; i < alen; i++)
1043 FTH_ARRAY_DATA(result)[i] = FTH_ARRAY_DATA(array)[i];
1044
1045 if (vlen > 0)
1046 for (i = alen, j = 0; j < vlen; i++, j++)
1047 FTH_ARRAY_DATA(result)[i] = FTH_ARRAY_DATA(value)[j];
1048
1049 return (result);
1050 }
1051
1052 FTH
fth_array_reverse(FTH array)1053 fth_array_reverse(FTH array)
1054 {
1055 #define h_ary_rev_bang "( ary -- ary' ) reverse array elements\n\
1056 #( 0 1 2 ) value ary\n\
1057 ary array-reverse! drop\n\
1058 ary => #( 2 1 0 )\n\
1059 Return ARY in reversed order.\n\
1060 See also array-reverse."
1061 ficlInteger i, j, len;
1062 FTH tmp;
1063
1064 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1065
1066 if (FTH_ARRAY_LENGTH(array) == 0)
1067 return (array);
1068
1069 tmp = ary_copy(array);
1070 len = FTH_ARRAY_LENGTH(array);
1071
1072 for (i = 0, j = len - 1; i < len; i++, j--)
1073 FTH_ARRAY_DATA(array)[i] = FTH_ARRAY_DATA(tmp)[j];
1074
1075 return (array);
1076 }
1077
1078 static void
ficl_array_reverse(ficlVm * vm)1079 ficl_array_reverse(ficlVm *vm)
1080 {
1081 #define h_array_reverse "( ary1 -- ary2 ) reverse array elements\n\
1082 #( 0 1 2 ) value ary1\n\
1083 ary1 array-reverse value ary2\n\
1084 ary1 => #( 0 1 2 )\n\
1085 ary2 => #( 2 1 0 )\n\
1086 Return new array with reversed order of ARY1.\n\
1087 See also array-reverse!."
1088 FTH ary;
1089
1090 FTH_STACK_CHECK(vm, 1, 1);
1091 ary = fth_array_copy(fth_pop_ficl_cell(vm));
1092 ficlStackPushFTH(vm->dataStack, fth_array_reverse(ary));
1093 }
1094
1095 FTH
fth_array_insert(FTH array,ficlInteger idx,FTH value)1096 fth_array_insert(FTH array, ficlInteger idx, FTH value)
1097 {
1098 ficlInteger ary_len, ins_len, res_len, new_buf_len;
1099 FTH ins;
1100
1101 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1102 ary_len = FTH_ARRAY_LENGTH(array);
1103
1104 if (idx < 0)
1105 idx += ary_len;
1106
1107 if (idx == 0) {
1108 ficlInteger i;
1109
1110 if (!FTH_ARRAY_P(value))
1111 return (fth_array_unshift(array, value));
1112
1113 for (i = FTH_ARRAY_LENGTH(value) - 1; i >= 0; i--)
1114 fth_array_unshift(array, FTH_ARRAY_DATA(value)[i]);
1115
1116 return (array);
1117 }
1118 if (idx < 0 || idx >= ary_len)
1119 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
1120
1121 if (FTH_ARRAY_P(value))
1122 ins = value;
1123 else
1124 ins = fth_make_array_var(1, value);
1125
1126 ins_len = FTH_ARRAY_LENGTH(ins);
1127 res_len = ary_len + ins_len;
1128 new_buf_len = FTH_ARRAY_TOP(array) + res_len;
1129
1130 if (new_buf_len > FTH_ARRAY_BUF_LENGTH(array)) {
1131 ficlInteger len;
1132 size_t size;
1133
1134 len = NEW_SEQ_LENGTH(new_buf_len);
1135
1136 if (len > MAX_SEQ_LENGTH)
1137 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
1138
1139 FTH_ARRAY_BUF_LENGTH(array) = len;
1140 size = sizeof(FTH) * (size_t) len;
1141 FTH_ARRAY_BUF(array) = FTH_REALLOC(FTH_ARRAY_BUF(array), size);
1142 FTH_ARRAY_DATA(array) = FTH_ARRAY_BUF(array) +
1143 FTH_ARRAY_TOP(array);
1144 }
1145 memmove(FTH_ARRAY_DATA(array) + idx + ins_len,
1146 FTH_ARRAY_DATA(array) + idx,
1147 sizeof(FTH) * (size_t) (ary_len - idx));
1148 memmove(FTH_ARRAY_DATA(array) + idx,
1149 FTH_ARRAY_DATA(ins), sizeof(FTH) * (size_t) ins_len);
1150 FTH_ARRAY_LENGTH(array) += FTH_ARRAY_LENGTH(ins);
1151 FTH_INSTANCE_CHANGED(array);
1152 return (array);
1153 }
1154
1155 static void
ficl_array_insert(ficlVm * vm)1156 ficl_array_insert(ficlVm *vm)
1157 {
1158 #define h_array_insert "( ary1 idx val -- ary2 ) insert element\n\
1159 #( 0 1 2 ) value ary1\n\
1160 ary1 1 10 array-insert value ary2\n\
1161 ary1 => #( 0 1 2 )\n\
1162 ary2 => #( 0 10 1 2 )\n\
1163 ary2 1 #( 4 5 6 ) array-insert => #( 0 4 5 6 10 1 2 )\n\
1164 Insert VAL to ARY1 at position IDX and return new array. \
1165 VAL can be an array or any other object. \
1166 Negative IDX counts from backward. \
1167 Raise OUT-OF-RANGE exception if IDX is not in ARY1's range."
1168 FTH ary, val;
1169 ficlInteger idx;
1170
1171 FTH_STACK_CHECK(vm, 3, 1);
1172 val = fth_pop_ficl_cell(vm);
1173 idx = ficlStackPopInteger(vm->dataStack);
1174 ary = fth_array_copy(fth_pop_ficl_cell(vm));
1175 ficlStackPushFTH(vm->dataStack, fth_array_insert(ary, idx, val));
1176 }
1177
1178 static void
ficl_array_insert_bang(ficlVm * vm)1179 ficl_array_insert_bang(ficlVm *vm)
1180 {
1181 #define h_array_insert_bang "( ary idx val -- ary' ) insert element\n\
1182 #( 0 1 2 ) value ary\n\
1183 ary 1 10 array-insert! drop\n\
1184 ary => #( 0 10 1 2 )\n\
1185 ary 1 #( 4 5 6 ) array-insert! => #( 0 4 5 6 10 1 2 )\n\
1186 Insert VAL to ARY at position IDX and return changed array. \
1187 VAL can be a single object or an array. \
1188 Negative IDX counts from backward. \
1189 Raise OUT-OF-RANGE exception if IDX is not in ARY's range."
1190 FTH ary, val;
1191 ficlInteger idx;
1192
1193 FTH_STACK_CHECK(vm, 3, 1);
1194 val = fth_pop_ficl_cell(vm);
1195 idx = ficlStackPopInteger(vm->dataStack);
1196 ary = fth_array_insert(fth_pop_ficl_cell(vm), idx, val);
1197 ficlStackPushFTH(vm->dataStack, ary);
1198 }
1199
1200 FTH
fth_array_delete(FTH array,ficlInteger idx)1201 fth_array_delete(FTH array, ficlInteger idx)
1202 {
1203 FTH value;
1204 ficlInteger len, cur_len;
1205
1206 FTH_ASSERT_ARGS(fth_array_length(array) > 0,
1207 array, FTH_ARG1, "a nonempty array");
1208 cur_len = FTH_ARRAY_LENGTH(array);
1209
1210 if (idx < 0)
1211 idx += cur_len;
1212
1213 if (idx < 0 || idx >= cur_len)
1214 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
1215
1216 if (idx == 0)
1217 return (fth_array_shift(array));
1218
1219 if (idx == (cur_len - 1))
1220 return (fth_array_pop(array));
1221
1222 value = FTH_ARRAY_DATA(array)[idx];
1223 FTH_ARRAY_LENGTH(array)--;
1224 len = NEW_SEQ_LENGTH(FTH_ARRAY_TOP(array) + FTH_ARRAY_LENGTH(array));
1225
1226 if (len < FTH_ARRAY_BUF_LENGTH(array)) {
1227 FTH_ARRAY_BUF_LENGTH(array) = len;
1228 FTH_ARRAY_BUF(array) = FTH_REALLOC(FTH_ARRAY_BUF(array),
1229 sizeof(FTH) * (size_t) len);
1230 FTH_ARRAY_DATA(array) = FTH_ARRAY_BUF(array) +
1231 FTH_ARRAY_TOP(array);
1232 }
1233 memmove(FTH_ARRAY_DATA(array) + idx,
1234 FTH_ARRAY_DATA(array) + idx + 1,
1235 sizeof(FTH) * (size_t) (FTH_ARRAY_LENGTH(array) - idx));
1236 FTH_INSTANCE_CHANGED(array);
1237 return (value);
1238 }
1239
1240 static void
ficl_array_delete(ficlVm * vm)1241 ficl_array_delete(ficlVm *vm)
1242 {
1243 #define h_array_delete "( ary idx -- val ) delete element\n\
1244 #( 'a 'b 'c ) value ary\n\
1245 ary 1 array-delete! => 'b\n\
1246 ary => #( 'a 'c )\n\
1247 Delete and return one element from ARY at position IDX. \
1248 Negative index counts from backward. \
1249 Raise OUT-OF-RANGE exception if IDX is not in ARY's range.\n\
1250 See also array-delete-key."
1251 FTH ary;
1252 ficlInteger idx;
1253
1254 FTH_STACK_CHECK(vm, 2, 1);
1255 idx = ficlStackPopInteger(vm->dataStack);
1256 ary = fth_pop_ficl_cell(vm);
1257 fth_push_ficl_cell(vm, fth_array_delete(ary, idx));
1258 }
1259
1260 FTH
fth_array_delete_key(FTH array,FTH key)1261 fth_array_delete_key(FTH array, FTH key)
1262 {
1263 #define h_adk "( ary key -- val ) delete element\n\
1264 #( 'a 'b 'c ) value ary\n\
1265 ary 'c array-delete-key => 'c\n\
1266 ary 'c array-delete-key => #f\n\
1267 Delete and return KEY from ARY if found, otherwise return #f.\n\
1268 See also array-delete!."
1269 ficlInteger i;
1270 FTH res;
1271
1272 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1273 res = FTH_FALSE;
1274
1275 for (i = 0; i < FTH_ARRAY_LENGTH(array); i++) {
1276 if (fth_object_equal_p(FTH_ARRAY_DATA(array)[i], key)) {
1277 res = fth_array_delete(array, i);
1278 break;
1279 }
1280 }
1281
1282 return (res);
1283 }
1284
1285 FTH
fth_array_reject(FTH array,FTH proc_or_xt,FTH args)1286 fth_array_reject(FTH array, FTH proc_or_xt, FTH args)
1287 {
1288 #define h_ary_reject_bang "( ary proc-or-xt args -- ary' ) remove elements\n\
1289 #( 0 1 2 ) value ary\n\
1290 ary lambda: <{ n1 n2 -- f }> n1 n2 > ; #( 2 ) array-reject! drop\n\
1291 ary => #( 0 1 )\n\
1292 \\ N1 corresponds to the current array element \
1293 and N2 comes from args, here 2.\n\
1294 \\ The same a bit shorter:\n\
1295 #( 0 1 2 ) value ary\n\
1296 ary <'> > #( 2 ) array-reject!\n\
1297 ary => #( 0 1 )\n\
1298 PROC-OR-XT will be called with ARGS, an array of zero or more proc arguments, \
1299 and the current array element set as first arg in ARGS array. \
1300 The length of ARGS + 1 is the required arity of PROC-OR-XT. \
1301 If PROC-OR-XT returns neither #f nor nil nor 0, the element will be removed.\n\
1302 See also array-reject."
1303 char *caller = RUNNING_WORD();
1304 ficlInteger i, len;
1305 FTH proc, tmp;
1306
1307 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1308
1309 if (FTH_ARRAY_LENGTH(array) < 2)
1310 return (array);
1311
1312 if (FTH_NIL_P(args))
1313 args = fth_make_empty_array();
1314 else if (!FTH_ARRAY_P(args))
1315 args = fth_make_array_var(1, args);
1316
1317 len = FTH_ARRAY_LENGTH(args);
1318 proc = proc_from_proc_or_xt(proc_or_xt, (int) len + 1, 0, 0);
1319 FTH_ASSERT_ARGS(FTH_PROC_P(proc), proc, FTH_ARG2, "a proc");
1320 tmp = ary_copy(args);
1321 fth_array_unshift(tmp, FTH_UNDEF);
1322
1323 for (i = 0; i < FTH_ARRAY_LENGTH(array); i++) {
1324 FTH ret;
1325
1326 FTH_ARRAY_DATA(tmp)[0] = FTH_ARRAY_DATA(array)[i];
1327 ret = fth_proc_apply(proc, tmp, caller);
1328
1329 if (!(FTH_FALSE_P(ret) || FTH_NIL_P(ret) || FTH_ZERO == ret))
1330 fth_array_delete(array, i--);
1331 }
1332
1333 return (array);
1334 }
1335
1336 static void
ficl_array_reject(ficlVm * vm)1337 ficl_array_reject(ficlVm *vm)
1338 {
1339 #define h_array_reject "( ary1 proc-or-xt args -- ary2 ) remove elementes\n\
1340 #( 0 1 2 ) value ary\n\
1341 ary lambda: <{ n1 n2 -- f }> n1 n2 > ; #( 2 ) array-reject => #( 0 1 )\n\
1342 \\ N1 corresponds to the current array element \
1343 and N2 comes from args, here 2.\n\
1344 \\ The same a bit shorter:\n\
1345 ary <'> > #( 2 ) array-reject => #( 0 1 )\n\
1346 PROC-OR-XT will be called with ARGS, an array of zero or more proc arguments, \
1347 and the current array element set as first arg in ARGS array. \
1348 The length of ARGS + 1 is the required arity of PROC-OR-XT. \
1349 If PROC-OR-XT returns neither #f nor nil nor 0, \
1350 the element will be pushed in a new array object. \
1351 The new array object will be returned.\n\
1352 See also array-reject!."
1353 FTH ary, proc, args;
1354
1355 FTH_STACK_CHECK(vm, 3, 1);
1356 args = fth_pop_ficl_cell(vm);
1357 proc = fth_pop_ficl_cell(vm);
1358 ary = fth_array_copy(fth_pop_ficl_cell(vm));
1359 ficlStackPushFTH(vm->dataStack, fth_array_reject(ary, proc, args));
1360 }
1361
1362 static FTH
ary_compact_each(FTH value,FTH new)1363 ary_compact_each(FTH value, FTH new)
1364 {
1365 if (FTH_NOT_NIL_P(value))
1366 fth_array_push(new, value);
1367 return (new);
1368 }
1369
1370 FTH
fth_array_compact(FTH array)1371 fth_array_compact(FTH array)
1372 {
1373 #define h_ary_comp_bang "( ary -- ary' ) remove nil elements\n\
1374 #( 0 nil 1 nil 2 ) value ary\n\
1375 ary array-compact! drop\n\
1376 ary => #( 0 1 2 )\n\
1377 Remove all nil elements from ARY and return changed array object.\n\
1378 See also array-compact."
1379 FTH old;
1380
1381 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1382 old = fth_array_copy(array);
1383 FTH_ARRAY_LENGTH(array) = 0;
1384 FTH_INSTANCE_CHANGED(array);
1385 return (fth_array_each(old, ary_compact_each, array));
1386 }
1387
1388 static void
ficl_array_compact(ficlVm * vm)1389 ficl_array_compact(ficlVm *vm)
1390 {
1391 #define h_array_compact "( ary1 -- ary2 ) remove nil elements\n\
1392 #( 0 nil 1 nil 2 ) value ary1\n\
1393 ary1 array-compact value ary2\n\
1394 ary1 => #( 0 nil 1 nil 2 )\n\
1395 ary2 => #( 0 1 2 )\n\
1396 Return new array object with nil elements removed.\n\
1397 See also array-compact!."
1398 FTH ary, new;
1399
1400 FTH_STACK_CHECK(vm, 1, 1);
1401 ary = fth_pop_ficl_cell(vm);
1402 new = fth_array_each(ary, ary_compact_each, fth_make_empty_array());
1403 ficlStackPushFTH(vm->dataStack, new);
1404 }
1405
1406 FTH
fth_array_fill(FTH array,FTH value)1407 fth_array_fill(FTH array, FTH value)
1408 {
1409 #define h_array_fill "( ary val -- ary' ) fill array\n\
1410 #( 0 1 2 ) value ary\n\
1411 ary 10 array-fill drop\n\
1412 ary => #( 10 10 10 )\n\
1413 Set all elements of ARY to VAL."
1414 ficlInteger i, len;
1415
1416 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1417 len = FTH_ARRAY_LENGTH(array);
1418
1419 for (i = 0; i < len; i++)
1420 FTH_ARRAY_DATA(array)[i] = value;
1421
1422 FTH_INSTANCE_CHANGED(array);
1423 return (array);
1424 }
1425
1426 ficlInteger
fth_array_index(FTH array,FTH key)1427 fth_array_index(FTH array, FTH key)
1428 {
1429 ficlInteger i, len;
1430
1431 if (!FTH_ARRAY_P(array))
1432 return (-1);
1433
1434 len = FTH_ARRAY_LENGTH(array);
1435
1436 for (i = 0; i < len; i++)
1437 if (fth_object_equal_p(FTH_ARRAY_DATA(array)[i], key))
1438 return (i);
1439
1440 return (-1);
1441 }
1442
1443 static void
ficl_array_index(ficlVm * vm)1444 ficl_array_index(ficlVm *vm)
1445 {
1446 #define h_array_index "( ary key -- idx|-1 ) find KEY\n\
1447 #( 'a 'b 'c ) 'b array-index => 1\n\
1448 #( 'a 'b 'c ) 'f array-index => -1\n\
1449 Return index of KEY in ARY or -1 if not found.\n\
1450 See also array-member? and array-find."
1451 FTH ary, key;
1452
1453 FTH_STACK_CHECK(vm, 2, 1);
1454 key = fth_pop_ficl_cell(vm);
1455 ary = fth_pop_ficl_cell(vm);
1456 ficlStackPushInteger(vm->dataStack, fth_array_index(ary, key));
1457 }
1458
1459 int
fth_array_member_p(FTH array,FTH item)1460 fth_array_member_p(FTH array, FTH item)
1461 {
1462 ficlInteger i, len;
1463
1464 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1465 len = FTH_ARRAY_LENGTH(array);
1466
1467 for (i = 0; i < len; i++)
1468 if (fth_object_equal_p(FTH_ARRAY_DATA(array)[i], item))
1469 return (1);
1470
1471 return (0);
1472 }
1473
1474 static void
ficl_array_member_p(ficlVm * vm)1475 ficl_array_member_p(ficlVm *vm)
1476 {
1477 #define h_array_member_p "( ary key -- f ) find KEY\n\
1478 #( 'a 'b 'c ) 'b array-member? => #t\n\
1479 #( 'a 'b 'c ) 'f array-member? => #f\n\
1480 Return #t if KEY exists in ARY, otherwise #f.\n\
1481 See also array-index and array-find."
1482 FTH ary, key;
1483
1484 FTH_STACK_CHECK(vm, 2, 1);
1485 key = fth_pop_ficl_cell(vm);
1486 ary = fth_pop_ficl_cell(vm);
1487 ficlStackPushBoolean(vm->dataStack, fth_array_member_p(ary, key));
1488 }
1489
1490 FTH
fth_array_find(FTH array,FTH key)1491 fth_array_find(FTH array, FTH key)
1492 {
1493 #define h_array_find "( ary key -- key|#f ) find KEY\n\
1494 #( 'a 'b 'c ) 'b array-find => 'b\n\
1495 #( 'a 'b 'c ) 'f array-find => #f\n\
1496 Return key if KEY exists in ARY, otherwise #f.\n\
1497 See also array-index and array-member?."
1498 ficlInteger i, len;
1499
1500 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1501 len = FTH_ARRAY_LENGTH(array);
1502
1503 for (i = 0; i < len; i++)
1504 if (fth_object_equal_p(FTH_ARRAY_DATA(array)[i], key))
1505 return (FTH_ARRAY_DATA(array)[i]);
1506
1507 return (FTH_FALSE);
1508 }
1509
1510 static FTH
ary_uniq_each(FTH value,FTH new)1511 ary_uniq_each(FTH value, FTH new)
1512 {
1513 if (!fth_array_member_p(new, value))
1514 fth_array_push(new, value);
1515 return (new);
1516 }
1517
1518 FTH
fth_array_uniq(FTH array)1519 fth_array_uniq(FTH array)
1520 {
1521 #define h_array_uniq_bang "( ary -- ary' ) remove duplicates\n\
1522 #( 0 1 2 3 2 1 0 ) value ary\n\
1523 ary array-uniq! drop\n\
1524 ary => #( 0 1 2 3 )\n\
1525 Return ARY without duplicated elements.\n\
1526 See also array-uniq."
1527 FTH old;
1528
1529 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1530 old = fth_array_copy(array);
1531 FTH_ARRAY_LENGTH(array) = 0;
1532 FTH_INSTANCE_CHANGED(array);
1533 return (fth_array_each(old, ary_uniq_each, array));
1534 }
1535
1536 static void
ficl_array_uniq(ficlVm * vm)1537 ficl_array_uniq(ficlVm *vm)
1538 {
1539 #define h_array_uniq "( ary1 -- ary2 ) remove duplicates\n\
1540 #( 0 1 2 3 2 1 0 ) array-uniq => #( 0 1 2 3 )\n\
1541 Return new array without duplicated elements of ARY1.\n\
1542 See also array-uniq!."
1543 FTH ary, new;
1544
1545 FTH_STACK_CHECK(vm, 1, 1);
1546 ary = fth_pop_ficl_cell(vm);
1547 new = fth_array_each(ary, ary_uniq_each, fth_make_empty_array());
1548 ficlStackPushFTH(vm->dataStack, new);
1549 }
1550
1551 #if defined(HAVE_QSORT)
1552
1553 static FTH fth_cmp_proc;
1554 static int
cmpit(const void * a,const void * b)1555 cmpit(const void *a, const void *b)
1556 {
1557 FTH r;
1558
1559 r = fth_proc_call(fth_cmp_proc, "array-sort", 2, *(FTH *)a, *(FTH *)b);
1560 return (FIX_TO_INT32(r));
1561 }
1562
1563 #endif /* HAVE_QSORT */
1564
1565 FTH
fth_array_sort(FTH array,FTH proc_or_xt)1566 fth_array_sort(FTH array, FTH proc_or_xt)
1567 {
1568 #define h_array_sort_bang "( ary proc-or-xt -- ary' ) sort array\n\
1569 #( 2 1 0 ) value ary\n\
1570 ary lambda: <{ a b -- f }>\n\
1571 a b < if\n\
1572 -1\n\
1573 else\n\
1574 a b > if\n\
1575 1\n\
1576 else\n\
1577 0\n\
1578 then\n\
1579 then\n\
1580 ; array-sort! drop\n\
1581 ary => #( 0 1 2 )\n\
1582 Return the sorted ARY. \
1583 PROC-OR-XT compares two elements A and B \
1584 and should return a negative integer if A < B, \
1585 0 if A == B, and a positive integer if A > B. \
1586 Raise BAD-ARITY exception if PROC-OR-XT doesn't take two arguments.\n\
1587 See also array-sort."
1588 FTH proc;
1589 size_t len;
1590
1591 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1592 len = (size_t) FTH_ARRAY_LENGTH(array);
1593
1594 if (len < 2)
1595 return (array);
1596
1597 proc = proc_from_proc_or_xt(proc_or_xt, 2, 0, 0);
1598 FTH_ASSERT_ARGS(FTH_PROC_P(proc), proc, FTH_ARG2, "a compare proc");
1599 #if defined(HAVE_QSORT)
1600 fth_cmp_proc = proc;
1601 qsort((void *) FTH_ARRAY_DATA(array), len, sizeof(FTH), cmpit);
1602 #endif
1603 FTH_INSTANCE_CHANGED(array);
1604 return (array);
1605 }
1606
1607 static void
ficl_array_sort(ficlVm * vm)1608 ficl_array_sort(ficlVm *vm)
1609 {
1610 #define h_array_sort "( ary1 proc-or-xt -- ary2 ) sort array\n\
1611 #( 2 1 0 ) value ary\n\
1612 ary lambda: <{ a b -- f }>\n\
1613 a b < if\n\
1614 -1\n\
1615 else\n\
1616 a b > if\n\
1617 1\n\
1618 else\n\
1619 0\n\
1620 then\n\
1621 then\n\
1622 ; array-sort => #( 0 1 2 )\n\
1623 Return new sorted array. \
1624 PROC-OR-XT compares two elements A and B \
1625 and should return a negative integer if A < B, \
1626 0 if A == B, and a positive integer if A > B. \
1627 Raise BAD-ARITY exception if PROC-OR-XT doesn't take two arguments.\n\
1628 See also array-sort!."
1629 FTH ary1, ary2, proc;
1630
1631 FTH_STACK_CHECK(vm, 2, 1);
1632 proc = fth_pop_ficl_cell(vm);
1633 ary1 = fth_pop_ficl_cell(vm);
1634 ary2 = fth_array_sort(fth_array_copy(ary1), proc);
1635 ficlStackPushFTH(vm->dataStack, ary2);
1636 }
1637
1638 FTH
fth_array_join(FTH array,FTH sep)1639 fth_array_join(FTH array, FTH sep)
1640 {
1641 #define h_array_join "( ary sep -- str ) join array to string\n\
1642 #( 0 1 2 ) \"--\" array-join => \"0--1--2\"\n\
1643 #( 0 1 2 ) nil array-join => \"0 1 2\"\n\
1644 Return string with all elements of ARY \
1645 converted to their string representation \
1646 and joined together separated by the string SEP. \
1647 If SEP is not a string, a space will be used as separator."
1648 ficlInteger i, len;
1649 FTH fs, el;
1650
1651 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1652 fs = fth_make_empty_string();
1653 len = FTH_ARRAY_LENGTH(array);
1654
1655 if (len == 0)
1656 return (fs);
1657
1658 if (!FTH_STRING_P(sep))
1659 sep = fth_make_string(" ");
1660
1661 fth_string_push(fs, fth_object_to_string(FTH_ARRAY_DATA(array)[0]));
1662
1663 for (i = 1; i < len; i++) {
1664 fth_string_push(fs, sep);
1665 el = fth_object_to_string(FTH_ARRAY_DATA(array)[i]);
1666 fth_string_push(fs, el);
1667 }
1668
1669 return (fs);
1670 }
1671
1672 FTH
fth_array_subarray(FTH array,ficlInteger start,ficlInteger end)1673 fth_array_subarray(FTH array, ficlInteger start, ficlInteger end)
1674 {
1675 FTH result;
1676 ficlInteger len;
1677 size_t size;
1678
1679 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1680 len = FTH_ARRAY_LENGTH(array);
1681
1682 if (start < 0)
1683 start += len;
1684
1685 if (start < 0 || start >= len)
1686 FTH_OUT_OF_BOUNDS(FTH_ARG2, start);
1687
1688 if (end < 0) {
1689 /*
1690 * We are looking for end length not last entry, hence end++.
1691 */
1692 end += len;
1693 end++;
1694 }
1695 if (end < start || end > len)
1696 end = len;
1697
1698 result = fth_make_array_len(end - start);
1699 size = sizeof(FTH) * (size_t) len;
1700 memmove(FTH_ARRAY_DATA(result), FTH_ARRAY_DATA(array) + start, size);
1701 return (result);
1702 }
1703
1704 static void
ficl_array_subarray(ficlVm * vm)1705 ficl_array_subarray(ficlVm *vm)
1706 {
1707 #define h_array_subarray "( ary start end -- subary ) return part of array\n\
1708 #( 0 1 2 3 4 ) 2 4 array-subarray => #( 2 3 )\n\
1709 #( 0 1 2 3 4 ) -3 -1 array-subarray => #( 2 3 4 )\n\
1710 #( 0 1 2 3 4 ) -3 nil array-subarray => #( 2 3 4 )\n\
1711 Return array built from ARY \
1712 beginning with index START up to but excluding index END. \
1713 If END is NIL, up to end of array will be returned. \
1714 Negative index counts from backward. \
1715 Raise OUT-OF-RANGE exception if START is not in ARY's range."
1716 FTH ary, last;
1717 ficlInteger beg, end;
1718
1719 FTH_STACK_CHECK(vm, 3, 1);
1720 last = fth_pop_ficl_cell(vm);
1721 beg = ficlStackPopInteger(vm->dataStack);
1722 ary = fth_pop_ficl_cell(vm);
1723 end = FTH_INTEGER_P(last) ? FTH_INT_REF(last) : fth_array_length(ary);
1724 ficlStackPushFTH(vm->dataStack, fth_array_subarray(ary, beg, end));
1725 }
1726
1727 void
fth_array_clear(FTH array)1728 fth_array_clear(FTH array)
1729 {
1730 #define h_array_clear "( ary -- ) clear array\n\
1731 #( 0 1 2 ) value ary\n\
1732 ary array-clear\n\
1733 ary => #( #f #f #f )\n\
1734 Clear array and set all elements to #f."
1735 ficlInteger i, len;
1736
1737 FTH_ASSERT_ARGS(FTH_ARRAY_P(array), array, FTH_ARG1, "an array");
1738 len = FTH_ARRAY_LENGTH(array);
1739
1740 for (i = 0; i < len; i++)
1741 FTH_ARRAY_DATA(array)[i] = FTH_FALSE;
1742
1743 FTH_INSTANCE_CHANGED(array);
1744 }
1745
1746 /*
1747 * ACELLS, elements for assocs and alists.
1748 */
1749
1750 #define FTH_ACELL_P(Obj) \
1751 (FTH_ARRAY_P(Obj) && (FTH_ARRAY_LENGTH(Obj) == 2))
1752 #define FTH_ACELL_KEY(Obj) FTH_ARRAY_DATA(Obj)[0]
1753 #define FTH_ACELL_VAL(Obj) FTH_ARRAY_DATA(Obj)[1]
1754
1755 static FTH
acl_inspect(FTH self)1756 acl_inspect(FTH self)
1757 {
1758 FTH key, val;
1759
1760 key = FTH_ACELL_KEY(self);
1761 val = FTH_ACELL_VAL(self);
1762 return (fth_make_string_format("'( %I . %I )", key, val));
1763 }
1764
1765 static FTH
acl_to_string(FTH self)1766 acl_to_string(FTH self)
1767 {
1768 FTH key, val;
1769
1770 key = FTH_ACELL_KEY(self);
1771 val = FTH_ACELL_VAL(self);
1772 return (fth_make_string_format("'( %M . %M )", key, val));
1773 }
1774
1775 static FTH
acl_dump(FTH self)1776 acl_dump(FTH self)
1777 {
1778 FTH key, val;
1779
1780 key = FTH_ACELL_KEY(self);
1781 val = FTH_ACELL_VAL(self);
1782 return (fth_make_string_format("%D %D", key, val));
1783 }
1784
1785 /* Acell is a special two element array. */
1786 FTH
fth_make_acell(FTH key,FTH value)1787 fth_make_acell(FTH key, FTH value)
1788 {
1789 FArray *ary;
1790
1791 ary = FTH_MALLOC(sizeof(FArray));
1792 ary->type = FTH_ARY_ARRAY;
1793 ary->length = 2;
1794 ary->buf_length = 2;
1795 ary->top = 0;
1796 ary->buf = FTH_MALLOC(sizeof(FTH) * 2);
1797 ary->data = ary->buf;
1798 ary->data[0] = key;
1799 ary->data[1] = value;
1800 return (fth_make_instance(acell_tag, ary));
1801 }
1802
1803 /* fth_car and fth_cdr return FTH_FALSE if not a list. */
1804 FTH
fth_acell_key(FTH cell)1805 fth_acell_key(FTH cell)
1806 {
1807 if (FTH_ACELL_P(cell))
1808 return (FTH_ACELL_KEY(cell));
1809 return (FTH_FALSE);
1810 }
1811
1812 FTH
fth_acell_value(FTH cell)1813 fth_acell_value(FTH cell)
1814 {
1815 if (FTH_ACELL_P(cell))
1816 return (FTH_ACELL_VAL(cell));
1817 return (FTH_FALSE);
1818 }
1819
1820 /*
1821 * ASSOC: sorted associative arrays as an alternative to hashs.
1822 */
1823 static ficlInteger
assoc_index(FTH assoc,FTH key)1824 assoc_index(FTH assoc, FTH key)
1825 {
1826 FTH id, kid;
1827 ficlInteger i, beg, end;
1828
1829 if (FTH_NIL_P(assoc) || FTH_FALSE_P(assoc))
1830 return (-1);
1831
1832 FTH_ASSERT_ARGS(FTH_ARRAY_P(assoc), assoc, FTH_ARG1, "an array");
1833
1834 if (FTH_ARRAY_LENGTH(assoc) == 0)
1835 return (-1);
1836
1837 beg = 0;
1838 end = FTH_ARRAY_LENGTH(assoc) - 1;
1839 id = fth_hash_id(key);
1840
1841 while (beg <= end) {
1842 i = (beg + end) / 2;
1843 kid = fth_hash_id(fth_acell_key(FTH_ARRAY_DATA(assoc)[i]));
1844
1845 if (id == kid)
1846 return (i);
1847 else if (id < kid)
1848 end = i - 1;
1849 else
1850 beg = i + 1;
1851 }
1852
1853 return (-1);
1854 }
1855
1856 static void
ficl_assoc_p(ficlVm * vm)1857 ficl_assoc_p(ficlVm *vm)
1858 {
1859 #define h_assoc_p "( obj -- f ) test if OBJ is an assoc\n\
1860 #a( 'a 0 'b 1 'c 2 ) assoc? => #t\n\
1861 nil assoc? => #f\n\
1862 Return #t if OBJ is an assoc array object, otherwise #f."
1863 FTH obj;
1864 int flag;
1865
1866 FTH_STACK_CHECK(vm, 1, 1);
1867 obj = fth_pop_ficl_cell(vm);
1868 flag = FTH_ARRAY_P(obj) && FTH_ARRAY_ASSOC_P(obj);
1869 ficlStackPushBoolean(vm->dataStack, flag);
1870 }
1871
1872 static void
ficl_values_to_assoc(ficlVm * vm)1873 ficl_values_to_assoc(ficlVm *vm)
1874 {
1875 #define h_values_to_assoc "( vals len -- ary ) return assoc array\n\
1876 'foo 0 'bar 1 4 >assoc => #a( '( 'foo . 0 ) '( 'bar . 1 ) )\n\
1877 Return assoc array object with LEN/2 key-value pairs \
1878 found on parameter stack. \
1879 Raise OUT-OF-RANGE exception if LEN < 0 or not even."
1880 ficlInteger i, len;
1881 FTH assoc, key, val;
1882
1883 FTH_STACK_CHECK(vm, 1, 0);
1884 len = ficlStackPopInteger(vm->dataStack);
1885
1886 if (len < 0)
1887 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARGn, len, "negative");
1888
1889 if (len % 2)
1890 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARGn, len, "odd");
1891
1892 if (len > MAX_SEQ_LENGTH)
1893 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARGn, len, "too long");
1894
1895 FTH_STACK_CHECK(vm, len, 1);
1896 assoc = fth_make_empty_array();
1897 FTH_ASSOC_SET(assoc);
1898 len /= 2;
1899
1900 for (i = 0; i < len; i++) {
1901 val = fth_pop_ficl_cell(vm);
1902 key = fth_pop_ficl_cell(vm);
1903 fth_assoc(assoc, key, val);
1904 }
1905
1906 ficlStackPushFTH(vm->dataStack, assoc);
1907 }
1908
1909 static FTH
assoc_insert(FTH assoc,FTH id,FTH val)1910 assoc_insert(FTH assoc, FTH id, FTH val)
1911 {
1912 ficlInteger i, len, alen;
1913
1914 FTH_ASSERT_ARGS(FTH_ARRAY_P(assoc), assoc, FTH_ARG1, "an array");
1915
1916 if (!FTH_ARRAY_ASSOC_P(assoc))
1917 FTH_ASSOC_SET(assoc);
1918
1919 alen = FTH_ARRAY_LENGTH(assoc);
1920
1921 for (i = 0; i < alen; i++)
1922 if (id < fth_hash_id(fth_acell_key(FTH_ARRAY_DATA(assoc)[i])))
1923 break;
1924
1925 len = NEW_SEQ_LENGTH(FTH_ARRAY_TOP(assoc) + alen + 1);
1926
1927 if (len > MAX_SEQ_LENGTH)
1928 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARG1, len, "too long");
1929
1930 if (len > FTH_ARRAY_BUF_LENGTH(assoc)) {
1931 size_t size;
1932
1933 FTH_ARRAY_BUF_LENGTH(assoc) = len;
1934 size = sizeof(FTH) * (size_t) len;
1935 FTH_ARRAY_BUF(assoc) = FTH_REALLOC(FTH_ARRAY_BUF(assoc), size);
1936 FTH_ARRAY_DATA(assoc) = FTH_ARRAY_BUF(assoc) +
1937 FTH_ARRAY_TOP(assoc);
1938 }
1939 memmove(FTH_ARRAY_DATA(assoc) + i + 1,
1940 FTH_ARRAY_DATA(assoc) + i,
1941 sizeof(FTH) * (size_t) (FTH_ARRAY_LENGTH(assoc) - i));
1942 FTH_ARRAY_LENGTH(assoc)++;
1943 FTH_ARRAY_DATA(assoc)[i] = val;
1944 FTH_INSTANCE_CHANGED(assoc);
1945 return (assoc);
1946 }
1947
1948 FTH
fth_assoc(FTH assoc,FTH key,FTH value)1949 fth_assoc(FTH assoc, FTH key, FTH value)
1950 {
1951 #define h_assoc "( ass key val -- 'ass ) return assoc array\n\
1952 #() value ass\n\
1953 ass 'a 10 assoc => #a( '( 'a . 10 ) )\n\
1954 ass 'b 20 assoc => #a( '( 'a . 10 ) '( 'b . 20 ) )\n\
1955 Build sorted assoc array. \
1956 ASS must be an assoc array or an empty array #().\n\
1957 See also array-assoc, array-assoc-ref, array-assoc-set!, array-assoc-remove!."
1958 FTH val;
1959
1960 val = fth_make_acell(key, value);
1961
1962 if (FTH_NIL_P(assoc) || FTH_FALSE_P(assoc)) {
1963 assoc = fth_make_array_var(1, val);
1964 FTH_ASSOC_SET(assoc);
1965 return (assoc);
1966 }
1967 return (assoc_insert(assoc, fth_hash_id(key), val));
1968 }
1969
1970 FTH
fth_array_assoc(FTH assoc,FTH key)1971 fth_array_assoc(FTH assoc, FTH key)
1972 {
1973 #define h_array_ass "( ass key -- key-val|#f ) find KEY\n\
1974 #() 'a #( 0 1 ) assoc value ass\n\
1975 ass => #a( '( 'a . #( 0 1 ) ) )\n\
1976 ass 'a array-assoc => '( 'a . #( 0 1 ) )\n\
1977 ass 0 array-assoc => #f\n\
1978 ass 1 array-assoc => #f\n\
1979 If KEY matches, return corresponding key-value pair, otherwise #f."
1980 ficlInteger idx;
1981
1982 idx = assoc_index(assoc, key);
1983
1984 if (idx >= 0)
1985 return (ary_ref(assoc, fth_make_int(idx)));
1986
1987 return (FTH_FALSE);
1988 }
1989
1990 FTH
fth_array_assoc_ref(FTH assoc,FTH key)1991 fth_array_assoc_ref(FTH assoc, FTH key)
1992 {
1993 #define h_aryass_ref "( ass key -- val|#f ) find KEY\n\
1994 #() 'a #( 0 1 ) assoc value ass\n\
1995 ass => #a( '( 'a . #( 0 1 ) ) )\n\
1996 ass 'a array-assoc-ref => #( 0 1 )\n\
1997 ass 0 array-assoc-ref => #f\n\
1998 ass 1 array-assoc-ref => #f\n\
1999 If KEY matches, return corresponding value, otherwise #f."
2000 ficlInteger idx;
2001 FTH as;
2002
2003 idx = assoc_index(assoc, key);
2004
2005 if (idx >= 0) {
2006 as = ary_ref(assoc, fth_make_int(idx));
2007
2008 if (FTH_ACELL_P(as))
2009 return (FTH_ACELL_VAL(as));
2010 /* else fall through */
2011 }
2012 return (FTH_FALSE);
2013 }
2014
2015 FTH
fth_array_assoc_set(FTH assoc,FTH key,FTH value)2016 fth_array_assoc_set(FTH assoc, FTH key, FTH value)
2017 {
2018 #define h_array_ass_set "( ass key val -- 'ass ) set KEY to VAL\n\
2019 #() 'a #( 0 1 ) assoc value ass\n\
2020 ass => #a( '( 'a . #( 0 1 ) ) )\n\
2021 ass 'a 10 array-assoc-set! => #a( '( 'a . 10 ) )\n\
2022 ass 0 10 array-assoc-set! => #a( '( 0 . 10 ) '( 'a . 10 ) )\n\
2023 ass 1 10 array-assoc-set! => #a( '( 0 . 10 ) '( 1 . 10 ) '( 'a . 10 ) )\n\
2024 ass => #a( '( 0 . 10 ) '( 1 . 10 ) '( 'a . 10 ) )\n\
2025 If KEY matches, set key-value pair, otherwise add new pair to ASS."
2026 ficlInteger idx;
2027
2028 idx = assoc_index(assoc, key);
2029
2030 if (idx >= 0) {
2031 fth_array_set(assoc, idx, fth_make_acell(key, value));
2032 return (assoc);
2033 }
2034 return (fth_assoc(assoc, key, value));
2035 }
2036
2037 FTH
fth_array_assoc_remove(FTH assoc,FTH key)2038 fth_array_assoc_remove(FTH assoc, FTH key)
2039 {
2040 #define h_aar "( ass key -- 'ass ) remove KEY\n\
2041 #() 'a #( 0 1 ) assoc 'd 10 assoc value ass\n\
2042 ass => #a( '( 'a . #( 0 1 ) ) '( 'd . 10 ) )\n\
2043 ass 'a array-assoc-remove! => #a( '( 'd . 10 ) )\n\
2044 ass 0 array-assoc-remove! => #a( '( 'd . 10 ) )\n\
2045 ass 1 array-assoc-remove! => #a( '( 'd . 10 ) )\n\
2046 If KEY matches, remove key-value pair from ASS."
2047 ficlInteger idx;
2048
2049 idx = assoc_index(assoc, key);
2050
2051 if (idx >= 0)
2052 fth_array_delete(assoc, idx);
2053
2054 return (assoc);
2055 }
2056
2057 /*
2058 * LIST: Built with arrays.
2059 */
2060
2061 #define h_list_of_list_functions "\
2062 *** LIST PRIMITIVES ***\n\
2063 '() ( -- lst )\n\
2064 .list ( lst -- )\n\
2065 >list ( vals len -- lst )\n\
2066 cadddr ( lst -- val )\n\
2067 caddr ( lst -- val )\n\
2068 cadr ( lst -- val )\n\
2069 car ( lst -- val )\n\
2070 cddr ( lst -- val )\n\
2071 cdr ( lst -- val )\n\
2072 cons ( val lst1 -- lst2 )\n\
2073 cons2 ( val1 val2 lst1 -- lst2 )\n\
2074 cons? ( obj -- f )\n\
2075 last-pair ( lst -- val )\n\
2076 list->array ( lst -- ary )\n\
2077 list-append ( arg0 arg1 ... argn n -- lst )\n\
2078 list-copy ( lst1 -- ary2 )\n\
2079 list-delete ( lst1 key -- lst2 )\n\
2080 list-delete! ( lst key -- lst' )\n\
2081 list-fill ( lst val -- lst' )\n\
2082 list-head ( lst1 idx -- lst2 )\n\
2083 list-index ( lst key -- idx )\n\
2084 list-insert ( lst1 idx val -- lst2 )\n\
2085 list-length ( lst -- len )\n\
2086 list-member? ( lst key -- f )\n\
2087 list-ref ( lst idx -- val )\n\
2088 list-reverse ( lst1 -- ary2 )\n\
2089 list-set! ( lst idx val -- )\n\
2090 list-slice ( lst1 idx :key count 1 -- lst2 )\n\
2091 list-slice! ( lst idx :key count 1 -- lst' )\n\
2092 list-tail ( lst1 idx -- lst2 )\n\
2093 list= ( obj1 obj2 -- f )\n\
2094 list? ( obj -- f )\n\
2095 make-list ( len :key initial-element nil -- lst )\n\
2096 nil? ( obj -- f )\n\
2097 null? alias for nil?\n\
2098 pair? ( obj -- f )\n\
2099 set-car! ( lst val -- lst' )\n\
2100 set-cdr! ( lst val -- lst' )\n\
2101 Assoc lists:\n\
2102 >alist ( vals len -- alst )\n\
2103 acons ( key val alst1 -- alst2 )\n\
2104 list-assoc ( alst key -- ret )\n\
2105 list-assoc-ref ( alst key -- val )\n\
2106 list-assoc-remove! ( alst key -- alst' )\n\
2107 list-assoc-set! ( alst key val -- alst' )"
2108
2109 /*
2110 * If OBJ is a list (or array), return length of list, if OBJ is nil,
2111 * return 0 otherwise -1.
2112 */
2113 ficlInteger
fth_list_length(FTH obj)2114 fth_list_length(FTH obj)
2115 {
2116 if (FTH_CONS_P(obj))
2117 return (FTH_ARRAY_LENGTH(obj));
2118 return (FTH_NIL_P(obj) ? 0 : -1);
2119 }
2120
2121 static void
ficl_list_length(ficlVm * vm)2122 ficl_list_length(ficlVm *vm)
2123 {
2124 #define h_list_length "( obj -- len ) return list length\n\
2125 '( 0 1 2 ) list-length => 3\n\
2126 nil list-length => 0\n\
2127 '() list-length => 0\n\
2128 5 list-length => -1\n\
2129 If OBJ is a list (or array), return length of list, \
2130 if OBJ is nil, return 0 otherwise -1."
2131 FTH obj;
2132
2133 FTH_STACK_CHECK(vm, 1, 1);
2134 obj = fth_pop_ficl_cell(vm);
2135 ficlStackPushInteger(vm->dataStack, fth_list_length(obj));
2136 }
2137
2138 static FTH
make_list_instance(FArray * ary)2139 make_list_instance(FArray *ary)
2140 {
2141 FTH_ARY_LIST_SET(ary);
2142 return (fth_make_instance(list_tag, ary));
2143 }
2144
2145 FTH
fth_make_list_var(int len,...)2146 fth_make_list_var(int len,...)
2147 {
2148 int i;
2149 FArray *ary;
2150 va_list list;
2151
2152 ary = make_array((ficlInteger) len);
2153 va_start(list, len);
2154
2155 for (i = 0; i < len; i++)
2156 ary->data[i] = va_arg(list, FTH);
2157
2158 va_end(list);
2159 return (make_list_instance(ary));
2160 }
2161
2162 FTH
fth_make_list_len(ficlInteger len)2163 fth_make_list_len(ficlInteger len)
2164 {
2165 return (make_list_instance(make_array(len)));
2166 }
2167
2168 FTH
fth_make_list_with_init(ficlInteger len,FTH init)2169 fth_make_list_with_init(ficlInteger len, FTH init)
2170 {
2171 ficlInteger i;
2172 FArray *ary;
2173
2174 ary = make_array(len);
2175
2176 for (i = 0; i < ary->length; i++)
2177 ary->data[i] = init;
2178
2179 return (make_list_instance(ary));
2180 }
2181
2182 FTH
fth_make_empty_list(void)2183 fth_make_empty_list(void)
2184 {
2185 return (fth_make_list_len(0L));
2186 }
2187
2188 static void
ficl_nil_p(ficlVm * vm)2189 ficl_nil_p(ficlVm *vm)
2190 {
2191 #define h_nil_p "( obj -- f ) test if OBJ is nil\n\
2192 '( 0 1 2 ) nil? => #f\n\
2193 nil nil? => #t\n\
2194 '() nil? => #t\n\
2195 0 nil? => #f\n\
2196 Return #t if OBJ is nil, otherwise #f."
2197 FTH obj;
2198
2199 FTH_STACK_CHECK(vm, 1, 1);
2200 obj = fth_pop_ficl_cell(vm);
2201 ficlStackPushBoolean(vm->dataStack, FTH_NIL_P(obj));
2202 }
2203
2204 static void
ficl_list_p(ficlVm * vm)2205 ficl_list_p(ficlVm *vm)
2206 #define h_list_p "( obj -- f ) test if OBJ is a list\n\
2207 #( 0 1 2 ) list? => #f\n\
2208 '( 0 1 2 ) list? => #t\n\
2209 nil list? => #t\n\
2210 '() list? => #t\n\
2211 0 list? => #f\n\
2212 Return #t if OBJ is a list (nil or a cons pointer), otherwise #f."
2213 {
2214 FTH obj;
2215 int flag;
2216
2217 FTH_STACK_CHECK(vm, 1, 1);
2218 obj = fth_pop_ficl_cell(vm);
2219 flag = FTH_NIL_P(obj) || (FTH_CONS_P(obj) && FTH_ARRAY_LIST_P(obj));
2220 ficlStackPushBoolean(vm->dataStack, flag);
2221 }
2222
2223 static void
ficl_cons_p(ficlVm * vm)2224 ficl_cons_p(ficlVm *vm)
2225 #define h_cons_p "( obj -- f ) test if OBJ is cons\n\
2226 #( 0 1 2 ) cons? => #f\n\
2227 '( 0 1 2 ) cons? => #t\n\
2228 nil cons? => #f\n\
2229 '() cons? => #f\n\
2230 0 cons? => #f\n\
2231 Return #t if OBJ is a cons pointer, otherwise #f."
2232 {
2233 FTH obj;
2234 int flag;
2235
2236 FTH_STACK_CHECK(vm, 1, 1);
2237 obj = fth_pop_ficl_cell(vm);
2238 flag = FTH_CONS_P(obj) && FTH_ARRAY_LIST_P(obj);
2239 ficlStackPushBoolean(vm->dataStack, flag);
2240 }
2241
2242 static void
ficl_pair_p(ficlVm * vm)2243 ficl_pair_p(ficlVm *vm)
2244 #define h_pair_p "( obj -- f ) test if OBJ is a pair\n\
2245 #( 0 1 2 ) pair? => #f\n\
2246 '( 0 1 2 ) pair? => #t\n\
2247 nil pair? => #f\n\
2248 '() pair? => #f\n\
2249 0 pair? => #f\n\
2250 Return #t if OBJ is a pair (a cons pointer), otherwise #f."
2251 {
2252 FTH obj;
2253 int flag;
2254
2255 FTH_STACK_CHECK(vm, 1, 1);
2256 obj = fth_pop_ficl_cell(vm);
2257 flag = FTH_PAIR_P(obj) && FTH_ARRAY_LIST_P(obj);
2258 ficlStackPushBoolean(vm->dataStack, flag);
2259 }
2260
2261 static void
ficl_make_list(ficlVm * vm)2262 ficl_make_list(ficlVm *vm)
2263 {
2264 #define h_make_list "( len :key initial-element nil -- lst ) return list\n\
2265 0 make-list => '()\n\
2266 3 make-list => '( nil nil nil )\n\
2267 3 :initial-element 10 make-list => '( 10 10 10 )\n\
2268 Return list of length LEN filled with keyword INITIAL-ELEMENT values. \
2269 INITIAL-ELEMENT defaults to nil if not specified. \
2270 Raise OUT-OF-RANGE exception if LEN < 0."
2271 FTH size, init, ls;
2272
2273 init = fth_get_optkey(FTH_KEYWORD_INIT, FTH_NIL);
2274 FTH_STACK_CHECK(vm, 1, 1);
2275 size = fth_pop_ficl_cell(vm);
2276 FTH_ASSERT_ARGS(FTH_INTEGER_P(size), size, FTH_ARG1, "an integer");
2277 ls = fth_make_list_with_init(FTH_INT_REF(size), init);
2278 fth_push_ficl_cell(vm, ls);
2279 }
2280
2281 static void
ficl_values_to_list(ficlVm * vm)2282 ficl_values_to_list(ficlVm *vm)
2283 {
2284 #define h_values_to_list "( len-vals len -- lst ) return list\n\
2285 0 1 2 3 >list => '( 0 1 2 )\n\
2286 Return list object with LEN objects found on parameter stack. \
2287 Raise OUT-OF-RANGE exception if LEN < 0."
2288 ficlInteger i, len;
2289 FTH ls;
2290
2291 FTH_STACK_CHECK(vm, 1, 0);
2292 len = ficlStackPopInteger(vm->dataStack);
2293 ls = fth_make_list_len(len);
2294 FTH_STACK_CHECK(vm, len, 1);
2295
2296 for (i = len - 1; i >= 0; i--)
2297 FTH_ARRAY_DATA(ls)[i] = fth_pop_ficl_cell(vm);
2298
2299 ficlStackPushFTH(vm->dataStack, ls);
2300 }
2301
2302 /*
2303 * Return Lisp-like cons pointer with VALUE as car and LIST as cdr.
2304 */
2305 FTH
fth_cons(FTH val,FTH list)2306 fth_cons(FTH val, FTH list)
2307 {
2308 #define h_list_cons "( val list1 -- list2 ) return list\n\
2309 0 nil cons => '( 0 )\n\
2310 0 1 nil cons cons => '( 0 1 )\n\
2311 0 1 2 nil cons cons cons => '( 0 1 2 ) etc.\n\
2312 Return Lisp-like cons pointer with VAL as car and LIST as cdr.\n\
2313 See also cons2."
2314 if (FTH_NIL_P(list))
2315 return (fth_make_list_var(1, val));
2316
2317 if (FTH_CONS_P(list))
2318 return (fth_array_unshift(list, val));
2319
2320 return (fth_make_list_var(2, val, list));
2321 }
2322
2323 /*
2324 * Return Lisp-like cons pointer with VALUE1 as car, VALUE2 as cadr
2325 * and LIST as cddr.
2326 */
2327 FTH
fth_cons_2(FTH val1,FTH val2,FTH list)2328 fth_cons_2(FTH val1, FTH val2, FTH list)
2329 {
2330 #define h_list_cons_2 "( val1 val2 list1 -- list2 ) return list\n\
2331 0 1 nil cons2 value lst1\n\
2332 lst1 => '( 0 1 )\n\
2333 lst1 car => 0\n\
2334 lst1 cdr => '( 1 )\n\
2335 0 1 2 nil cons cons2 value lst2\n\
2336 lst2 => '( 0 1 2 )\n\
2337 lst2 car => 0\n\
2338 lst2 cdr => '( 1 2 )\n\
2339 Return Lisp-like cons pointer with VAL1 as car, \
2340 VAL2 as cadr and LIST as cddr.\n\
2341 See also cons."
2342 if (FTH_NIL_P(list))
2343 return (fth_make_list_var(2, val1, val2));
2344
2345 if (FTH_CONS_P(list))
2346 return (fth_array_unshift(fth_array_unshift(list, val2), val1));
2347
2348 return (fth_make_list_var(3, val1, val2, list));
2349
2350 }
2351
2352 #define MAKE_CAR(Name, Idx) \
2353 FTH \
2354 fth_ ## Name (FTH list) \
2355 { \
2356 FTH ret = FTH_NIL; \
2357 \
2358 if (fth_list_length(list) > Idx) \
2359 ret = FTH_ARRAY_DATA(list)[Idx]; \
2360 \
2361 return (ret); \
2362 }
2363
2364 MAKE_CAR(car, 0L)
2365 MAKE_CAR(cadr, 1L)
2366 MAKE_CAR(caddr, 2L)
2367 MAKE_CAR(cadddr, 3L)
2368
2369 #define h_list_car "( list -- val ) return first list entry\n\
2370 '( 0 1 2 3 4 ) car => 0\n\
2371 '() car => nil\n\
2372 Return first entry, the car, of LIST or nil.\n\
2373 See also cadr, caddr, cadddr."
2374 #define h_list_cadr "( lst -- val ) return second list entry\n\
2375 '( 0 1 2 3 4 ) cadr => 1\n\
2376 '() cadr => nil\n\
2377 Return second entry, the cadr, of LIST or nil.\n\
2378 See also car, caddr, cadddr."
2379 #define h_list_caddr "( lst -- val ) return third list entry\n\
2380 '( 0 1 2 3 4 ) caddr => 2\n\
2381 '() caddr => nil\n\
2382 Return third entry, the caddr, of LIST or nil.\n\
2383 See also car, cadr, cadddr."
2384 #define h_list_cadddr "( lst -- val ) return fourth list entry\n\
2385 '( 0 1 2 3 4 ) cadddr => 3\n\
2386 '() cadddr => nil\n\
2387 Return fourth entry, the cadddr, of LIST or nil.\n\
2388 See also car, cadr, caddr."
2389
2390 #define MAKE_CDR(Name, Idx) \
2391 FTH \
2392 fth_ ## Name (FTH list) \
2393 { \
2394 FTH ls = FTH_NIL; \
2395 \
2396 if (fth_list_length(list) > Idx) { \
2397 ls = fth_array_subarray(list, Idx, -1L); \
2398 FTH_LIST_SET(ls); \
2399 } \
2400 return (ls); \
2401 }
2402
2403 MAKE_CDR(cdr, 1L)
2404 MAKE_CDR(cddr, 2L)
2405
2406 #define h_list_cdr "( list -- val ) return rest of list\n\
2407 '( 0 1 2 ) cdr => '( 1 2 )\n\
2408 '( 0 ) cdr => nil\n\
2409 '() cdr => nil\n\
2410 Return rest, the cdr, of LIST without its first entry.\n\
2411 See also cddr and car, cadr, caddr, cadddr."
2412 #define h_list_cddr "( list -- val ) return rest of list\n\
2413 '( 0 1 2 ) cddr => '( 2 )\n\
2414 '( 0 ) cddr => nil\n\
2415 '() cddr => nil\n\
2416 Return rest, the cddr, of LIST without its first and second entries.\n\
2417 See also cdr and car, cadr, caddr, cadddr."
2418
2419 static void
ficl_print_list(ficlVm * vm)2420 ficl_print_list(ficlVm *vm)
2421 {
2422 #define h_print_list "( lst -- ) print list\n\
2423 '( 0 1 2 ) .list => '( 0 1 2 )\n\
2424 Print list object LST to current output."
2425 FTH obj;
2426
2427 FTH_STACK_CHECK(vm, 1, 0);
2428 obj = fth_pop_ficl_cell(vm);
2429 FTH_ASSERT_ARGS(FTH_LIST_P(obj), obj, FTH_ARG1, "a list");
2430 fth_print(fth_string_ref(ary_to_string(obj)));
2431 }
2432
2433 static void
ficl_list_equal_p(ficlVm * vm)2434 ficl_list_equal_p(ficlVm *vm)
2435 {
2436 #define h_list_equal_p "( lst1 lst2 -- f ) compare lists\n\
2437 '( 0 1 2 ) value l1\n\
2438 '( 0 1 2 ) value l2\n\
2439 '( 0 1 3 ) value l3\n\
2440 l1 l1 list= #t\n\
2441 l1 l2 list= #t\n\
2442 l1 l3 list= #f\n\
2443 Return #t if LST1 and LST2 are list objects of same length and content, \
2444 otherwise #f."
2445 FTH obj1, obj2;
2446 int flag;
2447
2448 FTH_STACK_CHECK(vm, 2, 1);
2449 obj2 = fth_pop_ficl_cell(vm);
2450 obj1 = fth_pop_ficl_cell(vm);
2451 /*
2452 * nil == '()
2453 * 0 make-list == '() (list object with 0 entries)
2454 */
2455 flag = ((fth_list_length(obj1) == 0 && fth_list_length(obj2) == 0) ||
2456 fth_array_equal_p(obj1, obj2));
2457 ficlStackPushBoolean(vm->dataStack, flag);
2458 }
2459
2460 static void
ficl_set_car(ficlVm * vm)2461 ficl_set_car(ficlVm *vm)
2462 {
2463 #define h_list_set_car "( lst val -- lst' ) set car\n\
2464 '( 0 1 2 ) 10 set-car! => '( 10 1 2 )\n\
2465 '() 10 set-car! => nil\n\
2466 Set VAL to car of LST.\n\
2467 See also set-cdr!."
2468 FTH lst, val;
2469
2470 FTH_STACK_CHECK(vm, 2, 1);
2471 val = fth_pop_ficl_cell(vm);
2472 lst = fth_pop_ficl_cell(vm);
2473
2474 if (FTH_CONS_P(lst) && FTH_ARRAY_LENGTH(lst) > 0) {
2475 fth_array_set(lst, 0L, val);
2476 ficlStackPushFTH(vm->dataStack, lst);
2477 } else
2478 fth_push_ficl_cell(vm, FTH_NIL);
2479 }
2480
2481 static void
ficl_set_cdr(ficlVm * vm)2482 ficl_set_cdr(ficlVm *vm)
2483 {
2484 #define h_list_set_cdr "( lst val -- lst' ) set cdr\n\
2485 '( 0 1 2 ) 10 set-cdr! => '( 0 10 )\n\
2486 '() 10 set-cdr! => nil\n\
2487 Set VAL to cdr of LST.\n\
2488 See also set-car!."
2489 FTH lst, val, ls;
2490
2491 FTH_STACK_CHECK(vm, 2, 1);
2492 val = fth_pop_ficl_cell(vm);
2493 lst = fth_pop_ficl_cell(vm);
2494 ls = FTH_NIL;
2495
2496 if (FTH_CONS_P(lst)) {
2497 if (FTH_ARRAY_LENGTH(lst) == 1)
2498 fth_array_push(lst, val);
2499 else {
2500 fth_array_set(lst, 1L, val);
2501 FTH_ARRAY_LENGTH(lst) = 2;
2502 }
2503 ls = fth_list_append(fth_make_acell(fth_acell_key(lst), val));
2504 }
2505 fth_push_ficl_cell(vm, ls);
2506 }
2507
2508 FTH
fth_list_to_array(FTH list)2509 fth_list_to_array(FTH list)
2510 {
2511 #define h_list_to_array "( lst -- ary|#f ) return array\n\
2512 #( 0 #{ 'foo 10 } 2 ) value lst1\n\
2513 lst1 list->array value ary2\n\
2514 lst1 1 list-ref 'foo 30 hash-set!\n\
2515 lst1 => '( 0 #{ 'foo 30 } 2 )\n\
2516 ary2 => #( 0 #{ 'foo 30 } 2 )\n\
2517 Return copy of LST as array only with references of each element \
2518 in contrary to list-copy. \
2519 If LST is not a cons pointer, return #( lst )."
2520 if (FTH_CONS_P(list))
2521 return (ary_to_array(list));
2522 return (fth_make_array_var(1, list));
2523 }
2524
2525 /*
2526 * Return copy of LIST using object-copy for all elements.
2527 */
2528 FTH
fth_list_copy(FTH list)2529 fth_list_copy(FTH list)
2530 {
2531 #define h_list_copy "( lst1 -- lst2 ) duplicate list\n\
2532 #( 0 #{ 'foo 10 } 2 ) value lst1\n\
2533 lst1 list-copy value lst2\n\
2534 lst1 1 list-ref 'foo 30 hash-set!\n\
2535 lst1 => '( 0 #{ 'foo 30 } 2 )\n\
2536 lst2 => '( 0 #{ 'foo 10 } 2 )\n\
2537 Return copy of LST1 with all elements new created \
2538 in contrary to list->array.\n\
2539 See also list->array."
2540 FTH ls;
2541
2542 ls = FTH_NIL;
2543
2544 if (FTH_CONS_P(list)) {
2545 ls = ary_copy(list);
2546 FTH_LIST_SET(ls);
2547 }
2548 return (ls);
2549 }
2550
2551 /*
2552 * Return element at position IDX. Negative IDX counts from backward.
2553 * Raise OUT_OF_RANGE exception if IDX is not in LIST's range.
2554 */
2555 FTH
fth_list_ref(FTH list,ficlInteger idx)2556 fth_list_ref(FTH list, ficlInteger idx)
2557 {
2558 if (FTH_CONS_P(list))
2559 return (fth_array_ref(list, idx));
2560 return (FTH_NIL);
2561 }
2562
2563 static void
ficl_list_ref(ficlVm * vm)2564 ficl_list_ref(ficlVm *vm)
2565 {
2566 #define h_list_ref "( lst idx -- val ) return value at IDX\n\
2567 '( 'a 'b 'c ) 1 list-ref => 'b\n\
2568 Return value at position IDX of LST. \
2569 Negative IDX counts from backward. \
2570 Raise OUT-OF-RANGE exception if IDX is not in LST's range."
2571 FTH lst;
2572 ficlInteger idx;
2573
2574 FTH_STACK_CHECK(vm, 2, 1);
2575 idx = ficlStackPopInteger(vm->dataStack);
2576 lst = fth_pop_ficl_cell(vm);
2577 fth_push_ficl_cell(vm, fth_list_ref(lst, idx));
2578 }
2579
2580 /*
2581 * Store VALUE at position IDX and return VALUE. Negative IDX counts
2582 * from backward. Raise OUT_OF_RANGE exception if IDX is not in LST's
2583 * range.
2584 */
2585 FTH
fth_list_set(FTH list,ficlInteger idx,FTH value)2586 fth_list_set(FTH list, ficlInteger idx, FTH value)
2587 {
2588 if (FTH_CONS_P(list))
2589 fth_array_set(list, idx, value);
2590 return (value);
2591 }
2592
2593 static void
ficl_list_set(ficlVm * vm)2594 ficl_list_set(ficlVm *vm)
2595 {
2596 #define h_list_set "( lst idx val -- ) set value at IDX\n\
2597 '( 'a 'b 'c ) value lst\n\
2598 lst 1 'e list-set!\n\
2599 lst => '( 'a 'e 'c )\n\
2600 Store VAL at position IDX in LST. \
2601 Negative IDX counts from backward. \
2602 Raise OUT-OF-RANGE exception if IDX is not in LST's range."
2603 FTH lst, val;
2604 ficlInteger idx;
2605
2606 FTH_STACK_CHECK(vm, 3, 0);
2607 val = fth_pop_ficl_cell(vm);
2608 idx = ficlStackPopInteger(vm->dataStack);
2609 lst = fth_pop_ficl_cell(vm);
2610 fth_list_set(lst, idx, val);
2611 }
2612
2613 static FTH
ls_append_each(FTH value,FTH ls)2614 ls_append_each(FTH value, FTH ls)
2615 {
2616 if (FTH_NOT_NIL_P(value)) {
2617 ls = fth_array_append(ls, value);
2618 FTH_LIST_SET(ls);
2619 }
2620 return (ls);
2621 }
2622
2623 /*
2624 * If ARGS is not an Array or List object, return FTH_NIL, otherwise
2625 * return new List object with each element of ARGS append with
2626 * fth_array_append.
2627 */
2628 FTH
fth_list_append(FTH args)2629 fth_list_append(FTH args)
2630 {
2631 FTH ls;
2632
2633 ls = FTH_NIL;
2634
2635 if (FTH_CONS_P(args)) {
2636 ls = fth_make_empty_list();
2637 ls = fth_array_each(args, ls_append_each, ls);
2638 FTH_LIST_SET(ls);
2639 }
2640 return (ls);
2641 }
2642
2643 static void
ficl_list_append(ficlVm * vm)2644 ficl_list_append(ficlVm *vm)
2645 {
2646 #define h_list_append "( arg0 arg1 ... argn n -- lst ) return list\n\
2647 0 1 '( 2 3 4 ) 5 6 5 list-append => '( 0 1 2 3 4 5 6 )\n\
2648 '( 0 ) '( 1 ) 2 list-append => '( 0 1 )\n\
2649 '( 0 ) '( 1 2 3 ) 2 list-append => '( 0 1 2 3 )\n\
2650 '( 0 '( 1 ) ) '( '( 2 ) ) 2 list-append => '( 0 '( 1 ) '( 2 ) )\n\
2651 '( 0 1 ) 2 3 nil acons 2 list-append => '( 0 1 '( 2 . 3 ) )\n\
2652 '() 0 2 list-append => '( 0 )\n\
2653 0 list-append => '()\n\
2654 Return list object with N objects found on parameter stack. \
2655 Raise OUT-OF-RANGE exception if N < 0."
2656 ficlInteger i, len;
2657 FTH ls;
2658
2659 FTH_STACK_CHECK(vm, 1, 1);
2660 ls = FTH_NIL;
2661 len = ficlStackPopInteger(vm->dataStack);
2662
2663 if (len < 0)
2664 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARGn, len, "negative");
2665
2666 if (len > MAX_SEQ_LENGTH)
2667 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARGn, len, "too long");
2668
2669 if (len == 0) {
2670 fth_push_ficl_cell(vm, ls);
2671 return;
2672 }
2673 FTH_STACK_CHECK(vm, len, 1);
2674 ls = fth_make_list_len(len);
2675
2676 for (i = len - 1; i >= 0; i--)
2677 FTH_ARRAY_DATA(ls)[i] = fth_pop_ficl_cell(vm);
2678
2679 fth_push_ficl_cell(vm, fth_list_append(ls));
2680 }
2681
2682 /*
2683 * Return new list with elements reversed.
2684 */
2685 FTH
fth_list_reverse(FTH list)2686 fth_list_reverse(FTH list)
2687 {
2688 #define h_list_reverse "( lst1 -- lst2 ) reverse list elements\n\
2689 '( 0 1 2 ) value l1\n\
2690 l1 list-reverse value l2\n\
2691 l1 => '( 0 1 2 )\n\
2692 l2 => '( 2 1 0 )\n\
2693 Return new list with elements reversed."
2694 FTH ls;
2695
2696 ls = list;
2697
2698 if (FTH_CONS_P(list)) {
2699 ls = fth_array_reverse(ary_copy(list));
2700 FTH_LIST_SET(ls);
2701 }
2702 return (ls);
2703 }
2704
2705 static void
ficl_list_insert(ficlVm * vm)2706 ficl_list_insert(ficlVm *vm)
2707 {
2708 #define h_list_insert "( lst1 idx val -- lst2 ) insert element\n\
2709 '( 0 1 2 ) value l1\n\
2710 l1 0 10 list-insert value l2\n\
2711 l1 => '( 0 1 2 )\n\
2712 l2 => '( 10 0 1 2 )\n\
2713 l1 1 '( 4 5 6 ) list-insert => '( 0 4 5 6 10 1 2 )\n\
2714 Insert VAL to LST1 at position IDX and return new list. \
2715 VAL can be a list or any other object. \
2716 Negative IDX counts from backward. \
2717 Raise OUT-OF-RANGE exception if IDX is not in LST1's range."
2718 ficlInteger idx;
2719 FTH lst, val, ls;
2720
2721 FTH_STACK_CHECK(vm, 3, 1);
2722 val = fth_pop_ficl_cell(vm);
2723 idx = ficlStackPopInteger(vm->dataStack);
2724 lst = fth_pop_ficl_cell(vm);
2725 ls = FTH_NIL;
2726
2727 if (FTH_CONS_P(lst)) {
2728 ls = fth_array_insert(ary_copy(lst), idx, val);
2729 FTH_LIST_SET(ls);
2730 }
2731 fth_push_ficl_cell(vm, ls);
2732 }
2733
2734 static FTH
ls_delete_each(FTH value,FTH data)2735 ls_delete_each(FTH value, FTH data)
2736 {
2737 FTH key, ls;
2738
2739 key = FTH_ARRAY_DATA(data)[0];
2740 ls = FTH_ARRAY_DATA(data)[1];
2741
2742 if (!fth_object_equal_p(value, key))
2743 fth_array_push(ls, value);
2744
2745 return (data);
2746 }
2747
2748 static void
ficl_list_delete(ficlVm * vm)2749 ficl_list_delete(ficlVm *vm)
2750 {
2751 #define h_list_delete "( lst1 key -- lst2 ) delete element\n\
2752 '( 0 0 1 2 ) 0 list-delete => '( 1 2 )\n\
2753 Return new list without all elements equal KEY.\n\
2754 See also list-delete!."
2755 FTH lst, key, data, ls;
2756
2757 FTH_STACK_CHECK(vm, 2, 1);
2758 key = fth_pop_ficl_cell(vm);
2759 lst = fth_pop_ficl_cell(vm);
2760 ls = FTH_NIL;
2761
2762 if (FTH_CONS_P(lst)) {
2763 ls = fth_make_empty_list();
2764 data = fth_make_array_var(2, key, ls);
2765 fth_array_each(lst, ls_delete_each, data);
2766 }
2767 fth_push_ficl_cell(vm, ls);
2768 }
2769
2770 static void
ficl_list_delete_bang(ficlVm * vm)2771 ficl_list_delete_bang(ficlVm *vm)
2772 {
2773 #define h_list_delete_bang "( lst key -- lst' ) delete element\n\
2774 '( 'a 'b 'c ) value ls\n\
2775 ls 1 list-delete! => 'b\n\
2776 ls => '( 'a 'c )\n\
2777 Return LST without all elements equal KEY.\n\
2778 See also list-delete."
2779 ficlInteger i, len;
2780 FTH lst, key;
2781
2782 FTH_STACK_CHECK(vm, 2, 1);
2783 key = fth_pop_ficl_cell(vm);
2784 lst = fth_pop_ficl_cell(vm);
2785
2786 if (FTH_CONS_P(lst)) {
2787 len = FTH_ARRAY_LENGTH(lst);
2788
2789 for (i = 0; i < len; i++)
2790 if (fth_object_equal_p(FTH_ARRAY_DATA(lst)[i], key))
2791 fth_array_delete(lst, i--);
2792 }
2793 fth_push_ficl_cell(vm, lst);
2794 }
2795
2796 static void
ficl_list_slice(ficlVm * vm)2797 ficl_list_slice(ficlVm *vm)
2798 {
2799 #define h_list_slice "( lst1 idx :key count 1 -- lst2 ) remove elements\n\
2800 '( 0 1 1 2 ) 1 :count 2 list-slice => '( 0 2 )\n\
2801 Return new list without COUNT elements from IDX on. \
2802 Raise OUT-OF-RANGE exception if IDX is not in LST1's range.\n\
2803 See also list-slice!."
2804 ficlInteger idx, cnt;
2805 FTH lst, ls;
2806
2807 cnt = fth_get_optkey_int(FTH_KEYWORD_COUNT, 1L);
2808 FTH_STACK_CHECK(vm, 2, 1);
2809 idx = ficlStackPopInteger(vm->dataStack);
2810 lst = fth_pop_ficl_cell(vm);
2811 ls = FTH_NIL;
2812
2813 if (FTH_CONS_P(lst)) {
2814 ficlInteger i , end, len;
2815
2816 len = FTH_ARRAY_LENGTH(lst);
2817
2818 if (idx < 0)
2819 idx += len;
2820
2821 if (idx < 0 || idx >= len)
2822 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
2823
2824 end = idx + cnt;
2825 ls = fth_make_empty_list();
2826
2827 for (i = 0; i < len; i++)
2828 if (i < idx || i >= end)
2829 fth_array_push(ls, FTH_ARRAY_DATA(lst)[i]);
2830 }
2831 fth_push_ficl_cell(vm, ls);
2832 }
2833
2834 static void
ficl_list_slice_bang(ficlVm * vm)2835 ficl_list_slice_bang(ficlVm *vm)
2836 {
2837 #define h_list_slice_bang "( lst idx :key count 1 -- lst' ) remove elements\n\
2838 '( 0 1 1 2 ) value ls\n\
2839 ls 1 :count 2 list-slice! drop\n\
2840 ls => '( 0 2 )\n\
2841 Return LST without COUNT elements from IDX on. \
2842 Raise OUT-OF-RANGE exception if IDX is not in LST's range.\n\
2843 See also list-slice."
2844 FTH lst;
2845 ficlInteger idx, cnt;
2846
2847 cnt = fth_get_optkey_int(FTH_KEYWORD_COUNT, 1L);
2848 FTH_STACK_CHECK(vm, 2, 1);
2849 idx = ficlStackPopInteger(vm->dataStack);
2850 lst = fth_pop_ficl_cell(vm);
2851
2852 if (FTH_CONS_P(lst)) {
2853 ficlInteger i, j, end, len;
2854 FTH el;
2855
2856 len = FTH_ARRAY_LENGTH(lst);
2857
2858 if (idx < 0)
2859 idx += len;
2860
2861 if (idx < 0 || idx >= len)
2862 FTH_OUT_OF_BOUNDS(FTH_ARG2, idx);
2863
2864 end = idx + cnt;
2865
2866 for (i = 0, j = 0; i < len; i++) {
2867 if (i < idx || i >= end) {
2868 el = FTH_ARRAY_DATA(lst)[i];
2869 FTH_ARRAY_DATA(lst)[j++] = el;
2870 }
2871 }
2872 FTH_ARRAY_LENGTH(lst) = j;
2873 }
2874 fth_push_ficl_cell(vm, lst);
2875 }
2876
2877 static void
ficl_list_fill(ficlVm * vm)2878 ficl_list_fill(ficlVm *vm)
2879 {
2880 #define h_list_fill "( lst val -- lst' ) fill list\n\
2881 '( 0 1 2 ) value ls\n\
2882 ls 10 list-fill drop\n\
2883 ls => '( 10 10 10 )\n\
2884 Set all elements of LST to VAL."
2885 FTH lst, val;
2886
2887 FTH_STACK_CHECK(vm, 2, 1);
2888 val = fth_pop_ficl_cell(vm);
2889 lst = fth_pop_ficl_cell(vm);
2890
2891 if (FTH_CONS_P(lst))
2892 fth_array_fill(lst, val);
2893
2894 fth_push_ficl_cell(vm, lst);
2895 }
2896
2897 static void
ficl_list_index(ficlVm * vm)2898 ficl_list_index(ficlVm *vm)
2899 {
2900 #define h_list_index "( lst key -- idx|-1 ) find KEY\n\
2901 '( 'a 'b 'c ) 'b list-index => 1\n\
2902 '( 'a 'b 'c ) 'f list-index => -1\n\
2903 Return index of KEY in LST or -1 if not found.\n\
2904 See also list-member?."
2905 FTH lst, key;
2906 ficlInteger idx;
2907
2908 FTH_STACK_CHECK(vm, 2, 1);
2909 key = fth_pop_ficl_cell(vm);
2910 lst = fth_pop_ficl_cell(vm);
2911 idx = -1;
2912
2913 if (FTH_CONS_P(lst))
2914 idx = fth_array_index(lst, key);
2915
2916 ficlStackPushInteger(vm->dataStack, idx);
2917 }
2918
2919 /*
2920 * Return FTH_TRUE if KEY exists in LIST, otherwise FTH_FALSE.
2921 */
2922 FTH
fth_list_member_p(FTH list,FTH key)2923 fth_list_member_p(FTH list, FTH key)
2924 {
2925 #define h_list_member_p "( lst key -- f ) find KEY\n\
2926 '( 'a 'b 'c ) 'b list-member? => #t\n\
2927 '( 'a 'b 'c ) 'f list-member? => #f\n\
2928 Return #t if KEY exists in LST, otherwise #f.\n\
2929 See also list-index."
2930 if (FTH_CONS_P(list))
2931 return (BOOL_TO_FTH(fth_array_member_p(list, key)));
2932 return (FTH_FALSE);
2933 }
2934
2935 static void
ficl_list_head(ficlVm * vm)2936 ficl_list_head(ficlVm *vm)
2937 {
2938 #define h_list_head "( lst1 idx -- lst2 ) return part of list\n\
2939 '( 0 1 2 3 ) 2 list-head => '( 0 1 )\n\
2940 Return first IDX entries of LST1 in a new list or nil.\n\
2941 See also list-tail and list-pair."
2942 ficlInteger idx;
2943 FTH lst, ls;
2944
2945 FTH_STACK_CHECK(vm, 2, 1);
2946 idx = ficlStackPopInteger(vm->dataStack);
2947 lst = fth_pop_ficl_cell(vm);
2948 ls = FTH_NIL;
2949
2950 if (FTH_CONS_P(lst)) {
2951 ls = fth_array_subarray(lst, 0L, idx);
2952 FTH_LIST_SET(ls);
2953 }
2954 fth_push_ficl_cell(vm, ls);
2955 }
2956
2957 static void
ficl_list_tail(ficlVm * vm)2958 ficl_list_tail(ficlVm *vm)
2959 {
2960 #define h_list_tail "( lst1 idx -- lst2 ) return part of list\n\
2961 '( 0 1 2 3 ) 2 list-tail => '( 2 3 )\n\
2962 Return IDX'th cdr of LST1 up to the last entry in a new list or nil.\n\
2963 See also list-head and list-pair."
2964 ficlInteger idx, len;
2965 FTH lst, ls;
2966
2967 FTH_STACK_CHECK(vm, 2, 1);
2968 idx = ficlStackPopInteger(vm->dataStack);
2969 lst = fth_pop_ficl_cell(vm);
2970 ls = FTH_NIL;
2971
2972 if (FTH_CONS_P(lst)) {
2973 len = FTH_ARRAY_LENGTH(lst);
2974
2975 if (idx >= 0 && len >= idx) {
2976 ficlInteger i , j;
2977
2978 ls = fth_make_list_len(len - idx);
2979
2980 for (i = idx, j = 0; i < len; i++, j++)
2981 FTH_ARRAY_DATA(ls)[j] = FTH_ARRAY_DATA(lst)[i];
2982 } else
2983 ls = lst;
2984 }
2985 fth_push_ficl_cell(vm, ls);
2986 }
2987
2988 static void
ficl_last_pair(ficlVm * vm)2989 ficl_last_pair(ficlVm *vm)
2990 {
2991 #define h_last_pair "( list -- last-pair ) return part of list\n\
2992 '( 0 1 2 3 ) last-pair => '( 3 )\n\
2993 '( 0 ) 1 2 nil acons 2 list-append value ls\n\
2994 ls => '( 0 '( 1 . 2 ) )\n\
2995 ls last-pair => '( '( 1 . 2 ) )\n\
2996 Return last pair in LIST.\n\
2997 See also list-head and list-tail."
2998 FTH lst, ls;
2999
3000 FTH_STACK_CHECK(vm, 1, 1);
3001 lst = fth_pop_ficl_cell(vm);
3002 ls = FTH_NIL;
3003
3004 if (FTH_CONS_P(lst) && FTH_ARRAY_LENGTH(lst) > 0)
3005 ls = fth_make_list_var(1, fth_array_ref(lst, -1L));
3006
3007 fth_push_ficl_cell(vm, ls);
3008 }
3009
3010 /*
3011 * ALIST: sorted associative lists as an alternative to hashs.
3012 */
3013
3014 static void
ficl_values_to_alist(ficlVm * vm)3015 ficl_values_to_alist(ficlVm *vm)
3016 {
3017 #define h_values_to_alist "( vals len -- ary ) return assoc list\n\
3018 'foo 0 'bar 1 4 >alist => 'a( '( 'foo . 0 ) '( 'bar . 1 ) )\n\
3019 Return assoc list object with LEN/2 key-value pairs \
3020 found on parameter stack. \
3021 Raise OUT-OF-RANGE exception if LEN < 0 or not even."
3022 ficlInteger i, len;
3023 FTH alist, key, val;
3024
3025 FTH_STACK_CHECK(vm, 1, 0);
3026 len = ficlStackPopInteger(vm->dataStack);
3027
3028 if (len < 0)
3029 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARGn, len, "negative");
3030
3031 if (len % 2)
3032 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARGn, len, "odd");
3033
3034 if (len > MAX_SEQ_LENGTH)
3035 FTH_OUT_OF_BOUNDS_ERROR(FTH_ARGn, len, "too long");
3036
3037 FTH_STACK_CHECK(vm, len, 1);
3038 alist = fth_make_empty_list();
3039 len /= 2;
3040
3041 for (i = 0; i < len; i++) {
3042 val = fth_pop_ficl_cell(vm);
3043 key = fth_pop_ficl_cell(vm);
3044 assoc_insert(alist, fth_hash_id(key), fth_make_acell(key, val));
3045 }
3046
3047 ficlStackPushFTH(vm->dataStack, alist);
3048 }
3049
3050 FTH
fth_acons(FTH key,FTH value,FTH alist)3051 fth_acons(FTH key, FTH value, FTH alist)
3052 {
3053 #define h_list_acons "( key val alist -- alist' ) return assoc list\n\
3054 '() value ass\n\
3055 'a 10 ass acons to ass\n\
3056 ass => 'a( '( 'a . 10 ) )\n\
3057 'b 20 ass acons to ass\n\
3058 ass => 'a( '( 'a . 10 ) '( 'b . 20 ) )\n\
3059 Return new Lisp-like associated list from key-value pair and ALIST.\n\
3060 See also list-assoc, list-assoc-ref, list-assoc-set!, list-assoc-remove!."
3061 FTH ls, val;
3062
3063 val = fth_make_acell(key, value);
3064
3065 if (FTH_NIL_P(alist))
3066 ls = fth_make_list_var(1, val);
3067 else if (FTH_CONS_P(alist))
3068 ls = fth_array_unshift(alist, val);
3069 else
3070 ls = fth_make_list_var(2, val, alist);
3071
3072 FTH_ASSOC_SET(ls);
3073 return (ls);
3074 }
3075
3076 /*
3077 * If KEY matches, return corresponding key-value pair, otherwise
3078 * FTH_FALSE.
3079 */
3080 FTH
fth_list_assoc(FTH alist,FTH key)3081 fth_list_assoc(FTH alist, FTH key)
3082 {
3083 #define h_list_ass "( alist key -- key-val|#f ) find KEY\n\
3084 'a '( 0 1 ) nil acons value ass\n\
3085 ass => 'a( '( 'a . '( 0 1 ) ) )\n\
3086 ass 'a list-assoc => '( 'a . '( 0 1 ) )\n\
3087 ass 0 list-assoc => #f\n\
3088 ass 1 list-assoc => #f\n\
3089 If KEY matches, return corresponding key-value pair, otherwise #f."
3090 if (FTH_CONS_P(alist))
3091 return (fth_array_assoc(alist, key));
3092 return (FTH_FALSE);
3093 }
3094
3095 /*
3096 * If KEY matches, return corresponding value, otherwise FTH_FALSE.
3097 */
3098 FTH
fth_list_assoc_ref(FTH alist,FTH key)3099 fth_list_assoc_ref(FTH alist, FTH key)
3100 {
3101 #define h_list_ass_ref "( alist key -- val|#f ) find KEY\n\
3102 'a '( 0 1 ) nil acons value ass\n\
3103 ass => 'a( '( 'a . '( 0 1 ) ) )\n\
3104 ass 'a list-assoc-ref => '( 0 1 )\n\
3105 ass 0 list-assoc-ref => #f\n\
3106 ass 1 list-assoc-ref => #f\n\
3107 If KEY matches, return corresponding value, otherwise #f."
3108 if (FTH_CONS_P(alist))
3109 return (fth_array_assoc_ref(alist, key));
3110 return (FTH_FALSE);
3111 }
3112
3113 /*
3114 * If KEY matches, set key-value pair, otherwise add new pair to ALIST.
3115 * Return current assoc-list.
3116 */
3117 FTH
fth_list_assoc_set(FTH alist,FTH key,FTH value)3118 fth_list_assoc_set(FTH alist, FTH key, FTH value)
3119 {
3120 #define h_list_ass_set "( alist key val -- alist' ) set KEY to VAL\n\
3121 'a '( 0 1 ) nil acons value ass\n\
3122 ass => 'a( '( 'a . '( 0 1 ) ) )\n\
3123 ass 'a 10 list-assoc-set! => 'a( '( 'a . 10 ) )\n\
3124 ass 0 10 list-assoc-set! => 'a( '( 0 . 10 ) '( 'a . 10 ) )\n\
3125 ass 1 10 list-assoc-set! => 'a( '( 0 . 10 ) '( 1 . 10 ) '( 'a . 10 ) )\n\
3126 ass => 'a( '( 0 . 10 ) '( 1 . 10 ) '( 'a . 10 ) )\n\
3127 If KEY matches, set key-value pair, otherwise add new pair to ALIST."
3128 ficlInteger idx;
3129 FTH val;
3130
3131 val = fth_make_acell(key, value);
3132
3133 if (FTH_CONS_P(alist)) {
3134 idx = assoc_index(alist, key);
3135
3136 if (idx >= 0)
3137 fth_array_set(alist, idx, val);
3138 else
3139 assoc_insert(alist, fth_hash_id(key), val);
3140 } else {
3141 alist = fth_make_list_var(1, val);
3142 FTH_ASSOC_SET(alist);
3143 }
3144 return (alist);
3145 }
3146
3147 /*
3148 * If KEY matches, remove key-value pair from ALIST. Return current
3149 * assoc-list.
3150 */
3151 FTH
fth_list_assoc_remove(FTH alist,FTH key)3152 fth_list_assoc_remove(FTH alist, FTH key)
3153 {
3154 #define h_list_ass_rem "( alist key -- alist' ) remove element\n\
3155 'a '( 0 1 ) 'd 10 nil acons acons value ass\n\
3156 ass => 'a( '( 'a . '( 0 1 ) ) '( 'd . 10 ) )\n\
3157 ass 'a list-assoc-remove! => 'a( '( 'd . 10 ) )\n\
3158 ass 0 list-assoc-remove! => 'a( '( 'd . 10 ) )\n\
3159 ass 1 list-assoc-remove! => 'a( '( 'd . 10 ) )\n\
3160 If KEY matches, remove key-value pair from ALIST. \
3161 Return current ALIST."
3162 if (FTH_CONS_P(alist))
3163 return (fth_array_assoc_remove(alist, key));
3164 return (alist);
3165 }
3166
3167 void
init_array_type(void)3168 init_array_type(void)
3169 {
3170 /* array */
3171 array_tag = make_object_type(FTH_STR_ARRAY, FTH_ARRAY_T);
3172 fth_set_object_inspect(array_tag, ary_inspect);
3173 fth_set_object_to_string(array_tag, ary_to_string);
3174 fth_set_object_dump(array_tag, ary_dump);
3175 fth_set_object_to_array(array_tag, ary_to_array);
3176 fth_set_object_copy(array_tag, ary_copy);
3177 fth_set_object_value_ref(array_tag, ary_ref);
3178 fth_set_object_value_set(array_tag, ary_set);
3179 fth_set_object_equal_p(array_tag, ary_equal_p);
3180 fth_set_object_length(array_tag, ary_length);
3181 fth_set_object_mark(array_tag, ary_mark);
3182 fth_set_object_free(array_tag, ary_free);
3183 /* list */
3184 list_tag = make_object_type_from(FTH_STR_LIST,
3185 FTH_ARRAY_T, array_tag);
3186 /* acell */
3187 acell_tag = make_object_type_from(FTH_STR_ACELL,
3188 FTH_ARRAY_T, array_tag);
3189 fth_set_object_inspect(acell_tag, acl_inspect);
3190 fth_set_object_to_string(acell_tag, acl_to_string);
3191 fth_set_object_dump(acell_tag, acl_dump);
3192 }
3193
3194 void
init_array(void)3195 init_array(void)
3196 {
3197 fth_set_object_apply(array_tag, (void *) ary_ref, 1, 0, 0);
3198
3199 /* struct members */
3200 init_ary_length();
3201 init_ary_buf_length();
3202 init_ary_top();
3203
3204 /* array */
3205 FTH_PRI1("array-length", ficl_array_length, h_array_length);
3206 FTH_PRI1("array?", ficl_array_p, h_array_p);
3207 FTH_PRI1("make-array", ficl_make_array, h_make_array);
3208 FTH_PRI1("array-concat", ficl_values_to_array, h_values_to_array);
3209 FTH_PRI1(">array", ficl_values_to_array, h_values_to_array);
3210 FTH_PRI1("#()", ficl_make_empty_array, h_empty_array);
3211 FTH_PRI1(".array", ficl_print_array, h_print_array);
3212 FTH_PRI1("array=", ficl_array_equal_p, h_array_equal_p);
3213 FTH_PROC("array->array", fth_array_to_array, 1, 0, 0, h_array_to_array);
3214 FTH_PROC("array->list", fth_array_to_list, 1, 0, 0, h_array_to_list);
3215 FTH_PRI1("array-copy", ficl_array_copy, h_array_copy);
3216 FTH_PRI1("array-ref", ficl_array_ref, h_array_ref);
3217 FTH_PRI1("array-set!", ficl_array_set, h_array_set);
3218 FTH_PROC("array-push", fth_array_push, 2, 0, 0, h_array_push);
3219 FTH_PROC("array-pop", fth_array_pop, 1, 0, 0, h_array_pop);
3220 FTH_PROC("array-unshift", fth_array_unshift, 2, 0, 0, h_array_unshift);
3221 FTH_PROC("array-shift", fth_array_shift, 1, 0, 0, h_array_shift);
3222 FTH_PROC("array-append", fth_array_append, 2, 0, 0, h_array_append);
3223 FTH_PRI1("array-reverse", ficl_array_reverse, h_array_reverse);
3224 FTH_PROC("array-reverse!", fth_array_reverse, 1, 0, 0, h_ary_rev_bang);
3225 FTH_PRI1("array-insert", ficl_array_insert, h_array_insert);
3226 FTH_PRI1("array-insert!", ficl_array_insert_bang, h_array_insert_bang);
3227 FTH_PRI1("array-delete!", ficl_array_delete, h_array_delete);
3228 FTH_PROC("array-delete-key", fth_array_delete_key, 2, 0, 0, h_adk);
3229 FTH_PRI1("array-reject", ficl_array_reject, h_array_reject);
3230 FTH_PROC("array-reject!", fth_array_reject, 3, 0, 0, h_ary_reject_bang);
3231 FTH_PRI1("array-compact", ficl_array_compact, h_array_compact);
3232 FTH_PROC("array-compact!", fth_array_compact, 1, 0, 0, h_ary_comp_bang);
3233 FTH_PROC("array-fill", fth_array_fill, 2, 0, 0, h_array_fill);
3234 FTH_PRI1("array-index", ficl_array_index, h_array_index);
3235 FTH_PRI1("array-member?", ficl_array_member_p, h_array_member_p);
3236 FTH_PROC("array-find", fth_array_find, 2, 0, 0, h_array_find);
3237 FTH_PRI1("array-uniq", ficl_array_uniq, h_array_uniq);
3238 FTH_PROC("array-uniq!", fth_array_uniq, 1, 0, 0, h_array_uniq_bang);
3239 FTH_PRI1("array-sort", ficl_array_sort, h_array_sort);
3240 FTH_PROC("array-sort!", fth_array_sort, 2, 0, 0, h_array_sort_bang);
3241 FTH_PROC("array-join", fth_array_join, 2, 0, 0, h_array_join);
3242 FTH_PRI1("array-subarray", ficl_array_subarray, h_array_subarray);
3243 FTH_VOID_PROC("array-clear", fth_array_clear, 1, 0, 0, h_array_clear);
3244
3245 /* assoc */
3246 FTH_PRI1("assoc?", ficl_assoc_p, h_assoc_p);
3247 FTH_PRI1(">assoc", ficl_values_to_assoc, h_values_to_assoc);
3248 FTH_PROC("assoc", fth_assoc, 3, 0, 0, h_assoc);
3249 FTH_PROC("array-assoc", fth_array_assoc, 2, 0, 0, h_array_ass);
3250 FTH_PROC("array-assoc-ref", fth_array_assoc_ref, 2, 0, 0, h_aryass_ref);
3251 FTH_PROC("array-assoc-set!", fth_array_assoc_set, 3, 0, 0,
3252 h_array_ass_set);
3253 FTH_PROC("array-assoc-remove!", fth_array_assoc_remove, 2, 0, 0, h_aar);
3254 FTH_ADD_FEATURE_AND_INFO(FTH_STR_ARRAY, h_list_of_array_functions);
3255
3256 /* list */
3257 FTH_PRI1("list-length", ficl_list_length, h_list_length);
3258 FTH_PRI1("nil?", ficl_nil_p, h_nil_p);
3259 FTH_PRI1("null?", ficl_nil_p, h_nil_p);
3260 FTH_PRI1("list?", ficl_list_p, h_list_p);
3261 FTH_PRI1("cons?", ficl_cons_p, h_cons_p);
3262 FTH_PRI1("pair?", ficl_pair_p, h_pair_p);
3263 FTH_PRI1("make-list", ficl_make_list, h_make_list);
3264 FTH_PRI1(">list", ficl_values_to_list, h_values_to_list);
3265 fth_define_constant("'()", FTH_NIL, "( -- empty-lst )");
3266 FTH_PROC("cons", fth_cons, 2, 0, 0, h_list_cons);
3267 FTH_PROC("cons2", fth_cons_2, 3, 0, 0, h_list_cons_2);
3268 FTH_PROC("car", fth_car, 1, 0, 0, h_list_car);
3269 FTH_PROC("cadr", fth_cadr, 1, 0, 0, h_list_cdr);
3270 FTH_PROC("caddr", fth_caddr, 1, 0, 0, h_list_cadr);
3271 FTH_PROC("cadddr", fth_cadddr, 1, 0, 0, h_list_caddr);
3272 FTH_PROC("cdr", fth_cdr, 1, 0, 0, h_list_cdr);
3273 FTH_PROC("cddr", fth_cddr, 1, 0, 0, h_list_cddr);
3274 FTH_PRI1(".list", ficl_print_list, h_print_list);
3275 FTH_PRI1("list=", ficl_list_equal_p, h_list_equal_p);
3276 FTH_PRI1("set-car!", ficl_set_car, h_list_set_car);
3277 FTH_PRI1("set-cdr!", ficl_set_cdr, h_list_set_cdr);
3278 FTH_PROC("list->array", fth_list_to_array, 1, 0, 0, h_list_to_array);
3279 FTH_PROC("list-copy", fth_list_copy, 1, 0, 0, h_list_copy);
3280 FTH_PRI1("list-ref", ficl_list_ref, h_list_ref);
3281 FTH_PRI1("list-set!", ficl_list_set, h_list_set);
3282 FTH_PRI1("list-append", ficl_list_append, h_list_append);
3283 FTH_PROC("list-reverse", fth_list_reverse, 1, 0, 0, h_list_reverse);
3284 FTH_PROC("list-member?", fth_list_member_p, 2, 0, 0, h_list_member_p);
3285 FTH_PRI1("list-insert", ficl_list_insert, h_list_insert);
3286 FTH_PRI1("list-delete", ficl_list_delete, h_list_delete);
3287 FTH_PRI1("list-delete!", ficl_list_delete_bang, h_list_delete_bang);
3288 FTH_PRI1("list-slice", ficl_list_slice, h_list_slice);
3289 FTH_PRI1("list-slice!", ficl_list_slice_bang, h_list_slice_bang);
3290 FTH_PRI1("list-fill", ficl_list_fill, h_list_fill);
3291 FTH_PRI1("list-index", ficl_list_index, h_list_index);
3292 FTH_PRI1("list-head", ficl_list_head, h_list_head);
3293 FTH_PRI1("list-tail", ficl_list_tail, h_list_tail);
3294 FTH_PRI1("last-pair", ficl_last_pair, h_last_pair);
3295
3296 /* alist */
3297 FTH_PRI1(">alist", ficl_values_to_alist, h_values_to_alist);
3298 FTH_PROC("acons", fth_acons, 3, 0, 0, h_list_acons);
3299 FTH_PROC("list-assoc", fth_list_assoc, 2, 0, 0, h_list_ass);
3300 FTH_PROC("list-assoc-ref", fth_list_assoc_ref, 2, 0, 0,
3301 h_list_ass_ref);
3302 FTH_PROC("list-assoc-set!", fth_list_assoc_set, 3, 0, 0,
3303 h_list_ass_set);
3304 FTH_PROC("list-assoc-remove!", fth_list_assoc_remove, 2, 0, 0,
3305 h_list_ass_rem);
3306 FTH_ADD_FEATURE_AND_INFO(FTH_STR_LIST, h_list_of_list_functions);
3307 }
3308
3309 /*
3310 * array.c ends here
3311 */
3312