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) 1985-2020, University of Amsterdam
7 VU University Amsterdam
8 CWI, Amsterdam
9 All rights reserved.
10
11 Redistribution and use in source and binary forms, with or without
12 modification, are permitted provided that the following conditions
13 are met:
14
15 1. Redistributions of source code must retain the above copyright
16 notice, this list of conditions and the following disclaimer.
17
18 2. Redistributions in binary form must reproduce the above copyright
19 notice, this list of conditions and the following disclaimer in
20 the documentation and/or other materials provided with the
21 distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 /*#define O_DEBUG 1*/
38 #include "pl-incl.h"
39 #include "pl-arith.h"
40 #include "os/pl-ctype.h"
41 #include "pl-inline.h"
42 #include <math.h>
43 #ifdef HAVE_SYS_RESOURCE_H
44 #include <sys/resource.h>
45 #endif
46
47 #undef LD
48 #define LD LOCAL_LD
49
50 static int unify_with_occurs_check(Word t1, Word t2,
51 occurs_check_t mode ARG_LD);
52
53
54 /*******************************
55 * CYCLIC TERMS *
56 *******************************/
57
58 #if O_CYCLIC
59
60 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
61 Cyclic term unification. The algorithm has been described to me by Bart
62 Demoen. Here it is (translated from dutch):
63
64 I created my own variation. You only need it during general unification.
65 Here is a short description: suppose you unify 2 terms f(...) and
66 f(...), which are represented on the heap (=global stack) as:
67
68 +-----+ and +-----+
69 | f/3 | | f/3 |
70 +-----+ +-----+
71 args args'
72
73 Before working on args and args', change this into the structure below,
74 using a reference pointer pointing from functor of the one to the other
75 term.
76
77 +-----+ and +-----+
78 | ----+----------------->| f/3 |
79 +-----+ +-----+
80 args args'
81
82 If, during this unification you find a compound whose functor is a
83 reference to the term at the right hand you know you hit a cycle and the
84 terms are the same.
85
86 Of course functor_t must be different from ref. Overwritten functors are
87 collected in a stack and reset regardless of whether the unification
88 succeeded or failed.
89
90 Note that we need to dereference the functors both left and right.
91 References at the right are rare, but possible. The trick is to use both
92 sharing and cycles, where the cycles at the left are shorter:
93
94 t :-
95 X = s(X), Y = y(X,X),
96 A = s(s(s(A))), B = y(A,A),
97 Y = B.
98
99 While unifying the first argument of y/2, the left-walker crosses to the
100 right after the first cycle and creates references in A, which are
101 processed by the right-walker when entering the second argument of y/2.
102
103 Initial measurements show a performance degradation for deep unification
104 of approx. 30%. On the other hand, if subterms appear multiple times in
105 a term unification can be much faster. As only a small percentage of the
106 unifications of a realistic program are covered by unify() and involve
107 deep unification the overall impact of performance is small (< 3%).
108 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
109
110 static void
initvisited(ARG1_LD)111 initvisited(ARG1_LD)
112 { LD->cycle.vstack.unit_size = sizeof(Word);
113 }
114
115
116 #ifdef O_DEBUG
117 static int
empty_visited(ARG1_LD)118 empty_visited(ARG1_LD)
119 { return emptySegStack(&LD->cycle.vstack);
120 }
121 #endif
122
123
124 static inline int
visitedWord(Word p ARG_LD)125 visitedWord(Word p ARG_LD)
126 { if ( is_marked(p) )
127 succeed;
128 set_marked(p);
129 if ( !pushSegStack(&LD->cycle.vstack, p, Word) )
130 outOfCore();
131 fail;
132 }
133
134
135 static inline int
visited(Functor f ARG_LD)136 visited(Functor f ARG_LD)
137 { Word p = &f->definition;
138
139 return visitedWord(p PASS_LD);
140 }
141
142
143 static void
unvisit(ARG1_LD)144 unvisit(ARG1_LD)
145 { Word p;
146
147 while( popSegStack(&LD->cycle.vstack, &p, Word) )
148 { clear_marked(p);
149 }
150 }
151
152 static void
unvisit_and_unfirst(ARG1_LD)153 unvisit_and_unfirst(ARG1_LD)
154 { Word p;
155
156 while( popSegStack(&LD->cycle.vstack, &p, Word) )
157 { clear_both(p);
158 }
159 }
160
161
162 static void
popVisited(ARG1_LD)163 popVisited(ARG1_LD)
164 { Word p = NULL;
165
166 popSegStack(&LD->cycle.vstack, &p, Word);
167 clear_marked(p);
168 }
169
170
171 static inline void
initCyclic(ARG1_LD)172 initCyclic(ARG1_LD)
173 { LD->cycle.lstack.unit_size = sizeof(Word);
174 }
175
176
177 static inline void
linkTermsCyclic(Functor f1,Functor f2 ARG_LD)178 linkTermsCyclic(Functor f1, Functor f2 ARG_LD)
179 { Word p1 = (Word)&f1->definition;
180 Word p2 = (Word)&f2->definition;
181
182 *p1 = makeRefG(p2);
183 if ( !pushSegStack(&LD->cycle.lstack, p1, Word) )
184 outOfCore();
185 }
186
187
188 static inline void
exitCyclic(ARG1_LD)189 exitCyclic(ARG1_LD)
190 { Word p;
191
192 while( popSegStack(&LD->cycle.lstack, &p, Word) )
193 { *p = *unRef(*p);
194 }
195 }
196
197 #else /*O_CYCLIC*/
198
visited(Functor f ARG_LD)199 static inline visited(Functor f ARG_LD) { fail; }
unvisit(Word * base ARG_LD)200 static inline unvisit(Word *base ARG_LD) { }
initCyclic(ARG1_LD)201 static inline void initCyclic(ARG1_LD) {}
exitCyclic(ARG1_LD)202 static inline void exitCyclic(ARG1_LD) {}
linkTermsCyclic(Functor f1,Functor f2 ARG_LD)203 static inline void linkTermsCyclic(Functor f1, Functor f2 ARG_LD) {}
204
205 #endif /*O_CYCLIC*/
206
207 #define HAVE_VISITED
208 #define AC_TERM_WALK_LR 1
209 #include "pl-termwalk.c"
210
211 /********************************
212 * UNIFICATION *
213 *********************************/
214
215 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
216 Unify is the general unification procedure. This raw routine should only
217 be called by interpret as it does not undo bindings made during the
218 unification in case the unification fails. pl_unify() (implementing =/2)
219 does undo bindings and should be used by foreign predicates. See also
220 unify_ptrs().
221
222 Unification depends on the datatypes available in the system and will in
223 general need updating if new types are added. It should be noted that
224 unify() is not the only place were unification happens. Other points
225 are:
226
227 - various of the virtual machine instructions
228 - various macros, for example APPENDLIST and CLOSELIST
229 - unifyAtomic(): unification of atomic data.
230 - various builtin predicates. They should be flagged some way.
231
232 Returns one of:
233
234 - FALSE: terms cannot unify. Note that this routine does not
235 rollback changes it made!
236 - TRUE: Unification has completed successfully
237 - GLOBAL_OVERFLOW: Unification cannot be completed due to lack
238 of global-space.
239 - TRAIL_OVERFLOW: Unification cannot be completed due to lack
240 of trail-space.
241 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
242
243 static int
do_unify(Word t1,Word t2 ARG_LD)244 do_unify(Word t1, Word t2 ARG_LD)
245 { term_agendaLR agenda;
246 int compound = FALSE;
247 int rc = FALSE;
248
249 do
250 { word w1, w2;
251
252 deRef(t1); w1 = *t1;
253 deRef(t2); w2 = *t2;
254
255 DEBUG(CHK_ATOM_GARBAGE_COLLECTED,
256 { assert(w1 != ATOM_garbage_collected);
257 assert(w2 != ATOM_garbage_collected);
258 });
259
260 if ( isVar(w1) )
261 { if ( unlikely(tTop+1 >= tMax) )
262 { rc = TRAIL_OVERFLOW;
263 goto out_fail;
264 }
265
266 if ( isVar(w2) )
267 { if ( t1 < t2 ) /* always point downwards */
268 { Trail(t2, makeRef(t1));
269 continue;
270 }
271 if ( t1 == t2 )
272 continue;
273 Trail(t1, makeRef(t2));
274 continue;
275 }
276 #ifdef O_ATTVAR
277 if ( isAttVar(w2 ) )
278 w2 = makeRef(t2);
279 #endif
280 Trail(t1, w2);
281 continue;
282 }
283 if ( isVar(w2) )
284 { if ( unlikely(tTop+1 >= tMax) )
285 { rc = TRAIL_OVERFLOW;
286 goto out_fail;
287 }
288 #ifdef O_ATTVAR
289 if ( isAttVar(w1) )
290 w1 = makeRef(t1);
291 #endif
292 Trail(t2, w1);
293 continue;
294 }
295
296 #ifdef O_ATTVAR
297 if ( isAttVar(w1) )
298 { if ( !hasGlobalSpace(0) )
299 { rc = overflowCode(0);
300 goto out_fail;
301 }
302 assignAttVar(t1, t2 PASS_LD);
303 continue;
304 }
305 if ( isAttVar(w2) )
306 { if ( !hasGlobalSpace(0) )
307 { rc = overflowCode(0);
308 goto out_fail;
309 }
310 assignAttVar(t2, t1 PASS_LD);
311 continue;
312 }
313 #endif
314
315 if ( w1 == w2 )
316 continue;
317 if ( tag(w1) != tag(w2) )
318 goto out_fail;
319
320 switch(tag(w1))
321 { case TAG_ATOM:
322 goto out_fail;
323 case TAG_INTEGER:
324 if ( storage(w1) == STG_INLINE ||
325 storage(w2) == STG_INLINE )
326 goto out_fail;
327 case TAG_STRING:
328 case TAG_FLOAT:
329 if ( equalIndirect(w1, w2) )
330 continue;
331 goto out_fail;
332 case TAG_COMPOUND:
333 { Functor f1 = valueTerm(w1);
334 Functor f2 = valueTerm(w2);
335 int arity;
336
337 #if O_CYCLIC
338 while ( isRef(f1->definition) )
339 f1 = (Functor)unRef(f1->definition);
340 while ( isRef(f2->definition) )
341 f2 = (Functor)unRef(f2->definition);
342 if ( f1 == f2 )
343 continue;
344 #endif
345
346 if ( f1->definition != f2->definition )
347 goto out_fail;
348 arity = arityFunctor(f1->definition);
349
350 if ( !compound )
351 { compound = TRUE;
352 initCyclic(PASS_LD1);
353 initTermAgendaLR(&agenda, arity, f1->arguments, f2->arguments);
354 } else
355 { if ( !pushWorkAgendaLR(&agenda, arity, f1->arguments, f2->arguments) )
356 { rc = MEMORY_OVERFLOW;
357 goto out_fail;
358 }
359 }
360
361 linkTermsCyclic(f1, f2 PASS_LD);
362
363 continue;
364 }
365 }
366 } while(compound && nextTermAgendaLR(&agenda, &t1, &t2));
367
368 rc = TRUE;
369
370 out_fail:
371 if ( compound )
372 { clearTermAgendaLR(&agenda);
373 exitCyclic(PASS_LD1);
374 }
375 return rc;
376 }
377
378
379 static int
raw_unify_ptrs(Word t1,Word t2 ARG_LD)380 raw_unify_ptrs(Word t1, Word t2 ARG_LD)
381 { switch(LD->prolog_flag.occurs_check)
382 { case OCCURS_CHECK_FALSE:
383 return do_unify(t1, t2 PASS_LD);
384 case OCCURS_CHECK_TRUE:
385 return unify_with_occurs_check(t1, t2, OCCURS_CHECK_TRUE PASS_LD);
386 case OCCURS_CHECK_ERROR:
387 return unify_with_occurs_check(t1, t2, OCCURS_CHECK_ERROR PASS_LD);
388 default:
389 assert(0);
390 fail;
391 }
392 }
393
394
395 static
396 PRED_IMPL("=", 2, unify, 0)
397 { PRED_LD
398
399 return PL_unify(A1, A2);
400 }
401
402
403 static
404 PRED_IMPL("\\=", 2, not_unify, 0)
405 { PRED_LD
406 Word p1 = valTermRef(A1);
407 Word p2 = p1+1;
408 word w1, w2;
409 term_t ex;
410
411 deRef(p1); w1 = *p1;
412 deRef(p2); w2 = *p2;
413
414 if ( isVar(w1) || isVar(w2) )
415 { if ( LD->prolog_flag.occurs_check == OCCURS_CHECK_FALSE )
416 return FALSE; /* can unify */
417 goto full_check;
418 }
419 if ( w1 == w2 )
420 return FALSE;
421 if ( isAttVar(w1) || isAttVar(w2) )
422 goto full_check;
423 if ( tag(w1) != tag(w2) )
424 return TRUE;
425
426 switch(tag(w1))
427 { case TAG_ATOM:
428 return TRUE;
429 case TAG_INTEGER:
430 if ( storage(w1) == STG_INLINE ||
431 storage(w2) == STG_INLINE )
432 return TRUE;
433 case TAG_STRING:
434 case TAG_FLOAT:
435 return !equalIndirect(w1, w2);
436 case TAG_COMPOUND:
437 break;
438 }
439
440 full_check:
441 ex = PL_new_term_ref();
442
443 if ( can_unify(p1, p2, ex) )
444 return FALSE;
445 if ( !PL_is_variable(ex) )
446 return PL_raise_exception(ex);
447 return TRUE;
448 }
449
450
451 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
452 Public unification procedure for `raw' data. See also PL_unify().
453
454 Return:
455
456 - TRUE: success
457 - If (flags&ALLOW_RETCODE), one of
458 - FALSE: unification failure
459 - *_OVERFLOW: stack or memory overflow
460 Else
461 - FALSE: unification failure or raised exception
462 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
463
464 int
unify_ptrs(Word t1,Word t2,int flags ARG_LD)465 unify_ptrs(Word t1, Word t2, int flags ARG_LD)
466 { for(;;)
467 { int rc;
468
469 rc = raw_unify_ptrs(t1, t2 PASS_LD);
470 if ( rc >= 0 )
471 return rc;
472
473 if ( !(flags&ALLOW_RETCODE) )
474 { if ( rc == MEMORY_OVERFLOW )
475 { return PL_no_memory();
476 } else /* Stack overflow */
477 { int rc2;
478
479 PushPtr(t1); PushPtr(t2);
480 rc2 = makeMoreStackSpace(rc, flags);
481 PopPtr(t2); PopPtr(t1);
482 if ( !rc2 )
483 return FALSE;
484 }
485 } else
486 return rc; /* return error code */
487 }
488 }
489
490
491 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
492 can_unify(t1, t2, ex) succeeds if two terms *can* be unified, without
493 actually doing so. This is basically a stripped version of unify()
494 above. See this function for comments. Note that we have to execute
495 delayed goals and these may raise an exception. If this happens, ex is
496 set to the exception term.
497
498 If ex = 0, a possible exception is ignored and cleared.
499 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
500
501 bool
can_unify(Word t1,Word t2,term_t ex)502 can_unify(Word t1, Word t2, term_t ex)
503 { GET_LD
504 fid_t fid;
505
506 if ( (fid = PL_open_foreign_frame()) )
507 { int handle_exception = !ex;
508
509 if ( !ex )
510 ex = PL_new_term_ref();
511
512 if ( unify_ptrs(t1, t2, ALLOW_GC|ALLOW_SHIFT PASS_LD) &&
513 foreignWakeup(ex PASS_LD) )
514 { PL_discard_foreign_frame(fid);
515 return TRUE;
516 }
517
518 if ( exception_term && isVar(*valTermRef(ex)) )
519 PL_put_term(ex, exception_term);
520 if ( !handle_exception && !isVar(*valTermRef(ex)) )
521 PL_clear_exception();
522
523 PL_discard_foreign_frame(fid);
524 }
525
526 return FALSE;
527 }
528
529
530 /*******************************
531 * OCCURS-CHECK *
532 *******************************/
533
534 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
535 int var_occurs_in(Word v, Word t)
536
537 Succeeds of the term `v' occurs in `t'. v must be dereferenced on
538 entry. Returns one of
539
540 - FALSE if v does not occur in t
541 - TRUE if v occurs in t
542 - MEMORY_OVERFLOW if the malloc() fails.
543 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
544
545 static int
var_occurs_in(Word v,Word t ARG_LD)546 var_occurs_in(Word v, Word t ARG_LD)
547 { segstack visited;
548 Functor tmp[256];
549 term_agenda agenda;
550 int compound = FALSE;
551 int rc = FALSE;
552
553 deRef(t);
554 if ( v == t )
555 { if ( isTerm(*t) )
556 goto unified;
557
558 return FALSE;
559 }
560
561 do
562 { if ( v == t )
563 { rc = TRUE;
564 break;
565 }
566
567 unified:
568 if ( isTerm(*t) )
569 { Functor f = valueTerm(*t);
570 int arity = arityFunctor(f->definition);
571
572 if ( !compound )
573 { compound = TRUE;
574 initSegStack(&visited, sizeof(Functor), sizeof(tmp), tmp);
575 f->definition |= FIRST_MASK;
576 if ( !pushSegStack(&visited, f, Functor) )
577 outOfCore();
578 initTermAgenda(&agenda, arity, f->arguments);
579 } else if ( !(f->definition & FIRST_MASK) )
580 { f->definition |= FIRST_MASK;
581 if ( !pushSegStack(&visited, f, Functor) ||
582 !pushWorkAgenda(&agenda, arity, f->arguments) )
583 return MEMORY_OVERFLOW;
584 }
585 }
586 } while( compound && (t=nextTermAgenda(&agenda)) );
587
588 if ( compound )
589 { Functor f;
590
591 while( popSegStack(&visited, &f, Functor) )
592 f->definition &= ~FIRST_MASK;
593 clearTermAgenda(&agenda);
594 }
595
596 return rc;
597 }
598
599
600 int
PL_var_occurs_in(term_t var,term_t value)601 PL_var_occurs_in(term_t var, term_t value)
602 { GET_LD
603 Word v = valTermRef(var);
604
605 deRef(v);
606
607 return var_occurs_in(v, valTermRef(value) PASS_LD);
608 }
609
610
611 static int
failed_unify_with_occurs_check(Word t1,Word t2,occurs_check_t mode ARG_LD)612 failed_unify_with_occurs_check(Word t1, Word t2, occurs_check_t mode ARG_LD)
613 { int rc;
614
615 if ( mode == OCCURS_CHECK_TRUE )
616 fail;
617
618 deRef(t1);
619 deRef(t2);
620 if ( isVar(*t2) ) /* try to make Var = Term */
621 { Word tmp = t1;
622
623 t1 = t2;
624 t2 = tmp;
625 }
626
627 blockGC(0 PASS_LD);
628 rc = PL_error(NULL, 0, NULL, ERR_OCCURS_CHECK, t1, t2);
629 unblockGC(0 PASS_LD);
630
631 return rc;
632 }
633
634
635 static int
unify_with_occurs_check(Word t1,Word t2,occurs_check_t mode ARG_LD)636 unify_with_occurs_check(Word t1, Word t2, occurs_check_t mode ARG_LD)
637 { mark m;
638 int rc;
639
640 deRef(t1);
641 deRef(t2);
642 if ( canBind(*t1) )
643 { if ( onStack(global, t1) && var_occurs_in(t1, t2 PASS_LD) )
644 return failed_unify_with_occurs_check(t1, t2, mode PASS_LD);
645 return do_unify(t1, t2 PASS_LD);
646 }
647 if ( canBind(*t2) )
648 { if ( onStack(global, t2) && var_occurs_in(t2, t1 PASS_LD) )
649 return failed_unify_with_occurs_check(t1, t2, mode PASS_LD);
650 return do_unify(t1, t2 PASS_LD);
651 }
652
653 Mark(m);
654 rc = do_unify(t1, t2 PASS_LD);
655 DiscardMark(m);
656
657 if ( rc == TRUE )
658 { TrailEntry tt = tTop;
659 TrailEntry mt = m.trailtop;
660
661 while(--tt >= mt)
662 { Word p = tt->address;
663 Word p2;
664
665 if ( isTrailVal(p) ) /* assignment of an attvars */
666 { p = (--tt)->address;
667
668 if ( isTrailVal((--tt)->address) ) /* tail of wakeup list */
669 tt--;
670 if ( isTrailVal((--tt)->address) ) /* head of wakeup list */
671 tt--;
672 }
673
674 deRef2(p, p2);
675 if ( var_occurs_in(p2, p2 PASS_LD) )
676 { if ( mode == OCCURS_CHECK_ERROR )
677 { Word t = allocGlobalNoShift(1);
678
679 if ( !t )
680 return GLOBAL_OVERFLOW;
681 *t = *p2;
682 Undo(m);
683 rc = failed_unify_with_occurs_check(p, t, mode PASS_LD);
684 }
685 rc = FALSE;
686 break;
687 }
688 }
689 }
690
691 return rc;
692 }
693
694
695 static
696 PRED_IMPL("unify_with_occurs_check", 2, unify_with_occurs_check, 0)
697 { PRED_LD
698 occurs_check_t old = LD->prolog_flag.occurs_check;
699 int rc;
700
701 LD->prolog_flag.occurs_check = OCCURS_CHECK_TRUE;
702 rc = PL_unify(A1, A2);
703 LD->prolog_flag.occurs_check = old;
704
705 return rc;
706 }
707
708
709 /********************************
710 * TYPE CHECKING *
711 *********************************/
712
713 static
714 PRED_IMPL("nonvar", 1, nonvar, 0)
715 { PRED_LD
716 return PL_is_variable(A1) ? FALSE : TRUE;
717 }
718
719 static
720 PRED_IMPL("var", 1, var, 0)
721 { PRED_LD
722 return PL_is_variable(A1);
723 }
724
725 static
726 PRED_IMPL("integer", 1, integer, 0)
727 { return PL_is_integer(A1);
728 }
729
730 static
731 PRED_IMPL("float", 1, float, 0)
732 { return PL_is_float(A1);
733 }
734
735 static
736 PRED_IMPL("rational", 1, rational, 0)
737 { return PL_is_rational(A1);
738 }
739
740
741 #if O_STRING
742 static
743 PRED_IMPL("string", 1, string, 0)
744 { return PL_is_string(A1);
745 }
746 #endif /* O_STRING */
747
748 static
749 PRED_IMPL("number", 1, number, 0)
750 { return PL_is_number(A1);
751 }
752
753 static
754 PRED_IMPL("atom", 1, atom, 0)
755 { PRED_LD
756 return PL_is_atom(A1);
757 }
758
759 static
760 PRED_IMPL("atomic", 1, atomic, 0)
761 { PRED_LD
762 return PL_is_atomic(A1);
763 }
764
765
766 /*******************************
767 * GROUND *
768 *******************************/
769
770 typedef enum
771 { ph_mark,
772 ph_unmark
773 } phase;
774
775 static inline int
ph_visitedWord(Word p,phase ph)776 ph_visitedWord(Word p, phase ph)
777 { switch(ph)
778 { case ph_mark:
779 if ( is_marked(p) )
780 succeed;
781 set_marked(p);
782 break;
783 case ph_unmark:
784 if ( !is_marked(p) )
785 succeed;
786 clear_marked(p);
787 }
788 fail;
789 }
790
791 static inline int
ph_visited(Functor f,phase ph)792 ph_visited(Functor f, phase ph)
793 { Word p = &f->definition;
794
795 return ph_visitedWord(p, ph);
796 }
797
798
799 static Word
ph_ground(Word p,phase ph ARG_LD)800 ph_ground(Word p, phase ph ARG_LD) /* Phase 1 marking */
801 { term_agenda agenda;
802
803 initTermAgenda(&agenda, 1, p);
804 while((p=nextTermAgenda(&agenda)))
805 { if ( canBind(*p) )
806 { clearTermAgenda(&agenda);
807 return p;
808 }
809 if ( isTerm(*p) )
810 { Functor f = valueTerm(*p);
811
812 if ( !ph_visited(f, ph) )
813 { pushWorkAgenda(&agenda, arityFunctor(f->definition), f->arguments);
814 }
815 }
816 }
817
818 return NULL;
819 }
820
821
822 Word
ground__LD(Word p ARG_LD)823 ground__LD(Word p ARG_LD)
824 { Word rc1, rc2;
825
826 deRef(p);
827 if ( canBind(*p) )
828 return p;
829 if ( !isTerm(*p) )
830 return NULL;
831
832 rc1 = ph_ground(p, ph_mark PASS_LD); /* mark functors */
833 rc2 = ph_ground(p, ph_unmark PASS_LD); /* unmark the very same functors */
834 assert(rc1 == rc2);
835 return rc1;
836 }
837
838
839 int
PL_is_ground(term_t t)840 PL_is_ground(term_t t)
841 { GET_LD
842
843 return ground__LD(valTermRef(t) PASS_LD) == NULL;
844 }
845
846
847 static
848 PRED_IMPL("ground", 1, ground, PL_FA_ISO)
849 { PRED_LD
850
851 return ground__LD(valTermRef(A1) PASS_LD) == NULL;
852 }
853
854 static
855 PRED_IMPL("nonground", 2, nonground, 0)
856 { PRED_LD
857 Word p;
858
859 if ( (p=ground__LD(valTermRef(A1) PASS_LD)) )
860 return unify_ptrs(valTermRef(A2), p, ALLOW_GC|ALLOW_SHIFT PASS_LD);
861
862 return FALSE;
863 }
864
865
866 static
867 PRED_IMPL("compound", 1, compound, 0)
868 { return PL_is_compound(A1);
869 }
870
871
872 static
873 PRED_IMPL("callable", 1, callable, PL_FA_ISO)
874 { return PL_is_callable(A1);
875 }
876
877
878 /*******************************
879 * COMPLEXITY *
880 *******************************/
881
882 static size_t
term_size(Word p,size_t max ARG_LD)883 term_size(Word p, size_t max ARG_LD)
884 { size_t count = 0;
885 term_agenda agenda;
886 Word t;
887
888 initvisited(PASS_LD1);
889 initTermAgenda(&agenda, 1, p);
890
891 while((t=nextTermAgenda(&agenda)))
892 { if ( isAttVar(*t) )
893 { Word p = valPAttVar(*t);
894
895 if ( ++count > max )
896 break;
897
898 assert(onGlobalArea(p));
899 pushWorkAgenda(&agenda, 1, p);
900 } else if ( isIndirect(*t) )
901 { Word p = addressIndirect(*t);
902
903 count += wsizeofInd(*p)+2;
904 if ( count > max )
905 break;
906 } else if ( isTerm(*t) )
907 { Functor f = valueTerm(*t);
908 size_t arity = arityFunctor(f->definition);
909
910 if ( visited(f PASS_LD) )
911 continue;
912
913 count += arity+1;
914 if ( count > max )
915 break;
916
917 pushWorkAgenda(&agenda, arity, f->arguments);
918 }
919 }
920
921 clearTermAgenda(&agenda);
922 unvisit(PASS_LD1);
923
924 return count;
925 }
926
927
928 /** $term_size(+Term, +Max, -Size)
929
930 Size represents the total size of Term on the stack, counted in cells.
931 */
932
933 static
934 PRED_IMPL("$term_size", 3, term_size, 0)
935 { PRED_LD
936 size_t c, m;
937 term_t t = A1;
938 term_t mx = A2;
939 term_t count = A3;
940
941 if ( PL_is_variable(mx) )
942 m = (size_t)-1;
943 else if ( !PL_get_size_ex(mx, &m) )
944 return FALSE;
945
946 c = term_size(valTermRef(t), m PASS_LD);
947 if ( c > m )
948 return FALSE;
949
950 return PL_unify_integer(count, c);
951 }
952
953
954 /*******************************
955 * CYCLIC *
956 *******************************/
957
958 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
959 A DFS search is used to iterate over all 'term chains' in a term graph.
960 A term chain is a list of terms where term N+1 is the last argument of
961 term N. Terms are 'TEMP' marked as we find them. When the end of a term
962 chain has been reached all terms in the chain are 'PERM' marked as we
963 know that all terms in that chain are acyclic. If we reach a term that
964 was already TEMP marked then we terminate the search as a cycle has been
965 detected. If we reach a term that has already been PERM marked then we
966 backtrack as a shared term that we know to be acyclic has been reached.
967
968 Two strategies are used to avoid repeated pop+push cycles of the same
969 term chain:
970
971 1. aggressively cache new term chains for all args of the tail term.
972 2. only cache the current term chain if we know at least one arg of the
973 tail term is itself a term.
974
975 Author: Keri Harris
976 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
977
978 #define ACYCLIC_TEMP_MASK FIRST_MASK
979 #define ACYCLIC_PERM_MASK MARK_MASK
980
981 #define set_acyclic_temp(p) do { *(p) |= ACYCLIC_TEMP_MASK; } while(0)
982 #define set_acyclic_perm(p) do { *(p) |= ACYCLIC_PERM_MASK; } while(0)
983
984 #define clear_acyclic_temp(p) do { *(p) &= ~ACYCLIC_TEMP_MASK; } while(0)
985 #define clear_acyclic_perm(p) do { *(p) &= ~ACYCLIC_PERM_MASK; } while(0)
986 #define clear_acyclic_both(p) \
987 do { *(p) &= ~(ACYCLIC_TEMP_MASK|ACYCLIC_PERM_MASK); } while(0)
988
989 #define is_acyclic_temp(p) (*(p) & ACYCLIC_TEMP_MASK)
990 #define is_acyclic_perm(p) (*(p) & ACYCLIC_PERM_MASK)
991 #define is_acyclic_or_temp(p) (*(p) & (ACYCLIC_TEMP_MASK|ACYCLIC_PERM_MASK))
992
993 typedef struct termChain
994 { Functor head;
995 Functor tail;
996 Word p;
997 } termChain;
998
999 typedef struct term_chain_agenda
1000 { termChain work;
1001 segstack stack;
1002 } term_chain_agenda;
1003
1004
1005 static int
ph_acyclic_mark(Word p ARG_LD)1006 ph_acyclic_mark(Word p ARG_LD)
1007 { term_chain_agenda agenda;
1008 termChain chains[32];
1009 Functor top = valueTerm(*p);
1010 Functor head = top;
1011 Functor tail = top;
1012 Functor iter;
1013 Word pdef;
1014 int arity;
1015
1016 initSegStack(&agenda.stack, sizeof(termChain), sizeof(chains), chains);
1017
1018 while ( TRUE )
1019 { if ( is_acyclic_temp(&tail->definition) )
1020 { if ( is_acyclic_perm(&tail->definition) )
1021 { goto end_of_chain;
1022 } else
1023 { clearSegStack(&agenda.stack);
1024 return FALSE;
1025 }
1026 }
1027
1028 set_acyclic_temp(&tail->definition);
1029
1030 arity = arityFunctor(tail->definition);
1031
1032 if ( arity > 1 )
1033 { int i;
1034 int new_workspace = FALSE;
1035
1036 iter = tail;
1037 for( i = arity-2; i >= 0; i-- )
1038 { p = iter->arguments + i;
1039 deRef(p);
1040
1041 if ( isTerm(*p) )
1042 { if ( !new_workspace )
1043 { if ( !pushSegStack(&agenda.stack, agenda.work, termChain) )
1044 outOfCore();
1045 agenda.work.head = head;
1046 agenda.work.tail = tail;
1047 agenda.work.p = iter->arguments + arity-1;
1048
1049 head = tail = valueTerm(*p);
1050 new_workspace = TRUE;
1051 } else
1052 { if ( !pushSegStack(&agenda.stack, agenda.work, termChain) )
1053 outOfCore();
1054 agenda.work.head = agenda.work.tail = valueTerm(*p);
1055 agenda.work.p = NULL;
1056 }
1057 }
1058 }
1059
1060 if ( new_workspace )
1061 continue;
1062 }
1063
1064 p = tail->arguments + arity-1;
1065 deRef(p);
1066
1067 process_p:
1068 if ( isTerm(*p) )
1069 { tail = valueTerm(*p);
1070 } else
1071 {
1072 end_of_chain:
1073
1074 if ( head == top )
1075 return TRUE;
1076
1077 iter = head;
1078 pdef = &iter->definition;
1079 while ( iter != tail )
1080 { set_acyclic_perm(pdef);
1081
1082 p = iter->arguments + arityFunctor(*pdef) - 1;
1083 deRef(p);
1084 iter = valueTerm(*p);
1085 pdef = &iter->definition;
1086 }
1087 set_acyclic_perm(pdef);
1088
1089 head = agenda.work.head;
1090 tail = agenda.work.tail;
1091 p = agenda.work.p;
1092
1093 if ( !popSegStack(&agenda.stack, &agenda.work, termChain) )
1094 { assert(0);
1095 }
1096
1097 if ( p )
1098 { deRef(p);
1099 goto process_p;
1100 }
1101 }
1102 }
1103
1104 return TRUE;
1105 }
1106
1107
1108 static int
ph_acyclic_unmark(Word p ARG_LD)1109 ph_acyclic_unmark(Word p ARG_LD)
1110 { term_agenda agenda;
1111
1112 initTermAgenda(&agenda, 1, p);
1113 while((p=nextTermAgenda(&agenda)))
1114 { if ( isTerm(*p) )
1115 { Functor f = valueTerm(*p);
1116 Word p = &f->definition;
1117
1118 if ( is_acyclic_temp(p) )
1119 { clear_acyclic_both(p);
1120 } else
1121 { continue;
1122 }
1123
1124 pushWorkAgenda(&agenda, arityFunctor(f->definition), f->arguments);
1125 }
1126 }
1127
1128 return TRUE;
1129 }
1130
1131
1132 int
is_acyclic(Word p ARG_LD)1133 is_acyclic(Word p ARG_LD)
1134 { int rc1;
1135
1136 deRef(p);
1137 if ( isTerm(*p) )
1138 { rc1 = ph_acyclic_mark(p PASS_LD);
1139 ph_acyclic_unmark(p PASS_LD);
1140
1141 return rc1;
1142 }
1143
1144 return TRUE;
1145 }
1146
1147
1148 static int
PL_is_acyclic__LD(term_t t ARG_LD)1149 PL_is_acyclic__LD(term_t t ARG_LD)
1150 { int rc;
1151
1152 if ( (rc=is_acyclic(valTermRef(t) PASS_LD)) == TRUE )
1153 return TRUE;
1154
1155 if ( rc == MEMORY_OVERFLOW )
1156 rc = PL_error(NULL, 0, NULL, ERR_NOMEM);
1157
1158 return rc;
1159 }
1160
1161
1162 int
PL_is_acyclic(term_t t)1163 PL_is_acyclic(term_t t)
1164 { GET_LD
1165
1166 return PL_is_acyclic__LD(t PASS_LD);
1167 }
1168
1169
1170 static
1171 PRED_IMPL("acyclic_term", 1, acyclic_term, PL_FA_ISO)
1172 { PRED_LD
1173
1174 return PL_is_acyclic__LD(A1 PASS_LD);
1175 }
1176
1177
1178 static
1179 PRED_IMPL("cyclic_term", 1, cyclic_term, 0)
1180 { PRED_LD
1181 int rc;
1182
1183 if ( (rc=is_acyclic(valTermRef(A1) PASS_LD)) == TRUE )
1184 return FALSE;
1185 if ( rc == FALSE )
1186 return TRUE;
1187
1188 return PL_error(NULL, 0, NULL, ERR_NOMEM);
1189 }
1190
1191
1192 /*******************************
1193 * FACTORIZE *
1194 *******************************/
1195
1196 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1197 Factorizing a term based on the internal sharing. This takes the
1198 following steps:
1199
1200 1. scan_shared() walks the term and
1201 a. Set MARK_MASK on all visited terms and FIRST_MASK on those find
1202 twice.
1203 b. Create a list Var=Term for all terms found twice.
1204 c. Returns the count of places that must be shared.
1205 2. reverse_factor_pointers() walks through the created list, placing
1206 the functor in Var and creating a reference from the location of
1207 the original functor.
1208 3. link_shared() walks the term and
1209 a. If the functor is a reference, follow the reference-chain to
1210 find the functor. Link the term into the reference-chain.
1211 b. If the functor is marked, unmark it.
1212 4. restore_shared_functors() finishes the job by following the
1213 variable-list and putting all functors from the variable back
1214 into the term and setting the variable to be a real variable.
1215 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1216
1217 static int
scan_shared(Word t,Word vart,size_t * count ARG_LD)1218 scan_shared(Word t, Word vart, size_t *count ARG_LD)
1219 { term_agenda agenda;
1220 size_t shared = 0;
1221 Word p;
1222
1223 initTermAgenda(&agenda, 1, t);
1224 while( (p=nextTermAgenda(&agenda)) )
1225 { if ( isTerm(*p) )
1226 { Functor f = valueTerm(*p);
1227 Word d = &f->definition;
1228
1229 if ( is_marked(d) )
1230 { if ( !is_first(d) )
1231 { Word v;
1232
1233 if ( !(v=allocGlobalNoShift(6)) )
1234 return GLOBAL_OVERFLOW;
1235
1236 v[0] = FUNCTOR_dot2;
1237 v[1] = consPtr(&v[3], TAG_COMPOUND|STG_GLOBAL);
1238 v[2] = ATOM_nil;
1239 v[3] = FUNCTOR_equals2;
1240 v[4] = 0; /* For now */
1241 v[5] = consPtr(d, TAG_COMPOUND|STG_GLOBAL);
1242
1243 *vart = consPtr(&v[0], TAG_COMPOUND|STG_GLOBAL);
1244 vart = &v[2];
1245
1246 set_first(d);
1247 shared++; /* this is already the second one */
1248 }
1249 shared++;
1250 } else
1251 { int arity = arityFunctor(f->definition);
1252
1253 pushWorkAgenda(&agenda, arity, f->arguments);
1254 set_marked(d);
1255 }
1256 }
1257 }
1258 clearTermAgenda(&agenda);
1259 *count = shared;
1260
1261 return TRUE;
1262 }
1263
1264
1265 /* Needed to restore if we run out of stack
1266 */
1267
1268 static int
unscan_shared(Word t ARG_LD)1269 unscan_shared(Word t ARG_LD)
1270 { term_agenda agenda;
1271 Word p;
1272
1273 initTermAgenda(&agenda, 1, t);
1274 while( (p=nextTermAgenda(&agenda)) )
1275 { if ( isTerm(*p) )
1276 { Functor f = valueTerm(*p);
1277 Word d = &f->definition;
1278
1279 if ( is_marked(d) )
1280 { int arity;
1281
1282 clear_marked(d);
1283 clear_first(d);
1284 arity = arityFunctor(f->definition);
1285 pushWorkAgenda(&agenda, arity, f->arguments);
1286 }
1287 }
1288 }
1289 clearTermAgenda(&agenda);
1290
1291 return TRUE;
1292 }
1293
1294
1295 static void
reverse_factor_pointers(Word vars ARG_LD)1296 reverse_factor_pointers(Word vars ARG_LD)
1297 { while(*vars != ATOM_nil)
1298 { Word v = (Word)valueTerm(*vars);
1299 Functor t = valueTerm(v[5]);
1300
1301 v[4] = t->definition & ~(MARK_MASK|FIRST_MASK); /* v[4] is the variable */
1302 t->definition = makeRefG(&v[4])|MARK_MASK|FIRST_MASK;
1303
1304 vars = &v[2];
1305 }
1306 }
1307
1308
1309 static void
restore_shared_functors(Word vars ARG_LD)1310 restore_shared_functors(Word vars ARG_LD)
1311 { while(*vars != ATOM_nil)
1312 { Word v = (Word)valueTerm(*vars);
1313 Functor t = valueTerm(v[5]);
1314 Word p = &v[4];
1315
1316 deRef(p);
1317 t->definition = *p;
1318 setVar(*p);
1319
1320 vars = &v[2];
1321 }
1322 }
1323
1324
1325 static int
link_shared(Word t ARG_LD)1326 link_shared(Word t ARG_LD)
1327 { term_agenda agenda;
1328 Word p;
1329
1330 initTermAgenda(&agenda, 1, t);
1331 while( (p=nextTermAgenda(&agenda)) )
1332 { if ( isTerm(*p) )
1333 { Functor f = valueTerm(*p);
1334 Word d = &f->definition;
1335
1336 if ( isRef(*d) ) /* shared term */
1337 { Word v;
1338
1339 v = unRef(*d & ~(FIRST_MASK|MARK_MASK));
1340 deRef(v);
1341
1342 if ( is_marked(d) )
1343 { int arity = arityFunctor(*v);
1344 pushWorkAgenda(&agenda, arity, f->arguments);
1345 }
1346
1347 if ( v < p )
1348 { TrailAssignment(p);
1349 *p = makeRefG(v);
1350 } else
1351 { TrailAssignment(p);
1352 *p = *v;
1353 *v = makeRefG(p);
1354 }
1355 } else if ( is_marked(d) )
1356 { int arity;
1357 word fun = f->definition & ~(FIRST_MASK|MARK_MASK);
1358
1359 clear_marked(d);
1360 arity = arityFunctor(fun);
1361 pushWorkAgenda(&agenda, arity, f->arguments);
1362 }
1363 }
1364 }
1365 clearTermAgenda(&agenda);
1366
1367 return TRUE;
1368 }
1369
1370
1371 int
PL_factorize_term(term_t term,term_t template,term_t factors)1372 PL_factorize_term(term_t term, term_t template, term_t factors)
1373 { GET_LD
1374 fid_t fid;
1375 term_t vars, wrapped;
1376 Word t;
1377 size_t count;
1378 int rc;
1379
1380 for(;;)
1381 { if ( !(fid = PL_open_foreign_frame()) ||
1382 !(wrapped = PL_new_term_ref()) ||
1383 !(vars = PL_new_term_ref()) ||
1384 !PL_unify_term(wrapped, PL_FUNCTOR, FUNCTOR_var1, PL_TERM, term) )
1385 return FALSE;
1386
1387 PL_put_nil(vars);
1388 t = valTermRef(wrapped);
1389
1390 DEBUG(CHK_SECURE, checkStacks(NULL));
1391 startCritical;
1392 switch( (rc=scan_shared(t, valTermRef(vars), &count PASS_LD)) )
1393 { case TRUE:
1394 if ( tTop + 2*count > tMax )
1395 rc = TRAIL_OVERFLOW;
1396 else if ( gTop + count > gMax )
1397 rc = GLOBAL_OVERFLOW;
1398 else
1399 break;
1400 /*FALLTHROUGH*/
1401 default:
1402 unscan_shared(t PASS_LD);
1403 PL_discard_foreign_frame(fid);
1404 if ( !endCritical ||
1405 !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
1406 return FALSE;
1407 continue;
1408 }
1409
1410 break;
1411 }
1412
1413 reverse_factor_pointers(valTermRef(vars) PASS_LD);
1414 link_shared(t PASS_LD);
1415 restore_shared_functors(valTermRef(vars) PASS_LD);
1416 PL_close_foreign_frame(fid);
1417 DEBUG(CHK_SECURE, checkStacks(NULL));
1418
1419 if ( !endCritical )
1420 return FALSE;
1421
1422 _PL_get_arg(1, wrapped, wrapped);
1423 return ( PL_unify(template, wrapped) &&
1424 PL_unify(factors, vars) );
1425 }
1426
1427 static
1428 PRED_IMPL("$factorize_term", 3, factorize_term, 0)
1429 { return PL_factorize_term(A1, A2, A3);
1430 }
1431
1432 /*******************************
1433 * META-CALL SUPPORT *
1434 *******************************/
1435
1436 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1437 deterministic(-Bool)
1438
1439 Bool = true if no choicepoint has been created in the current clause.
1440 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1441
1442 static
1443 PRED_IMPL("deterministic", 1, deterministic, 0)
1444 { PRED_LD
1445 LocalFrame FR = environment_frame->parent;
1446 Choice BFR = LD->choicepoints;
1447
1448 for( ; BFR; BFR = BFR->parent)
1449 { switch(BFR->type)
1450 { case CHP_CLAUSE:
1451 if ( BFR->frame == FR )
1452 return PL_unify_atom(A1, ATOM_true);
1453 case CHP_JUMP:
1454 if ( (void *)BFR > (void *)FR )
1455 return PL_unify_atom(A1, ATOM_false);
1456 else
1457 return PL_unify_atom(A1, ATOM_true);
1458 default:
1459 continue;
1460 }
1461 }
1462
1463 return PL_unify_atom(A1, ATOM_true);
1464 }
1465
1466
1467 #ifdef O_TERMHASH
1468 /*******************************
1469 * TERM-HASH *
1470 *******************************/
1471
1472 static bool
termHashValue(word term,long depth,unsigned int * hval ARG_LD)1473 termHashValue(word term, long depth, unsigned int *hval ARG_LD)
1474 { for(;;)
1475 { switch(tag(term))
1476 { case TAG_VAR:
1477 case TAG_ATTVAR:
1478 fail;
1479 case TAG_ATOM:
1480 { *hval = MurmurHashAligned2(&atomValue(term)->hash_value,
1481 sizeof(unsigned int), *hval);
1482 succeed;
1483 }
1484 case TAG_STRING:
1485 { size_t len;
1486 char *s;
1487
1488 s = getCharsString(term, &len);
1489 *hval = MurmurHashAligned2(s, len, *hval);
1490
1491 succeed;
1492 }
1493 case TAG_INTEGER:
1494 if ( storage(term) == STG_INLINE )
1495 { int64_t v = valInt(term);
1496
1497 *hval = MurmurHashAligned2(&v, sizeof(v), *hval);
1498
1499 succeed;
1500 }
1501 /*FALLTHROUGH*/
1502 case TAG_FLOAT:
1503 { Word p = addressIndirect(term);
1504 size_t n = wsizeofInd(*p);
1505
1506 *hval = MurmurHashAligned2(p+1, n*sizeof(word), *hval);
1507
1508 succeed;
1509 }
1510 case TAG_COMPOUND:
1511 { Functor t = valueTerm(term);
1512 FunctorDef fd;
1513 int arity;
1514 Word p;
1515 unsigned int atom_hashvalue;
1516
1517 if ( visited(t PASS_LD) )
1518 { *hval = MurmurHashAligned2(hval, sizeof(*hval), *hval);
1519 succeed;
1520 }
1521
1522 fd = valueFunctor(t->definition);
1523 arity = fd->arity;
1524
1525 atom_hashvalue = atomValue(fd->name)->hash_value + arity;
1526 *hval = MurmurHashAligned2(&atom_hashvalue,
1527 sizeof(atom_hashvalue),
1528 *hval);
1529
1530 if ( --depth != 0 )
1531 { for(p = t->arguments; arity-- > 0; p++)
1532 { if ( !termHashValue(*p, depth, hval PASS_LD) )
1533 { popVisited(PASS_LD1);
1534 fail;
1535 }
1536 }
1537 }
1538
1539 popVisited(PASS_LD1);
1540 succeed;
1541 }
1542 case TAG_REFERENCE:
1543 { term = *unRef(term);
1544 continue;
1545 }
1546 default:
1547 assert(0);
1548 }
1549 }
1550 }
1551
1552
1553 /* term_hash(+Term, +Depth, +Range, -HashKey) */
1554
1555 static
1556 PRED_IMPL("term_hash", 4, term_hash4, 0)
1557 { PRED_LD
1558 Word p = valTermRef(A1);
1559 unsigned int hraw = MURMUR_SEED;
1560 long depth;
1561 int range;
1562 int rc = TRUE;
1563
1564 if ( !PL_get_long_ex(A2, &depth) )
1565 fail;
1566 if ( depth < -1 )
1567 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_zero, A2);
1568
1569 if ( !PL_get_integer_ex(A3, &range) )
1570 fail;
1571 if ( range < 1 )
1572 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_one, A2);
1573
1574 if ( depth != 0 )
1575 { initvisited(PASS_LD1);
1576 rc = termHashValue(*p, depth, &hraw PASS_LD);
1577 DEBUG(CHK_SECURE, assert(empty_visited(PASS_LD1)));
1578 }
1579
1580 if ( rc )
1581 { hraw = hraw % range;
1582
1583 return PL_unify_integer(A4, hraw);
1584 }
1585
1586 succeed;
1587 }
1588
1589 #endif /*O_TERMHASH*/
1590
1591
1592 /********************************
1593 * STANDARD ORDER *
1594 *********************************/
1595
1596 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1597 There are atoms of different type. We only define comparison between
1598 atoms of the same type, except for mixed ISO Latin-1 and UCS atoms.
1599 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1600
1601 int
compareAtoms(atom_t w1,atom_t w2)1602 compareAtoms(atom_t w1, atom_t w2)
1603 { Atom a1 = atomValue(w1);
1604 Atom a2 = atomValue(w2);
1605
1606 if ( a1->type == a2->type )
1607 { if ( a1->type->compare )
1608 { return (*a1->type->compare)(w1, w2);
1609 } else
1610 { size_t l = (a1->length <= a2->length ? a1->length : a2->length);
1611 int v;
1612
1613 if ( (v=memcmp(a1->name, a2->name, l)) != 0 )
1614 return v < 0 ? CMP_LESS : CMP_GREATER;
1615 return a1->length == a2->length ? CMP_EQUAL :
1616 a1->length < a2->length ? CMP_LESS : CMP_GREATER;
1617 }
1618 } else if ( true(a1->type, PL_BLOB_TEXT) &&
1619 true(a2->type, PL_BLOB_TEXT) )
1620 { PL_chars_t t1, t2;
1621 size_t len;
1622
1623 get_atom_text(w1, &t1);
1624 get_atom_text(w2, &t2);
1625 len = t1.length > t2.length ? t1.length : t2.length;
1626
1627 return PL_cmp_text(&t1, 0, &t2, 0, len);
1628 } else
1629 { return a1->type->rank == a2->type->rank ? CMP_EQUAL :
1630 a1->type->rank < a2->type->rank ? CMP_LESS : CMP_GREATER;
1631 }
1632 }
1633
1634
1635 static int
compareStrings(word w1,word w2 ARG_LD)1636 compareStrings(word w1, word w2 ARG_LD)
1637 { PL_chars_t t1, t2;
1638 size_t len;
1639
1640 get_string_text(w1, &t1 PASS_LD);
1641 get_string_text(w2, &t2 PASS_LD);
1642 len = (t1.length > t2.length ? t1.length : t2.length);
1643
1644 return PL_cmp_text(&t1, 0, &t2, 0, len);
1645 }
1646
1647
1648 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1649 compareStandard(Word p1, Word p2, int eq)
1650
1651 Rules:
1652
1653 Var @< AttVar @< Number @< String @< Atom < Term
1654
1655 OldVar < NewVar (not relyable)
1656 Atom: alphabetically
1657 Strings: alphabetically
1658 number: value
1659 Term: arity / alphabetically / recursive
1660
1661 If eq == TRUE, only test for equality. In this case expensive inequality
1662 tests (alphabetical order) are skipped and the call returns NOTEQ.
1663 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1664
1665 static int
compare_primitives(Word p1,Word p2,int eq ARG_LD)1666 compare_primitives(Word p1, Word p2, int eq ARG_LD)
1667 { word t1, t2;
1668 word w1, w2;
1669
1670 w1 = *p1;
1671 w2 = *p2;
1672
1673 if ( w1 == w2 )
1674 { if ( isVar(w1) )
1675 { cmpvars:
1676 if ( p1 == p2 )
1677 return CMP_EQUAL;
1678 return p1 < p2 ? CMP_LESS : CMP_GREATER;
1679 }
1680 return CMP_EQUAL;
1681 }
1682
1683 t1 = tag(w1);
1684 t2 = tag(w2);
1685
1686 if ( t1 != t2 )
1687 { if ( !truePrologFlag(PLFLAG_ISO) && !eq )
1688 { if ( (t1 == TAG_INTEGER && t2 == TAG_FLOAT) ||
1689 (t1 == TAG_FLOAT && t2 == TAG_INTEGER) )
1690 { number left, right;
1691 int rc;
1692
1693 get_number(w1, &left PASS_LD);
1694 get_number(w2, &right PASS_LD);
1695 if ( left.type == V_FLOAT && isnan(left.value.f) )
1696 rc = CMP_LESS;
1697 else if ( right.type == V_FLOAT && isnan(right.value.f) )
1698 rc = CMP_GREATER;
1699 else
1700 rc = cmpNumbers(&left, &right);
1701 clearNumber(&left);
1702 clearNumber(&right);
1703
1704 if ( rc == CMP_EQUAL )
1705 rc = (t1 == TAG_FLOAT) ? CMP_LESS : CMP_GREATER;
1706 return rc;
1707 }
1708 }
1709
1710 if ( t1 > TAG_ATTVAR || t2 > TAG_ATTVAR )
1711 return t1 < t2 ? CMP_LESS : CMP_GREATER;
1712 }
1713
1714 switch(t1)
1715 { case TAG_VAR:
1716 case TAG_ATTVAR:
1717 goto cmpvars;
1718 case TAG_INTEGER:
1719 { number n1, n2;
1720 int rc;
1721
1722 get_rational(w1, &n1);
1723 get_rational(w2, &n2);
1724 if ( eq && (n1.type != n2.type) )
1725 return CMP_NOTEQ;
1726 rc = cmpNumbers(&n1, &n2);
1727 clearNumber(&n1);
1728 clearNumber(&n2);
1729
1730 return rc;
1731 }
1732 case TAG_FLOAT:
1733 { if ( equalIndirect(w1,w2) )
1734 { return CMP_EQUAL;
1735 } else if ( eq )
1736 { return CMP_NOTEQ;
1737 } else
1738 { double f1 = valFloat(w1);
1739 double f2 = valFloat(w2);
1740
1741 if ( isnan(f1) )
1742 { if ( isnan(f2) )
1743 { double nf1 = NaN_value(f1);
1744 double nf2 = NaN_value(f2);
1745
1746 if ( nf1 < nf2 )
1747 { return CMP_LESS;
1748 } else if ( nf1 > nf2 )
1749 { return CMP_GREATER;
1750 } else if ( signbit(nf1) != signbit(nf2) )
1751 { return signbit(nf1) ? CMP_LESS : CMP_GREATER;
1752 } else
1753 { return CMP_EQUAL;
1754 }
1755 }
1756 return CMP_LESS;
1757 } else if ( isnan(f2) )
1758 { return CMP_GREATER;
1759 }
1760
1761 if ( f1 < f2 )
1762 { return CMP_LESS;
1763 } else if ( f1 > f2 )
1764 { return CMP_GREATER;
1765 } else
1766 { assert(signbit(f1) != signbit(f2));
1767 return signbit(f1) ? CMP_LESS : CMP_GREATER;
1768 }
1769 }
1770 }
1771 case TAG_ATOM:
1772 return eq ? CMP_NOTEQ : compareAtoms(w1, w2);
1773 case TAG_STRING:
1774 return compareStrings(w1, w2 PASS_LD);
1775 case TAG_COMPOUND:
1776 return CMP_COMPOUND;
1777 default:
1778 assert(0);
1779 return CMP_ERROR;
1780 }
1781 }
1782
1783 static int
compare_functors(word f1,word f2,int eq)1784 compare_functors(word f1, word f2, int eq)
1785 { if ( eq )
1786 { return CMP_NOTEQ;
1787 } else
1788 { FunctorDef fd1 = valueFunctor(f1);
1789 FunctorDef fd2 = valueFunctor(f2);
1790
1791 if ( fd1->arity != fd2->arity )
1792 return fd1->arity > fd2->arity ? CMP_GREATER : CMP_LESS;
1793
1794 return compareAtoms(fd1->name, fd2->name);
1795 }
1796 }
1797
1798 static int
do_compare(term_agendaLR * agenda,Functor f1,Functor f2,int eq ARG_LD)1799 do_compare(term_agendaLR *agenda, Functor f1, Functor f2, int eq ARG_LD)
1800 { Word p1, p2;
1801
1802 goto compound;
1803
1804 while( nextTermAgendaLR(agenda, &p1, &p2) )
1805 { int rc;
1806
1807 deRef(p1);
1808 deRef(p2);
1809
1810 if ( (rc=compare_primitives(p1, p2, eq PASS_LD)) != CMP_COMPOUND )
1811 { if ( rc == CMP_EQUAL )
1812 continue;
1813 return rc;
1814 } else
1815 { f1 = (Functor)valPtr(*p1);
1816 f2 = (Functor)valPtr(*p2);
1817
1818 #if O_CYCLIC
1819 while ( isRef(f1->definition) )
1820 f1 = (Functor)unRef(f1->definition);
1821 while ( isRef(f2->definition) )
1822 f2 = (Functor)unRef(f2->definition);
1823 if ( f1 == f2 )
1824 continue;
1825 #endif
1826
1827 if ( f1->definition != f2->definition )
1828 { return compare_functors(f1->definition, f2->definition, eq);
1829 } else
1830 { int arity;
1831
1832 compound:
1833 arity = arityFunctor(f1->definition);
1834
1835 linkTermsCyclic(f1, f2 PASS_LD);
1836 if ( !pushWorkAgendaLR(agenda, arity, f1->arguments, f2->arguments) )
1837 { PL_error(NULL, 0, NULL, ERR_RESOURCE, ATOM_memory);
1838 return CMP_ERROR;
1839 }
1840 continue;
1841 }
1842 }
1843 }
1844
1845 return CMP_EQUAL;
1846 }
1847
1848
1849 int
compareStandard(Word p1,Word p2,int eq ARG_LD)1850 compareStandard(Word p1, Word p2, int eq ARG_LD)
1851 { int rc;
1852
1853 deRef(p1);
1854 deRef(p2);
1855
1856 if ( (rc=compare_primitives(p1, p2, eq PASS_LD)) != CMP_COMPOUND )
1857 { return rc;
1858 } else
1859 { Functor f1 = (Functor)valPtr(*p1);
1860 Functor f2 = (Functor)valPtr(*p2);
1861
1862 if ( f1->definition != f2->definition )
1863 { return compare_functors(f1->definition, f2->definition, eq);
1864 } else
1865 { term_agendaLR agenda;
1866
1867 initCyclic(PASS_LD1);
1868 initTermAgendaLR0(&agenda);
1869 rc = do_compare(&agenda, f1, f2, eq PASS_LD);
1870 clearTermAgendaLR(&agenda);
1871 exitCyclic(PASS_LD1);
1872
1873 return rc;
1874 }
1875 }
1876 }
1877
1878
1879 /* compare(-Diff, +T1, +T2) */
1880
1881 static
1882 PRED_IMPL("compare", 3, compare, PL_FA_ISO)
1883 { PRED_LD
1884 Word d = valTermRef(A1);
1885 Word p1 = valTermRef(A2);
1886 Word p2 = p1+1;
1887 int val;
1888 atom_t a;
1889
1890 deRef(d);
1891 if ( canBind(*d) )
1892 { a = 0;
1893 } else
1894 { if ( isAtom(*d) )
1895 { a = *d;
1896
1897 if ( a == ATOM_equals )
1898 return compareStandard(p1, p2, TRUE PASS_LD) == CMP_EQUAL ? TRUE : FALSE;
1899
1900 if ( a != ATOM_smaller && a != ATOM_larger )
1901 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_order, A1);
1902 } else
1903 return PL_type_error("atom", A1);
1904 }
1905
1906 if ( (val = compareStandard(p1, p2, FALSE PASS_LD)) == CMP_ERROR )
1907 return FALSE;
1908
1909 if ( a )
1910 { if ( a == ATOM_smaller )
1911 return val < 0;
1912 else
1913 return val > 0;
1914 } else
1915 { a = val < 0 ? ATOM_smaller :
1916 val > 0 ? ATOM_larger :
1917 ATOM_equals;
1918
1919 return PL_unify_atom(A1, a);
1920 }
1921 }
1922
1923
1924 static
1925 PRED_IMPL("@<", 2, std_lt, 0)
1926 { PRED_LD
1927 Word p1 = valTermRef(A1);
1928 Word p2 = p1+1;
1929 int rc;
1930
1931 if ( (rc=compareStandard(p1, p2, FALSE PASS_LD)) == CMP_ERROR )
1932 return FALSE;
1933
1934 return rc < 0 ? TRUE : FALSE;
1935 }
1936
1937
1938 static
1939 PRED_IMPL("@=<", 2, std_leq, 0)
1940 { PRED_LD
1941 Word p1 = valTermRef(A1);
1942 Word p2 = p1+1;
1943 int rc;
1944
1945 if ( (rc=compareStandard(p1, p2, FALSE PASS_LD)) == CMP_ERROR )
1946 return FALSE;
1947
1948 return rc <= 0 ? TRUE : FALSE;
1949 }
1950
1951
1952 static
1953 PRED_IMPL("@>", 2, std_gt, 0)
1954 { PRED_LD
1955 Word p1 = valTermRef(A1);
1956 Word p2 = p1+1;
1957 int rc;
1958
1959 if ( (rc=compareStandard(p1, p2, FALSE PASS_LD)) == CMP_ERROR )
1960 return FALSE;
1961
1962 return rc > 0 ? TRUE : FALSE;
1963 }
1964
1965
1966 static
1967 PRED_IMPL("@>=", 2, std_geq, 0)
1968 { PRED_LD
1969 Word p1 = valTermRef(A1);
1970 Word p2 = p1+1;
1971 int rc;
1972
1973 if ( (rc=compareStandard(p1, p2, FALSE PASS_LD)) == CMP_ERROR )
1974 return FALSE;
1975
1976 return rc >= 0 ? TRUE : FALSE;
1977 }
1978
1979 /********************************
1980 * EQUALITY *
1981 *********************************/
1982
1983 static
1984 PRED_IMPL("==", 2, equal, 0)
1985 { PRED_LD
1986 Word p1 = valTermRef(A1);
1987 Word p2 = p1+1;
1988 int rc;
1989
1990 if ( (rc=compareStandard(p1, p2, TRUE PASS_LD)) == CMP_ERROR )
1991 return FALSE;
1992
1993 return rc == CMP_EQUAL ? TRUE : FALSE;
1994 }
1995
1996
1997 static
1998 PRED_IMPL("\\==", 2, nonequal, 0)
1999 { PRED_LD
2000 Word p1 = valTermRef(A1);
2001 Word p2 = p1+1;
2002 int rc;
2003
2004 if ( (rc=compareStandard(p1, p2, TRUE PASS_LD)) == CMP_ERROR )
2005 return FALSE;
2006
2007 return rc == CMP_EQUAL ? FALSE : TRUE;
2008 }
2009
2010
2011 /** ?=(@X, @Y) is semidet.
2012
2013 True if we can decide for now and forever that X and Y are either equal
2014 or non-equal. I.e. X and Y are equal or they cannot unify.
2015 */
2016
2017 static
2018 PRED_IMPL("?=", 2, can_compare, 0)
2019 { PRED_LD
2020 fid_t fid = PL_open_foreign_frame();
2021 int rc;
2022
2023 rc = PL_unify(A1, A2);
2024 if ( rc )
2025 { FliFrame fr = (FliFrame) valTermRef(fid);
2026
2027 assert(fr->magic == FLI_MAGIC);
2028 if ( fr->mark.trailtop != tTop )
2029 rc = FALSE;
2030 } else if ( exception_term )
2031 { PL_close_foreign_frame(fid); /* keep exception */
2032 return FALSE;
2033 } else
2034 { rc = TRUE; /* could not unify */
2035 }
2036
2037 PL_discard_foreign_frame(fid);
2038 return rc;
2039 }
2040
2041
2042 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2043 same_term(@T1, @T2) is semidet.
2044
2045 True if T1 and T2 is really the same term, so setarg/3 affects both
2046 terms.
2047 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2048
2049 int
PL_same_term__LD(term_t T1,term_t T2 ARG_LD)2050 PL_same_term__LD(term_t T1, term_t T2 ARG_LD)
2051 { Word t1 = valTermRef(T1);
2052 Word t2 = valTermRef(T2);
2053
2054 deRef(t1);
2055 deRef(t2);
2056
2057 if ( isVar(*t1) )
2058 return t1 == t2;
2059 if ( *t1 == *t2 )
2060 succeed;
2061 if ( isIndirect(*t1) && isIndirect(*t2) )
2062 return equalIndirect(*t1, *t2);
2063
2064 fail;
2065 }
2066
2067 static
2068 PRED_IMPL("same_term", 2, same_term, 0)
2069 { PRED_LD
2070
2071 return PL_same_term(A1, A2);
2072 }
2073
2074
2075 /********************************
2076 * TERM HACKING *
2077 *********************************/
2078
2079 /* functor(+Term, -Name, -Arity) */
2080 /* functor(-Term, +Name, +Arity) */
2081
2082 PRED_IMPL("functor", 3, functor, 0)
2083 { PRED_LD
2084 size_t arity;
2085 atom_t name;
2086 Word p = valTermRef(A1);
2087
2088 deRef(p);
2089
2090 if ( isTerm(*p) )
2091 { FunctorDef fd = valueFunctor(functorTerm(*p));
2092
2093 if ( fd->arity == 0 )
2094 return PL_domain_error("compound_non_zero_arity", A1);
2095
2096 if ( !PL_unify_atom(A2, fd->name) ||
2097 !PL_unify_integer(A3, fd->arity) )
2098 fail;
2099
2100 succeed;
2101 }
2102 if ( isAtomic(*p) )
2103 { if ( !PL_unify(A2, A1) ||
2104 !PL_unify_integer(A3, 0) )
2105 fail;
2106
2107 succeed;
2108 }
2109 if ( !PL_is_atomic(A2) )
2110 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atomic, A2);
2111
2112 if ( !PL_get_size_ex(A3, &arity) )
2113 fail;
2114 if ( arity == 0 )
2115 return PL_unify(A1, A2);
2116 if ( PL_get_atom_ex(A2, &name) )
2117 return PL_unify_functor(A1, PL_new_functor(name, arity));
2118
2119 fail;
2120 }
2121
2122
2123 /* compound_name_arity(+Compound, -Name, -Arity) */
2124 /* compound_name_arity(-Compound, +Name, +Arity) */
2125
2126 PRED_IMPL("compound_name_arity", 3, compound_name_arity, 0)
2127 { PRED_LD
2128 size_t arity;
2129 atom_t name;
2130 Word p = valTermRef(A1);
2131
2132 deRef(p);
2133
2134 if ( isTerm(*p) )
2135 { FunctorDef fd = valueFunctor(functorTerm(*p));
2136 if ( !PL_unify_atom(A2, fd->name) ||
2137 !PL_unify_integer(A3, fd->arity) )
2138 fail;
2139
2140 succeed;
2141 }
2142 if ( !canBind(*p) )
2143 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_compound, A1);
2144
2145 if ( !PL_get_atom_ex(A2, &name) ||
2146 !PL_get_size_ex(A3, &arity) )
2147 fail;
2148
2149 return PL_unify_compound(A1, PL_new_functor(name, arity));
2150 }
2151
2152
2153 /** '$filled_array'(-Compound, +Name, +Arity, +Value) is det.
2154 * Created an array (compound) with all arguments set to Value.
2155 */
2156
2157
2158 PRED_IMPL("$filled_array", 4, filled_array, 0)
2159 { PRED_LD
2160 size_t arity;
2161 atom_t name;
2162 functor_t f;
2163 Word p, v;
2164 term_t compound = PL_new_term_ref();
2165 size_t i;
2166
2167 if ( !PL_get_atom_ex(A2, &name) ||
2168 !PL_get_size_ex(A3, &arity) )
2169 return FALSE;
2170
2171 f = PL_new_functor(name, arity);
2172 if ( !(p = allocGlobal(arity+1)) )
2173 return FALSE;
2174 v = valTermRef(A4);
2175 deRef(v);
2176
2177 p[0] = f;
2178 if ( arity > 0 )
2179 { word w;
2180 bArgVar(&p[1], v PASS_LD);
2181 w = isVar(p[1]) ? makeRefG(&p[1]) : p[1];
2182 for(i=2; i<=arity; i++)
2183 p[i] = w;
2184 }
2185
2186 *valTermRef(compound) = consPtr(p, TAG_COMPOUND|STG_GLOBAL);
2187 return PL_unify(A1, compound);
2188 }
2189
2190
2191
2192
2193 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2194 int get_arg_integer_ex(term_t t, intptr_t *n)
2195
2196 Get argument position from t. Returns:
2197
2198 TRUE if t is a small non-negative integer
2199 -1 if t is unbound
2200 FALSE
2201 - with exception if t is not an integer or negative
2202 - without exception if t is 0 or a large positive integer
2203 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2204
2205 static int
get_arg_integer_ex(term_t t,intptr_t * n ARG_LD)2206 get_arg_integer_ex(term_t t, intptr_t *n ARG_LD)
2207 { Word p = valTermRef(t);
2208
2209 deRef(p);
2210 if ( isTaggedInt(*p) )
2211 { intptr_t v = valInt(*p);
2212
2213 if ( v > 0 )
2214 { *n = v;
2215 return TRUE;
2216 }
2217 if ( v == 0 )
2218 return FALSE;
2219 }
2220
2221 if ( isInteger(*p) )
2222 { number n;
2223
2224 get_integer(*p, &n);
2225 if ( ar_sign_i(&n) < 0 )
2226 PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_zero, t);
2227
2228 return FALSE;
2229 }
2230
2231 if ( canBind(*p) )
2232 return -1;
2233
2234 PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
2235 return FALSE;
2236 }
2237
2238
2239 static
2240 PRED_IMPL("arg", 3, arg, PL_FA_NONDETERMINISTIC)
2241 { PRED_LD
2242 unsigned arity;
2243 unsigned argn;
2244
2245 term_t n = A1;
2246 term_t term = A2;
2247 term_t arg = A3;
2248
2249 switch( CTX_CNTRL )
2250 { case FRG_FIRST_CALL:
2251 { intptr_t idx;
2252 int rc;
2253 Word p = valTermRef(term);
2254
2255 deRef(p);
2256 if ( isTerm(*p) )
2257 arity = arityTerm(*p);
2258 else
2259 return PL_error("arg", 3, NULL, ERR_TYPE, ATOM_compound, term);
2260
2261 if ( (rc=get_arg_integer_ex(n, &idx PASS_LD)) == TRUE )
2262 { if ( idx <= (intptr_t)arity )
2263 { Word ap = argTermP(*p, idx-1);
2264
2265 return unify_ptrs(valTermRef(arg), ap, ALLOW_GC|ALLOW_SHIFT PASS_LD);
2266 }
2267 fail;
2268 }
2269 if ( rc == -1 ) /* variable */
2270 { argn = 1;
2271
2272 goto genarg;
2273 }
2274 return FALSE; /* bigint, negative or type error */
2275 }
2276 case FRG_REDO:
2277 { term_t a;
2278 fid_t fid;
2279 int rc;
2280 Word p = valTermRef(term);
2281
2282 deRef(p);
2283 arity = arityTerm(*p);
2284 argn = (unsigned)CTX_INT + 1;
2285
2286 genarg:
2287 rc = FALSE;
2288 if ( !(fid=PL_open_foreign_frame()) ||
2289 !(a = PL_new_term_ref()) )
2290 return FALSE;
2291 for(; argn <= arity; argn++)
2292 { _PL_get_arg(argn, term, a);
2293 if ( PL_unify(arg, a) )
2294 { if ( !PL_unify_integer(n, argn) )
2295 break;
2296 if ( argn == arity )
2297 { rc = TRUE;
2298 break;
2299 }
2300 PL_close_foreign_frame(fid);
2301 ForeignRedoInt(argn);
2302 }
2303 if ( exception_term )
2304 break;
2305 PL_rewind_foreign_frame(fid);
2306 }
2307
2308 PL_close_foreign_frame(fid);
2309 return rc;
2310 }
2311 default:
2312 succeed;
2313 }
2314 }
2315
2316
2317 #define SETARG_BACKTRACKABLE 0x1
2318 #define SETARG_LINK 0x2
2319
2320
2321 /* unify_vp() assumes *vp is a variable and binds it to val.
2322 The assignment is *not* trailed. As no allocation takes
2323 place, there are no error conditions.
2324 */
2325
2326 void
unify_vp(Word vp,Word val ARG_LD)2327 unify_vp(Word vp, Word val ARG_LD)
2328 { deRef(val);
2329
2330 if ( isVar(*val) )
2331 { if ( val < vp )
2332 { *vp = makeRef(val);
2333 } else if ( vp < val )
2334 { setVar(*vp);
2335 *val = makeRef(vp);
2336 } else
2337 setVar(*vp);
2338 } else if ( isAttVar(*val) )
2339 { *vp = makeRef(val);
2340 } else
2341 *vp = *val;
2342 }
2343
2344
2345 static word
setarg(term_t n,term_t term,term_t value,int flags ARG_LD)2346 setarg(term_t n, term_t term, term_t value, int flags ARG_LD)
2347 { size_t arity, argn;
2348 atom_t name;
2349 Word a, v;
2350
2351 if ( !PL_get_size_ex(n, &argn) )
2352 return FALSE;
2353 if ( argn == 0 )
2354 return FALSE;
2355 if ( !PL_get_name_arity(term, &name, &arity) )
2356 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_compound, term);
2357
2358 if ( argn > arity )
2359 return FALSE;
2360
2361 if ( (flags & SETARG_BACKTRACKABLE) )
2362 { a = valTermRef(term);
2363 deRef(a);
2364 a = argTermP(*a, argn-1);
2365
2366 if ( isVar(*a) )
2367 { return unify_ptrs(valTermRef(value), a, ALLOW_GC|ALLOW_SHIFT PASS_LD);
2368 } else
2369 { if ( !hasGlobalSpace(0) )
2370 { int rc;
2371
2372 if ( (rc=ensureGlobalSpace(0, ALLOW_GC)) != TRUE )
2373 return raiseStackOverflow(rc);
2374 a = valTermRef(term);
2375 deRef(a);
2376 a = argTermP(*a, argn-1);
2377 }
2378
2379 TrailAssignment(a);
2380 }
2381 } else
2382 { v = valTermRef(value);
2383 deRef(v);
2384
2385 if ( storage(*v) == STG_GLOBAL )
2386 { if ( !(flags & SETARG_LINK) )
2387 { term_t copy = PL_new_term_ref();
2388
2389 if ( !duplicate_term(value, copy PASS_LD) )
2390 fail;
2391 value = copy;
2392 }
2393
2394 freezeGlobal(PASS_LD1);
2395 }
2396
2397 a = valTermRef(term); /* duplicate may shift stacks */
2398 deRef(a);
2399 a = argTermP(*a, argn-1);
2400 }
2401 /* this is unify(), but the */
2402 /* assignment must *not* be trailed */
2403 v = valTermRef(value);
2404 unify_vp(a, v PASS_LD);
2405
2406 return TRUE;
2407 }
2408
2409
2410 static
2411 PRED_IMPL("setarg", 3, setarg, 0)
2412 { PRED_LD
2413
2414 return setarg(A1, A2, A3, SETARG_BACKTRACKABLE PASS_LD);
2415 }
2416
2417
2418 static
2419 PRED_IMPL("nb_setarg", 3, nb_setarg, 0)
2420 { PRED_LD
2421
2422 return setarg(A1, A2, A3, 0 PASS_LD);
2423 }
2424
2425
2426 static
2427 PRED_IMPL("nb_linkarg", 3, nb_linkarg, 0)
2428 { PRED_LD
2429
2430 return setarg(A1, A2, A3, SETARG_LINK PASS_LD);
2431 }
2432
2433
2434 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2435 Cycle detection for lists using Brent's algorithm.
2436
2437 skip_list() was originally added to SWI-Prolog by Ulrich Neumerkel. The
2438 code below is a clean-room re-implementation by Keri Harris.
2439
2440 See http://en.wikipedia.org/wiki/Cycle_detection#Brent.27s_algorithm
2441 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2442
2443 intptr_t
skip_list(Word l,Word * tailp ARG_LD)2444 skip_list(Word l, Word *tailp ARG_LD)
2445 { deRef(l);
2446
2447 if ( !isList(*l) )
2448 { *tailp = l;
2449 return 0;
2450 } else
2451 { Word checkCell, currentCell;
2452 intptr_t length = 0;
2453 int power, lam;
2454
2455 checkCell = currentCell = l;
2456 lam = 0;
2457 power = 1;
2458
2459 while ( TRUE )
2460 { currentCell = TailList(currentCell);
2461 deRef(currentCell);
2462 length++;
2463
2464 if ( !isList(*currentCell) || (*checkCell == *currentCell) )
2465 break;
2466
2467 lam++;
2468 if ( power == lam )
2469 { checkCell = currentCell;
2470 power *= 2;
2471 lam = 0;
2472 }
2473 }
2474
2475 *tailp = currentCell;
2476
2477 return length;
2478 }
2479 }
2480
2481
2482 /** '$skip_list'(-Length, +Xs0, -Xs) is det.
2483
2484 Xs0, Xs is a pair of list differences. Xs0 is the input list and Xs is
2485 the minimal remaining list. Examination of Xs permits to classify the
2486 list Xs0:
2487
2488 Xs | list type of Xs0 | Length
2489 [] ... | well formed | length
2490 Var ... | partial | elements skipped
2491 [_|_] ... | infinite | upper bound for cycle
2492 Term ... | malformed | elements skipped
2493 */
2494
2495 PRED_IMPL("$skip_list", 3, skip_list, 0)
2496 { PRED_LD
2497 Word tail;
2498 intptr_t len;
2499
2500 len = skip_list(valTermRef(A2), &tail PASS_LD);
2501 if ( unify_ptrs(valTermRef(A3), tail, ALLOW_GC|ALLOW_SHIFT PASS_LD) &&
2502 PL_unify_integer(A1, len) )
2503 return TRUE;
2504
2505 return FALSE;
2506 }
2507
2508
2509 /* Determine the length of a list. Returns:
2510
2511 len >= 0 if list is proper
2512 len == -1 if list is not a list
2513 len == -2 if list is incomplete (i.e. tail is unbound)
2514
2515 ** Mon Apr 18 16:29:01 1988 jan@swivax.UUCP (Jan Wielemaker) */
2516
2517 intptr_t
lengthList(term_t list,int errors)2518 lengthList(term_t list, int errors)
2519 { GET_LD
2520 intptr_t length = 0;
2521 Word l = valTermRef(list);
2522 Word tail;
2523
2524 length = skip_list(l, &tail PASS_LD);
2525
2526 if ( isNil(*tail) )
2527 return length;
2528
2529 if ( errors )
2530 { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, pushWordAsTermRef(l));
2531 popTermRef();
2532 }
2533
2534 return isVar(*tail) ? -2 : -1;
2535 }
2536
2537
2538 static
2539 PRED_IMPL("=..", 2, univ, PL_FA_ISO)
2540 { GET_LD
2541 term_t t = A1;
2542 term_t list = A2;
2543 Word p;
2544 int n;
2545
2546 if ( PL_is_variable(t) )
2547 { atom_t name;
2548 int arity;
2549 term_t tail = PL_copy_term_ref(list);
2550 term_t head = PL_new_term_ref();
2551
2552 if ( !PL_get_list(tail, head, tail) )
2553 { if ( PL_get_nil(tail) )
2554 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
2555 ATOM_non_empty_list, tail);
2556 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, tail);
2557 }
2558
2559 if ( PL_get_nil(tail) ) /* A =.. [H] */
2560 { if ( !PL_is_atomic(head) )
2561 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atomic, head);
2562 return PL_unify(t, head);
2563 }
2564 if ( !PL_get_atom_ex(head, &name) )
2565 fail;
2566
2567 if ( (arity = (int)lengthList(tail, FALSE)) < 0 ) /* TBD: check MAXINT */
2568 { if ( arity == -1 )
2569 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list);
2570 else
2571 return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
2572 }
2573
2574 if ( (p = allocGlobal(arity+1)) )
2575 { Word l = valTermRef(tail);
2576
2577 *valTermRef(head) = consPtr(p, TAG_COMPOUND|STG_GLOBAL);
2578 *p++ = PL_new_functor(name, arity);
2579 deRef(l);
2580 while(isList(*l))
2581 { Word h = HeadList(l);
2582
2583 deRef(h);
2584 *p++ = needsRef(*h) ? makeRef(h) : *h;
2585 l = TailList(l);
2586 deRef(l);
2587 }
2588
2589 return PL_unify(t, head);
2590 }
2591
2592 return FALSE;
2593 }
2594
2595 p = valTermRef(t);
2596 deRef(p);
2597
2598 if ( isTerm(*p) )
2599 { FunctorDef fd = valueFunctor(functorTerm(*p));
2600 term_t head, l;
2601
2602 if ( fd->arity == 0 )
2603 return PL_domain_error("compound_non_zero_arity", A1);
2604
2605 head = PL_new_term_ref();
2606 l = PL_new_term_ref();
2607
2608 if ( !PL_unify_list_ex(list, head, l) ||
2609 !PL_unify_atom(head, fd->name) )
2610 return FALSE;
2611
2612 for(n = 1; n <= fd->arity; n++)
2613 { if ( !PL_unify_list_ex(l, head, l) ||
2614 !PL_unify_arg(n, t, head) )
2615 return FALSE;
2616 }
2617
2618 return PL_unify_nil_ex(l);
2619 }
2620
2621 if ( PL_is_atomic(t) ) /* 3 =.. X, 3.4 =.. X, "foo" =.. X */
2622 { term_t head = PL_new_term_ref();
2623 term_t l = PL_new_term_ref();
2624
2625 if ( PL_unify_list_ex(list, head, l) &&
2626 PL_unify(head, t) &&
2627 PL_unify_nil_ex(l) )
2628 succeed;
2629 }
2630
2631 fail;
2632 }
2633
2634
2635 /** compound_name_arguments(-Term, +Name, +Arguments)
2636 compound_name_arguments(+Term, -Name, -Arguments)
2637 */
2638
2639 static
2640 PRED_IMPL("compound_name_arguments", 3, compound_name_arguments, 0)
2641 { GET_LD
2642 term_t t = A1;
2643 term_t list = A3;
2644 intptr_t len;
2645 size_t arity;
2646 atom_t name;
2647 size_t n;
2648
2649 if ( PL_is_variable(t) )
2650 { term_t tail = PL_copy_term_ref(list);
2651 term_t head = PL_new_term_ref();
2652
2653 if ( !PL_get_atom_ex(A2, &name) )
2654 return FALSE;
2655
2656 if ( (len = lengthList(tail, FALSE)) < 0 )
2657 { if ( len == -1 )
2658 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list);
2659 else
2660 return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
2661 }
2662
2663 if ( !PL_unify_compound(t, PL_new_functor(name, (size_t)len)) )
2664 fail;
2665
2666 for(n=1; PL_get_list(tail, head, tail); n++)
2667 { if ( !PL_unify_arg(n, t, head) )
2668 fail;
2669 }
2670
2671 succeed;
2672 }
2673
2674 /* 1st arg is term */
2675 if ( PL_get_compound_name_arity(t, &name, &arity) )
2676 { term_t head = PL_new_term_ref();
2677 term_t l = PL_copy_term_ref(list);
2678
2679 if ( !PL_unify_atom(A2, name) )
2680 fail;
2681
2682 for(n = 1; n <= arity; n++)
2683 { if ( !PL_unify_list_ex(l, head, l) ||
2684 !PL_unify_arg(n, t, head) )
2685 fail;
2686 }
2687
2688 return PL_unify_nil_ex(l);
2689 }
2690
2691 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_compound, A1);
2692 }
2693
2694
2695 /*******************************
2696 * NUMBERVARS *
2697 *******************************/
2698
2699 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2700 Returns >= 0: Number for next variable variable
2701 -1: Error
2702 < -1: Out of stack error or ALREADY_NUMBERED or CONTAINS_ATTVAR
2703
2704 TBD: when using the `singletons' mode, the predicate is not cycle safe
2705 (this is an error) and does not exploit sharing. We could fix this using
2706 both flags:
2707
2708 - Not marked: go in there
2709 - Marked, but not alt-mark: map vars in there _-->n
2710 - both-marked: done
2711 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2712
2713 #define ALREADY_NUMBERED (-10)
2714 #define CONTAINS_ATTVAR (-11)
2715 #define REPRESENTATION_ERROR (-12)
2716
2717 static intptr_t
do_number_vars(Word p,nv_options * options,intptr_t n,mark * m ARG_LD)2718 do_number_vars(Word p, nv_options *options, intptr_t n, mark *m ARG_LD)
2719 { term_agenda agenda;
2720 intptr_t start = n;
2721
2722 initTermAgenda(&agenda, 1, p);
2723 while((p=nextTermAgenda(&agenda)))
2724 { if ( canBind(*p) )
2725 { Word a;
2726 word v;
2727
2728 if ( isAttVar(*p) )
2729 { switch(options->on_attvar)
2730 { case AV_SKIP:
2731 continue;
2732 case AV_ERROR:
2733 n = CONTAINS_ATTVAR;
2734 goto out;
2735 case AV_BIND:
2736 break;
2737 }
2738 }
2739
2740 if ( !hasGlobalSpace(2) )
2741 { n = overflowCode(2);
2742 goto out;
2743 }
2744
2745 a = gTop;
2746 a[0] = options->functor;
2747 if ( options->singletons )
2748 { a[1] = ATOM_anonvar;
2749 } else
2750 { intptr_t v = n+options->offset;
2751 a[1] = consInt(v);
2752 if ( valInt(a[1]) != v )
2753 { n = REPRESENTATION_ERROR;
2754 goto out;
2755 }
2756 n++;
2757 }
2758 gTop += 2;
2759
2760 v = consPtr(a, TAG_COMPOUND|STG_GLOBAL);
2761 bindConst(p, v);
2762 } else if ( isTerm(*p) )
2763 { Functor f = valueTerm(*p);
2764
2765 if ( f->definition == options->functor )
2766 { if ( (Word)f >= m->globaltop ) /* new one we created ourselves */
2767 { if ( options->singletons )
2768 { Word p = &f->arguments[0];
2769
2770 if ( *p == ATOM_anonvar )
2771 { intptr_t v = n+options->offset;
2772 *p = consInt(v);
2773 if ( valInt(*p) != v )
2774 { n = REPRESENTATION_ERROR;
2775 goto out;
2776 }
2777 n++;
2778 }
2779 }
2780 } else
2781 { Word p = &f->arguments[0];
2782
2783 deRef(p);
2784 if ( options->numbered_check && isInteger(*p) )
2785 { intptr_t i = (intptr_t)valInteger(*p); /* cannot be bigger */
2786
2787 if ( i >= (intptr_t)start )
2788 { n = ALREADY_NUMBERED;
2789 goto out;
2790 }
2791 }
2792 if ( isVar(*p) || isTerm(*p) )
2793 goto do_number; /* number '$VAR'(_) */
2794 }
2795 continue;
2796 }
2797
2798 do_number:
2799 if ( !options->singletons && visited(f PASS_LD) )
2800 continue;
2801
2802 if ( !pushWorkAgenda(&agenda, arityFunctor(f->definition), f->arguments) )
2803 { n = MEMORY_OVERFLOW;
2804 goto out;
2805 }
2806 }
2807 }
2808
2809 out:
2810 clearTermAgenda(&agenda);
2811
2812 return n; /* anything else */
2813 }
2814
2815
2816 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2817 Returns >= 0: Number for next variable variable
2818 -1: Error. Exception is left in the environment
2819 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2820
2821 intptr_t
numberVars(term_t t,nv_options * options,intptr_t n ARG_LD)2822 numberVars(term_t t, nv_options *options, intptr_t n ARG_LD)
2823 { if ( !inTaggedNumRange(n) )
2824 { PL_representation_error("tagged_integer");
2825 return NV_ERROR;
2826 }
2827
2828 options->offset = n;
2829 n = 0;
2830
2831 for(;;)
2832 { mark m;
2833 intptr_t rc;
2834
2835 Mark(m);
2836 initvisited(PASS_LD1);
2837 rc = do_number_vars(valTermRef(t), options, n, &m PASS_LD);
2838 unvisit(PASS_LD1);
2839 if ( rc >= 0 ) /* all ok */
2840 { DiscardMark(m);
2841 return rc + options->offset;
2842 } else
2843 { switch( rc )
2844 { case CONTAINS_ATTVAR:
2845 DiscardMark(m);
2846 PL_error(NULL, 0, NULL,
2847 ERR_TYPE, ATOM_free_of_attvar, t);
2848 return NV_ERROR;
2849 case ALREADY_NUMBERED:
2850 DiscardMark(m);
2851 PL_error(NULL, 0, "already numbered",
2852 ERR_PERMISSION, ATOM_numbervars, ATOM_term, t);
2853 return NV_ERROR;
2854 case REPRESENTATION_ERROR:
2855 DiscardMark(m);
2856 PL_representation_error("tagged_integer");
2857 return NV_ERROR;
2858 default:
2859 Undo(m);
2860 DiscardMark(m);
2861 if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) )
2862 return NV_ERROR;
2863 }
2864 }
2865 }
2866 }
2867
2868
2869 static const opt_spec numbervar_options[] =
2870 { { ATOM_attvar, OPT_ATOM },
2871 { ATOM_functor_name, OPT_ATOM },
2872 { ATOM_singletons, OPT_BOOL },
2873 { NULL_ATOM, 0 }
2874 };
2875
2876
2877 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2878 numbervars(+Term, +Start, -End, +Options)
2879 numbervars(+Term, +Functor, +Start, -End)
2880 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2881
2882 static
2883 PRED_IMPL("numbervars", 4, numbervars, 0)
2884 { GET_LD
2885 intptr_t n;
2886 atom_t name = ATOM_isovar; /* '$VAR' */
2887 atom_t av = ATOM_error;
2888 term_t t, end, options;
2889 nv_options opts;
2890
2891 opts.singletons = FALSE;
2892 opts.numbered_check = FALSE;
2893
2894 t = PL_copy_term_ref(A1);
2895
2896 if ( PL_get_intptr_ex(A2, &n) )
2897 { end = A3;
2898 options = A4;
2899 } else
2900 return FALSE;
2901
2902 if ( options &&
2903 !scan_options(options, 0, ATOM_numbervar_option, numbervar_options,
2904 &av, &name, &opts.singletons) )
2905 fail;
2906
2907 if ( av == ATOM_error )
2908 opts.on_attvar = AV_ERROR;
2909 else if ( av == ATOM_skip )
2910 opts.on_attvar = AV_SKIP;
2911 else if ( av == ATOM_bind )
2912 opts.on_attvar = AV_BIND;
2913 else
2914 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_numbervar_option, options);
2915
2916 if ( opts.singletons ) /* Hack */
2917 { if ( !is_acyclic(valTermRef(A1) PASS_LD) )
2918 opts.singletons = FALSE;
2919 }
2920
2921 opts.functor = PL_new_functor(name, 1);
2922 n = numberVars(t, &opts, n PASS_LD);
2923 if ( n != NV_ERROR )
2924 return PL_unify_int64(end, n);
2925
2926 return FALSE;
2927 }
2928
2929
2930 static
2931 PRED_IMPL("var_number", 2, var_number, 0)
2932 { PRED_LD
2933 term_t t = A1;
2934 Word p = valTermRef(t);
2935
2936 deRef(p);
2937 if ( isTerm(*p) )
2938 { Functor f = valueTerm(*p);
2939
2940 if ( f->definition == FUNCTOR_isovar1 )
2941 { Word a = &f->arguments[0];
2942
2943 deRef(a);
2944 if ( isAtom(*a) || isInteger(*a) )
2945 return _PL_unify_atomic(A2, *a);
2946 }
2947 }
2948
2949 return FALSE;
2950 }
2951
2952
2953 /*******************************
2954 * TERM-VARIABLES *
2955 *******************************/
2956
2957 #define TV_ATTVAR 0x1
2958 #define TV_SINGLETON 0x2
2959 #define TV_EXCEPTION ((size_t)-1)
2960 #define TV_NOSPACE ((size_t)-2)
2961 #define TV_NOMEM ((size_t)-3)
2962
2963 static size_t
term_variables_loop(term_agenda * agenda,size_t maxcount,int flags ARG_LD)2964 term_variables_loop(term_agenda *agenda, size_t maxcount, int flags ARG_LD)
2965 { Word p;
2966 size_t count = 0;
2967
2968 while( (p=nextTermAgenda(agenda)) )
2969 { word w;
2970
2971 again:
2972 w = *p;
2973
2974 if ( canBind(w) )
2975 { term_t v;
2976
2977 if ( visitedWord(p PASS_LD) )
2978 { if ( (flags&TV_SINGLETON) )
2979 (*p) |= FIRST_MASK;
2980 continue;
2981 }
2982
2983 if ( (flags&TV_ATTVAR) )
2984 { if ( isAttVar(w) )
2985 { Word p2 = valPAttVar(w);
2986
2987 if ( ++count > maxcount )
2988 return count;
2989 if ( !(v = PL_new_term_ref_noshift()) )
2990 return TV_NOSPACE;
2991 *valTermRef(v) = makeRef(p);
2992
2993 deRef2(p2, p);
2994 goto again;
2995 }
2996 } else
2997 { if ( ++count > maxcount )
2998 return count;
2999 if ( !(v = PL_new_term_ref_noshift()) )
3000 return TV_NOSPACE;
3001 *valTermRef(v) = makeRef(p);
3002 }
3003 } else if ( isTerm(w) )
3004 { Functor f = valueTerm(w);
3005
3006 if ( visited(f PASS_LD) && !(flags&TV_SINGLETON) )
3007 continue;
3008 if ( !pushWorkAgenda(agenda, arityFunctor(f->definition), f->arguments) )
3009 return TV_NOMEM;
3010 }
3011 }
3012
3013 return count;
3014 }
3015
3016
3017 static size_t
term_variables_to_termv(term_t t,term_t * vp,size_t maxcount,int flags ARG_LD)3018 term_variables_to_termv(term_t t, term_t *vp, size_t maxcount, int flags ARG_LD)
3019 { term_agenda agenda;
3020 term_t v0 = PL_new_term_refs(0);
3021 size_t count;
3022
3023 startCritical;
3024 initvisited(PASS_LD1);
3025 initTermAgenda(&agenda, 1, valTermRef(t));
3026 count = term_variables_loop(&agenda, maxcount, flags PASS_LD);
3027 clearTermAgenda(&agenda);
3028 if ( (flags&TV_SINGLETON) && (ssize_t)count >= 0 )
3029 { size_t o = 0;
3030 size_t i;
3031
3032 for(i=0; i<count; i++)
3033 { Word p = valTermRef(v0+i);
3034
3035 assert(isRef(*p));
3036 p = unRef(*p);
3037 if ( !((*p)&FIRST_MASK) )
3038 { if ( o != i )
3039 *valTermRef(v0+o) = *valTermRef(v0+i);
3040 o++;
3041 }
3042 }
3043 if ( o < i )
3044 PL_reset_term_refs(v0+o);
3045
3046 count = o;
3047 }
3048 unvisit_and_unfirst(PASS_LD1);
3049 if ( !endCritical )
3050 return TV_EXCEPTION;
3051
3052 *vp = v0;
3053 return count;
3054 }
3055
3056
3057
3058 static int
term_variables(term_t t,term_t vars,term_t tail,int flags ARG_LD)3059 term_variables(term_t t, term_t vars, term_t tail, int flags ARG_LD)
3060 { term_t list = PL_copy_term_ref(vars);
3061 term_t head = PL_new_term_ref();
3062 term_t v0;
3063 size_t i, maxcount, count;
3064
3065 if ( !(!tail && PL_skip_list(vars, 0, &maxcount) == PL_LIST) ||
3066 (flags&TV_SINGLETON) )
3067 maxcount = ~0;
3068
3069 for(;;)
3070 { count = term_variables_to_termv(t, &v0, maxcount, flags PASS_LD);
3071 if ( count == TV_EXCEPTION )
3072 return FALSE;
3073 if ( count == TV_NOSPACE )
3074 { PL_reset_term_refs(v0);
3075 if ( !makeMoreStackSpace(LOCAL_OVERFLOW, ALLOW_SHIFT) )
3076 return FALSE; /* GC doesn't help */
3077 continue;
3078 }
3079 if ( count == TV_NOMEM )
3080 return PL_error(NULL, 0, NULL, ERR_NOMEM);
3081 if ( count > maxcount )
3082 return FALSE;
3083 break;
3084 }
3085
3086 for(i=0; i<count; i++)
3087 { if ( !PL_unify_list(list, head, list) ||
3088 !PL_unify(head, v0+i) )
3089 fail;
3090 }
3091 PL_reset_term_refs(head);
3092
3093 if ( tail )
3094 return PL_unify(list, tail);
3095 else
3096 return PL_unify_nil(list);
3097 }
3098
3099
3100 static
3101 PRED_IMPL("term_variables", 2, term_variables2, PL_FA_ISO)
3102 { PRED_LD
3103
3104 return term_variables(A1, A2, 0, 0 PASS_LD);
3105 }
3106
3107
3108 static
3109 PRED_IMPL("term_variables", 3, term_variables3, 0)
3110 { PRED_LD
3111
3112 return term_variables(A1, A2, A3, 0 PASS_LD);
3113 }
3114
3115
3116 static
3117 PRED_IMPL("term_singletons", 2, term_singletons, 0)
3118 { PRED_LD
3119
3120 if ( PL_is_acyclic(A1) )
3121 return term_variables(A1, A2, 0, TV_SINGLETON PASS_LD);
3122 else
3123 return PL_representation_error("acyclic_term");
3124 }
3125
3126
3127 static
3128 PRED_IMPL("term_attvars", 2, term_attvars, 0)
3129 { PRED_LD
3130
3131 return term_variables(A1, A2, 0, TV_ATTVAR PASS_LD);
3132 }
3133
3134
3135 static int
is_most_general_term(Word p ARG_LD)3136 is_most_general_term(Word p ARG_LD)
3137 { deRef(p);
3138
3139 if ( isAtom(*p) )
3140 return TRUE;
3141
3142 if ( isTerm(*p) )
3143 { Functor t = valueTerm(*p);
3144
3145 if ( t->definition == FUNCTOR_dot2 )
3146 { Word tail;
3147
3148 (void)skip_list(p, &tail PASS_LD);
3149
3150 if ( isNil(*tail) )
3151 { Word l = p;
3152 int rc = TRUE;
3153
3154 while( isList(*l) )
3155 { Word h = HeadList(l);
3156
3157 deRef(h);
3158 if ( !isVar(*h) )
3159 { rc = FALSE;
3160 break;
3161 }
3162 set_marked(h);
3163 l = TailList(l);
3164 deRef(l);
3165 }
3166
3167 l = p;
3168 while( isList(*l) )
3169 { Word h = HeadList(l);
3170
3171 deRef(h);
3172 if ( is_marked(h) )
3173 { clear_marked(h);
3174 l = TailList(l);
3175 deRef(l);
3176 } else
3177 { break;
3178 }
3179 }
3180
3181 return rc;
3182 }
3183 } else
3184 { size_t arity = arityFunctor(t->definition);
3185 size_t i, j;
3186 int rc = TRUE;
3187
3188 for(i=0; i<arity; i++)
3189 { Word a = &t->arguments[i];
3190
3191 deRef(a);
3192 if ( !isVar(*a) )
3193 { rc = FALSE;
3194 break;
3195 }
3196 set_marked(a);
3197 }
3198 for(j=0; j<i; j++)
3199 { Word a = &t->arguments[j];
3200
3201 deRef(a);
3202 clear_marked(a);
3203 }
3204
3205 return rc;
3206 }
3207 }
3208
3209 return FALSE;
3210 }
3211
3212
3213 static
3214 PRED_IMPL("is_most_general_term", 1, is_most_general_term, 0)
3215 { PRED_LD
3216
3217 return is_most_general_term(valTermRef(A1) PASS_LD);
3218 }
3219
3220
3221 /*******************************
3222 * SUBSUMES *
3223 *******************************/
3224
3225 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3226 subsumes is defined as
3227
3228 subsumes(General, Specific) :-
3229 term_variables(Specific, SVars),
3230 General = Specific,
3231 term_variables(SVars, SVars).
3232
3233 Below is the implementation, but we keep the array of variables instead
3234 of creating an array and we check whether these are all unique variables
3235 by scanning the array. This saves both time and space.
3236
3237 We tried to do this using a one-sided unification implementation. Most
3238 of this is fairly trivial, but we must make sure we know when left
3239 argument (general) becomes a pointer in the specific term. There are
3240 three cases for this to happen. One is following a cycle-reference, two
3241 is following a previously bound term and three is following a reference
3242 pointer from a variable that was shared between general and specific
3243 before the entry of subsumes/2. The first two are easily fixed. I don't
3244 know how to fix the latter without a complete scan on specific. If we
3245 need to do that anyway, we can just as well use the below simple
3246 algorithm.
3247
3248 We can enhance on this by combining this with the one-sided unification.
3249 We could delay scanning specific until we bind the first variable. This
3250 will not have any significant inpact on performance for a succeeding
3251 subsumes check, but can result in early failure and avoiding the scan of
3252 specific. This works because the one-sided unification algorithm can
3253 only succeed in places where it should fail.
3254
3255 The latest version of the old algorithm is in the GIT commit
3256
3257 f68eb71a9d5d0b9b6055483842d9654c30e29550
3258 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3259
3260 static int
subsumes(term_t general,term_t specific ARG_LD)3261 subsumes(term_t general, term_t specific ARG_LD)
3262 { term_t v0;
3263 size_t i, n;
3264 term_t ex = 0;
3265 int rc;
3266 int omode;
3267
3268 for(;;)
3269 { n = term_variables_to_termv(specific, &v0, ~0, 0 PASS_LD);
3270 if ( n == TV_EXCEPTION )
3271 return FALSE;
3272 if ( n == TV_NOSPACE )
3273 { PL_reset_term_refs(v0);
3274 if ( !makeMoreStackSpace(LOCAL_OVERFLOW, ALLOW_SHIFT) )
3275 return FALSE; /* GC does not help */
3276 continue;
3277 }
3278 if ( n == TV_NOMEM )
3279 return PL_error(NULL, 0, NULL, ERR_NOMEM);
3280 break;
3281 }
3282
3283 omode = LD->prolog_flag.occurs_check;
3284 LD->prolog_flag.occurs_check = OCCURS_CHECK_FALSE;
3285 rc = PL_unify(general, specific);
3286 LD->prolog_flag.occurs_check = omode;
3287
3288 if ( rc &&
3289 (ex = PL_new_term_ref()) &&
3290 foreignWakeup(ex PASS_LD) )
3291 { int rc = TRUE;
3292
3293 startCritical;
3294 initvisited(PASS_LD1);
3295 for(i=0; i<n; i++)
3296 { Word p = valTermRef(v0+i);
3297 deRef(p);
3298
3299 if ( !canBind(*p) || visitedWord(p PASS_LD) )
3300 { rc = FALSE;
3301 break;
3302 }
3303 }
3304 unvisit(PASS_LD1);
3305 if ( !endCritical )
3306 return FALSE;
3307 return rc;
3308 }
3309
3310 if ( ex && !PL_is_variable(ex) )
3311 return PL_raise_exception(ex);
3312
3313 fail;
3314 }
3315
3316
3317 static
3318 PRED_IMPL("subsumes_term", 2, subsumes_term, PL_FA_ISO)
3319 { PRED_LD
3320 int rc;
3321 fid_t fid;
3322
3323 fid = PL_open_foreign_frame();
3324 rc = subsumes(A1, A2 PASS_LD);
3325 PL_discard_foreign_frame(fid);
3326
3327 return rc;
3328 }
3329
3330
3331 /** free_variable_set(+Template^GoalIn, -GoalOut, -VarTemplate)
3332
3333 This implements _|free variable set|_ as defined the ISO core standard
3334 (sec. 7.1.1.4) for setof/3 and bagof/3. This demands ^/2-quantification
3335 to be on the outside (except for M:) and removes ^/2 from the goal-term.
3336 The latter implies that we no longer need ^/2 as a predicate.
3337 */
3338
3339 static size_t
free_variables_loop(Word t,atom_t * mname,term_t goal ARG_LD)3340 free_variables_loop(Word t, atom_t *mname, term_t goal ARG_LD)
3341 { term_agenda agenda;
3342 int in_goal = FALSE;
3343 int existential = FALSE; /* TRUE when processing left of ^ */
3344 size_t n = 0;
3345 word mark = 0; /* mark that tells us we completed vars */
3346
3347 initTermAgenda(&agenda, 1, t);
3348 while((t=nextTermAgenda(&agenda)))
3349 { if ( t == &mark )
3350 { existential = FALSE;
3351 continue;
3352 }
3353
3354 again:
3355 if ( canBind(*t) )
3356 { term_t v;
3357
3358 if ( !visitedWord(t PASS_LD) && !existential )
3359 { if ( !(v = PL_new_term_ref_noshift()) )
3360 { n = TV_NOSPACE;
3361 goto out;
3362 }
3363 *valTermRef(v) = makeRef(t);
3364
3365 n++;
3366 }
3367
3368 continue;
3369 }
3370
3371 if ( isTerm(*t) )
3372 { Functor f = valueTerm(*t);
3373 functor_t fd = f->definition; /* modified by visited */
3374
3375 if ( visited(f PASS_LD) )
3376 { if ( !in_goal && !existential )
3377 { *valTermRef(goal) = *t;
3378 in_goal = TRUE;
3379 }
3380 continue;
3381 }
3382
3383 if ( !in_goal )
3384 { if ( fd == FUNCTOR_hat2 && existential == FALSE )
3385 { if ( !pushWorkAgenda(&agenda, 1, &f->arguments[1]) ||
3386 !pushWorkAgenda(&agenda, 1, &mark) ||
3387 !pushWorkAgenda(&agenda, 1, &f->arguments[0]) )
3388 return TV_NOMEM;
3389 existential = TRUE;
3390 continue;
3391 }
3392 if ( fd == FUNCTOR_colon2 && !existential )
3393 { Word a1;
3394
3395 deRef2(&f->arguments[0], a1);
3396 if ( isAtom(*a1) )
3397 *mname = *a1;
3398 t = &f->arguments[1];
3399 goto again;
3400 } else if ( !existential )
3401 { *valTermRef(goal) = *t;
3402 in_goal = TRUE;
3403 }
3404 }
3405
3406 if ( !pushWorkAgenda(&agenda, arityFunctor(fd), f->arguments) )
3407 return TV_NOMEM;
3408
3409 continue;
3410 } else if ( !in_goal && !existential) /* non-term goal (atom or invalid) */
3411 { *valTermRef(goal) = needsRef(*t) ? makeRef(t) : *t;
3412 in_goal = TRUE;
3413 }
3414 }
3415
3416 out:
3417 clearTermAgenda(&agenda);
3418
3419 return n;
3420 }
3421
3422
3423 static
3424 PRED_IMPL("$free_variable_set", 3, free_variable_set, 0)
3425 { GET_LD
3426
3427 for(;;)
3428 { term_t goal = PL_new_term_ref();
3429 term_t v0 = PL_new_term_refs(0);
3430 size_t n;
3431 atom_t mname = (atom_t)0;
3432
3433 startCritical;
3434 initvisited(PASS_LD1);
3435 n = free_variables_loop(valTermRef(A1), &mname, goal PASS_LD);
3436 unvisit(PASS_LD1);
3437 if ( !endCritical )
3438 return FALSE;
3439 if ( n == TV_NOSPACE )
3440 { PL_reset_term_refs(goal);
3441 if ( !makeMoreStackSpace(LOCAL_OVERFLOW, ALLOW_SHIFT) )
3442 return FALSE;
3443 continue;
3444 }
3445 if ( n == TV_NOMEM )
3446 return PL_error(NULL, 0, NULL, ERR_NOMEM);
3447
3448 if ( PL_unify_functor(A3, PL_new_functor(ATOM_v, (int)n)) )
3449 { int i, m = (int)n;
3450
3451 for(i=0; i<m; i++)
3452 { if ( !PL_unify_arg(i+1, A3, v0+i) )
3453 return FALSE;
3454 }
3455
3456 if ( mname )
3457 { term_t m = PL_new_term_ref();
3458
3459 PL_put_atom(m, mname);
3460 if ( !PL_cons_functor(goal, FUNCTOR_colon2, m, goal) )
3461 return FALSE;
3462 }
3463
3464 return PL_unify(A2, goal);
3465 }
3466 return FALSE;
3467 }
3468 }
3469
3470
3471 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3472 unifiable(@X, @Y, -Substitution)
3473
3474 If X can be unified to Y, unify Substitution with a list of Variable =
3475 value for the substitutions that must be made to make X and Y identical.
3476
3477 The implementation extracts the substitutions from the trail, rewinding
3478 the trail at the same time. This is fairly trivial, except for the
3479 assignments of attributed variables (assignAttVar()). The last operation
3480 of assignAttVar() is a trailed assignment replacing the attvar with its
3481 value. Before that it performs two trailed actions to update the wakeup
3482 list. These two must be skipped.
3483
3484 Unfortunately, if a value is unified to a local stack variable (which
3485 can only be the case if one of the arguments is a plain variable) things
3486 get very complicated. Therefore we test these cases before going into
3487 the trouble. Note that unifying attributed variables is no problem as
3488 these always live on the global stack.
3489
3490 (*) Unfortunately, we cannot handle shift/GC during this process. In
3491 particular, if we need space for the result-list, we cannot call
3492 allocGlobal(), because the resulting GC will do early-reset on the
3493 trailed variables and thus invalidate our nice and clean trail. So, if
3494 there is no space we rewind and retry the whole process.
3495 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3496
3497 static int
unifiable_occurs_check(term_t t1,term_t t2 ARG_LD)3498 unifiable_occurs_check(term_t t1, term_t t2 ARG_LD)
3499 { switch(LD->prolog_flag.occurs_check)
3500 { case OCCURS_CHECK_FALSE:
3501 return TRUE;
3502 case OCCURS_CHECK_TRUE:
3503 case OCCURS_CHECK_ERROR:
3504 { Word p1 = valTermRef(t1);
3505 Word p2 = valTermRef(t2);
3506
3507 deRef(p1);
3508 if ( !var_occurs_in(p1, p2 PASS_LD) )
3509 return TRUE;
3510
3511 return failed_unify_with_occurs_check(p1, p2,
3512 LD->prolog_flag.occurs_check
3513 PASS_LD);
3514 }
3515 default:
3516 assert(0);
3517 fail;
3518 }
3519 }
3520
3521
3522 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3523 Same as unify_ptrs(), but ensures that all assignments are trailed by
3524 setting LD->mark_bar to the top of the memory. Note that NO_MARK_BAR
3525 also needs support in garbageCollect() and growStacks().
3526 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3527
3528 static bool
unify_all_trail_ptrs(Word t1,Word t2,mark * m ARG_LD)3529 unify_all_trail_ptrs(Word t1, Word t2, mark *m ARG_LD)
3530 { for(;;)
3531 { int rc;
3532
3533 Mark(*m);
3534 LD->mark_bar = NO_MARK_BAR;
3535 rc = raw_unify_ptrs(t1, t2 PASS_LD);
3536 if ( rc == TRUE ) /* Terms unified */
3537 { return rc;
3538 } else if ( rc == FALSE ) /* Terms did not unify */
3539 { if ( !exception_term ) /* Check for occurs error */
3540 Undo(*m);
3541 DiscardMark(*m);
3542 return rc;
3543 } else /* Stack overflow */
3544 { int rc2;
3545
3546 Undo(*m);
3547 DiscardMark(*m);
3548 PushPtr(t1); PushPtr(t2);
3549 rc2 = makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT);
3550 PopPtr(t2); PopPtr(t1);
3551 if ( !rc2 )
3552 return FALSE;
3553 }
3554 }
3555 }
3556
3557
3558 static ssize_t
unifiable(term_t t1,term_t t2,term_t subst ARG_LD)3559 unifiable(term_t t1, term_t t2, term_t subst ARG_LD)
3560 { mark m;
3561 int rc;
3562
3563 if ( PL_is_variable(t1) )
3564 { if ( PL_compare(t1, t2) == 0 )
3565 { return PL_unify_atom(subst, ATOM_nil);
3566 } else
3567 { if ( !unifiable_occurs_check(t1, t2 PASS_LD) )
3568 fail;
3569
3570 return PL_unify_term(subst,
3571 PL_FUNCTOR, FUNCTOR_dot2,
3572 PL_FUNCTOR, FUNCTOR_equals2,
3573 PL_TERM, t1,
3574 PL_TERM, t2,
3575 PL_ATOM, ATOM_nil);
3576 }
3577 }
3578 if ( PL_is_variable(t2) )
3579 { if ( !unifiable_occurs_check(t2, t1 PASS_LD) )
3580 fail;
3581
3582 return PL_unify_term(subst,
3583 PL_FUNCTOR, FUNCTOR_dot2,
3584 PL_FUNCTOR, FUNCTOR_equals2,
3585 PL_TERM, t2,
3586 PL_TERM, t1,
3587 PL_ATOM, ATOM_nil);
3588 }
3589
3590 retry:
3591 if ( unify_all_trail_ptrs(valTermRef(t1), /* can do shift/gc */
3592 valTermRef(t2), &m PASS_LD) )
3593 { TrailEntry tt = tTop;
3594 TrailEntry mt = m.trailtop;
3595
3596 if ( tt > mt )
3597 { ssize_t needed = (tt-mt)*6+1;
3598 Word list, gp, tail;
3599
3600 if ( !hasGlobalSpace(needed) ) /* See (*) */
3601 { int rc = overflowCode(needed);
3602
3603 Undo(m);
3604 DiscardMark(m);
3605 rc = makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT);
3606 if ( rc )
3607 goto retry;
3608 return FALSE;
3609 }
3610
3611 DiscardMark(m);
3612 tail = list = gTop;
3613 gp = list+1;
3614
3615 *list = ATOM_nil;
3616 while(--tt >= mt)
3617 { Word p = tt->address;
3618
3619 *tail = consPtr(&gp[0], TAG_COMPOUND|STG_GLOBAL);
3620 gp[0] = FUNCTOR_dot2;
3621 gp[1] = consPtr(&gp[3], TAG_COMPOUND|STG_GLOBAL);
3622 gp[2] = ATOM_nil;
3623 tail = &gp[2];
3624 gp[3] = FUNCTOR_equals2;
3625 if ( isTrailVal(p) )
3626 { Word p2 = tt[-1].address;
3627 gp[4] = makeRef(p2);
3628 gp[5] = *p2;
3629 } else
3630 { gp[5] = *p;
3631 assert(onGlobalArea(p));
3632 gp[4] = makeRefG(p);
3633 setVar(*p);
3634 }
3635 gp += 6;
3636
3637 if ( isTrailVal(p) )
3638 { assert(isAttVar(trailVal(p)));
3639
3640 tt--; /* re-insert the attvar */
3641 *tt->address = trailVal(p);
3642
3643 tt--; /* restore tail of wakeup list */
3644 p = tt->address;
3645 if ( isTrailVal(p) )
3646 { tt--;
3647 *tt->address = trailVal(p);
3648 } else
3649 { setVar(*p);
3650 }
3651
3652 tt--; /* restore head of wakeup list */
3653 p = tt->address;
3654 if ( isTrailVal(p) )
3655 { tt--;
3656 *tt->address = trailVal(p);
3657 } else
3658 { setVar(*p);
3659 }
3660
3661 assert(tt>=mt);
3662 }
3663 }
3664 gTop = gp; /* may not have used all space */
3665 tTop = m.trailtop;
3666
3667 rc = PL_unify(pushWordAsTermRef(list), subst);
3668 popTermRef();
3669
3670 return rc;
3671 } else
3672 { DiscardMark(m);
3673 return PL_unify_atom(subst, ATOM_nil);
3674 }
3675 } else
3676 { return FALSE;
3677 }
3678 }
3679
3680
3681 static
3682 PRED_IMPL("unifiable", 3, unifiable, 0)
3683 { PRED_LD
3684
3685 return unifiable(A1, A2, A3 PASS_LD);
3686 }
3687
3688
3689
3690 /*******************************
3691 * ATOMS *
3692 *******************************/
3693
3694 static
3695 PRED_IMPL("atom_length", 2, atom_length, PL_FA_ISO)
3696 { PRED_LD
3697 int flags;
3698 PL_chars_t txt;
3699
3700 if ( truePrologFlag(PLFLAG_ISO) )
3701 flags = CVT_ATOM|CVT_STRING|CVT_EXCEPTION|BUF_ALLOW_STACK;
3702 else
3703 flags = CVT_ALL|CVT_EXCEPTION|BUF_ALLOW_STACK;
3704
3705 if ( PL_get_text(A1, &txt, flags) )
3706 { int rc = PL_unify_int64_ex(A2, txt.length);
3707
3708 PL_free_text(&txt);
3709
3710 return rc;
3711 }
3712
3713 fail;
3714 }
3715
3716
3717 #define X_AUTO 0x00
3718 #define X_ATOM 0x01
3719 #define X_NUMBER 0x02
3720 #define X_MASK 0x0f
3721 #define X_CHARS 0x10
3722 #define X_STRING 0x20
3723 #define X_NO_SYNTAX_ERROR 0x40
3724 #define X_NO_LEADING_WHITE 0x80
3725
3726 static int
x_chars(const char * pred,term_t atom,term_t string,int how ARG_LD)3727 x_chars(const char *pred, term_t atom, term_t string, int how ARG_LD)
3728 { PL_chars_t atext, stext;
3729 int arg1;
3730 int flags2 = CVT_STRING|CVT_LIST|CVT_EXCEPTION;
3731
3732 arg1 = PL_get_text(atom, &atext,
3733 (how & X_NUMBER) ? CVT_NUMBER : CVT_ATOMIC);
3734
3735 if ( arg1 ) /* +,? */
3736 { int ok;
3737 int out_type;
3738 fid_t fid = PL_open_foreign_frame();
3739
3740 out_type = (how&X_CHARS ? PL_CHAR_LIST :
3741 how&X_STRING ? PL_STRING : PL_CODE_LIST);
3742
3743 ok = PL_unify_text(string, 0, &atext, out_type);
3744
3745 if ( ok )
3746 { PL_close_foreign_frame(fid);
3747 return ok;
3748 }
3749 flags2 |= CVT_VARNOFAIL;
3750 PL_discard_foreign_frame(fid);
3751 } else if ( !PL_is_variable(atom) )
3752 { atom_t type;
3753
3754 how &= X_MASK;
3755 type = (how == X_ATOM ? ATOM_atom :
3756 how == X_NUMBER ? ATOM_number :
3757 ATOM_atomic);
3758
3759 return PL_error(pred, 2, NULL, ERR_TYPE, type, atom);
3760 }
3761
3762 if ( PL_get_text(string, &stext, flags2) != TRUE )
3763 return FALSE;
3764
3765 switch(how&X_MASK)
3766 { case X_ATOM:
3767 case_atom:
3768 return PL_unify_text(atom, 0, &stext, PL_ATOM);
3769 case X_NUMBER:
3770 case X_AUTO:
3771 { strnumstat rc;
3772
3773 if ( stext.encoding == ENC_ISO_LATIN_1 )
3774 { unsigned char *q, *s = (unsigned char *)stext.text.t;
3775 number n;
3776
3777 if ( (how&X_MASK) == X_NUMBER && !(how&X_NO_LEADING_WHITE) )
3778 { while(*s && isBlank(*s)) /* ISO: number_codes(X, " 42") */
3779 s++;
3780 }
3781
3782 if ( (rc=str_number(s, &q, &n, 0)) == NUM_OK ) /* TBD: rational support? */
3783 { if ( *q == EOS )
3784 { int rc2 = PL_unify_number(atom, &n);
3785 clearNumber(&n);
3786 return rc2;
3787 } else
3788 rc = NUM_ERROR;
3789 clearNumber(&n);
3790 }
3791 } else
3792 rc = NUM_ERROR;
3793
3794 if ( (how&X_MASK) == X_AUTO )
3795 goto case_atom;
3796 else if ( !(how & X_NO_SYNTAX_ERROR) )
3797 return PL_error(pred, 2, NULL, ERR_SYNTAX, str_number_error(rc));
3798 else
3799 return FALSE;
3800 }
3801 default:
3802 assert(0);
3803 return FALSE;
3804 }
3805 }
3806
3807
3808 static
3809 PRED_IMPL("name", 2, name, 0)
3810 { PRED_LD
3811 return x_chars("name", A1, A2, X_AUTO PASS_LD);
3812 }
3813
3814
3815 static
3816 PRED_IMPL("atom_chars", 2, atom_chars, PL_FA_ISO)
3817 { PRED_LD
3818 return x_chars("atom_chars", A1, A2, X_ATOM|X_CHARS PASS_LD);
3819 }
3820
3821
3822 static
3823 PRED_IMPL("atom_codes", 2, atom_codes, PL_FA_ISO)
3824 { PRED_LD
3825 return x_chars("atom_codes", A1, A2, X_ATOM PASS_LD);
3826 }
3827
3828
3829 static
3830 PRED_IMPL("number_chars", 2, number_chars, PL_FA_ISO)
3831 { PRED_LD
3832 return x_chars("number_chars", A1, A2, X_NUMBER|X_CHARS PASS_LD);
3833 }
3834
3835
3836 static
3837 PRED_IMPL("number_codes", 2, number_codes, PL_FA_ISO)
3838 { PRED_LD
3839 return x_chars("number_codes", A1, A2, X_NUMBER PASS_LD);
3840 }
3841
3842
3843 static
3844 PRED_IMPL("number_string", 2, number_string, 0)
3845 { PRED_LD
3846 return x_chars("number_string", A1, A2,
3847 X_NUMBER|X_STRING|X_NO_SYNTAX_ERROR|X_NO_LEADING_WHITE
3848 PASS_LD);
3849 }
3850
3851
3852 static
3853 PRED_IMPL("char_code", 2, char_code, PL_FA_ISO)
3854 { PRED_LD
3855 PL_chars_t txt;
3856 int n;
3857 term_t atom = A1;
3858 term_t chr = A2;
3859 int vatom = PL_is_variable(atom);
3860 int vchr = PL_is_variable(chr);
3861 int achr = -1;
3862 int cchr = -1;
3863
3864 if ( vatom && vchr )
3865 return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
3866
3867 if ( !vatom )
3868 { if ( PL_get_text(atom, &txt, CVT_ATOM|CVT_STRING) && txt.length == 1 )
3869 { if ( txt.encoding == ENC_WCHAR )
3870 achr = txt.text.w[0];
3871 else
3872 achr = txt.text.t[0]&0xff;
3873 } else
3874 { return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_character, atom);
3875 }
3876 }
3877
3878 if ( !vchr )
3879 { if ( !PL_get_integer_ex(chr, &n) )
3880 fail;
3881
3882 if ( n >= 0 && n <= PLMAXWCHAR )
3883 cchr = n;
3884 else if ( n < 0 || n > 0x10ffff )
3885 return PL_type_error("character_code", chr);
3886 #if SIZEOF_WCHAR_T == 2
3887 else if ( n > PLMAXWCHAR )
3888 return PL_representation_error("character_code");
3889 #else
3890 else
3891 assert(0);
3892 #endif
3893 }
3894
3895 if ( achr == cchr )
3896 succeed;
3897 if ( vatom )
3898 return PL_unify_atom(atom, codeToAtom(cchr));
3899 else
3900 return PL_unify_integer(chr, achr);
3901 }
3902
3903
3904 static int
is_code(word w)3905 is_code(word w)
3906 { if ( isTaggedInt(w) )
3907 { intptr_t code = valInt(w);
3908
3909 return code >= 0 && code <= PLMAXWCHAR;
3910 }
3911
3912 return FALSE;
3913 }
3914
3915 static int
is_char(word w)3916 is_char(word w)
3917 { PL_chars_t text;
3918
3919 return ( isAtom(w) &&
3920 get_atom_text(w, &text) &&
3921 text.length == 1
3922 );
3923 }
3924
3925 static
3926 PRED_IMPL("$is_char_code", 1, is_char_code, 0)
3927 { PRED_LD;
3928 Word p = valTermRef(A1);
3929
3930 deRef(p);
3931 return is_code(*p);
3932
3933 return FALSE;
3934 }
3935
3936 static
3937 PRED_IMPL("$is_char", 1, is_char, 0)
3938 { PRED_LD;
3939 Word p = valTermRef(A1);
3940
3941 deRef(p);
3942 return is_char(*p);
3943 }
3944
3945
3946 static int
is_text_list(term_t text,term_t lent,int (* test)(word)ARG_LD)3947 is_text_list(term_t text, term_t lent, int (*test)(word) ARG_LD)
3948 { Word p = valTermRef(text);
3949 intptr_t len = 0;
3950
3951 deRef(p);
3952 while(isList(*p))
3953 { Word av = HeadList(p);
3954 Word h;
3955
3956 deRef2(av, h);
3957 if ( !(*test)(*h) )
3958 return FALSE;
3959 deRef2(av+1, p);
3960
3961 if ( ++len == 1000 )
3962 { Word tail;
3963 skip_list(p, &tail PASS_LD);
3964 if ( !isNil(*tail) )
3965 return FALSE;
3966 }
3967 }
3968 return ( isNil(*p) &&
3969 PL_unify_int64(lent, len) );
3970 }
3971
3972 static
3973 PRED_IMPL("$is_code_list", 2, is_code_list, 0)
3974 { PRED_LD
3975
3976 return is_text_list(A1, A2, is_code PASS_LD);
3977 }
3978
3979 static
3980 PRED_IMPL("$is_char_list", 2, is_char_list, 0)
3981 { PRED_LD
3982
3983 return is_text_list(A1, A2, is_char PASS_LD);
3984 }
3985
3986
3987 static
3988 PRED_IMPL("atom_number", 2, atom_number, 0)
3989 { PRED_LD
3990 char *s;
3991 size_t len;
3992
3993 if ( PL_get_nchars(A1, &len, &s, CVT_ATOM|CVT_STRING) )
3994 { number n;
3995 unsigned char *q;
3996 strnumstat rc;
3997
3998 if ( (rc=str_number((unsigned char *)s, &q, &n, 0) == NUM_OK) ) /* TBD: rational support */
3999 { if ( *q == EOS )
4000 { int rc = PL_unify_number(A2, &n);
4001 clearNumber(&n);
4002
4003 return rc;
4004 } else
4005 { clearNumber(&n);
4006 return FALSE;
4007 }
4008 } else
4009 { return FALSE;
4010 }
4011 } else if ( PL_get_nchars(A2, &len, &s, CVT_NUMBER) )
4012 { return PL_unify_atom_nchars(A1, len, s);
4013 }
4014
4015 if ( !PL_is_variable(A2) )
4016 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_number, A2);
4017 else if ( !PL_is_atom(A1) )
4018 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, A1);
4019 else
4020 return FALSE;
4021 }
4022
4023 /* MacOS X Mavericks and Yosemite write a char (nul) too many if the
4024 * buffer is short. Thanks to Samer Abdallah for sorting this out.
4025 */
4026 #ifdef __APPLE__
4027 #define WCSXFRM_BUFFER_OVERRUN 1
4028 #else
4029 #define WCSXFRM_BUFFER_OVERRUN 0
4030 #endif
4031
4032 static
4033 PRED_IMPL("collation_key", 2, collation_key, 0)
4034 {
4035 #ifdef HAVE_WCSXFRM
4036 wchar_t *s;
4037 size_t len;
4038 wchar_t buf[256];
4039 size_t buflen = sizeof(buf)/sizeof(wchar_t) - WCSXFRM_BUFFER_OVERRUN;
4040 wchar_t *o = buf;
4041 size_t n;
4042
4043 if ( !PL_get_wchars(A1, &len, &s, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) )
4044 fail;
4045 for(;;)
4046 { if ( (n=wcsxfrm(o, s, buflen)) < buflen )
4047 { int rc = PL_unify_wchars(A2, PL_STRING, n, o);
4048
4049 if ( o != buf )
4050 PL_free(o);
4051
4052 return rc;
4053 } else
4054 { assert(o == buf);
4055 buflen = n+1;
4056 o = PL_malloc(buflen*sizeof(wchar_t));
4057 }
4058 }
4059 #else
4060 GET_LD
4061 return PL_unify(A1, A2);
4062 #endif
4063 }
4064
4065 static word
concat(term_t a1,term_t a2,term_t a3,int bidirectional,control_t ctx,int accept,int otype ARG_LD)4066 concat(term_t a1, term_t a2, term_t a3,
4067 int bidirectional, /* FALSE: only mode +,+,- */
4068 control_t ctx,
4069 int accept, /* CVT_* */
4070 int otype ARG_LD) /* PL_ATOM or PL_STRING */
4071 { PL_chars_t t1, t2, t3;
4072 int rc;
4073 int inmode = bidirectional ? CVT_VARNOFAIL : 0;
4074
4075 #define L1 t1.length
4076 #define L2 t2.length
4077 #define L3 t3.length
4078
4079 if ( ForeignControl(ctx) == FRG_CUTTED )
4080 succeed;
4081
4082 t1.text.t = t2.text.t = t3.text.t = NULL;
4083
4084 if ( !PL_get_text(a1, &t1, accept|inmode|CVT_EXCEPTION) ||
4085 !PL_get_text(a2, &t2, accept|inmode|CVT_EXCEPTION) ||
4086 !PL_get_text(a3, &t3, accept|CVT_EXCEPTION|CVT_VARNOFAIL) )
4087 fail;
4088
4089 if ( t1.text.t && t2.text.t )
4090 { if ( t3.text.t )
4091 { rc = ( t1.length + t2.length == t3.length &&
4092 PL_cmp_text(&t1, 0, &t3, 0, t1.length) == 0 &&
4093 PL_cmp_text(&t2, 0, &t3, t1.length, t2.length) == 0 );
4094 goto out;
4095 } else
4096 { PL_chars_t c;
4097 PL_chars_t *v[2];
4098
4099 v[0] = &t1;
4100 v[1] = &t2;
4101
4102 PL_concat_text(2, v, &c);
4103
4104 rc = PL_unify_text(a3, 0, &c, otype);
4105 PL_free_text(&c);
4106 goto out;
4107 }
4108 }
4109
4110 if ( !t3.text.t )
4111 return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
4112
4113 if ( t1.text.t ) /* +, -, + */
4114 { if ( L1 <= L3 &&
4115 PL_cmp_text(&t1, 0, &t3, 0, L1) == 0 )
4116 return PL_unify_text_range(a2, &t3, L1, L3-L1, otype);
4117 fail;
4118 } else if ( t2.text.t ) /* -, +, + */
4119 { if ( L2 <= L3 &&
4120 PL_cmp_text(&t2, 0, &t3, L3-L2, L2) == 0 )
4121 return PL_unify_text_range(a1, &t3, 0, L3-L2, otype);
4122 fail;
4123 } else /* -, -, + */
4124 { size_t at_n;
4125
4126 switch ( ForeignControl(ctx) )
4127 { case FRG_FIRST_CALL:
4128 if ( PL_same_term(a1, a2) ) /* sharing variables */
4129 { if ( L3 % 2 )
4130 { rc = FALSE;
4131 goto out;
4132 } else
4133 { at_n = L3/2;
4134 if ( PL_cmp_text(&t3, 0, &t3, at_n, at_n) == 0 )
4135 { PL_unify_text_range(a1, &t3, 0, at_n, otype);
4136 rc = TRUE;
4137 } else
4138 { rc = FALSE;
4139 }
4140 goto out;
4141 }
4142 }
4143 at_n = 0;
4144 break;
4145 case FRG_REDO:
4146 at_n = ForeignContextInt(ctx);
4147 break;
4148 default:
4149 succeed;
4150 }
4151
4152 PL_unify_text_range(a2, &t3, at_n, L3-at_n, otype);
4153 PL_unify_text_range(a1, &t3, 0, at_n, otype);
4154 if ( at_n < L3 )
4155 ForeignRedoInt(at_n+1);
4156
4157 rc = TRUE;
4158 }
4159
4160 out:
4161 if ( t1.text.t ) PL_free_text(&t1);
4162 if ( t2.text.t ) PL_free_text(&t2);
4163 if ( t3.text.t ) PL_free_text(&t3);
4164
4165 #undef L1
4166 #undef L2
4167 #undef L3
4168
4169 return rc;
4170 }
4171
4172
4173 static
4174 PRED_IMPL("atom_concat", 3, atom_concat, PL_FA_NONDETERMINISTIC|PL_FA_ISO)
4175 { PRED_LD
4176
4177 return concat(A1, A2, A3, TRUE, PL__ctx, CVT_ATOMIC, PL_ATOM PASS_LD);
4178 }
4179
4180
4181 static
4182 PRED_IMPL("atomic_concat", 3, atomic_concat, PL_FA_ISO)
4183 { PRED_LD
4184
4185 return concat(A1, A2, A3, FALSE, PL__ctx, CVT_ATOMIC, PL_ATOM PASS_LD);
4186 }
4187
4188
4189 static int
split_atom(term_t list,PL_chars_t * st,term_t atom ARG_LD)4190 split_atom(term_t list, PL_chars_t *st, term_t atom ARG_LD)
4191 { PL_chars_t at;
4192 size_t i, last;
4193 term_t tail = PL_copy_term_ref(list);
4194 term_t head = PL_new_term_ref();
4195 size_t sep_len = st->length;
4196
4197 if ( !PL_get_text(atom, &at, CVT_ATOMIC|CVT_EXCEPTION) )
4198 return FALSE;
4199
4200 for(last=i=0; (ssize_t)i<=(ssize_t)(at.length-sep_len); )
4201 { if ( PL_cmp_text(st, 0, &at, i, sep_len) == 0 )
4202 { if ( !PL_unify_list(tail, head, tail) ||
4203 !PL_unify_text_range(head, &at, last, i-last, PL_ATOM) )
4204 fail;
4205 i += sep_len;
4206 last = i;
4207 } else
4208 i++;
4209 }
4210
4211 if ( !PL_unify_list(tail, head, tail) ||
4212 !PL_unify_text_range(head, &at, last, at.length-last, PL_ATOM) )
4213 fail;
4214
4215 return PL_unify_nil(tail);
4216 }
4217
4218
4219 static void
append_text_to_buffer(Buffer b,PL_chars_t * txt,IOENC * enc)4220 append_text_to_buffer(Buffer b, PL_chars_t *txt, IOENC *enc)
4221 { if ( txt->encoding == *enc )
4222 { if ( txt->encoding == ENC_ISO_LATIN_1 )
4223 { addMultipleBuffer(b, txt->text.t, txt->length, char);
4224 } else
4225 { addMultipleBuffer(b, txt->text.w, txt->length, pl_wchar_t);
4226 }
4227 } else if ( txt->encoding == ENC_ISO_LATIN_1 )
4228 { const unsigned char *s = (const unsigned char*)txt->text.t;
4229 const unsigned char *e = &s[txt->length];
4230
4231 for( ;s<e; s++)
4232 { pl_wchar_t chr = *s;
4233
4234 addBuffer(b, chr, pl_wchar_t);
4235 }
4236 } else /* promote our buffer */
4237 { size_t len = entriesBuffer(b, char);
4238 unsigned char *tmp = PL_malloc(len);
4239 const unsigned char *s = tmp;
4240 const unsigned char *e = &s[len];
4241
4242 memcpy(tmp, baseBuffer(b, char), len);
4243 discardBuffer(b);
4244 initBuffer(b);
4245
4246 for( ;s<e; s++)
4247 { pl_wchar_t chr = *s;
4248
4249 addBuffer(b, chr, pl_wchar_t);
4250 }
4251
4252 PL_free(tmp);
4253 *enc = ENC_WCHAR;
4254 /* and add new text */
4255 addMultipleBuffer(b, txt->text.w, txt->length, pl_wchar_t);
4256 }
4257 }
4258
4259
4260 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4261 atomic_list_concat() implements atomic_list_concat/2,3 and
4262 atomics_to_string/2,3.
4263
4264 (*) Note that the atom-version for historical reasons supports the mode
4265 (-,+,+)
4266 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4267
4268 static foreign_t
atomic_list_concat(term_t list,term_t sep,term_t atom,int ret_type ARG_LD)4269 atomic_list_concat(term_t list, term_t sep, term_t atom, int ret_type ARG_LD)
4270 { term_t l = PL_copy_term_ref(list);
4271 term_t head = PL_new_term_ref();
4272 IOENC enc = ENC_ISO_LATIN_1;
4273 tmp_buffer b;
4274 PL_chars_t st; /* separator text */
4275 int ntxt = 0;
4276
4277 if ( sep && !PL_get_text(sep, &st, CVT_ATOMIC) )
4278 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, sep);
4279
4280 initBuffer(&b);
4281 while( PL_get_list(l, head, l) )
4282 { PL_chars_t txt;
4283
4284 if ( !PL_get_text(head, &txt, CVT_ATOMIC) )
4285 { if ( PL_is_variable(head) && sep && ret_type == PL_ATOM ) /* see (*) */
4286 goto split;
4287 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, head);
4288 }
4289
4290 if ( ntxt > 0 && sep )
4291 append_text_to_buffer((Buffer)&b, &st, &enc);
4292
4293 append_text_to_buffer((Buffer)&b, &txt, &enc);
4294 PL_free_text(&txt);
4295 if ( ++ntxt == 100 )
4296 { if ( lengthList(l, TRUE) < 0 )
4297 return FALSE;
4298 }
4299 }
4300
4301 if ( PL_get_nil(l) )
4302 { PL_chars_t sum;
4303 int rc;
4304
4305 sum.encoding = enc;
4306 sum.storage = PL_CHARS_HEAP;
4307 sum.canonical = TRUE;
4308
4309 if ( enc == ENC_ISO_LATIN_1 )
4310 { sum.text.t = baseBuffer(&b, char);
4311 sum.length = entriesBuffer(&b, char);
4312 } else
4313 { sum.text.w = baseBuffer(&b, pl_wchar_t);
4314 sum.length = entriesBuffer(&b, pl_wchar_t);
4315 }
4316
4317 rc = PL_unify_text(atom, 0, &sum, ret_type);
4318 discardBuffer(&b);
4319
4320 return rc;
4321 }
4322
4323 split:
4324 if ( !sep || st.length == 0 )
4325 { if ( !sep )
4326 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, l);
4327
4328 return PL_domain_error("non_empty_atom", sep);
4329 }
4330 discardBuffer(&b);
4331 return split_atom(list, &st, atom PASS_LD);
4332 }
4333
4334
4335 static
4336 PRED_IMPL("atomic_list_concat", 3, atomic_list_concat, 0)
4337 { PRED_LD
4338 return atomic_list_concat(A1, A2, A3, PL_ATOM PASS_LD);
4339 }
4340
4341
4342 static
4343 PRED_IMPL("atomic_list_concat", 2, atomic_list_concat, 0)
4344 { PRED_LD
4345 return atomic_list_concat(A1, 0, A2, PL_ATOM PASS_LD);
4346 }
4347
4348
4349 static
4350 PRED_IMPL("atomics_to_string", 3, atomics_to_string, 0)
4351 { PRED_LD
4352 return atomic_list_concat(A1, A2, A3, PL_STRING PASS_LD);
4353 }
4354
4355
4356 static
4357 PRED_IMPL("atomics_to_string", 2, atomics_to_string, 0)
4358 { PRED_LD
4359 return atomic_list_concat(A1, 0, A2, PL_STRING PASS_LD);
4360 }
4361
4362
4363 /** sub_atom_icasechk(+Haystack, ?Start, +Needle) is semidet.
4364 */
4365
4366 static
4367 PRED_IMPL("sub_atom_icasechk", 3, sub_atom_icasechk, 0)
4368 { PRED_LD
4369 char *needleA=NULL, *haystackA=NULL;
4370 pl_wchar_t *needleW=NULL, *haystackW=NULL;
4371 size_t l1, l2, offset;
4372 int has_offset;
4373
4374 term_t haystack = A1;
4375 term_t start = A2;
4376 term_t needle = A3;
4377
4378 if ( PL_is_variable(start) )
4379 has_offset = FALSE, offset = 0;
4380 else if ( PL_get_size_ex(start, &offset) )
4381 has_offset = TRUE;
4382 else
4383 return FALSE;
4384
4385 if ( PL_get_nchars(needle, &l1, &needleA, CVT_ALL|BUF_STACK) &&
4386 PL_get_nchars(haystack, &l2, &haystackA, CVT_ALL) )
4387 { char *s, *q, *s2 = haystackA + offset;
4388 const char *eq = (const char *)&needleA[l1];
4389 const char *es = (const char *)&haystackA[l2];
4390
4391 for (; s2<=es-l1; s2++)
4392 { for(q=needleA, s=s2; q<eq && s<es; q++, s++)
4393 { if ( *q != *s && *q != toLower(*s) )
4394 break;
4395 }
4396 if ( q == eq )
4397 { offset = s2-haystackA;
4398 goto found;
4399 }
4400 if ( has_offset )
4401 break;
4402 }
4403 fail;
4404 }
4405
4406 if ( PL_get_wchars(needle, &l1, &needleW, CVT_ALL|CVT_EXCEPTION|BUF_STACK) &&
4407 PL_get_wchars(haystack, &l2, &haystackW, CVT_ALL|CVT_EXCEPTION) )
4408 { pl_wchar_t *s, *q, *s2 = haystackW + offset;
4409 pl_wchar_t *eq = &needleW[l1];
4410 pl_wchar_t *es = &haystackW[l2];
4411
4412 for (; s2<=es-l1; s2++)
4413 { for(q=needleW, s=s2; q<eq && s<es; q++, s++)
4414 { if ( *q != *s && *q != (pl_wchar_t)towlower(*s) )
4415 break;
4416 }
4417 if ( q == eq )
4418 { offset = s2-haystackW;
4419 goto found;
4420 }
4421 if ( has_offset )
4422 break;
4423 }
4424 fail;
4425 }
4426
4427 return FALSE;
4428
4429 found:
4430 if ( !has_offset )
4431 return PL_unify_integer(start, offset);
4432
4433 return TRUE;
4434 }
4435
4436
4437 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4438 ISO compliant hacking into atoms. The state is represented by a
4439 `redo-int', of which we use the first 15 bits for the `before' and the
4440 second 15 bits for the `after'.
4441
4442 There are many possibilities (think the semantics are a bit overloaded).
4443
4444 * sub is given
4445 + if len conflicts: fail
4446 + if before or after given: test deterministically
4447 + otherwise: search (non-deterministic)
4448 * two of the integers are given
4449 + generate (deterministic)
4450 * before is given:
4451 + split the remainder (non-deterministic)
4452 * len is given:
4453 + enumerate breaks (non-deterministic)
4454 * after is given:
4455 + split the remainder (non-deterministic)
4456 * non given:
4457 + enumerate using before and len (non-deterministic)
4458 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4459
4460 enum sub_type
4461 { SUB_SEARCH, /* sub given, but no position */
4462 SUB_SPLIT_TAIL, /* before given, split tail */
4463 SUB_SPLIT_HEAD, /* after given, split head */
4464 SUB_SPLIT_LEN, /* len given, move it */
4465 SUB_ENUM /* all free */
4466 };
4467
4468 typedef struct
4469 { enum sub_type type; /* Type of enumeration */
4470 size_t n1; /* 1-st state id */
4471 size_t n2; /* 2-nd state id */
4472 size_t n3;
4473 } sub_state;
4474
4475
4476 static int
get_positive_integer_or_unbound(term_t t,ssize_t * v ARG_LD)4477 get_positive_integer_or_unbound(term_t t, ssize_t *v ARG_LD)
4478 { long i;
4479
4480 if ( PL_get_long(t, &i) ) /* TBD: should be ssize_t */
4481 { if ( i < 0 )
4482 PL_error(NULL, 0, NULL, ERR_DOMAIN,
4483 ATOM_not_less_than_zero, t);
4484 *v = i;
4485
4486 return TRUE;
4487 }
4488
4489 if ( PL_is_variable(t) )
4490 return TRUE;
4491
4492 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t);
4493 }
4494
4495
4496
4497 static foreign_t
sub_text(term_t atom,term_t before,term_t len,term_t after,term_t sub,control_t h,int type ARG_LD)4498 sub_text(term_t atom,
4499 term_t before, term_t len, term_t after,
4500 term_t sub,
4501 control_t h,
4502 int type /* PL_ATOM or PL_STRING */
4503 ARG_LD)
4504 { PL_chars_t ta, ts; /* the strings */
4505 ssize_t b = -1, l = -1, a = -1; /* the integers */
4506 sub_state *state; /* non-deterministic state */
4507 atom_t expected = (type == PL_STRING ? ATOM_string : ATOM_atom);
4508 int match;
4509 fid_t fid;
4510
4511 #define la ta.length
4512 #define ls ts.length
4513
4514 switch( ForeignControl(h) )
4515 { case FRG_FIRST_CALL:
4516 { if ( !PL_get_text(atom, &ta, CVT_ATOMIC|BUF_ALLOW_STACK) )
4517 return PL_error(NULL, 0, NULL, ERR_TYPE, expected, atom);
4518
4519 if ( !get_positive_integer_or_unbound(before, &b PASS_LD) ||
4520 !get_positive_integer_or_unbound(len, &l PASS_LD) ||
4521 !get_positive_integer_or_unbound(after, &a PASS_LD) )
4522 fail;
4523
4524 if ( !PL_get_text(sub, &ts, CVT_ATOMIC|BUF_ALLOW_STACK) )
4525 { if ( !PL_is_variable(sub) )
4526 return PL_error(NULL, 0, NULL, ERR_TYPE, expected, sub);
4527 ts.text.t = NULL;
4528 }
4529
4530 if ( ts.text.t ) /* `sub' given */
4531 { if ( l >= 0 && (int)ls != l ) /* len conflict */
4532 fail;
4533 if ( b >= 0 ) /* before given: test */
4534 { if ( PL_cmp_text(&ta, b, &ts, 0, ls) == 0 )
4535 { return (PL_unify_integer(len, ls) &&
4536 PL_unify_integer(after, la-ls-b)) ? TRUE : FALSE;
4537 }
4538 fail;
4539 }
4540 if ( a >= 0 ) /* after given: test */
4541 { ssize_t off = la-a-ls;
4542
4543 if ( off >= 0 && PL_cmp_text(&ta, (unsigned)off, &ts, 0, ls) == 0 )
4544 { return (PL_unify_integer(len, ls) &&
4545 PL_unify_integer(before, off)) ? TRUE : FALSE;
4546 }
4547 fail;
4548 }
4549 state = allocForeignState(sizeof(*state));
4550 state->type = SUB_SEARCH;
4551 state->n1 = 0;
4552 state->n2 = la;
4553 state->n3 = ls;
4554 break;
4555 }
4556
4557 if ( b >= 0 ) /* before given */
4558 { if ( b > (int)la )
4559 fail;
4560
4561 if ( l >= 0 ) /* len given */
4562 { if ( b+l <= (int)la ) /* deterministic fit */
4563 { if ( PL_unify_text_range(sub, &ta, b, l, type) &&
4564 PL_unify_integer(after, la-b-l) )
4565 succeed;
4566 }
4567 fail;
4568 }
4569 if ( a >= 0 ) /* after given */
4570 { if ( (l = la-a-b) >= 0 )
4571 { if ( PL_unify_text_range(sub, &ta, b, l, type) &&
4572 PL_unify_integer(len, l) )
4573 succeed;
4574 }
4575
4576 fail;
4577 }
4578 state = allocForeignState(sizeof(*state));
4579 state->type = SUB_SPLIT_TAIL;
4580 state->n1 = 0; /* len of the split */
4581 state->n2 = la; /* length of the atom */
4582 state->n3 = b; /* length before */
4583 break;
4584 }
4585
4586 if ( l >= 0 ) /* no before, len given */
4587 { if ( l > (int)la )
4588 fail;
4589
4590 if ( a >= 0 ) /* len and after */
4591 { if ( (b = la-a-l) >= 0 )
4592 { if ( PL_unify_text_range(sub, &ta, b, l, type) &&
4593 PL_unify_integer(before, b) )
4594 succeed;
4595 }
4596
4597 fail;
4598 }
4599 state = allocForeignState(sizeof(*state));
4600 state->type = SUB_SPLIT_LEN;
4601 state->n1 = 0; /* before */
4602 state->n2 = l; /* length */
4603 state->n3 = la;
4604 break;
4605 }
4606
4607 if ( a >= 0 ) /* only after given */
4608 { if ( a > (int)la )
4609 fail;
4610
4611 state = allocForeignState(sizeof(*state));
4612 state->type = SUB_SPLIT_HEAD;
4613 state->n1 = 0; /* before */
4614 state->n2 = la;
4615 state->n3 = a;
4616 break;
4617 }
4618
4619 state = allocForeignState(sizeof(*state));
4620 state->type = SUB_ENUM;
4621 state->n1 = 0; /* before */
4622 state->n2 = 0; /* len */
4623 state->n3 = la; /* total length */
4624 break;
4625 }
4626 case FRG_REDO:
4627 state = ForeignContextPtr(h);
4628 PL_get_text(atom, &ta, CVT_ATOMIC|BUF_ALLOW_STACK);
4629 break;
4630 case FRG_CUTTED:
4631 state = ForeignContextPtr(h);
4632 if ( state )
4633 freeForeignState(state, sizeof(*state));
4634 succeed;
4635 default:
4636 assert(0);
4637 fail;
4638 }
4639
4640 fid = PL_open_foreign_frame();
4641 again:
4642 switch(state->type)
4643 { case SUB_SEARCH:
4644 { PL_get_text(sub, &ts, CVT_ATOMIC|BUF_ALLOW_STACK);
4645 la = state->n2;
4646 ls = state->n3;
4647
4648 for( ; state->n1+ls <= la; state->n1++ )
4649 { if ( PL_cmp_text(&ta, state->n1, &ts, 0, ls) == 0 )
4650 { match = (PL_unify_integer(before, state->n1) &&
4651 PL_unify_integer(len, ls) &&
4652 PL_unify_integer(after, la-ls-state->n1));
4653
4654 state->n1++;
4655 goto next;
4656 }
4657 }
4658 goto exit_fail;
4659 }
4660 case SUB_SPLIT_TAIL: /* before given, rest unbound */
4661 { la = state->n2;
4662 b = state->n3;
4663 l = state->n1++;
4664
4665 match = (PL_unify_text_range(sub, &ta, b, l, type) &&
4666 PL_unify_integer(len, l) &&
4667 PL_unify_integer(after, la-b-l));
4668 out:
4669 if ( b+l < (int)la )
4670 goto next;
4671 else if ( match )
4672 goto exit_succeed;
4673 else
4674 goto exit_fail;
4675 }
4676 case SUB_SPLIT_LEN:
4677 { b = state->n1++;
4678 l = state->n2;
4679 la = state->n3;
4680
4681 match = (PL_unify_text_range(sub, &ta, b, l, type) &&
4682 PL_unify_integer(before, b) &&
4683 PL_unify_integer(after, la-b-l));
4684 goto out;
4685 }
4686 case SUB_SPLIT_HEAD:
4687 { b = state->n1++;
4688 la = state->n2;
4689 a = state->n3;
4690 l = la - a - b;
4691
4692 match = (PL_unify_text_range(sub, &ta, b, l, type) &&
4693 PL_unify_integer(before, b) &&
4694 PL_unify_integer(len, l));
4695 if ( l > 0 )
4696 goto next;
4697 else if ( match )
4698 goto exit_succeed;
4699 else
4700 goto exit_fail;
4701 }
4702 case SUB_ENUM:
4703 { b = state->n1;
4704 l = state->n2++;
4705 la = state->n3;
4706 a = la-b-l;
4707
4708 match = (PL_unify_text_range(sub, &ta, b, l, type) &&
4709 PL_unify_integer(before, b) &&
4710 PL_unify_integer(len, l) &&
4711 PL_unify_integer(after, a));
4712 if ( a == 0 )
4713 { if ( b == (int)la )
4714 { if ( match )
4715 goto exit_succeed;
4716 else
4717 goto exit_fail;
4718 }
4719 state->n2 = 0;
4720 state->n1++;
4721 }
4722 goto next;
4723 }
4724 }
4725
4726 exit_fail:
4727 freeForeignState(state, sizeof(*state));
4728 fail;
4729
4730 exit_succeed:
4731 freeForeignState(state, sizeof(*state));
4732 succeed;
4733
4734 next:
4735 if ( match )
4736 { ForeignRedoPtr(state);
4737 } else
4738 { if ( !PL_exception(0) )
4739 { PL_rewind_foreign_frame(fid);
4740 goto again;
4741 } else
4742 { goto exit_fail;
4743 }
4744 }
4745
4746 #undef la
4747 #undef ls
4748 }
4749
4750
4751 foreign_t
pl_sub_atom(term_t atom,term_t before,term_t len,term_t after,term_t sub,control_t h)4752 pl_sub_atom(term_t atom,
4753 term_t before, term_t len, term_t after,
4754 term_t sub,
4755 control_t h)
4756 { GET_LD
4757 return sub_text(atom, before, len, after, sub, h, PL_ATOM PASS_LD);
4758 }
4759
4760
4761 #if O_STRING
4762 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4763 Provisional String manipulation functions.
4764 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4765
4766 static
4767 PRED_IMPL("string_length", 2, string_length, 0)
4768 { PRED_LD
4769 PL_chars_t t;
4770
4771 if ( PL_get_text(A1, &t, CVT_ALL|CVT_EXCEPTION|BUF_ALLOW_STACK) )
4772 { int rc = PL_unify_int64_ex(A2, t.length);
4773
4774 PL_free_text(&t);
4775
4776 return rc;
4777 }
4778
4779 fail;
4780 }
4781
4782
4783 static
4784 PRED_IMPL("string_concat", 3, string_concat, PL_FA_NONDETERMINISTIC)
4785 { PRED_LD
4786
4787 return concat(A1, A2, A3, TRUE, PL__ctx, CVT_ATOMIC, PL_STRING PASS_LD);
4788 }
4789
4790
4791 foreign_t
pl_sub_string(term_t atom,term_t before,term_t len,term_t after,term_t sub,control_t h)4792 pl_sub_string(term_t atom,
4793 term_t before, term_t len, term_t after,
4794 term_t sub,
4795 control_t h)
4796 { GET_LD
4797 return sub_text(atom, before, len, after, sub, h, PL_STRING PASS_LD);
4798 }
4799
4800 #endif /* O_STRING */
4801
4802
4803 /********************************
4804 * CONTROL *
4805 *********************************/
4806
4807 word
pl_repeat(control_t h)4808 pl_repeat(control_t h)
4809 { switch( ForeignControl(h) )
4810 { case FRG_FIRST_CALL:
4811 case FRG_REDO:
4812 ForeignRedoInt(2L);
4813 case FRG_CUTTED:
4814 default:
4815 succeed;
4816 }
4817 }
4818
4819 word
pl_fail()4820 pl_fail() /* just to define it */
4821 { fail;
4822 }
4823
4824 word
pl_true()4825 pl_true() /* just to define it */
4826 { succeed;
4827 }
4828
4829 word
pl_halt(term_t code)4830 pl_halt(term_t code)
4831 { GET_LD
4832 int status;
4833 atom_t a;
4834
4835 if ( PL_get_atom(code, &a) && a == ATOM_abort )
4836 { PL_abort_process();
4837 return FALSE; /* not reached */
4838 } else if ( !PL_get_integer_ex(code, &status) )
4839 { return FALSE;
4840 }
4841
4842 PL_halt(status);
4843 fail; /* exception? */
4844 }
4845
4846 #if defined(O_LIMIT_DEPTH) || defined(O_INFERENCE_LIMIT)
4847 static foreign_t
unify_det(term_t t ARG_LD)4848 unify_det(term_t t ARG_LD)
4849 { Choice ch;
4850
4851 for(ch=LD->choicepoints; ch; ch = ch->parent)
4852 { if ( ch->frame == environment_frame )
4853 continue; /* choice from I_FOPENNDET */
4854 switch(ch->type)
4855 { case CHP_CATCH:
4856 case CHP_DEBUG:
4857 continue;
4858 default:
4859 break;
4860 }
4861 break;
4862 }
4863
4864 if ( ch && ch->frame == environment_frame->parent )
4865 { return PL_unify_atom(t, ATOM_cut);
4866 } else
4867 { if ( PL_unify_atom(t, ATOM_true) )
4868 ForeignRedoInt(1);
4869 return FALSE;
4870 }
4871 }
4872
4873 #endif
4874
4875 #ifdef O_LIMIT_DEPTH
4876
4877 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4878 The predicates below provide the infrastructure for
4879 call_with_depth_limit/3. This predicate was included on request by Steve
4880 Moyle, for improving the implementation of a theorem prover.
4881
4882 The implementation of call_with_depth_limit/3 in pl-prims.pl is
4883
4884 ```
4885 call_with_depth_limit(G, Limit, Result) :-
4886 $depth_limit(Limit, OLimit, OReached),
4887 ( catch(G, E, depth_limit_except(OLimit, OReached, E)),
4888 $depth_limit_true(Limit, OLimit, OReached, Result, Cut),
4889 Cut
4890 ; $depth_limit_false(OLimit, OReached, Result)
4891 ).
4892 ```
4893
4894 $depth_limit/3 sets the new limit and fetches the old values so they can
4895 be restored by the other calls. '$depth_limit_true'/5 restores the old
4896 limits, and unifies Result with the maximum depth reached during the
4897 proof. Cut is unified with ! if G succeeded deterministically, and
4898 `true' otherwise and ensures the wrapper maintains the determistic
4899 properties of G. It can be debated whether this is worthwhile ...
4900
4901 Finally, '$depth_limit_false'/4 checks for a depth-overflow, and unifies
4902 result with `depth_limit_exceeded' if an overflow has occurred and just
4903 fails otherwise. Of course it always restores the outer environment.
4904
4905 Note that call_with_depth_limit/3 cannot be written as a simple foreign
4906 call using PL_open_query(), etc, as the non-deterministic predicate is
4907 not allowed to return to the parent environment without closing the
4908 query.
4909 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4910
4911 /* $depth_limit(+Limit, -OldLimit, -DepthReached)
4912 */
4913
4914 static
4915 PRED_IMPL("$depth_limit", 3, pl_depth_limit, 0)
4916 { GET_LD
4917 long levels;
4918 long clevel = levelFrame(environment_frame) - 1;
4919
4920 if ( PL_get_long_ex(A1, &levels) )
4921 { if ( PL_unify_integer(A2, depth_limit) &&
4922 PL_unify_integer(A3, depth_reached) )
4923 { depth_limit = clevel + levels + 1; /* 1 for the catch/3 */
4924 depth_reached = clevel;
4925
4926 updateAlerted(LD);
4927 succeed;
4928 }
4929 }
4930
4931 fail;
4932 }
4933
4934
4935 static
4936 PRED_IMPL("$depth_limit_true", 5, pl_depth_limit_true, PL_FA_NONDETERMINISTIC)
4937 { term_t limit = A1;
4938 term_t olimit = A2;
4939 term_t oreached = A3;
4940 term_t res = A4;
4941 term_t cut = A5;
4942
4943 switch( CTX_CNTRL )
4944 { case FRG_FIRST_CALL:
4945 { GET_LD
4946 long l, ol, or;
4947
4948 if ( PL_get_long_ex(limit, &l) &&
4949 PL_get_long_ex(olimit, &ol) &&
4950 PL_get_long_ex(oreached, &or) )
4951 { intptr_t clevel = levelFrame(environment_frame) - 1;
4952 intptr_t used = depth_reached - clevel - 1;
4953
4954 depth_limit = ol;
4955 depth_reached = or;
4956 updateAlerted(LD);
4957
4958 if ( used < 1 )
4959 used = 1;
4960 if ( !PL_unify_integer(res, used) )
4961 fail;
4962
4963 return unify_det(cut PASS_LD);
4964 }
4965
4966 break;
4967 }
4968 case FRG_REDO:
4969 { GET_LD
4970 long levels;
4971 long clevel = levelFrame(environment_frame) - 1;
4972
4973 PL_get_long_ex(limit, &levels);
4974 depth_limit = clevel + levels + 1; /* 1 for catch/3 */
4975 depth_reached = clevel;
4976 updateAlerted(LD);
4977
4978 fail; /* backtrack to goal */
4979 }
4980 case FRG_CUTTED:
4981 succeed;
4982 }
4983
4984 fail;
4985 }
4986
4987
4988 static
4989 PRED_IMPL("$depth_limit_false", 3, depth_limit_false, 0)
4990 { PRED_LD
4991 long ol, or;
4992
4993 if ( PL_get_long_ex(A1, &ol) &&
4994 PL_get_long_ex(A2, &or) )
4995 { int exceeded = (depth_reached > depth_limit);
4996
4997 depth_limit = ol;
4998 depth_reached = or;
4999 updateAlerted(LD);
5000
5001 if ( exceeded )
5002 return PL_unify_atom(A3, ATOM_depth_limit_exceeded);
5003 }
5004
5005 fail;
5006 }
5007
5008
5009 static
5010 PRED_IMPL("$depth_limit_except", 3, depth_limit_except, 0)
5011 { PRED_LD
5012 long ol, or;
5013
5014 if ( PL_get_long_ex(A1, &ol) &&
5015 PL_get_long_ex(A2, &or) )
5016 { depth_limit = ol;
5017 depth_reached = or;
5018 updateAlerted(LD);
5019
5020 return PL_raise_exception(A3);
5021 }
5022
5023 fail;
5024 }
5025
5026 #endif /*O_LIMIT_DEPTH*/
5027
5028 #ifdef O_INFERENCE_LIMIT
5029
5030 #define INFERENCE_LIMIT_OVERHEAD 2
5031
5032 static
5033 PRED_IMPL("$inference_limit", 2, pl_inference_limit, 0)
5034 { PRED_LD
5035 int64_t limit;
5036
5037 if ( PL_get_int64_ex(A1, &limit) &&
5038 PL_unify_int64(A2, LD->inference_limit.limit) )
5039 { int64_t nlimit = LD->statistics.inferences + limit + INFERENCE_LIMIT_OVERHEAD;
5040
5041 if ( limit < 0 )
5042 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
5043 ATOM_not_less_than_zero, A1);
5044
5045 DEBUG(MSG_INFERENCE_LIMIT,
5046 Sdprintf("Install %lld --> %lld\n",
5047 LD->inference_limit.limit, nlimit));
5048
5049 if ( nlimit < LD->inference_limit.limit )
5050 LD->inference_limit.limit = nlimit;
5051
5052 updateAlerted(LD);
5053 return TRUE;
5054 }
5055
5056 return FALSE;
5057 }
5058
5059
5060 /** '$inference_limit_true'(+Limit, +OldLimit, ?Result)
5061
5062 On first call:
5063
5064 1. If Result is nonvar, there was the inference limit is exceeded.
5065 The limit is already reset by '$inference_limit_except'/3, so we
5066 just indicate that our result is deterministic.
5067 2. Else, restore the limit and indicate determinism in Det.
5068
5069 On redo, use Limit to set a new limit and fail to continue retrying the
5070 guarded goal.
5071 */
5072
5073 static
5074 PRED_IMPL("$inference_limit_true", 3, pl_inference_limit_true,
5075 PL_FA_NONDETERMINISTIC)
5076 { PRED_LD
5077
5078 switch( CTX_CNTRL )
5079 { case FRG_FIRST_CALL:
5080 { int64_t olimit;
5081
5082 if ( !PL_is_variable(A3) )
5083 return TRUE;
5084
5085 if ( PL_get_int64_ex(A2, &olimit) )
5086 { DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("true (det) --> %lld\n", olimit));
5087 LD->inference_limit.limit = olimit;
5088 updateAlerted(LD);
5089
5090 return unify_det(A3 PASS_LD);
5091 }
5092
5093 return FALSE;
5094 }
5095 case FRG_REDO:
5096 { int64_t limit;
5097
5098 if ( PL_get_int64_ex(A1, &limit) )
5099 { LD->inference_limit.limit =
5100 LD->statistics.inferences + limit + INFERENCE_LIMIT_OVERHEAD;
5101 DEBUG(MSG_INFERENCE_LIMIT,
5102 Sdprintf("true (ndet) --> %lld\n", LD->inference_limit.limit));
5103
5104 updateAlerted(LD);
5105 }
5106
5107 return FALSE;
5108 }
5109 case FRG_CUTTED:
5110 return TRUE;
5111 }
5112
5113 return FALSE;
5114 }
5115
5116
5117 static
5118 PRED_IMPL("$inference_limit_false", 1, inference_limit_false, 0)
5119 { PRED_LD
5120 int64_t olimit;
5121
5122 if ( PL_get_int64_ex(A1, &olimit) )
5123 { LD->inference_limit.limit = olimit;
5124 DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("false --> %lld\n", olimit));
5125 updateAlerted(LD);
5126 }
5127
5128 return FALSE;
5129 }
5130
5131
5132 /** '$inference_limit_except'(+OldLimit, +Exception, -Result)
5133
5134 Restore the limit. If exception is =inference_limit_exceeded=, unify
5135 Result with this, otherwise re-throw the exception.
5136 */
5137
5138 static
5139 PRED_IMPL("$inference_limit_except", 3, inference_limit_except, 0)
5140 { PRED_LD
5141 int64_t olimit;
5142
5143 if ( PL_get_int64_ex(A1, &olimit) )
5144 { atom_t a;
5145
5146 DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("except --> %lld\n", olimit));
5147
5148 LD->inference_limit.limit = olimit;
5149 updateAlerted(LD);
5150
5151 if ( PL_get_atom(A2, &a) && a == ATOM_inference_limit_exceeded )
5152 { return PL_unify_atom(A3, a);
5153 } else
5154 { return PL_raise_exception(A2);
5155 }
5156 }
5157
5158 return FALSE;
5159 }
5160
5161 void
raiseInferenceLimitException(void)5162 raiseInferenceLimitException(void)
5163 { GET_LD
5164 fid_t fid;
5165 static predicate_t not_exceed[6];
5166 static int done = FALSE;
5167 Definition def = environment_frame->predicate;
5168 int64_t olimit;
5169 int i;
5170
5171 if ( LD->exception.processing )
5172 return;
5173 /* Do not throw here */
5174 olimit = LD->inference_limit.limit;
5175 LD->inference_limit.limit = INFERENCE_NO_LIMIT;
5176
5177 DEBUG(MSG_INFERENCE_LIMIT,
5178 Sdprintf("Got inference limit in %s\n", predicateName(def)));
5179
5180 if ( !done )
5181 { not_exceed[0] = PL_predicate("$inference_limit_true", 3, "system");
5182 not_exceed[1] = PL_predicate("$inference_limit_false", 1, "system");
5183 not_exceed[2] = PL_predicate("$inference_limit_except", 3, "system");
5184 not_exceed[3] = PL_predicate("$inference_limit", 2, "system");
5185 not_exceed[4] = PL_predicate("call_with_inference_limit", 3, "system");
5186 not_exceed[5] = GD->procedures.catch3;
5187 }
5188
5189 for(i=0; i<6; i++)
5190 { if ( not_exceed[i]->definition == def )
5191 { LD->inference_limit.limit = olimit;
5192 DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("--> Ignored\n"));
5193 return;
5194 }
5195 }
5196
5197 if ( (fid = PL_open_foreign_frame()) )
5198 { term_t t;
5199
5200 LD->exception.processing = TRUE;
5201 t = PL_new_term_ref();
5202 PL_put_atom(t, ATOM_inference_limit_exceeded);
5203 PL_raise_exception(t);
5204 PL_close_foreign_frame(fid);
5205 }
5206 }
5207 #endif /*O_INFERENCE_LIMIT*/
5208
5209 /********************************
5210 * STATISTICS *
5211 *********************************/
5212
5213 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5214 Fetch runtime statistics. There are two standards here. One is based on
5215 old C-Prolog compatibility, exended as required by SWI-Prolog and the
5216 other is defined by Quintus/SICStus. The latter is included if
5217 QP_STATISTICS is defined. The compatibility is pretty complete, except
5218 the `atoms' key that is defined by both and this ambiguous.
5219 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5220
5221 static size_t
programSpace(void)5222 programSpace(void)
5223 { size_t allocated = heapUsed();
5224
5225 if ( allocated )
5226 return allocated - GD->statistics.stack_space;
5227
5228 return 0;
5229 }
5230
5231
5232 static size_t
CStackSize(PL_local_data_t * ld)5233 CStackSize(PL_local_data_t *ld)
5234 {
5235 #ifdef O_PLMT
5236 if ( ld->thread.info->pl_tid != 1 )
5237 { DEBUG(1, Sdprintf("Thread-stack: %ld\n", ld->thread.info->c_stack_size));
5238 return ld->thread.info->c_stack_size;
5239 }
5240 #endif
5241 #ifdef HAVE_GETRLIMIT
5242 { struct rlimit rlim;
5243
5244 if ( getrlimit(RLIMIT_STACK, &rlim) == 0 )
5245 { DEBUG(1, Sdprintf("Stack: %ld\n", rlim.rlim_cur));
5246 return rlim.rlim_cur;
5247 }
5248 }
5249 #endif
5250
5251 return 0;
5252 }
5253
5254 #define QP_STATISTICS 1
5255
5256 #ifdef QP_STATISTICS
5257
5258 static int
5259 #ifdef O_PLMT
qp_statistics__LD(atom_t key,int64_t v[],PL_local_data_t * LD)5260 qp_statistics__LD(atom_t key, int64_t v[], PL_local_data_t *LD)
5261 #else
5262 qp_statistics__LD(atom_t key, int64_t v[], PL_local_data_t *ld)
5263 #endif
5264 { int vn;
5265
5266 if ( key == ATOM_runtime ) /* compat: exclude gc-time */
5267 { v[0] = (int64_t)((LD->statistics.user_cputime -
5268 LD->gc.stats.totals.time -
5269 GD->atoms.gc_time) * 1000.0);
5270 v[1] = v[0] - LD->statistics.last_cputime;
5271 LD->statistics.last_cputime = (intptr_t)v[0];
5272 vn = 2;
5273 } else if ( key == ATOM_system_time )
5274 { v[0] = (int64_t)(LD->statistics.system_cputime * 1000.0);
5275 v[1] = v[0] - LD->statistics.last_systime;
5276 LD->statistics.last_systime = (intptr_t)v[0];
5277 vn = 2;
5278 } else if ( key == ATOM_real_time )
5279 { v[0] = (int64_t)WallTime();
5280 v[1] = v[0] - LD->statistics.last_real_time;
5281 LD->statistics.last_real_time = (intptr_t)v[0];
5282 vn = 2;
5283 } else if ( key == ATOM_walltime )
5284 { double wt = WallTime();
5285 if ( !LD->statistics.last_walltime )
5286 LD->statistics.last_walltime = LD->statistics.start_time;
5287 v[0] = (int64_t)((wt - LD->statistics.start_time) * 1000.0);
5288 v[1] = (int64_t)((wt - LD->statistics.last_walltime) * 1000.0);
5289 LD->statistics.last_walltime = wt;
5290 vn = 2;
5291 } else if ( key == ATOM_memory || key == ATOM_core )
5292 { v[0] = UsedMemory();
5293 v[1] = FreeMemory();
5294 vn = 2;
5295 } else if ( key == ATOM_stacks )
5296 { v[0] = usedStack(global);
5297 v[1] = usedStack(local);
5298 vn = 2;
5299 } else if ( key == ATOM_global_stack )
5300 { v[0] = usedStack(global);
5301 v[1] = roomStack(global);
5302 vn = 2;
5303 } else if ( key == ATOM_local_stack )
5304 { v[0] = usedStack(local);
5305 v[1] = roomStack(local);
5306 vn = 2;
5307 } else if ( key == ATOM_trail )
5308 { v[0] = usedStack(trail);
5309 v[1] = roomStack(trail);
5310 vn = 2;
5311 } else if ( key == ATOM_program )
5312 { v[0] = programSpace();
5313 v[1] = 0;
5314 vn = 2;
5315 } else if ( key == ATOM_garbage_collection )
5316 { vn=0;
5317 gc_stats *stats = &LD->gc.stats;
5318 gc_stat *last = last_gc_stats(stats);
5319
5320 v[vn++] = stats->totals.collections;
5321 v[vn++] = stats->totals.trail_gained + stats->totals.global_gained;
5322 v[vn++] = (int64_t)(stats->totals.time * 1000.0);
5323 v[vn++] = last->trail_after + last->global_after;
5324
5325 } else if ( key == ATOM_stack_shifts )
5326 {
5327 v[0] = LD->shift_status.global_shifts;
5328 v[1] = LD->shift_status.local_shifts;
5329 v[2] = (int64_t)(LD->shift_status.time * 1000.0);
5330 vn = 3;
5331 } else if ( key == ATOM_atoms )
5332 { v[0] = GD->statistics.atoms;
5333 v[1] = GD->statistics.atom_string_space;
5334 v[2] = 0;
5335 vn = 3;
5336 } else if ( key == ATOM_atom_garbage_collection )
5337 {
5338 #ifdef O_ATOMGC
5339 v[0] = GD->atoms.gc;
5340 v[1] = GD->statistics.atom_string_space_freed;
5341 v[2] = (int64_t)(GD->atoms.gc_time * 1000.0);
5342 vn = 3;
5343 #else
5344 vn = 0; /* no values */
5345 #endif
5346 } else if ( key == ATOM_clause_garbage_collection )
5347 {
5348 #ifdef O_CLAUSEGC
5349 v[0] = GD->clauses.cgc_count;
5350 v[1] = GD->clauses.cgc_reclaimed;
5351 v[2] = (int64_t)(GD->clauses.cgc_time * 1000.0);
5352 vn = 3;
5353 #else
5354 vn = 0; /* no values */
5355 #endif
5356 } else
5357 vn = -1; /* unknown key */
5358
5359 return vn;
5360 }
5361
5362 #endif /*QP_STATISTICS*/
5363
5364 static int
5365 #ifdef O_PLMT
swi_statistics__LD(atom_t key,Number v,PL_local_data_t * LD)5366 swi_statistics__LD(atom_t key, Number v, PL_local_data_t *LD)
5367 #else
5368 swi_statistics__LD(atom_t key, Number v, PL_local_data_t *ld)
5369 #endif
5370 { v->type = V_INTEGER; /* most of them */
5371
5372 if (key == ATOM_cputime) /* time */
5373 { v->type = V_FLOAT;
5374 v->value.f = LD->statistics.user_cputime;
5375 } else if (key == ATOM_process_cputime) /* time */
5376 { v->type = V_FLOAT;
5377 v->value.f = GD->statistics.user_cputime;
5378 } else if (key == ATOM_inferences) /* inferences */
5379 v->value.i = LD->statistics.inferences;
5380 else if (key == ATOM_stack)
5381 v->value.i = GD->statistics.stack_space;
5382 else if (key == ATOM_stack_limit)
5383 v->value.i = LD->stacks.limit;
5384 else if (key == ATOM_local) /* local stack */
5385 v->value.i = sizeStack(local);
5386 else if (key == ATOM_localused)
5387 v->value.i = usedStack(local);
5388 else if (key == ATOM_trail) /* trail */
5389 v->value.i = sizeStack(trail);
5390 else if (key == ATOM_trailused)
5391 v->value.i = usedStack(trail);
5392 else if (key == ATOM_global) /* global */
5393 v->value.i = sizeStack(global);
5394 else if (key == ATOM_globalused )
5395 v->value.i = usedStack(global);
5396 else if (key == ATOM_c_stack)
5397 v->value.i = CStackSize(LD);
5398 else if (key == ATOM_atoms) /* atoms */
5399 v->value.i = GD->statistics.atoms;
5400 else if (key == ATOM_atom_space) /* atom_space */
5401 v->value.i = atom_space();
5402 else if (key == ATOM_functors) /* functors */
5403 v->value.i = GD->statistics.functors;
5404 else if (key == ATOM_functor_space) /* functor_space */
5405 v->value.i = functor_space();
5406 else if (key == ATOM_predicates) /* predicates */
5407 v->value.i = GD->statistics.predicates;
5408 else if (key == ATOM_clauses) /* clauses */
5409 v->value.i = GD->statistics.clauses;
5410 else if (key == ATOM_modules) /* modules */
5411 v->value.i = GD->statistics.modules;
5412 else if (key == ATOM_codes) /* codes */
5413 v->value.i = GD->statistics.codes;
5414 else if (key == ATOM_epoch)
5415 { v->type = V_FLOAT;
5416 v->value.f = LD->statistics.start_time;
5417 } else if (key == ATOM_process_epoch)
5418 { v->type = V_FLOAT;
5419 v->value.f = PL_local_data.statistics.start_time;
5420 } else if (key == ATOM_gctime)
5421 { v->type = V_FLOAT;
5422 v->value.f = LD->gc.stats.totals.time;
5423 } else if (key == ATOM_collections)
5424 v->value.i = LD->gc.stats.totals.collections;
5425 else if (key == ATOM_collected)
5426 v->value.i = LD->gc.stats.totals.trail_gained +
5427 LD->gc.stats.totals.global_gained;
5428 #ifdef HAVE_BOEHM_GC
5429 else if ( key == ATOM_heap_gc )
5430 v->value.i = GC_get_gc_no();
5431 #endif
5432 else if (key == ATOM_heapused) /* heap usage */
5433 v->value.i = programSpace();
5434 #ifdef O_ATOMGC
5435 else if (key == ATOM_agc)
5436 v->value.i = GD->atoms.gc;
5437 else if (key == ATOM_agc_gained)
5438 v->value.i = GD->atoms.collected;
5439 else if (key == ATOM_agc_time)
5440 { v->type = V_FLOAT;
5441 v->value.f = GD->atoms.gc_time;
5442 }
5443 #endif
5444 #ifdef O_ATOMGC
5445 else if (key == ATOM_cgc)
5446 v->value.i = GD->clauses.cgc_count;
5447 else if (key == ATOM_cgc_gained)
5448 v->value.i = GD->clauses.cgc_reclaimed;
5449 else if (key == ATOM_cgc_time)
5450 { v->type = V_FLOAT;
5451 v->value.f = GD->clauses.cgc_time;
5452 }
5453 #endif
5454 else if (key == ATOM_global_shifts)
5455 v->value.i = LD->shift_status.global_shifts;
5456 else if (key == ATOM_local_shifts)
5457 v->value.i = LD->shift_status.local_shifts;
5458 else if (key == ATOM_trail_shifts)
5459 v->value.i = LD->shift_status.trail_shifts;
5460 else if (key == ATOM_shift_time)
5461 { v->type = V_FLOAT;
5462 v->value.f = LD->shift_status.time;
5463 }
5464 #ifdef O_PLMT
5465 else if ( key == ATOM_threads )
5466 v->value.i = GD->statistics.threads_created -
5467 GD->statistics.engines_created -
5468 GD->statistics.threads_finished +
5469 GD->statistics.engines_finished;
5470 else if ( key == ATOM_engines )
5471 v->value.i = GD->statistics.engines_created -
5472 GD->statistics.engines_finished;
5473 else if ( key == ATOM_threads_created )
5474 v->value.i = GD->statistics.threads_created -
5475 GD->statistics.engines_created;
5476 else if ( key == ATOM_engines_created )
5477 v->value.i = GD->statistics.engines_created;
5478 else if ( key == ATOM_thread_cputime )
5479 { v->type = V_FLOAT;
5480 v->value.f = GD->statistics.thread_cputime;
5481 } else if ( key == ATOM_threads_peak )
5482 v->value.i = GD->thread.peak_id;
5483 #endif
5484 else if (key == ATOM_table_space_used)
5485 { alloc_pool *pool;
5486 if ( (pool=LD->tabling.node_pool) )
5487 v->value.i = pool->size;
5488 else
5489 v->value.i = 0;
5490 } else if (key == ATOM_indexes_created)
5491 v->value.i = GD->statistics.indexes.created;
5492 else if (key == ATOM_indexes_destroyed)
5493 v->value.i = GD->statistics.indexes.destroyed;
5494
5495 else
5496 return -1; /* unknown key */
5497
5498 succeed;
5499 }
5500
5501
5502 int
pl_statistics_ld(term_t k,term_t value,PL_local_data_t * ld ARG_LD)5503 pl_statistics_ld(term_t k, term_t value, PL_local_data_t *ld ARG_LD)
5504 { number result; /* make compiler happy */
5505 atom_t key;
5506 int rc;
5507 #ifdef QP_STATISTICS
5508 int64_t v[4];
5509 #endif
5510
5511 if ( !PL_get_atom_ex(k, &key) )
5512 fail;
5513
5514 if ( !PL_is_list(value) )
5515 { switch(swi_statistics__LD(key, &result, ld))
5516 { case TRUE:
5517 return PL_unify_number(value, &result);
5518 case FALSE:
5519 fail;
5520 case -1:
5521 break;
5522 }
5523 }
5524
5525 #ifdef QP_STATISTICS
5526 if ( (rc=qp_statistics__LD(key, v, ld)) >= 0 )
5527 { int64_t *p;
5528 term_t tail = PL_copy_term_ref(value);
5529 term_t head = PL_new_term_ref();
5530
5531 for(p = v; rc-- > 0; p++)
5532 { if ( !PL_unify_list(tail, head, tail) )
5533 { if ( PL_unify_nil(tail) )
5534 succeed;
5535 fail;
5536 }
5537 if ( !PL_unify_int64(head, *p) )
5538 fail;
5539 }
5540
5541 return PL_unify_nil(tail);
5542 }
5543 #endif /*QP_STATISTICS*/
5544
5545 return PL_error("statistics", 2, NULL, ERR_DOMAIN,
5546 PL_new_atom("statistics_key"), k);
5547 }
5548
5549
5550 static
5551 PRED_IMPL("statistics", 2, statistics, 0)
5552 { GET_LD
5553 atom_t k;
5554
5555 if ( PL_get_atom(A1, &k) )
5556 { if ( k == ATOM_process_cputime )
5557 GD->statistics.user_cputime = CpuTime(CPU_USER);
5558 if ( k == ATOM_cputime || k == ATOM_runtime )
5559 LD->statistics.user_cputime = ThreadCPUTime(LD, CPU_USER);
5560 else if ( k == ATOM_system_time )
5561 LD->statistics.system_cputime = ThreadCPUTime(LD, CPU_SYSTEM);
5562 }
5563
5564 return pl_statistics_ld(A1, A2, LD PASS_LD);
5565 }
5566
5567
5568 /********************************
5569 * OPTIONS *
5570 *********************************/
5571
5572 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
5573 $cmd_option_val/3, provides access to the option structure from Prolog.
5574 This is halfway a generic structure package ... Anyway, it is better
5575 then direct coded access, as the indirect approach allows us to
5576 enumerate the options and generalise the option processing from the
5577 saved-states.
5578
5579 See also pl-init.c, which exploits set_pl_option() to parse the options
5580 resource member. Please note this code doesn't use atoms as
5581 set_pl_option() is called before the Prolog system is initialised.
5582
5583 This code should be moved into another file.
5584 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
5585
5586 typedef struct
5587 { const char *name;
5588 int type;
5589 void *address;
5590 } optdef, *OptDef;
5591
5592 #define CMDOPT_BOOL 0
5593 #define CMDOPT_SIZE_T 1
5594 #define CMDOPT_STRING 2
5595 #define CMDOPT_LIST 3
5596
5597 static const optdef optdefs[] =
5598 { { "stack_limit", CMDOPT_SIZE_T, &GD->options.stackLimit },
5599
5600 { "goals", CMDOPT_LIST, &GD->options.goals },
5601 { "toplevel", CMDOPT_STRING, &GD->options.topLevel },
5602 { "init_file", CMDOPT_STRING, &GD->options.initFile },
5603 { "system_init_file", CMDOPT_STRING, &GD->options.systemInitFile },
5604 { "script_file", CMDOPT_LIST, &GD->options.scriptFiles },
5605 { "config", CMDOPT_STRING, &GD->options.config },
5606 { "compileout", CMDOPT_STRING, &GD->options.compileOut },
5607 { "class", CMDOPT_STRING, &GD->options.saveclass },
5608 { "search_paths", CMDOPT_LIST, &GD->options.search_paths },
5609 { "pldoc_server", CMDOPT_STRING, &GD->options.pldoc_server },
5610 #ifdef __WINDOWS__
5611 { "win_app", CMDOPT_BOOL, &GD->options.win_app },
5612 #endif
5613 { "home", CMDOPT_STRING, &GD->defaults.home },
5614
5615 { NULL, 0, NULL }
5616 };
5617
5618
5619 static
5620 PRED_IMPL("$cmd_option_val", 2, cmd_option_val, 0)
5621 { PRED_LD
5622 char *k;
5623
5624 term_t key = A1;
5625 term_t val = A2;
5626
5627 if ( PL_get_atom_chars(key, &k) )
5628 { OptDef d = (OptDef)optdefs;
5629
5630 for( ; d->name; d++ )
5631 { if ( streq(k, d->name) )
5632 { switch(d->type)
5633 { case CMDOPT_BOOL:
5634 { bool *lp = d->address;
5635
5636 return PL_unify_bool(val, *lp);
5637 }
5638 case CMDOPT_SIZE_T:
5639 { size_t *lp = d->address;
5640
5641 return PL_unify_int64(val, *lp);
5642 }
5643 case CMDOPT_STRING:
5644 { char **sp = d->address;
5645
5646 if ( *sp )
5647 return PL_unify_chars(val, PL_ATOM|REP_FN, (size_t)-1, *sp);
5648 return FALSE;
5649 }
5650 case CMDOPT_LIST:
5651 { opt_list **list = d->address;
5652 opt_list *l;
5653 term_t tail = PL_copy_term_ref(val);
5654 term_t head = PL_new_term_ref();
5655
5656 for( l=*list; l; l = l->next)
5657 { if ( !PL_unify_list(tail, head, tail) ||
5658 !PL_unify_chars(head, PL_ATOM|REP_FN, (size_t)-1, l->opt_val) )
5659 return FALSE;
5660 }
5661
5662 return PL_unify_nil(tail);
5663 }
5664 }
5665 }
5666 }
5667 }
5668
5669 return PL_existence_error("cmd_option", key);
5670 }
5671
5672
5673 static
5674 PRED_IMPL("$cmd_option_set", 2, cmd_option_set, 0)
5675 { char *k, *v;
5676
5677 term_t key = A1;
5678 term_t val = A2;
5679
5680 if ( PL_get_chars(key, &k, CVT_ALL|CVT_EXCEPTION|REP_FN) &&
5681 PL_get_chars(val, &v, CVT_ALL|CVT_EXCEPTION|REP_FN) )
5682 { return set_pl_option(k, v);
5683 }
5684
5685 return FALSE;
5686 }
5687
5688
5689 int
set_pl_option(const char * name,const char * value)5690 set_pl_option(const char *name, const char *value)
5691 { OptDef d = (OptDef)optdefs;
5692
5693 if ( streq(name, "goal") )
5694 name = "goals"; /* HACK */
5695
5696 for( ; d->name; d++ )
5697 { if ( streq(name, d->name) )
5698 { switch(d->type)
5699 { case CMDOPT_SIZE_T:
5700 { size_t *val = d->address;
5701 number n;
5702 unsigned char *q;
5703
5704 if ( str_number((unsigned char *)value, &q, &n, 0) == NUM_OK &&
5705 *q == EOS &&
5706 intNumber(&n) )
5707 { *val = (size_t)n.value.i;
5708 succeed;
5709 }
5710 fail;
5711 }
5712 case CMDOPT_STRING:
5713 { char **val = d->address;
5714
5715 *val = store_string(value);
5716 succeed;
5717 }
5718 case CMDOPT_LIST:
5719 { opt_list **l = d->address;
5720
5721 opt_append(l, value);
5722 succeed;
5723 }
5724 default:
5725 assert(0);
5726 }
5727 }
5728 }
5729
5730 fail;
5731 }
5732
5733
5734 /********************************
5735 * STYLE CHECK *
5736 *********************************/
5737
5738 static
5739 PRED_IMPL("$style_check", 2, style_check, 0)
5740 { PRED_LD
5741 int n;
5742
5743 term_t old = A1;
5744 term_t new = A2;
5745
5746 if ( PL_unify_integer(old, debugstatus.styleCheck) &&
5747 PL_get_integer(new, &n) )
5748 { debugstatus.styleCheck = n;
5749
5750 succeed;
5751 }
5752
5753 fail;
5754 }
5755
5756
5757 /*******************************
5758 * THROW *
5759 *******************************/
5760
5761 static
5762 PRED_IMPL("throw", 1, throw, 0)
5763 { PRED_LD
5764
5765 if ( PL_is_variable(A1) )
5766 return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
5767
5768 return PL_raise_exception(A1);
5769 }
5770
5771
5772 /*******************************
5773 * PUBLISH PREDICATES *
5774 *******************************/
5775
5776 BeginPredDefs(prims)
5777 PRED_DEF("=", 2, unify, PL_FA_ISO)
5778 PRED_DEF("\\=", 2, not_unify, PL_FA_ISO)
5779 PRED_DEF("unify_with_occurs_check", 2, unify_with_occurs_check, PL_FA_ISO)
5780 PRED_DEF("subsumes_term", 2, subsumes_term, PL_FA_ISO)
5781 PRED_DEF("nonvar", 1, nonvar, PL_FA_ISO)
5782 PRED_DEF("var", 1, var, PL_FA_ISO)
5783 PRED_DEF("integer", 1, integer, PL_FA_ISO)
5784 PRED_DEF("float", 1, float, PL_FA_ISO)
5785 PRED_DEF("rational", 1, rational, 0)
5786 PRED_DEF("number", 1, number, PL_FA_ISO)
5787 PRED_DEF("arg", 3, arg, PL_FA_NONDETERMINISTIC|PL_FA_ISO)
5788 PRED_DEF("atomic", 1, atomic, PL_FA_ISO)
5789 PRED_DEF("atom", 1, atom, PL_FA_ISO)
5790 PRED_DEF("string", 1, string, 0)
5791 PRED_DEF("ground", 1, ground, PL_FA_ISO)
5792 PRED_DEF("nonground", 2, nonground, 0)
5793 PRED_DEF("$term_size", 3, term_size, 0)
5794 PRED_DEF("acyclic_term", 1, acyclic_term, PL_FA_ISO)
5795 PRED_DEF("cyclic_term", 1, cyclic_term, 0)
5796 PRED_DEF("$factorize_term", 3, factorize_term, 0)
5797 PRED_DEF("compound", 1, compound, PL_FA_ISO)
5798 PRED_DEF("callable", 1, callable, PL_FA_ISO)
5799 PRED_DEF("==", 2, equal, PL_FA_ISO)
5800 PRED_DEF("\\==", 2, nonequal, PL_FA_ISO)
5801 PRED_DEF("compare", 3, compare, PL_FA_ISO)
5802 PRED_DEF("@<", 2, std_lt, PL_FA_ISO)
5803 PRED_DEF("@=<", 2, std_leq, PL_FA_ISO)
5804 PRED_DEF("@>", 2, std_gt, PL_FA_ISO)
5805 PRED_DEF("@>=", 2, std_geq, PL_FA_ISO)
5806 PRED_DEF("?=", 2, can_compare, 0)
5807 PRED_DEF("same_term", 2, same_term, 0)
5808 PRED_DEF("functor", 3, functor, PL_FA_ISO)
5809 PRED_DEF("=..", 2, univ, PL_FA_ISO)
5810 PRED_DEF("compound_name_arity", 3, compound_name_arity, 0)
5811 PRED_DEF("compound_name_arguments", 3, compound_name_arguments, 0)
5812 PRED_DEF("$filled_array", 4, filled_array, 0)
5813 PRED_DEF("numbervars", 4, numbervars, 0)
5814 PRED_DEF("var_number", 2, var_number, 0)
5815 PRED_DEF("term_variables", 2, term_variables2, PL_FA_ISO)
5816 PRED_DEF("term_variables", 3, term_variables3, 0)
5817 PRED_DEF("term_singletons", 2, term_singletons, 0)
5818 PRED_DEF("term_attvars", 2, term_attvars, 0)
5819 PRED_DEF("is_most_general_term", 1, is_most_general_term, 0)
5820 PRED_DEF("$free_variable_set", 3, free_variable_set, 0)
5821 PRED_DEF("unifiable", 3, unifiable, 0)
5822 #ifdef O_TERMHASH
5823 PRED_DEF("term_hash", 4, term_hash4, 0)
5824 #endif
5825 #ifdef O_LIMIT_DEPTH
5826 PRED_DEF("$depth_limit_except", 3, depth_limit_except, 0)
5827 PRED_DEF("$depth_limit_false", 3, depth_limit_false, 0)
5828 PRED_DEF("$depth_limit", 3, pl_depth_limit, 0)
5829 PRED_DEF("$depth_limit_true", 5, pl_depth_limit_true, PL_FA_NONDETERMINISTIC)
5830 #endif
5831 #ifdef O_INFERENCE_LIMIT
5832 PRED_DEF("$inference_limit", 2, pl_inference_limit, 0)
5833 PRED_DEF("$inference_limit_true", 3, pl_inference_limit_true,
5834 PL_FA_NONDETERMINISTIC)
5835 PRED_DEF("$inference_limit_false", 1, inference_limit_false, 0)
5836 PRED_DEF("$inference_limit_except", 3, inference_limit_except, 0)
5837 #endif
5838 PRED_DEF("atom_length", 2, atom_length, PL_FA_ISO)
5839 PRED_DEF("name", 2, name, 0)
5840 PRED_DEF("atom_chars", 2, atom_chars, PL_FA_ISO)
5841 PRED_DEF("atom_codes", 2, atom_codes, PL_FA_ISO)
5842 PRED_DEF("atom_concat", 3, atom_concat, PL_FA_NONDETERMINISTIC|PL_FA_ISO)
5843 PRED_DEF("atomic_concat", 3, atomic_concat, 0)
5844 PRED_DEF("number_chars", 2, number_chars, PL_FA_ISO)
5845 PRED_DEF("number_codes", 2, number_codes, PL_FA_ISO)
5846 PRED_DEF("number_string", 2, number_string, 0)
5847 PRED_DEF("char_code", 2, char_code, PL_FA_ISO)
5848 PRED_DEF("$is_char_code", 1, is_char_code, 0)
5849 PRED_DEF("$is_char", 1, is_char, 0)
5850 PRED_DEF("$is_code_list", 2, is_code_list, 0)
5851 PRED_DEF("$is_char_list", 2, is_char_list, 0)
5852 PRED_DEF("atom_number", 2, atom_number, 0)
5853 PRED_DEF("collation_key", 2, collation_key, 0)
5854 PRED_DEF("atomic_list_concat", 3, atomic_list_concat, 0)
5855 PRED_DEF("atomic_list_concat", 2, atomic_list_concat, 0)
5856 PRED_DEF("string_concat", 3, string_concat, PL_FA_NONDETERMINISTIC)
5857 PRED_DEF("string_length", 2, string_length, 0)
5858 PRED_DEF("atomics_to_string", 3, atomics_to_string, 0)
5859 PRED_DEF("atomics_to_string", 2, atomics_to_string, 0)
5860 PRED_DEF("sub_atom_icasechk", 3, sub_atom_icasechk, 0)
5861 PRED_DEF("statistics", 2, statistics, 0)
5862 PRED_DEF("$cmd_option_val", 2, cmd_option_val, 0)
5863 PRED_DEF("$cmd_option_set", 2, cmd_option_set, 0)
5864 PRED_DEF("$style_check", 2, style_check, 0)
5865 PRED_DEF("deterministic", 1, deterministic, 0)
5866 PRED_DEF("setarg", 3, setarg, 0)
5867 PRED_DEF("nb_setarg", 3, nb_setarg, 0)
5868 PRED_DEF("nb_linkarg", 3, nb_linkarg, 0)
5869 PRED_DEF("$skip_list", 3, skip_list, 0)
5870 PRED_DEF("throw", 1, throw, PL_FA_ISO)
5871 EndPredDefs
5872