1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 2013-2017, VU University Amsterdam
7 All rights reserved.
8
9 Redistribution and use in source and binary forms, with or without
10 modification, are permitted provided that the following conditions
11 are met:
12
13 1. Redistributions of source code must retain the above copyright
14 notice, this list of conditions and the following disclaimer.
15
16 2. Redistributions in binary form must reproduce the above copyright
17 notice, this list of conditions and the following disclaimer in
18 the documentation and/or other materials provided with the
19 distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
32 POSSIBILITY OF SUCH DAMAGE.
33 */
34
35 #include "pl-incl.h"
36 #include "pl-comp.h"
37 #include "pl-dict.h"
38 #include "pl-rsort.h"
39
40 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
41 Dicts are associative arrays, where keys are either atoms or small
42 integers. Dicts should be considered an abstract data type. They are
43 currently represented as compound terms using the functor `dict`/Arity.
44 The term has the following layout on the global stack:
45
46 ------------
47 | `dict`/A |
48 ------------
49 | tag |
50 ------------
51 | value1 |
52 ------------
53 | key1 |
54 ------------
55 | value2 |
56 ------------
57 | key2 |
58 ...
59
60 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
61
62 static int PL_get_dict_ex(term_t data, term_t tag, term_t dict, int flags);
63 #define DICT_GET_ALL 0xff
64 #define DICT_GET_PAIRS 0x01
65 #define DICT_GET_EQUALS 0x02
66 #define DICT_GET_COLON 0x04
67 #define DICT_GET_TERM 0x08
68
69 #define CACHED_DICT_FUNCTORS 128
70
71 static functor_t dict_functors[CACHED_DICT_FUNCTORS] = {0};
72
73 functor_t
dict_functor(int pairs)74 dict_functor(int pairs)
75 { if ( pairs < CACHED_DICT_FUNCTORS )
76 { if ( dict_functors[pairs] )
77 return dict_functors[pairs];
78
79 dict_functors[pairs] = lookupFunctorDef(ATOM_dict, pairs*2+1);
80 return dict_functors[pairs];
81 } else
82 { return lookupFunctorDef(ATOM_dict, pairs*2+1);
83 }
84 }
85
86 /*******************************
87 * LOW-LEVEL FUNCTIONS *
88 *******************************/
89
90 static int
get_dict_ex(term_t t,Word dp,int ex ARG_LD)91 get_dict_ex(term_t t, Word dp, int ex ARG_LD)
92 { Word p = valTermRef(t);
93
94 deRef(p);
95 if ( isTerm(*p) )
96 { Functor f = valueTerm(*p);
97 FunctorDef fd = valueFunctor(f->definition);
98
99 if ( fd->name == ATOM_dict &&
100 fd->arity%2 == 1 ) /* does *not* validate ordering */
101 { *dp = *p;
102 return TRUE;
103 }
104 }
105
106 if ( !ex )
107 return FALSE;
108
109 PL_type_error("dict", t);
110 return FALSE;
111 }
112
113
114 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
115 get_create_dict_ex(+t, -dict ARG_LD) extracts a dict from t or raises a
116 type error. The term reference dict contains a plain dict term handle
117 and is never a reference.
118 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
119
120 static int
get_create_dict_ex(term_t t,term_t dt ARG_LD)121 get_create_dict_ex(term_t t, term_t dt ARG_LD)
122 { Word p = valTermRef(t);
123
124 deRef(p);
125 if ( isTerm(*p) )
126 { Functor f = valueTerm(*p);
127 FunctorDef fd = valueFunctor(f->definition);
128
129 if ( fd->name == ATOM_dict &&
130 fd->arity%2 == 1 ) /* does *not* validate ordering */
131 { *valTermRef(dt) = *p;
132 return TRUE;
133 }
134 }
135
136 if ( PL_get_dict_ex(t, 0, dt, DICT_GET_ALL) )
137 { assert(isTerm(*valTermRef(dt)));
138 return TRUE;
139 }
140
141 return PL_type_error("dict", t);
142 }
143
144
145 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
146 dict_lookup_ptr() returns a pointer to the value for a given key
147 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
148
149 Word
dict_lookup_ptr(word dict,word name ARG_LD)150 dict_lookup_ptr(word dict, word name ARG_LD)
151 { Functor data = valueTerm(dict);
152 int arity = arityFunctor(data->definition);
153 int l = 1, h = arity/2;
154
155 if ( arity == 1 )
156 return NULL; /* empty */
157 assert(arity%2 == 1);
158
159 for(;;)
160 { int m = (l+h)/2;
161 Word p;
162
163 deRef2(&data->arguments[m*2], p);
164
165 if ( *p == name )
166 return p-1;
167
168 if ( l == h )
169 return NULL;
170
171 if ( *p < name )
172 l=m+1;
173 else if ( m == l )
174 h=m;
175 else
176 h=m-1;
177 }
178 }
179
180
181 /* True if the keys are proper keys and ordered. Return values:
182
183 TRUE: correctly ordered dict
184 FALSE: not ordered
185 -1: not a key
186 -2: duplicate key
187 */
188
189 static int
dict_ordered(Word data,int count,int ex ARG_LD)190 dict_ordered(Word data, int count, int ex ARG_LD)
191 { int ordered = TRUE;
192 Word n1, n2;
193
194 if ( count > 0 )
195 { data++; /* skip to key */
196 deRef2(data, n1);
197 if ( !is_dict_key(*n1) )
198 return -1;
199
200 for(; count > 1; count--, data += 2, n1=n2)
201 { deRef2(data+2, n2);
202 if ( !is_dict_key(*n2) )
203 return -1;
204 if ( *n1 < *n2 )
205 continue;
206 if ( *n1 > *n2 )
207 ordered = FALSE;
208 if ( *n1 == *n2 )
209 { if ( ex )
210 { term_t t = PL_new_term_ref();
211 *valTermRef(t) = linkVal(n1);
212 PL_error(NULL, 0, NULL, ERR_DUPLICATE_KEY, t);
213 }
214 return -2;
215 }
216 }
217 }
218
219 return ordered;
220 }
221
222
223 #if defined(O_PLMT) || defined(O_MULTIPLE_ENGINES)
224 #define GET_LDARG(x) PL_local_data_t *__PL_ld = (x)
225 #else
226 #define GET_LDARG(x)
227 #endif
228
229 static int
compare_dict_entry(const void * a,const void * b,void * arg)230 compare_dict_entry(const void *a, const void *b, void *arg)
231 { GET_LDARG(arg);
232 Word p = (Word)a+1;
233 Word q = (Word)b+1;
234
235 deRef(p);
236 deRef(q);
237 return (*p<*q ? -1 : *p>*q ? 1 : 0);
238 }
239
240
241 int
dict_order(Word dict,int ex ARG_LD)242 dict_order(Word dict, int ex ARG_LD)
243 { Functor data = (Functor)dict;
244 int arity = arityFunctor(data->definition);
245
246 assert(arity%2 == 1);
247
248 sort_r(data->arguments+1, arity/2, sizeof(word)*2,
249 compare_dict_entry, LD);
250
251 return dict_ordered(data->arguments+1, arity/2, ex PASS_LD) == TRUE;
252 }
253
254
255 /* dict_order_term_refs() orders an array of indexes into a key/value array
256 of term references. Returns 0 if there are no duplicates and else the
257 index of the first duplicate.
258 */
259
260 typedef struct order_term_refs
261 { PL_local_data_t *ld;
262 term_t *av;
263 } order_term_refs;
264
265
266 static int
compare_term_refs(const void * a,const void * b,void * arg)267 compare_term_refs(const void *a, const void *b, void *arg)
268 { const int *ip1 = a;
269 const int *ip2 = b;
270 order_term_refs *ctx = arg;
271 GET_LDARG(ctx->ld);
272 Word p = valTermRef(ctx->av[*ip1*2]);
273 Word q = valTermRef(ctx->av[*ip2*2]);
274
275 assert(!isRef(*p));
276 assert(!isRef(*q));
277
278 return (*p<*q ? -1 : *p>*q ? 1 : 0);
279 }
280
281
282 int
dict_order_term_refs(term_t * av,int * indexes,int count ARG_LD)283 dict_order_term_refs(term_t *av, int *indexes, int count ARG_LD)
284 { order_term_refs ctx;
285
286 ctx.ld = LD;
287 ctx.av = av;
288
289 sort_r(indexes, count, sizeof(int), compare_term_refs, &ctx);
290 if ( count > 1 )
291 { word k = *valTermRef(av[indexes[0]*2]);
292 int i;
293
294 for(i=1; i<count; i++)
295 { word k2 = *valTermRef(av[indexes[i]*2]);
296
297 if ( k == k2 )
298 return i;
299 k = k2;
300 }
301 }
302
303 return 0;
304 }
305
306
307 static int
assign_in_dict(Word dp,Word val ARG_LD)308 assign_in_dict(Word dp, Word val ARG_LD)
309 { deRef(val);
310
311 if ( !canBind(*val) )
312 { *dp = *val;
313 } else if ( isAttVar(*val) )
314 { *dp = makeRef(val);
315 } else
316 { if ( dp < val )
317 { if ( unlikely(tTop+1 >= tMax) )
318 return TRAIL_OVERFLOW;
319 setVar(*dp);
320 Trail(val, makeRef(dp));
321 } else
322 { *dp = makeRef(val);
323 }
324 }
325
326 return TRUE;
327 }
328
329
330 int
put_dict(word dict,int size,Word nv,word * new_dict ARG_LD)331 put_dict(word dict, int size, Word nv, word *new_dict ARG_LD)
332 { Functor data = valueTerm(dict);
333 int arity = arityFunctor(data->definition);
334 Word new, out, in, in_end, nv_end;
335 int modified = FALSE;
336
337 assert(arity%2 == 1);
338
339 if ( size == 0 )
340 { *new_dict = dict;
341 return TRUE;
342 }
343
344 if ( gTop+1+arity+2*size > gMax )
345 return GLOBAL_OVERFLOW;
346
347 new = gTop;
348 out = new+2; /* functor, tag */
349 in = data->arguments+1;
350 in_end = in+arity-1;
351 nv_end = nv+size*2;
352
353 while(in < in_end && nv < nv_end)
354 { Word i_name, n_name;
355 int rc;
356
357 deRef2(in+1, i_name);
358 deRef2(nv+1, n_name);
359
360 if ( *i_name == *n_name )
361 { if ( (rc=assign_in_dict(out++, nv PASS_LD)) != TRUE )
362 return rc;
363 *out++ = *i_name;
364 if ( !modified && compareStandard(nv, in, TRUE PASS_LD) )
365 modified = TRUE;
366 in += 2;
367 nv += 2;
368 } else if ( *i_name < *n_name )
369 { *out++ = linkVal(in);
370 *out++ = *i_name;
371 in += 2;
372 } else
373 { if ( (rc=assign_in_dict(out++, nv PASS_LD)) != TRUE )
374 return rc;
375 *out++ = *n_name;
376 nv += 2;
377 modified = TRUE;
378 }
379 }
380
381 if ( nv == nv_end )
382 { if ( !modified )
383 { *new_dict = dict;
384 return TRUE;
385 }
386 while(in < in_end)
387 { Word i_name;
388 deRef2(in+1, i_name);
389 *out++ = linkVal(in);
390 *out++ = *i_name;
391 in += 2;
392 }
393 } else
394 { while(nv < nv_end)
395 { Word n_name;
396 int rc;
397
398 deRef2(nv+1, n_name);
399 if ( (rc=assign_in_dict(out++, nv PASS_LD)) != TRUE )
400 return rc;
401 *out++ = *n_name;
402 nv += 2;
403 }
404 }
405
406 gTop = out;
407 new[1] = linkVal(&data->arguments[0]);
408 new[0] = dict_functor((out-(new+1))/2);
409
410 *new_dict = consPtr(new, TAG_COMPOUND|STG_GLOBAL);
411
412 return TRUE;
413 }
414
415
416 static int
del_dict(word dict,word key,word * new_dict ARG_LD)417 del_dict(word dict, word key, word *new_dict ARG_LD)
418 { Functor data = valueTerm(dict);
419 int arity = arityFunctor(data->definition);
420 Word new, out, in, in_end;
421
422 assert(arity%2 == 1);
423
424 if ( gTop+1+arity-2 > gMax )
425 return GLOBAL_OVERFLOW;
426
427 new = gTop;
428 out = new+2; /* functor, tag */
429 in = data->arguments+1;
430 in_end = in+arity-1;
431
432 while(in < in_end)
433 { Word i_name;
434
435 deRef2(in+1, i_name);
436 if ( *i_name != key )
437 { *out++ = linkVal(in);
438 *out++ = *i_name;
439 }
440 in += 2;
441 }
442
443 gTop = out;
444 new[1] = linkVal(&data->arguments[0]); /* tag */
445 new[0] = dict_functor((out-(new+1))/2); /* arity */
446
447 *new_dict = consPtr(new, TAG_COMPOUND|STG_GLOBAL);
448
449 return TRUE;
450 }
451
452
453 /* partial_unify_dict(dict1, dict2) unifies all common elements of two
454 dicts. It returns TRUE on success, FALSE on a failed unification
455 and *_OVERFLOW on some memory overflow
456 */
457
458 static int
partial_unify_dict(word dict1,word dict2 ARG_LD)459 partial_unify_dict(word dict1, word dict2 ARG_LD)
460 { Functor d1 = valueTerm(dict1);
461 Functor d2 = valueTerm(dict2);
462 Word in1 = d1->arguments;
463 Word in2 = d2->arguments;
464 Word end1 = in1+arityFunctor(d1->definition);
465 Word end2 = in2+arityFunctor(d2->definition);
466 int rc;
467
468 /* unify the tages */
469 if ( (rc=unify_ptrs(in1, in2, ALLOW_RETCODE PASS_LD)) != TRUE )
470 return rc;
471
472 /* advance to first v+k entry */
473 in1++;
474 in2++;
475
476 while(in1 < end1 && in2 < end2)
477 { Word n1, n2;
478
479 deRef2(in1+1, n1);
480 deRef2(in2+1, n2);
481 if ( *n1 == *n2 )
482 { if ( (rc = unify_ptrs(in1, in2, ALLOW_RETCODE PASS_LD)) != TRUE )
483 return rc;
484 in1 += 2;
485 in2 += 2;
486 } else if ( *n1 < *n2 )
487 { in1 += 2;
488 } else
489 { in2 += 2;
490 }
491 }
492
493 return TRUE;
494 }
495
496
497 /* select_dict() demands del to be a sub-dict of from and assigns
498 all remaining values in new.
499
500 Note that unify_ptrs() can push data onto the global stack in
501 case it encounters attributed variables. Therefore we need a
502 two pass process.
503 */
504
505 static int
select_dict(word del,word from,word * new_dict ARG_LD)506 select_dict(word del, word from, word *new_dict ARG_LD)
507 { Functor dd = valueTerm(del);
508 Functor fd = valueTerm(from);
509 Word din = dd->arguments;
510 Word fin = fd->arguments;
511 Word dend = din+arityFunctor(dd->definition);
512 Word fend = fin+arityFunctor(fd->definition);
513 size_t left = 0;
514 int rc;
515
516 /* unify the tags */
517 if ( (rc=unify_ptrs(din, fin, ALLOW_RETCODE PASS_LD)) != TRUE )
518 return rc;
519
520 /* advance to first v+k entry */
521 din++;
522 fin++;
523
524 while(din < dend && fin < fend)
525 { Word d, f;
526
527 deRef2(din+1, d);
528 deRef2(fin+1, f);
529
530 if ( *d == *f )
531 { if ( (rc = unify_ptrs(din, fin, ALLOW_RETCODE PASS_LD)) != TRUE )
532 return rc;
533 din += 2;
534 fin += 2;
535 } else if ( *d < *f )
536 { return FALSE;
537 } else
538 { fin += 2;
539 left++;
540 }
541 }
542 if ( din < dend )
543 return FALSE;
544 left += (fend-fin)/2;
545
546 if ( !new_dict )
547 return TRUE;
548
549 if ( gTop+2+2*left <= gMax )
550 { Word out = gTop;
551
552 *new_dict = consPtr(out, TAG_COMPOUND|STG_GLOBAL);
553
554 *out++ = dict_functor(left);
555 setVar(*out++); /* tag for new dict */
556
557 din = dd->arguments+1;
558 fin = fd->arguments+1;
559
560 while(left > 0)
561 { Word d, f;
562
563 deRef2(din+1, d);
564 deRef2(fin+1, f);
565 if ( *d == *f )
566 { din += 2;
567 fin += 2;
568 } else
569 { *out++ = linkVal(fin);
570 *out++ = *f;
571 fin += 2;
572 left--;
573 }
574 }
575 gTop = out;
576
577 return TRUE;
578 }
579
580 return GLOBAL_OVERFLOW;
581 }
582
583
584 static int
get_name_ex(term_t t,Word np ARG_LD)585 get_name_ex(term_t t, Word np ARG_LD)
586 { Word p = valTermRef(t);
587
588 deRef(p);
589 if ( is_dict_key(*p) )
590 { *np = *p;
591 return TRUE;
592 }
593
594 PL_type_error("dict-key", t);
595 return FALSE;
596 }
597
598
599 static int
get_name_value(Word p,Word name,Word value,Word mark,int flags ARG_LD)600 get_name_value(Word p, Word name, Word value, Word mark, int flags ARG_LD)
601 { const char *type;
602
603 deRef(p);
604
605 if ( isTerm(*p) )
606 { Functor f = valueTerm(*p);
607
608 if ( (f->definition == FUNCTOR_minus2 && (flags&DICT_GET_PAIRS)) ||
609 (f->definition == FUNCTOR_equals2 && (flags&DICT_GET_EQUALS)) ||
610 (f->definition == FUNCTOR_colon2 && (flags&DICT_GET_COLON)))
611 { Word np, vp;
612
613 deRef2(&f->arguments[0], np);
614 if ( is_dict_key(*np) )
615 { *name = *np;
616 deRef2(&f->arguments[1], vp);
617 *value = linkVal(vp);
618
619 return TRUE;
620 } else
621 { gTop = mark;
622 PL_type_error("dict-key", pushWordAsTermRef(np));
623 popTermRef();
624
625 return FALSE;
626 }
627 } else if ( arityFunctor(f->definition) == 1 &&
628 (flags&DICT_GET_TERM) ) /* Name(Value) */
629 { Word vp;
630
631 *name = nameFunctor(f->definition);
632 deRef2(&f->arguments[0], vp);
633 *value = linkVal(vp);
634 return TRUE;
635 }
636 }
637
638 if ( flags == DICT_GET_PAIRS )
639 type = "pair";
640 else
641 type = "key-value";
642
643 gTop = mark;
644 PL_type_error(type, pushWordAsTermRef(p));
645 popTermRef();
646
647 return FALSE; /* type error */
648 }
649
650
651
652 /*******************************
653 * FOREIGN SUPPORT *
654 *******************************/
655
656 int
PL_is_dict(term_t t)657 PL_is_dict(term_t t)
658 { GET_LD
659 Word p = valTermRef(t);
660
661 deRef(p);
662 if ( isTerm(*p) )
663 { Functor f = valueTerm(*p);
664 FunctorDef fd = valueFunctor(f->definition);
665
666 if ( fd->name == ATOM_dict &&
667 fd->arity%2 == 1 &&
668 dict_ordered(f->arguments+1, fd->arity/2, FALSE PASS_LD) == TRUE )
669 return TRUE;
670 }
671
672 return FALSE;
673 }
674
675
676 static int
PL_get_dict_ex(term_t data,term_t tag,term_t dict,int flags)677 PL_get_dict_ex(term_t data, term_t tag, term_t dict, int flags)
678 { GET_LD
679
680 if ( PL_is_dict(data) )
681 { PL_put_term(dict, data);
682 return TRUE;
683 }
684
685 if ( PL_is_list(data) )
686 { intptr_t len = lengthList(data, TRUE);
687 Word m, ap, tail;
688
689 if ( len < 0 )
690 return FALSE; /* not a proper list */
691 retry:
692 if ( !(m = allocGlobal(len*2+2)) )
693 return FALSE; /* global overflow */
694 ap = m;
695 *ap++ = dict_functor(len);
696 if ( tag )
697 { Word cp = valTermRef(tag);
698
699 *ap = linkVal(cp); /* TBD: maybe move to another function */
700 if ( tagex(*ap) == (TAG_REFERENCE|STG_LOCAL) )
701 { if ( unlikely(tTop+1 >= tMax) )
702 { if ( !makeMoreStackSpace(TRAIL_OVERFLOW, ALLOW_GC|ALLOW_SHIFT) )
703 return FALSE;
704 gTop = m;
705 goto retry;
706 }
707 deRef(cp)
708 setVar(*ap);
709 Trail(cp, makeRef(ap));
710 }
711 } else
712 { setVar(*ap);
713 }
714 ap++;
715
716 tail = valTermRef(data);
717 deRef(tail);
718 while( isList(*tail) )
719 { Word head = HeadList(tail);
720
721 if ( !get_name_value(head, ap+1, ap, m, flags PASS_LD) )
722 {
723 return FALSE;
724 }
725 ap += 2;
726 tail = TailList(tail);
727 deRef(tail);
728 }
729
730 if ( dict_order(m, TRUE PASS_LD) )
731 { gTop = ap;
732 *valTermRef(dict) = consPtr(m, TAG_COMPOUND|STG_GLOBAL);
733 DEBUG(CHK_SECURE, checkStacks(NULL));
734 return TRUE;
735 } else
736 { return FALSE;
737 }
738 } /* TBD: {name:value, ...} */
739
740 return PL_type_error("dict-data", data);
741 }
742
743
744 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
745 PL_for_dict() runs func on each key-value pair in dict. Returns
746 immediately with the return value of func if func returns non-zero. If
747 the flag DICT_SORTED is given, the key-value pairs are called in the
748 standard order of terms.
749 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
750
751 typedef struct cmp_dict_index_data
752 { Word data;
753 int *indexes;
754 PL_local_data_t *ld;
755 } cmp_dict_index_data;
756
757 static int
cmp_dict_index(const void * a1,const void * a2,void * arg)758 cmp_dict_index(const void *a1, const void *a2, void *arg)
759 { int *ip1 = (int*)a1;
760 int *ip2 = (int*)a2;
761 cmp_dict_index_data *ctx = arg;
762 GET_LDARG(ctx->ld);
763 Word p = &ctx->data[*ip1*2+1];
764 Word q = &ctx->data[*ip2*2+1];
765 int rc;
766
767 deRef(p);
768 deRef(q);
769
770 if ( *p == *q )
771 { rc = CMP_EQUAL;
772 } else
773 { if ( isAtom(*p) )
774 { if ( isAtom(*q) )
775 rc = compareAtoms(*p, *q);
776 else
777 rc = CMP_GREATER;
778 } else
779 { if ( isTaggedInt(*p) )
780 rc = valInt(*p) > valInt(*q) ? CMP_GREATER : CMP_LESS;
781 else
782 rc = CMP_LESS;
783 }
784 }
785
786 return rc;
787 }
788
789
790 int
PL_for_dict(term_t dict,int (* func)(term_t key,term_t value,int last,void * closure),void * closure,int flags)791 PL_for_dict(term_t dict,
792 int (*func)(term_t key, term_t value, int last, void *closure),
793 void *closure,
794 int flags)
795 { GET_LD
796 term_t av = PL_new_term_refs(2);
797 int i, arity, pairs;
798 Word p = valTermRef(dict);
799 int index_buf[256];
800 int *indexes = NULL;
801 int rc = 0;
802
803 deRef(p);
804 arity = arityTerm(*p);
805 pairs = arity/2;
806
807 if ( (flags&DICT_SORTED) )
808 { cmp_dict_index_data ctx;
809
810 if ( pairs < 256 )
811 indexes = index_buf;
812 else if ( !(indexes = malloc(pairs*sizeof(int))) )
813 return PL_no_memory();
814
815 for(i=0; i<pairs; i++)
816 indexes[i] = i;
817
818 ctx.ld = LD;
819 ctx.data = argTermP(*p,1);
820 ctx.indexes = indexes;
821
822 sort_r(indexes, pairs, sizeof(int), cmp_dict_index, &ctx);
823 }
824
825 for(i=0; i < pairs; )
826 { Word p = valTermRef(dict);
827 int in;
828
829 if ( indexes )
830 { in = indexes[i]*2+1;
831 } else
832 { in = i*2+1;
833 }
834
835 deRef(p);
836 Functor f = valueTerm(*p);
837 *valTermRef(av+0) = linkVal(&f->arguments[in+1]);
838 *valTermRef(av+1) = linkVal(&f->arguments[in]);
839
840 if ( (rc=(*func)(av+0, av+1, ++i == pairs, closure)) != 0 )
841 break;
842 }
843
844 if ( indexes && indexes != index_buf )
845 free(indexes);
846
847 return rc;
848 }
849
850
851 /*******************************
852 * RELOAD SUPPORT *
853 *******************************/
854
855 /* resortDictsInClause() resorts the contents of dicts in a clause
856
857 This predicate is called from pl-wic.c after reloading a clause from a
858 .qlf file or state if pl-wic.c detected a dict inside the clause. It
859 identifies the code ranges that constitute the k-v pairs in the dict and
860 re-orders them according to the new atom-handle ordering.
861
862 There is a complicating factor with B_FIRSTVAR/B_VAR,
863 B_ARGFIRSTVAR/B_ARGVAR and H_FIRSTVAR/H_VAR, that may get swapped after
864 reordering. This is corrected by fix_firstvars(). The current
865 implementation is quadratic in the number of variables in the dict.
866 */
867
868 typedef struct kv_code
869 { word key;
870 size_t start;
871 size_t len;
872 } kv_code;
873
874 #define KV_PREALOCATED 32
875 #define C_PREALLOCATED 256
876
877 static int
cmp_kv_pos(const void * p1,const void * p2)878 cmp_kv_pos(const void *p1, const void *p2)
879 { const kv_code *k1 = p1;
880 const kv_code *k2 = p2;
881
882 return k1->key < k2->key ? -1 : k1->key == k2->key ? 0 : 1;
883 }
884
885 static void
fix_firstvars(Code start,Code end)886 fix_firstvars(Code start, Code end)
887 { Code PC;
888
889 for( PC=start; PC < end; PC = stepPC(PC) )
890 { code op = fetchop(PC);
891 code first;
892 code var;
893
894 switch(op)
895 { case B_VAR0:
896 case B_VAR1:
897 case B_VAR2:
898 var = (code)VAROFFSET(op-B_VAR0);
899 first = B_FIRSTVAR;
900 goto find_first;
901 case B_VAR:
902 var = PC[1];
903 first = B_FIRSTVAR;
904 goto find_first;
905 case B_ARGVAR:
906 var = PC[1];
907 first = B_ARGFIRSTVAR;
908 goto find_first;
909 case H_VAR:
910 var = PC[1];
911 first = H_FIRSTVAR;
912 find_first:
913 { Code pc;
914
915 for(pc=PC; pc < end; pc = stepPC(pc))
916 { code op2 = fetchop(pc);
917
918 if ( op2 == first && pc[1] == var )
919 { DEBUG(MSG_DICT, Sdprintf("Swapping first vars\n"));
920 *PC = *pc;
921 *pc = encode(op);
922 }
923 }
924 }
925 }
926 }
927 }
928
929 int
resortDictsInCodes(Code PC,Code end)930 resortDictsInCodes(Code PC, Code end)
931 {
932 for( ; PC < end; PC = stepPC(PC) )
933 { code op = fetchop(PC);
934
935 switch(op)
936 { case H_RFUNCTOR:
937 case H_FUNCTOR:
938 case B_RFUNCTOR:
939 case B_FUNCTOR:
940 { word w = (word)PC[1];
941 FunctorDef fd = valueFunctor(w);
942
943 if ( fd->name == ATOM_dict &&
944 fd->arity > 1 &&
945 fd->arity%2 == 1 )
946 { int f, fields = fd->arity/2;
947 kv_code kv_buf[KV_PREALOCATED];
948 code c_buf[C_PREALLOCATED];
949 kv_code *kv_pos;
950 Code c_tmp;
951 Code fields_start, fs;
952
953 if ( fields <= KV_PREALOCATED )
954 kv_pos = kv_buf;
955 else if ( !(kv_pos = malloc(sizeof(kv_code)*fields)) )
956 return PL_no_memory();
957
958 PC = stepPC(PC); /* skip *_FUNCTOR */
959 PC = skipArgs(PC, 1); /* skip the type */
960 fields_start = PC;
961
962 for(f = 0; f < fields; f++)
963 { Code PCv = PC;
964
965 kv_pos[f].start = PC-fields_start;
966 PC = skipArgs(PC, 1); /* skip value */
967
968 code op = fetchop(PC);
969 switch(op)
970 { case H_ATOM:
971 case B_ATOM:
972 case H_SMALLINT:
973 case B_SMALLINT:
974 { kv_pos[f].key = (word)PC[1];
975 break;
976 }
977 default:
978 { if ( kv_pos != kv_buf )
979 free(kv_pos);
980 return TRUE; /* not a dict */
981 }
982 }
983
984 if ( !resortDictsInCodes(PCv, PC) )
985 { if ( kv_pos != kv_buf )
986 free(kv_pos);
987 return FALSE;
988 }
989
990 PC = stepPC(PC); /* skip key */
991 kv_pos[f].len = PC-fields_start-kv_pos[f].start;
992
993 DEBUG(MSG_DICT,
994 { if ( isAtom(kv_pos[f].key) )
995 Sdprintf("Got %s from %p..%p\n",
996 stringAtom(kv_pos[f].key), kv_pos[f].start, PC);
997 else
998 Sdprintf("Got %ld from %p..%p\n",
999 (long)valInt(kv_pos[f].key), kv_pos[f].start, PC);
1000 });
1001 }
1002
1003 qsort(kv_pos, fields, sizeof(*kv_pos), cmp_kv_pos);
1004 if ( PC-fields_start <= C_PREALLOCATED )
1005 c_tmp = c_buf;
1006 else if ( !(c_tmp = malloc((PC-fields_start)*sizeof(code))) )
1007 { if ( kv_pos != kv_buf )
1008 free(kv_pos);
1009 return PL_no_memory();
1010 }
1011
1012 memcpy(c_tmp, fields_start, (PC-fields_start)*sizeof(code));
1013 for(fs=fields_start, f = 0; f < fields; f++)
1014 { size_t len = kv_pos[f].len*sizeof(code);
1015
1016 memcpy(fs, c_tmp+kv_pos[f].start, len);
1017 fs += kv_pos[f].len;
1018 }
1019
1020 if ( kv_pos != kv_buf )
1021 free(kv_pos);
1022 if ( c_tmp != c_buf )
1023 free(c_tmp);
1024
1025 fix_firstvars(fields_start, PC);
1026 }
1027 }
1028 }
1029 }
1030
1031 return TRUE;
1032 }
1033
1034 int
resortDictsInClause(Clause clause)1035 resortDictsInClause(Clause clause)
1036 { Code PC, end;
1037
1038 PC = clause->codes;
1039 end = &PC[clause->code_size];
1040
1041 return resortDictsInCodes(PC, end);
1042 }
1043
1044
1045 /* resortDictsInTerm() re-sorts dicts inside term.
1046 Used by loadQlfTerm(). Term may not be cyclic.
1047 */
1048
1049 static void
resort_dicts_in_term(Word p ARG_LD)1050 resort_dicts_in_term(Word p ARG_LD)
1051 {
1052 right_arg:
1053 deRef(p);
1054
1055 if ( isTerm(*p) )
1056 { Functor t = valueTerm(*p);
1057 FunctorDef fd = valueFunctor(t->definition);
1058 Word ea;
1059
1060 if ( fd->name == ATOM_dict && fd->arity%2 == 1 &&
1061 dict_ordered(&t->arguments[1], fd->arity/2, FALSE PASS_LD) == FALSE )
1062 { DEBUG(MSG_DICT, Sdprintf("Re-ordering dict\n"));
1063 dict_order((Word)t, FALSE PASS_LD);
1064 }
1065
1066 ea = &t->arguments[fd->arity-1];
1067 for(p=t->arguments; p<ea; p++)
1068 resort_dicts_in_term(p PASS_LD);
1069
1070 goto right_arg;
1071 }
1072 }
1073
1074
1075 void
resortDictsInTerm(term_t t)1076 resortDictsInTerm(term_t t)
1077 { GET_LD
1078 Word p = valTermRef(t);
1079
1080 resort_dicts_in_term(p PASS_LD);
1081 }
1082
1083
1084
1085 /*******************************
1086 * PROLOG PREDICATES *
1087 *******************************/
1088
1089 /** is_dict(@Term)
1090 is_dict(@Term, ?Tag)
1091
1092 True if Term is a dict that belongs to Tag.
1093
1094 @tbd What if Term has a variable tag?
1095 */
1096
1097 static
1098 PRED_IMPL("is_dict", 1, is_dict, 0)
1099 { PRED_LD
1100 Word p = valTermRef(A1);
1101
1102 deRef(p);
1103 if ( isTerm(*p) )
1104 { Functor f = valueTerm(*p);
1105 FunctorDef fd = valueFunctor(f->definition);
1106
1107 if ( fd->name == ATOM_dict &&
1108 fd->arity%2 == 1 /*&&
1109 dict_ordered(f->arguments+1, fd->arity/2, FALSE PASS_LD) == TRUE*/ )
1110 return TRUE;
1111 }
1112
1113 return FALSE;
1114 }
1115
1116
1117 static
1118 PRED_IMPL("is_dict", 2, is_dict, 0)
1119 { PRED_LD
1120 Word p = valTermRef(A1);
1121
1122 deRef(p);
1123 if ( isTerm(*p) )
1124 { Functor f = valueTerm(*p);
1125 FunctorDef fd = valueFunctor(f->definition);
1126
1127 if ( fd->name == ATOM_dict &&
1128 fd->arity%2 == 1 /*&&
1129 dict_ordered(f->arguments+1, fd->arity/2, FALSE PASS_LD) == TRUE*/ )
1130 return unify_ptrs(&f->arguments[0], valTermRef(A2),
1131 ALLOW_GC|ALLOW_SHIFT PASS_LD);
1132 }
1133
1134 return FALSE;
1135 }
1136
1137
1138 /** get_dict(?Key, +Dict, ?Value)
1139
1140 True when Key is associated with Value in Dict. If Name is unbound, this
1141 predicate is true for all Name/Value pairs in the dict. The order in
1142 which these pairs are enumerated is _undefined_.
1143 */
1144
1145 static foreign_t
pl_get_dict(term_t PL__t0,int PL__ac,int ex,control_t PL__ctx)1146 pl_get_dict(term_t PL__t0, int PL__ac, int ex, control_t PL__ctx)
1147 { PRED_LD
1148 int i;
1149 word dict;
1150
1151 switch( CTX_CNTRL )
1152 { case FRG_FIRST_CALL:
1153 { Word np = valTermRef(A1);
1154
1155 if ( !get_dict_ex(A2, &dict, !ex PASS_LD) )
1156 return FALSE;
1157
1158 deRef(np);
1159 if ( is_dict_key(*np) )
1160 { Word vp;
1161
1162 if ( (vp=dict_lookup_ptr(dict, *np PASS_LD)) )
1163 return unify_ptrs(vp, valTermRef(A3), ALLOW_GC|ALLOW_SHIFT PASS_LD);
1164
1165 if ( ex )
1166 return PL_error(NULL, 0, NULL, ERR_EXISTENCE3,
1167 ATOM_key, A1, A2);
1168 return FALSE;
1169 }
1170 if ( canBind(*np) )
1171 { i = 1;
1172 goto search;
1173 }
1174 if ( !ex )
1175 return PL_type_error("dict-key", A1);
1176 return FALSE;
1177 }
1178 case FRG_REDO:
1179 { Functor f;
1180 int arity;
1181 fid_t fid;
1182 Word p;
1183
1184 i = (int)CTX_INT + 2;
1185 p = valTermRef(A2);
1186 deRef(p);
1187 dict = *p;
1188
1189 search:
1190 f = valueTerm(dict);
1191 arity = arityFunctor(f->definition);
1192
1193 if ( (fid=PL_open_foreign_frame()) )
1194 { for( ; i < arity; i += 2 )
1195 { Word np;
1196
1197 deRef2(&f->arguments[i+1], np); /* TBD: check type */
1198 if ( unify_ptrs(&f->arguments[i], valTermRef(A3),
1199 ALLOW_GC|ALLOW_SHIFT PASS_LD) &&
1200 _PL_unify_atomic(A1, *np) )
1201 { PL_close_foreign_frame(fid);
1202
1203 if ( i+2 < arity )
1204 ForeignRedoInt(i);
1205 else
1206 return TRUE;
1207 } else if ( exception_term )
1208 { PL_close_foreign_frame(fid);
1209 return FALSE;
1210 }
1211 PL_rewind_foreign_frame(fid);
1212 }
1213 PL_close_foreign_frame(fid);
1214 }
1215 return FALSE;
1216 }
1217 default:
1218 return TRUE;
1219 }
1220 }
1221
1222
1223 static
1224 PRED_IMPL("get_dict", 3, get_dict, PL_FA_NONDETERMINISTIC)
1225 { return pl_get_dict(PL__t0, PL__ac, FALSE, PL__ctx);
1226 }
1227
1228
1229 static
1230 PRED_IMPL("get_dict_ex", 3, get_dict_ex, PL_FA_NONDETERMINISTIC)
1231 { return pl_get_dict(PL__t0, PL__ac, TRUE, PL__ctx);
1232 }
1233
1234
1235 /** get_dict(+Key, +Dict, -Value, -NewDict, -NewValue) is semidet.
1236 */
1237
1238 static
1239 PRED_IMPL("get_dict", 5, get_dict, 0)
1240 { PRED_LD
1241 term_t dt = PL_new_term_refs(4);
1242 term_t av = dt+1;
1243 word key;
1244 Word vp;
1245
1246 if ( !get_name_ex(A1, &key PASS_LD) ||
1247 !(*valTermRef(av+1) = key) ||
1248 !get_create_dict_ex(A2, dt PASS_LD) ||
1249 !(vp=dict_lookup_ptr(*valTermRef(dt), key PASS_LD)) ||
1250 !unify_ptrs(vp, valTermRef(A3), ALLOW_GC|ALLOW_SHIFT PASS_LD) ||
1251 !PL_put_term(av+0, A5) )
1252 return FALSE;
1253
1254 for(;;)
1255 { word new;
1256 int rc;
1257
1258 if ( (rc = put_dict(*valTermRef(dt),
1259 1, valTermRef(av), &new PASS_LD)) == TRUE )
1260 { term_t t = dt+3;
1261
1262 *valTermRef(t) = new;
1263 return PL_unify(A4, t);
1264 } else
1265 { if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
1266 return FALSE;
1267 }
1268 }
1269 }
1270
1271
1272 /** dict_create(-Dict, ?Tag, +Data) is det.
1273
1274 Dict represents the name-value pairs in Data. If Data is a dict, Dict
1275 unified with Data. Otherwise, a new Dict is created. Suitable
1276 representations for Data are:
1277
1278 - {Name:Value, ...}
1279 - [Name=Value, ...]
1280 - [Name-Value, ...]
1281 - [Name(Value), ...]
1282 */
1283
1284
1285 static
1286 PRED_IMPL("dict_create", 3, dict_create, 0)
1287 { PRED_LD
1288 term_t m = PL_new_term_ref();
1289
1290 if ( PL_get_dict_ex(A3, A2, m, DICT_GET_ALL) )
1291 return PL_unify(A1, m);
1292
1293 return FALSE;
1294 }
1295
1296
1297 /** dict_pairs(+Dict, ?Tag, -Pairs)
1298 dict_pairs(-Dict, ?Tag, +Pairs)
1299 */
1300
1301 typedef struct dict_pairs_ctx
1302 { PL_local_data_t *ld;
1303 term_t head;
1304 term_t tail;
1305 term_t tmp;
1306 } dict_pairs_ctx;
1307
1308
1309 static int
put_pair(term_t key,term_t value,int last,void * closure)1310 put_pair(term_t key, term_t value, int last, void *closure)
1311 { dict_pairs_ctx *ctx = closure;
1312 GET_LDARG(ctx->ld);
1313
1314 if ( PL_cons_functor(ctx->tmp, FUNCTOR_minus2, key, value) &&
1315 PL_unify_list_ex(ctx->tail, ctx->head, ctx->tail) &&
1316 PL_unify(ctx->head, ctx->tmp) )
1317 return 0;
1318
1319 return -1;
1320 }
1321
1322 #undef GET_LDARG
1323
1324
1325 static
1326 PRED_IMPL("dict_pairs", 3, dict_pairs, 0)
1327 { PRED_LD
1328
1329 if ( !PL_is_variable(A1) )
1330 { term_t dict = PL_new_term_ref();
1331
1332 if ( get_create_dict_ex(A1, dict PASS_LD) )
1333 { dict_pairs_ctx ctx;
1334
1335 ctx.ld = LD;
1336 ctx.tail = PL_copy_term_ref(A3);
1337 ctx.head = PL_new_term_refs(2);
1338 ctx.tmp = ctx.head+1;
1339
1340 if ( PL_get_arg(1, dict, ctx.tmp) &&
1341 PL_unify(ctx.tmp, A2) &&
1342 PL_for_dict(dict, put_pair, &ctx, DICT_SORTED) == 0 )
1343 return PL_unify_nil_ex(ctx.tail);
1344
1345 return FALSE;
1346 }
1347 } else
1348 { term_t m = PL_new_term_ref();
1349
1350 if ( PL_get_dict_ex(A3, A2, m, DICT_GET_PAIRS) )
1351 return PL_unify(A1, m);
1352 }
1353
1354 return FALSE;
1355 }
1356
1357
1358 /** put_dict(+New, +DictIn, -DictOut)
1359
1360 True when Dict is a copy of Dict0 where values from Dict1 replace or extend
1361 the value set of Dict0.
1362 */
1363
1364 static
1365 PRED_IMPL("put_dict", 3, put_dict, 0)
1366 { PRED_LD
1367 term_t dt;
1368 fid_t fid = PL_open_foreign_frame();
1369
1370 retry:
1371 if ( (dt = PL_new_term_refs(2)) &&
1372 get_create_dict_ex(A2, dt+0 PASS_LD) &&
1373 get_create_dict_ex(A1, dt+1 PASS_LD) )
1374 { Functor f2 = valueTerm(*valTermRef(dt+1));
1375 int arity = arityFunctor(f2->definition);
1376 word new;
1377 int rc;
1378
1379 if ( (rc = put_dict(*valTermRef(dt+0),
1380 arity/2, &f2->arguments[1],
1381 &new PASS_LD)) == TRUE )
1382 { term_t t = PL_new_term_ref();
1383
1384 *valTermRef(t) = new;
1385 return PL_unify(A3, t);
1386 } else
1387 { assert(rc == GLOBAL_OVERFLOW);
1388 PL_rewind_foreign_frame(fid);
1389 if ( makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
1390 goto retry;
1391 }
1392 }
1393
1394 return FALSE;
1395 }
1396
1397 /** put_dict(+Key, +Dict0, +Value, -Dict)
1398
1399 True when Dict is a copy of Dict0 with Name Value added or replaced.
1400 */
1401
1402 static foreign_t
put_dict4(term_t key,term_t dict,term_t value,term_t newdict ARG_LD)1403 put_dict4(term_t key, term_t dict, term_t value, term_t newdict ARG_LD)
1404 { term_t dt = PL_new_term_refs(3);
1405 term_t av = dt+1;
1406 fid_t fid = PL_open_foreign_frame();
1407
1408 retry:
1409 if ( get_create_dict_ex(dict, dt PASS_LD) &&
1410 get_name_ex(key, valTermRef(av+1) PASS_LD) &&
1411 PL_put_term(av, value) )
1412 { word new;
1413 int rc;
1414
1415 if ( (rc = put_dict(*valTermRef(dt),
1416 1, valTermRef(av), &new PASS_LD)) == TRUE )
1417 { term_t t = PL_new_term_ref();
1418
1419 *valTermRef(t) = new;
1420 return PL_unify(newdict, t);
1421 } else
1422 { if ( makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
1423 { PL_rewind_foreign_frame(fid);
1424 goto retry;
1425 }
1426 }
1427 }
1428
1429 return FALSE;
1430 }
1431
1432
1433
1434 static
1435 PRED_IMPL("put_dict", 4, put_dict, 0)
1436 { PRED_LD
1437
1438 return put_dict4(A1, A2, A3, A4 PASS_LD);
1439 }
1440
1441
1442 /** b_set_dict(+Key, !Dict, +Value)
1443
1444 Backtrackable destructive assignment, similar to setarg/3.
1445 */
1446
1447 #define SETDICT_BACKTRACKABLE 0x1
1448 #define SETDICT_LINK 0x2
1449
1450 static int
setdict(term_t key,term_t dict,term_t value,int flags ARG_LD)1451 setdict(term_t key, term_t dict, term_t value, int flags ARG_LD)
1452 { word k, m;
1453 Word val;
1454
1455 retry:
1456 val = valTermRef(value);
1457 deRef(val);
1458
1459 if ( (flags&SETDICT_BACKTRACKABLE) )
1460 { if ( !hasGlobalSpace(0) )
1461 { int rc;
1462
1463 if ( (rc=ensureGlobalSpace(0, ALLOW_GC)) != TRUE )
1464 return raiseStackOverflow(rc);
1465 goto retry;
1466 }
1467 } else
1468 { if ( storage(*val) == STG_GLOBAL )
1469 { if ( !(flags & SETDICT_LINK) )
1470 { term_t copy = PL_new_term_ref();
1471
1472 if ( !duplicate_term(value, copy PASS_LD) )
1473 return FALSE;
1474 value = copy;
1475 val = valTermRef(value);
1476 deRef(val);
1477 }
1478 freezeGlobal(PASS_LD1);
1479 }
1480 }
1481
1482 if ( get_dict_ex(dict, &m, TRUE PASS_LD) &&
1483 get_name_ex(key, &k PASS_LD) )
1484 { Word vp;
1485
1486 if ( (vp=dict_lookup_ptr(m, k PASS_LD)) )
1487 { if ( (flags&SETDICT_BACKTRACKABLE) )
1488 TrailAssignment(vp);
1489 unify_vp(vp, val PASS_LD);
1490 return TRUE;
1491 }
1492
1493 return PL_error(NULL, 0, NULL, ERR_EXISTENCE3,
1494 ATOM_key, key, dict);
1495 }
1496
1497 return FALSE;
1498 }
1499
1500
1501 static
1502 PRED_IMPL("b_set_dict", 3, b_set_dict, 0)
1503 { PRED_LD
1504
1505 return setdict(A1, A2, A3, SETDICT_BACKTRACKABLE PASS_LD);
1506 }
1507
1508 static
1509 PRED_IMPL("nb_set_dict", 3, nb_set_dict, 0)
1510 { PRED_LD
1511
1512 return setdict(A1, A2, A3, 0 PASS_LD);
1513 }
1514
1515 static
1516 PRED_IMPL("nb_link_dict", 3, nb_link_dict, 0)
1517 { PRED_LD
1518
1519 return setdict(A1, A2, A3, SETDICT_LINK PASS_LD);
1520 }
1521
1522
1523 /** del_dict(+Key, +DictIn, ?Value, -DictOut)
1524
1525 True when Key-Value is in DictIn and DictOut contains all keys of DictIn
1526 except for Key.
1527 */
1528
1529 static
1530 PRED_IMPL("del_dict", 4, del_dict, 0)
1531 { PRED_LD
1532 word key;
1533 term_t mt = PL_new_term_ref();
1534 fid_t fid = PL_open_foreign_frame();
1535
1536 retry:
1537 if ( get_create_dict_ex(A2, mt PASS_LD) &&
1538 get_name_ex(A1, &key PASS_LD) )
1539 { Word vp;
1540
1541 if ( (vp=dict_lookup_ptr(*valTermRef(mt), key PASS_LD)) &&
1542 unify_ptrs(vp, valTermRef(A3), ALLOW_GC|ALLOW_SHIFT PASS_LD) )
1543 { int rc;
1544 word new;
1545
1546 if ( (rc=del_dict(*valTermRef(mt), key, &new PASS_LD)) == TRUE )
1547 { term_t t = PL_new_term_ref();
1548
1549 *valTermRef(t) = new;
1550 return PL_unify(A4, t);
1551 } else
1552 { assert(rc == GLOBAL_OVERFLOW);
1553 if ( makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
1554 { PL_rewind_foreign_frame(fid);
1555 goto retry;
1556 }
1557 }
1558 }
1559 }
1560
1561 return FALSE;
1562 }
1563
1564
1565 /** select_dict(+Select, +From) is semidet.
1566 select_dict(+Select, +From, -Rest) is semidet.
1567 */
1568
1569 static
1570 PRED_IMPL("select_dict", 3, select_dict, 0)
1571 { PRED_LD
1572 term_t dt = PL_new_term_refs(2);
1573 word r;
1574
1575 retry:
1576 if ( get_create_dict_ex(A1, dt+0 PASS_LD) &&
1577 get_create_dict_ex(A2, dt+1 PASS_LD) )
1578 { int rc = select_dict(*valTermRef(dt+0), *valTermRef(dt+1), &r PASS_LD);
1579
1580 switch(rc)
1581 { case TRUE:
1582 { term_t t = PL_new_term_ref();
1583
1584 *valTermRef(t) = r;
1585 return PL_unify(A3, t);
1586 }
1587 case FALSE:
1588 return rc;
1589 case MEMORY_OVERFLOW:
1590 return PL_no_memory();
1591 default:
1592 if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
1593 return FALSE;
1594 goto retry;
1595 }
1596 }
1597
1598 return FALSE;
1599 }
1600
1601
1602 static
1603 PRED_IMPL(":<", 2, select_dict, 0)
1604 { PRED_LD
1605 term_t dt = PL_new_term_refs(2);
1606
1607 retry:
1608 if ( get_create_dict_ex(A1, dt+0 PASS_LD) &&
1609 get_create_dict_ex(A2, dt+1 PASS_LD) )
1610 { int rc = select_dict(*valTermRef(dt+0), *valTermRef(dt+1), NULL PASS_LD);
1611
1612 switch(rc)
1613 { case TRUE:
1614 case FALSE:
1615 return rc;
1616 case MEMORY_OVERFLOW:
1617 return PL_no_memory();
1618 default:
1619 if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
1620 return FALSE;
1621 goto retry;
1622 }
1623 }
1624
1625 return FALSE;
1626 }
1627
1628
1629 static
1630 PRED_IMPL(">:<", 2, punify_dict, 0)
1631 { PRED_LD
1632 term_t dt = PL_new_term_refs(2);
1633
1634 retry:
1635 if ( get_create_dict_ex(A1, dt+0 PASS_LD) &&
1636 get_create_dict_ex(A2, dt+1 PASS_LD) )
1637 { int rc = partial_unify_dict(*valTermRef(dt+0), *valTermRef(dt+1) PASS_LD);
1638
1639 switch(rc)
1640 { case TRUE:
1641 case FALSE:
1642 return rc;
1643 case MEMORY_OVERFLOW:
1644 return PL_no_memory();
1645 default:
1646 if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
1647 return FALSE;
1648 goto retry;
1649 }
1650 }
1651
1652 return FALSE;
1653 }
1654
1655
1656 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1657 Part of FLI
1658 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1659
1660 int
PL_get_dict_key(atom_t key,term_t dict,term_t value)1661 PL_get_dict_key(atom_t key, term_t dict, term_t value)
1662 { GET_LD
1663 word d;
1664 Word vp;
1665
1666 if ( !is_dict_key(key) )
1667 return -1;
1668 if ( !get_dict_ex(dict, &d, FALSE PASS_LD) )
1669 return FALSE;
1670 if ( (vp=dict_lookup_ptr(d, key PASS_LD)) )
1671 { *valTermRef(value) = linkVal(vp);
1672 return TRUE;
1673 }
1674
1675 return FALSE;
1676 }
1677
1678
1679 /*******************************
1680 * PUBLISH PREDICATES *
1681 *******************************/
1682
1683 BeginPredDefs(dict)
1684 PRED_DEF("is_dict", 1, is_dict, 0)
1685 PRED_DEF("is_dict", 2, is_dict, 0)
1686 PRED_DEF("dict_create", 3, dict_create, 0)
1687 PRED_DEF("dict_pairs", 3, dict_pairs, 0)
1688 PRED_DEF("put_dict", 3, put_dict, 0)
1689 PRED_DEF("put_dict", 4, put_dict, 0)
1690 PRED_DEF("b_set_dict", 3, b_set_dict, 0)
1691 PRED_DEF("nb_set_dict", 3, nb_set_dict, 0)
1692 PRED_DEF("nb_link_dict", 3, nb_link_dict, 0)
1693 PRED_DEF("get_dict", 3, get_dict, PL_FA_NONDETERMINISTIC)
1694 PRED_DEF("$get_dict_ex", 3, get_dict_ex, PL_FA_NONDETERMINISTIC)
1695 PRED_DEF("del_dict", 4, del_dict, 0)
1696 PRED_DEF("get_dict", 5, get_dict, 0)
1697 PRED_DEF("select_dict", 3, select_dict, 0)
1698 PRED_DEF(":<", 2, select_dict, 0)
1699 PRED_DEF(">:<", 2, punify_dict, 0)
1700 EndPredDefs
1701