1 /* pair.c -*- mode:c; coding:utf-8; -*-
2 *
3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com>
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 *
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 *
12 * 2. Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditions and the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 *
16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 *
28 * $Id: $
29 */
30 #define LIBSAGITTARIUS_BODY
31 #include "sagittarius/private/pair.h"
32 #include "sagittarius/private/collection.h"
33 #include "sagittarius/private/compare.h"
34 #include "sagittarius/private/error.h"
35 #include "sagittarius/private/subr.h"
36 #include "sagittarius/private/string.h"
37 #include "sagittarius/private/symbol.h"
38 #include "sagittarius/private/library.h"
39 #include "sagittarius/private/vm.h"
40
41 static SgClass *list_cpl[] = {
42 SG_CLASS_LIST,
43 SG_CLASS_SEQUENCE,
44 SG_CLASS_COLLECTION,
45 SG_CLASS_TOP,
46 NULL
47 };
48 SG_DEFINE_BUILTIN_CLASS(Sg_ListClass, NULL, NULL, NULL, NULL, list_cpl+1);
49 SG_DEFINE_BUILTIN_CLASS(Sg_PairClass, NULL, NULL, NULL, NULL, list_cpl);
50 SG_DEFINE_BUILTIN_CLASS(Sg_NullClass, NULL, NULL, NULL, NULL, list_cpl);
51
make_pair()52 static inline SgPair* make_pair()
53 {
54 SgPair *z = SG_NEW(SgPair);
55 z->info = SG_NIL;
56 return z;
57 }
58
Sg_Cons(SgObject car,SgObject cdr)59 SgObject Sg_Cons(SgObject car, SgObject cdr)
60 {
61 SgPair *z = make_pair();
62 SG_SET_CAR(z, car);
63 SG_SET_CDR(z, cdr);
64 return SG_OBJ(z);
65 }
66
67 /* Public API */
Sg_IsPair(SgObject obj)68 int Sg_IsPair(SgObject obj)
69 {
70 return SG_PAIRP(obj);
71 }
72
Sg_Acons(SgObject caar,SgObject cdar,SgObject cdr)73 SgObject Sg_Acons(SgObject caar, SgObject cdar, SgObject cdr)
74 {
75 SgPair *y = make_pair();
76 SgPair *z = make_pair();
77 SG_SET_CAR(y, caar);
78 SG_SET_CDR(y, cdar);
79 SG_SET_CAR(z, SG_OBJ(y));
80 SG_SET_CDR(z, cdr);
81 return SG_OBJ(z);
82 }
83
Sg_List(SgObject elt,...)84 SgObject Sg_List(SgObject elt, ...)
85 {
86 va_list pvar;
87 SgObject cdr;
88
89 if (elt == NULL) return SG_NIL;
90
91 va_start(pvar, elt);
92 cdr = Sg_VaList(pvar);
93 va_end(pvar);
94 return Sg_Cons(elt, cdr);
95 }
96
Sg_VaList(va_list elts)97 SgObject Sg_VaList(va_list elts)
98 {
99 SgObject start = SG_NIL, cp = SG_NIL, obj;
100
101 for (obj = va_arg(elts, SgObject);
102 obj != NULL;
103 obj = va_arg(elts, SgObject)) {
104 if (SG_NULLP(start)) {
105 start = SG_OBJ(make_pair());
106 SG_SET_CAR(start, obj);
107 SG_SET_CDR(start, SG_NIL);
108 cp = start;
109 } else {
110 SgObject item;
111 item = SG_OBJ(make_pair());
112 SG_SET_CDR(cp, item);
113 SG_SET_CAR(item, obj);
114 SG_SET_CDR(item, SG_NIL);
115 cp = item;
116 }
117 }
118 return start;
119 }
120
array_to_list_with_tail(SgObject * array,int nelts,SgObject tail)121 static inline SgObject array_to_list_with_tail(SgObject *array,
122 int nelts, SgObject tail)
123 {
124 SgObject h = SG_NIL, t = SG_NIL;
125 if (array) {
126 int i;
127 for (i = 0; i < nelts; i++) SG_APPEND1(h, t, *array++);
128 }
129 if (!SG_NULLP(tail)) SG_APPEND(h, t, tail);
130 return h;
131 }
132
Sg_ArrayToList(SgObject * array,int nelts)133 SgObject Sg_ArrayToList(SgObject *array, int nelts)
134 {
135 return array_to_list_with_tail(array, nelts, SG_NIL);
136 }
137
Sg_ArrayToListWithTail(SgObject * array,int nelts,SgObject tail)138 SgObject Sg_ArrayToListWithTail(SgObject *array, int nelts, SgObject tail)
139 {
140 return array_to_list_with_tail(array, nelts, tail);
141 }
142
list_to_array_rec(SgObject list,int nullTermP,long * rlen)143 static SgObject* list_to_array_rec(SgObject list, int nullTermP, long *rlen)
144 {
145 SgObject *array, lp;
146 long len = Sg_Length(list), i, offset = 0;;
147 if (len < 0) Sg_Error(UC("proper list required, but got %S"), list);
148 if (nullTermP) offset++;
149 array = SG_NEW_ARRAY(SgObject, len+offset);
150 for (i = 0, lp = list; i<len; i++, lp = SG_CDR(lp)) {
151 array[i] = SG_CAR(lp);
152 }
153 /* just in case */
154 if (nullTermP) array[len] = NULL;
155 if (rlen) *rlen= len;
156 return array;
157 }
158
Sg_ListToArray(SgObject list,int nullTermP)159 SgObject* Sg_ListToArray(SgObject list, int nullTermP)
160 {
161 return list_to_array_rec(list, nullTermP, NULL);
162 }
163
164 #define CXR(cname, sname, body) \
165 SgObject cname (SgObject obj) \
166 { \
167 static SgObject PROC_NAME = SG_FALSE; \
168 SgObject obj2 = obj; \
169 if (SG_FALSEP(PROC_NAME)) { \
170 PROC_NAME = SG_INTERN(sname); \
171 } \
172 body \
173 return obj2; \
174 }
175
176 #define A \
177 if (!SG_PAIRP(obj2)) { \
178 Sg_WrongTypeOfArgumentViolation(PROC_NAME, \
179 SG_INTERN("pair"), \
180 obj2, obj); \
181 } \
182 obj2 = SG_CAR(obj2);
183
184 #define D \
185 if (!SG_PAIRP(obj2)) { \
186 Sg_WrongTypeOfArgumentViolation(PROC_NAME, \
187 SG_INTERN("pair"), \
188 obj2, obj); \
189 } \
190 obj2 = SG_CDR(obj2);
191
192 CXR(Sg_Car, "car", A)
193 CXR(Sg_Cdr, "cdr", D)
194 CXR(Sg_Caar, "caar", A A)
195 CXR(Sg_Cadr, "cadr", D A)
196 CXR(Sg_Cdar, "cdar", A D)
197 CXR(Sg_Cddr, "cddr", D D)
198 /* Maybe add cadr etc.*/
199
Sg_Length(SgObject obj)200 long Sg_Length(SgObject obj)
201 {
202 SgObject slow = obj;
203 long len = 0;
204 for (;;) {
205 if (SG_NULLP(obj)) break;
206 if (!SG_PAIRP(obj)) return SG_LIST_DOTTED;
207
208 obj = SG_CDR(obj);
209 len++;
210 if (SG_NULLP(obj)) break;
211 if (!SG_PAIRP(obj)) return SG_LIST_DOTTED;
212
213 obj = SG_CDR(obj);
214 slow = SG_CDR(slow);
215 if (obj == slow) return SG_LIST_CIRCULAR;
216 len++;
217 }
218 return len;
219 }
220
Sg_CopyList(SgObject list)221 SgObject Sg_CopyList(SgObject list)
222 {
223 SgObject start = SG_NIL, last = SG_NIL;
224 if (!SG_PAIRP(list)) return list;
225
226 SG_FOR_EACH(list, list) {
227 SG_APPEND1(start, last, SG_CAR(list));
228 }
229 if (!SG_NULLP(list)) SG_SET_CDR(last, list);
230 return start;
231 }
232
Sg_Append2X(SgObject list,SgObject obj)233 SgObject Sg_Append2X(SgObject list, SgObject obj)
234 {
235 SgObject cp;
236 SG_FOR_EACH(cp, list) {
237 if (SG_NULLP(SG_CDR(cp))) {
238 SG_SET_CDR(cp, obj);
239 return list;
240 }
241 }
242 return obj;
243 }
244
Sg_Append2(SgObject list,SgObject obj)245 SgObject Sg_Append2(SgObject list, SgObject obj)
246 {
247 SgObject start = SG_NIL, last = SG_NIL;
248 if (!SG_PAIRP(list)) return obj;
249
250 SG_FOR_EACH(list, list) {
251 SG_APPEND1(start, last, SG_CAR(list));
252 }
253 SG_SET_CDR(last, obj);
254 return start;
255 }
256
Sg_Append(SgObject args)257 SgObject Sg_Append(SgObject args)
258 {
259 SgObject start = SG_NIL, last = SG_NIL, cp;
260 SG_FOR_EACH(cp, args) {
261 if (!SG_PAIRP(SG_CDR(cp))) {
262 if (SG_NULLP(start)) return SG_CAR(cp);
263 SG_SET_CDR(last, SG_CAR(cp));
264 break;
265 } else if (SG_NULLP(SG_CAR(cp))) {
266 continue;
267 } else if (!SG_PAIRP(SG_CAR(cp))) {
268 Sg_Error(UC("pair required, but got %S"), SG_CAR(cp));
269 } else {
270 SG_APPEND(start, last, Sg_CopyList(SG_CAR(cp)));
271 }
272 }
273 return start;
274 }
275
Sg_ReverseX(SgObject list)276 SgObject Sg_ReverseX(SgObject list)
277 {
278 SgObject first, next, result = SG_NIL;
279 if (!SG_PAIRP(list)) return list;
280 for (first = list; SG_PAIRP(first); first = next) {
281 next = SG_CDR(first);
282 SG_SET_CDR(first, result);
283 result = first;
284 }
285 return result;
286 }
287
Sg_Reverse(SgObject list)288 SgObject Sg_Reverse(SgObject list)
289 {
290 SgObject cp, result;
291 SgPair *p;
292
293 if (!SG_PAIRP(list)) return list;
294
295 p = make_pair();
296 SG_SET_CAR(p, SG_NIL);
297 SG_SET_CDR(p, SG_NIL);
298 result = SG_OBJ(p);
299 SG_FOR_EACH(cp, list) {
300 SG_SET_CAR(result, SG_CAR(cp));
301 p = make_pair();
302 SG_SET_CAR(p, SG_NIL);
303 SG_SET_CDR(p, result);
304 result = SG_OBJ(p);
305 }
306 return SG_CDR(result);
307 }
308
Sg_LastPair(SgObject list)309 SgObject Sg_LastPair(SgObject list)
310 {
311 SgObject cp;
312 if (!SG_PAIRP(list)) Sg_Error(UC("pair required, but got %S"), list);
313
314 SG_FOR_EACH(cp, list) {
315 SgObject cdr = SG_CDR(cp);
316 if (!SG_PAIRP(cdr)) return cp;
317 }
318 return SG_UNDEF; /* never reached */
319 }
320
Sg_ListTail(SgObject list,long i,SgObject fallback)321 SgObject Sg_ListTail(SgObject list, long i, SgObject fallback)
322 {
323 long count = i;
324 SgObject oargs = list;
325 if (i < 0) goto err;
326 while (count-- > 0) {
327 if (!SG_PAIRP(list)) goto err;
328 list = SG_CDR(list);
329 }
330 return list;
331 err:
332 if (SG_UNBOUNDP(fallback)) {
333 Sg_AssertionViolation(SG_INTERN("list-tail"),
334 SG_MAKE_STRING("argument out of range"),
335 SG_LIST2(oargs, SG_MAKE_INT(i)));
336 }
337 return fallback;
338 }
339
Sg_ListRef(SgObject list,long i,SgObject fallback)340 SgObject Sg_ListRef(SgObject list, long i, SgObject fallback)
341 {
342 long k;
343 SgObject oargs = list;
344 if (i < 0) goto err;
345 for (k = 0; k < i; k++) {
346 if (!SG_PAIRP(list)) goto err;
347 list = SG_CDR(list);
348 }
349 if (!SG_PAIRP(list)) goto err;
350 return SG_CAR(list);
351 err:
352 if (SG_UNBOUNDP(fallback)) {
353 Sg_AssertionViolation(SG_INTERN("list-ref"),
354 SG_MAKE_STRING("argument out of range"),
355 SG_LIST2(oargs, SG_MAKE_INT(i)));
356 }
357 return fallback;
358 }
359
Sg_Memq(SgObject obj,SgObject list)360 SgObject Sg_Memq(SgObject obj, SgObject list)
361 {
362 SG_FOR_EACH(list, list) {
363 if (SG_EQ(obj, SG_CAR(list))) return list;
364 }
365 return SG_FALSE;
366 }
367
Sg_Memv(SgObject obj,SgObject list)368 SgObject Sg_Memv(SgObject obj, SgObject list)
369 {
370 SG_FOR_EACH(list, list) {
371 if (Sg_EqvP(obj, SG_CAR(list))) return list;
372 }
373 return SG_FALSE;
374 }
375
assq_rec(SgObject obj,SgObject alist)376 static SgObject assq_rec(SgObject obj, SgObject alist)
377 {
378 SgObject cp;
379 SG_FOR_EACH(cp, alist) {
380 SgObject entry = SG_CAR(cp);
381 if (!SG_PAIRP(entry)) continue;
382 if (SG_EQ(obj, SG_CAR(entry))) return entry;
383 }
384 return SG_FALSE;
385 }
386
Sg_Assq(SgObject obj,SgObject alist)387 SgObject Sg_Assq(SgObject obj, SgObject alist)
388 {
389 if (!SG_LISTP(alist)) {
390 Sg_WrongTypeOfArgumentViolation(SG_INTERN("assq"),
391 SG_MAKE_STRING("list"),
392 alist, SG_NIL);
393 }
394 return assq_rec(obj, alist);
395 }
396
Sg_Assv(SgObject obj,SgObject alist)397 SgObject Sg_Assv(SgObject obj, SgObject alist)
398 {
399 SgObject cp;
400 if (!SG_LISTP(alist)) {
401 Sg_WrongTypeOfArgumentViolation(SG_INTERN("assv"),
402 SG_MAKE_STRING("list"),
403 alist, SG_NIL);
404 }
405 SG_FOR_EACH(cp, alist) {
406 SgObject entry = SG_CAR(cp);
407 if (!SG_PAIRP(entry)) continue;
408 if (Sg_EqvP(obj, SG_CAR(entry))) return entry;
409 }
410 return SG_FALSE;
411 }
412
Sg_GetPairAnnotation(SgObject pair,SgObject name)413 SgObject Sg_GetPairAnnotation(SgObject pair, SgObject name)
414 {
415 SgObject s;
416 if (!SG_PAIRP(pair)) {
417 Sg_WrongTypeOfArgumentViolation(SG_INTERN("pair-annotation"),
418 SG_MAKE_STRING("pair"),
419 pair, SG_NIL);
420 }
421 s = assq_rec(name, SG_PAIR(pair)->info);
422 if (SG_FALSEP(s)) return SG_FALSE;
423 return SG_CDR(s);
424 }
425
Sg_SetPairAnnotation(SgObject pair,SgObject name,SgObject v)426 SgObject Sg_SetPairAnnotation(SgObject pair, SgObject name, SgObject v)
427 {
428 SgObject s;
429 if (!SG_PAIRP(pair)) {
430 Sg_WrongTypeOfArgumentViolation(SG_INTERN("pair-annotation"),
431 SG_MAKE_STRING("pair"),
432 pair, SG_NIL);
433 }
434 s = assq_rec(name, SG_PAIR(pair)->info);
435 if (SG_FALSEP(s)) {
436 SG_PAIR(pair)->info = Sg_Acons(name, v, SG_PAIR(pair)->info);
437 } else {
438 SG_SET_CDR(s, v);
439 }
440 return pair;
441 }
442
443 /* from Ypsilon */
do_transpose(long shortest_len,SgObject args[])444 static SgObject do_transpose(long shortest_len, SgObject args[])
445 {
446 SgObject ans = SG_NIL, tail = SG_NIL;
447 long i, n, argc;
448 SgObject *rest = list_to_array_rec(args[1], FALSE, &argc);
449
450 for (i = 0; i < shortest_len; i++) {
451 SgObject elt = SG_NIL, elt_tail = SG_NIL;
452
453 SG_APPEND1(elt, elt_tail, SG_CAR(args[0]));
454 args[0] = SG_CDR(args[0]);
455 for (n = 0; n < argc; n++) {
456 SG_APPEND1(elt, elt_tail, SG_CAR(rest[n]));
457 rest[n] = SG_CDR(rest[n]);
458 }
459 SG_APPEND1(ans, tail, elt);
460 }
461 return ans;
462 }
463
improper_list_error(SgObject name,SgObject v,SgObject irr)464 static void improper_list_error(SgObject name, SgObject v, SgObject irr)
465 {
466 Sg_WrongTypeOfArgumentViolation(name, SG_MAKE_STRING("proper list"), v, irr);
467 }
468
list_transpose_s(SgObject * args,int argc,void * data)469 static SgObject list_transpose_s(SgObject *args, int argc, void *data)
470 {
471 SgObject v;
472 if (argc < 1) {
473 Sg_WrongNumberOfArgumentsAtLeastViolation(SG_INTERN("list-transpose*"),
474 1, argc, SG_NIL);
475 }
476 /* since 0.3.4, optional arguments are packed to list.
477 so argc is always 2.
478 */
479 v = args[0];
480 if (SG_LISTP(args[0])) {
481 long each_len = Sg_Length(args[0]);
482 SgObject cp;
483 if (each_len < 0 && each_len != SG_LIST_CIRCULAR) goto err;
484 SG_FOR_EACH(cp, args[1]) {
485 v = SG_CAR(cp);
486 if (SG_LISTP(v)) {
487 long len = Sg_Length(v);
488 if (len < 0 && len != SG_LIST_CIRCULAR) goto err;
489 if (len >= 0) {
490 if (len < each_len) each_len = len;
491 else if (each_len < 0) each_len = len;
492 }
493 continue;
494 }
495 goto err;
496 }
497 return do_transpose(each_len, args);
498 }
499 err:
500 improper_list_error(SG_INTERN("list-transpose*"), v,
501 Sg_ArrayToList(args, argc));
502 return SG_UNDEF;
503 }
504
505 static SG_DEFINE_SUBR(list_transpose_s_stub, 1, 1, list_transpose_s,
506 SG_FALSE, NULL);
507
list_transpose_p(SgObject * args,int argc,void * data)508 static SgObject list_transpose_p(SgObject *args, int argc, void *data)
509 {
510 SgObject v;
511 if (argc < 1) {
512 Sg_WrongNumberOfArgumentsAtLeastViolation(SG_INTERN("list-transpose+"),
513 1, argc, SG_NIL);
514 }
515 v = args[0];
516 if (SG_LISTP(args[0])) {
517 long each_len = Sg_Length(args[0]);
518 SgObject cp;
519 if (each_len < 0) goto err;
520 SG_FOR_EACH(cp, args[1]) {
521 v = SG_CAR(cp);
522 if (SG_LISTP(v)) {
523 long len = Sg_Length(v);
524 if (len < 0) goto err;
525 if (len != each_len) return SG_FALSE;
526 continue;
527 }
528 return SG_FALSE;
529 }
530 return do_transpose(each_len, args);
531 }
532 err:
533 improper_list_error(SG_INTERN("list-transpose+"), v,
534 Sg_ArrayToList(args, argc));
535 return SG_UNDEF;
536 }
537
538 static SG_DEFINE_SUBR(list_transpose_p_stub, 1, 1, list_transpose_p,
539 SG_FALSE, NULL);
540
Sg__InitPair()541 void Sg__InitPair()
542 {
543 SgLibrary *lib = Sg_FindLibrary(SG_INTERN("(sagittarius)"), FALSE);
544 SG_PROCEDURE_NAME(&list_transpose_s_stub) = SG_MAKE_STRING("list-transpose*");
545 SG_PROCEDURE_TRANSPARENT(&list_transpose_s_stub) = SG_PROC_TRANSPARENT;
546 Sg_InsertBinding(lib, SG_INTERN("list-transpose*"),
547 SG_OBJ(&list_transpose_s_stub));
548 SG_PROCEDURE_NAME(&list_transpose_p_stub) = SG_MAKE_STRING("list-transpose+");
549 SG_PROCEDURE_TRANSPARENT(&list_transpose_p_stub) = SG_PROC_TRANSPARENT;
550 Sg_InsertBinding(lib, SG_INTERN("list-transpose+"),
551 SG_OBJ(&list_transpose_p_stub));
552 }
553
554 /*
555 end of file
556 Local Variables:
557 coding: utf-8-unix
558 End:
559 */
560