/* Part of SWI-Prolog Author: Jan Wielemaker E-mail: J.Wielemaker@vu.nl WWW: http://www.swi-prolog.org Copyright (c) 1985-2023, University of Amsterdam VU University Amsterdam CWI, Amsterdam SWI-Prolog Solutions b.v. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /*#define O_DEBUG 1*/ #include "pl-prims.h" #include "pl-arith.h" #include "pl-attvar.h" #include "pl-fli.h" #include "pl-gc.h" #include "pl-wam.h" #include "pl-write.h" #include "pl-gvar.h" #include "pl-read.h" #include "pl-util.h" #include "pl-funct.h" #include "os/pl-ctype.h" #include "os/pl-utf8.h" #include "os/pl-cstack.h" #include "pl-inline.h" #include #undef LD #define LD LOCAL_LD #define unify_with_occurs_check(t1, t2, mode) LDFUNC(unify_with_occurs_check, t1, t2, mode) static int unify_with_occurs_check(DECL_LD Word t1, Word t2, occurs_check_t mode); /******************************* * CYCLIC TERMS * *******************************/ #if O_CYCLIC /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Cyclic term unification. The algorithm has been described to me by Bart Demoen. Here it is (translated from dutch): I created my own variation. You only need it during general unification. Here is a short description: suppose you unify 2 terms f(...) and f(...), which are represented on the heap (=global stack) as: +-----+ and +-----+ | f/3 | | f/3 | +-----+ +-----+ args args' Before working on args and args', change this into the structure below, using a reference pointer pointing from functor of the one to the other term. +-----+ and +-----+ | ----+----------------->| f/3 | +-----+ +-----+ args args' If, during this unification you find a compound whose functor is a reference to the term at the right hand you know you hit a cycle and the terms are the same. Of course functor_t must be different from ref. Overwritten functors are collected in a stack and reset regardless of whether the unification succeeded or failed. Note that we need to dereference the functors both left and right. References at the right are rare, but possible. The trick is to use both sharing and cycles, where the cycles at the left are shorter: t :- X = s(X), Y = y(X,X), A = s(s(s(A))), B = y(A,A), Y = B. While unifying the first argument of y/2, the left-walker crosses to the right after the first cycle and creates references in A, which are processed by the right-walker when entering the second argument of y/2. Initial measurements show a performance degradation for deep unification of approx. 30%. On the other hand, if subterms appear multiple times in a term unification can be much faster. As only a small percentage of the unifications of a realistic program are covered by unify() and involve deep unification the overall impact of performance is small (< 3%). - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define initvisited(_) LDFUNC(initvisited, _) static void initvisited(DECL_LD) { LD->cycle.vstack.unit_size = sizeof(Word); } #ifdef O_DEBUG #define empty_visited(_) LDFUNC(empty_visited, _) static int empty_visited(DECL_LD) { return emptySegStack(&LD->cycle.vstack); } #endif #define visitedWord(p) LDFUNC(visitedWord, p) static inline int visitedWord(DECL_LD Word p) { if ( is_marked(p) ) succeed; set_marked(p); if ( !pushSegStack(&LD->cycle.vstack, p, Word) ) outOfCore(); fail; } #define visited(f) LDFUNC(visited, f) static inline int visited(DECL_LD Functor f) { Word p = &f->definition; return visitedWord(p); } #define unvisit(_) LDFUNC(unvisit, _) static void unvisit(DECL_LD) { Word p; while( popSegStack(&LD->cycle.vstack, &p, Word) ) { clear_marked(p); } } #define unvisit_and_unfirst(_) LDFUNC(unvisit_and_unfirst, _) static void unvisit_and_unfirst(DECL_LD) { Word p; while( popSegStack(&LD->cycle.vstack, &p, Word) ) { clear_both(p); } } #define popVisited(_) LDFUNC(popVisited, _) static void popVisited(DECL_LD) { Word p = NULL; popSegStack(&LD->cycle.vstack, &p, Word); clear_marked(p); } #define initCyclic(_) LDFUNC(initCyclic, _) static inline void initCyclic(DECL_LD) { LD->cycle.lstack.unit_size = sizeof(Word); } #define linkTermsCyclic(f1, f2) LDFUNC(linkTermsCyclic, f1, f2) static inline void linkTermsCyclic(DECL_LD Functor f1, Functor f2) { Word p1 = (Word)&f1->definition; Word p2 = (Word)&f2->definition; *p1 = makeRefG(p2); if ( !pushSegStack(&LD->cycle.lstack, p1, Word) ) outOfCore(); } #define exitCyclic(_) LDFUNC(exitCyclic, _) static inline void exitCyclic(DECL_LD) { Word p; while( popSegStack(&LD->cycle.lstack, &p, Word) ) { *p = *unRef(*p); } } #else /*O_CYCLIC*/ static inline visited(DECL_LD Functor f) { fail; } static inline unvisit(DECL_LD Word *base) { } static inline void initCyclic(DECL_LD) {} static inline void exitCyclic(DECL_LD) {} static inline void linkTermsCyclic(DECL_LD Functor f1, Functor f2) {} #endif /*O_CYCLIC*/ #define HAVE_VISITED #define AC_TERM_WALK_LR 1 #include "pl-termwalk.c" /******************************** * UNIFICATION * *********************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Unify is the general unification procedure. This raw routine should only be called by interpret as it does not undo bindings made during the unification in case the unification fails. pl_unify() (implementing =/2) does undo bindings and should be used by foreign predicates. See also unify_ptrs(). Unification depends on the datatypes available in the system and will in general need updating if new types are added. It should be noted that unify() is not the only place were unification happens. Other points are: - various of the virtual machine instructions - various macros, for example APPENDLIST and CLOSELIST - unifyAtomic(): unification of atomic data. - various builtin predicates. They should be flagged some way. Returns one of: - FALSE: terms cannot unify. Note that this routine does not rollback changes it made! - TRUE: Unification has completed successfully - GLOBAL_OVERFLOW: Unification cannot be completed due to lack of global-space. - TRAIL_OVERFLOW: Unification cannot be completed due to lack of trail-space. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define SWAPW(p,q) { Word _tmp = p; p=q; q=_tmp; } while(0) #define do_unify(t1, t2) LDFUNC(do_unify, t1, t2) static int do_unify(DECL_LD Word t1, Word t2) { term_agendaLR agenda; int compound = FALSE; int rc = FALSE; do { word w1, w2; deRef(t1); w1 = *t1; deRef(t2); w2 = *t2; DEBUG(CHK_ATOM_GARBAGE_COLLECTED, { assert(w1 != ATOM_garbage_collected); assert(w2 != ATOM_garbage_collected); }); if ( isVar(w1) ) { if ( unlikely(tTop+2 >= tMax) ) { rc = TRAIL_OVERFLOW; goto out_fail; } if ( isVar(w2) ) { uvars: if ( t1 < t2 ) /* always point downwards */ { if ( t1 > (Word)lBase ) { Word v; if ( unlikely(gTop+1 >= gMax) ) { rc = GLOBAL_OVERFLOW; goto out_fail; } v = gTop++; setVar(*v); Trail(t1, makeRefG(v)); Trail(t2, makeRefG(v)); } else { Trail(t2, makeRefG(t1)); } continue; } if ( t1 == t2 ) continue; SWAPW(t1, t2); goto uvars; } #ifdef O_ATTVAR if ( isAttVar(w2 ) ) w2 = makeRefG(t2); #endif Trail(t1, w2); continue; } if ( isVar(w2) ) { if ( unlikely(tTop+1 >= tMax) ) { rc = TRAIL_OVERFLOW; goto out_fail; } #ifdef O_ATTVAR if ( isAttVar(w1) ) w1 = makeRefG(t1); #endif Trail(t2, w1); continue; } #ifdef O_ATTVAR if ( isAttVar(w1) ) { if ( !hasGlobalSpace(0) ) { rc = overflowCode(0); goto out_fail; } assignAttVar(t1, t2); continue; } if ( isAttVar(w2) ) { if ( !hasGlobalSpace(0) ) { rc = overflowCode(0); goto out_fail; } assignAttVar(t2, t1); continue; } #endif if ( w1 == w2 ) continue; if ( tag(w1) != tag(w2) ) goto out_fail; switch(tag(w1)) { case TAG_ATOM: goto out_fail; case TAG_INTEGER: if ( storage(w1) == STG_INLINE || storage(w2) == STG_INLINE ) goto out_fail; case TAG_STRING: case TAG_FLOAT: if ( equalIndirect(w1, w2) ) continue; goto out_fail; case TAG_COMPOUND: { Functor f1 = valueTerm(w1); Functor f2 = valueTerm(w2); int arity; #if O_CYCLIC while ( isRef(f1->definition) ) f1 = (Functor)unRef(f1->definition); while ( isRef(f2->definition) ) f2 = (Functor)unRef(f2->definition); if ( f1 == f2 ) continue; #endif if ( f1->definition != f2->definition ) goto out_fail; arity = arityFunctor(f1->definition); if ( !compound ) { compound = TRUE; initCyclic(); initTermAgendaLR(&agenda, arity, f1->arguments, f2->arguments); } else { if ( !pushWorkAgendaLR(&agenda, arity, f1->arguments, f2->arguments) ) { rc = MEMORY_OVERFLOW; goto out_fail; } } linkTermsCyclic(f1, f2); continue; } } } while(compound && nextTermAgendaLR(&agenda, &t1, &t2)); rc = TRUE; out_fail: if ( compound ) { clearTermAgendaLR(&agenda); exitCyclic(); } return rc; } #define raw_unify_ptrs(t1, t2) LDFUNC(raw_unify_ptrs, t1, t2) static int raw_unify_ptrs(DECL_LD Word t1, Word t2) { switch(LD->prolog_flag.occurs_check) { case OCCURS_CHECK_FALSE: return do_unify(t1, t2); case OCCURS_CHECK_TRUE: return unify_with_occurs_check(t1, t2, OCCURS_CHECK_TRUE); case OCCURS_CHECK_ERROR: return unify_with_occurs_check(t1, t2, OCCURS_CHECK_ERROR); default: assert(0); fail; } } static PRED_IMPL("=", 2, unify, 0) { PRED_LD return PL_unify(A1, A2); } static PRED_IMPL("\\=", 2, not_unify, 0) { PRED_LD Word p1 = valTermRef(A1); Word p2 = p1+1; word w1, w2; term_t ex; deRef(p1); w1 = *p1; deRef(p2); w2 = *p2; if ( isVar(w1) || isVar(w2) ) { if ( LD->prolog_flag.occurs_check == OCCURS_CHECK_FALSE ) return FALSE; /* can unify */ goto full_check; } if ( w1 == w2 ) return FALSE; if ( isAttVar(w1) || isAttVar(w2) ) goto full_check; if ( tag(w1) != tag(w2) ) return TRUE; switch(tag(w1)) { case TAG_ATOM: return TRUE; case TAG_INTEGER: if ( storage(w1) == STG_INLINE || storage(w2) == STG_INLINE ) return TRUE; case TAG_STRING: case TAG_FLOAT: return !equalIndirect(w1, w2); case TAG_COMPOUND: break; } full_check: ex = PL_new_term_ref(); if ( can_unify(p1, p2, ex) ) return FALSE; if ( !PL_is_variable(ex) ) return PL_raise_exception(ex); return TRUE; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Public unification procedure for `raw' data. See also PL_unify(). Return: - TRUE: success - If (flags&ALLOW_RETCODE), one of - FALSE: unification failure - *_OVERFLOW: stack or memory overflow Else - FALSE: unification failure or raised exception - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ int unify_ptrs(DECL_LD Word t1, Word t2, int flags) { for(;;) { int rc; rc = raw_unify_ptrs(t1, t2); if ( rc >= 0 ) return rc; if ( !(flags&ALLOW_RETCODE) ) { if ( rc == MEMORY_OVERFLOW ) { return PL_no_memory(); } else /* Stack overflow */ { int rc2; PushPtr(t1); PushPtr(t2); rc2 = makeMoreStackSpace(rc, flags); PopPtr(t2); PopPtr(t1); if ( !rc2 ) return FALSE; } } else return rc; /* return error code */ } } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - can_unify(t1, t2, ex) succeeds if two terms *can* be unified, without actually doing so. This is basically a stripped version of unify() above. See this function for comments. Note that we have to execute delayed goals and these may raise an exception. If this happens, ex is set to the exception term. If ex = 0, a possible exception is ignored and cleared. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ bool can_unify(Word t1, Word t2, term_t ex) { GET_LD fid_t fid; if ( (fid = PL_open_foreign_frame()) ) { int handle_exception = !ex; if ( !ex ) ex = PL_new_term_ref(); if ( unify_ptrs(t1, t2, ALLOW_GC|ALLOW_SHIFT) && foreignWakeup(ex) ) { PL_discard_foreign_frame(fid); return TRUE; } if ( exception_term && isVar(*valTermRef(ex)) ) PL_put_term(ex, exception_term); if ( !handle_exception && !isVar(*valTermRef(ex)) ) PL_clear_exception(); PL_discard_foreign_frame(fid); } return FALSE; } /******************************* * OCCURS-CHECK * *******************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - int var_occurs_in(Word v, Word t) Succeeds of the term `v' occurs in `t'. v must be dereferenced on entry. Returns one of - FALSE if v does not occur in t - TRUE if v occurs in t - MEMORY_OVERFLOW if the malloc() fails. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define var_occurs_in(v, t) LDFUNC(var_occurs_in, v, t) static int var_occurs_in(DECL_LD Word v, Word t) { segstack visited; Functor tmp[256]; term_agenda agenda; int compound = FALSE; int rc = FALSE; deRef(t); if ( v == t ) { if ( isTerm(*t) ) goto unified; return FALSE; } do { if ( v == t ) { rc = TRUE; break; } unified: if ( isTerm(*t) ) { Functor f = valueTerm(*t); int arity = arityFunctor(f->definition); if ( !compound ) { compound = TRUE; initSegStack(&visited, sizeof(Functor), sizeof(tmp), tmp); f->definition |= FIRST_MASK; if ( !pushSegStack(&visited, f, Functor) ) outOfCore(); initTermAgenda(&agenda, arity, f->arguments); } else if ( !(f->definition & FIRST_MASK) ) { f->definition |= FIRST_MASK; if ( !pushSegStack(&visited, f, Functor) || !pushWorkAgenda(&agenda, arity, f->arguments) ) return MEMORY_OVERFLOW; } } } while( compound && (t=nextTermAgenda(&agenda)) ); if ( compound ) { Functor f; while( popSegStack(&visited, &f, Functor) ) f->definition &= ~FIRST_MASK; clearTermAgenda(&agenda); } return rc; } int PL_var_occurs_in(term_t var, term_t value) { GET_LD Word v = valTermRef(var); deRef(v); return var_occurs_in(v, valTermRef(value)); } #define failed_unify_with_occurs_check(t1, t2, mode) LDFUNC(failed_unify_with_occurs_check, t1, t2, mode) static int failed_unify_with_occurs_check(DECL_LD Word t1, Word t2, occurs_check_t mode) { int rc; if ( mode == OCCURS_CHECK_TRUE ) fail; deRef(t1); deRef(t2); if ( isVar(*t2) ) /* try to make Var = Term */ { Word tmp = t1; t1 = t2; t2 = tmp; } blockGC(0); rc = PL_error(NULL, 0, NULL, ERR_OCCURS_CHECK, t1, t2); unblockGC(0); return rc; } static int unify_with_occurs_check(DECL_LD Word t1, Word t2, occurs_check_t mode) { mark m; int rc; deRef(t1); deRef(t2); if ( canBind(*t1) ) { if ( onStack(global, t1) && var_occurs_in(t1, t2) ) return failed_unify_with_occurs_check(t1, t2, mode); return do_unify(t1, t2); } if ( canBind(*t2) ) { if ( onStack(global, t2) && var_occurs_in(t2, t1) ) return failed_unify_with_occurs_check(t1, t2, mode); return do_unify(t1, t2); } Mark(m); LD->mark_bar = NO_MARK_BAR; /* see also unify_all_trail_ptrs() */ rc = do_unify(t1, t2); DiscardMark(m); if ( rc == TRUE ) { TrailEntry tt = tTop; TrailEntry mt = m.trailtop; while(--tt >= mt) { Word p = tt->address; Word p2; if ( isTrailVal(p) ) /* assignment of an attvars */ { p = (--tt)->address; if ( isTrailVal((--tt)->address) ) /* tail of wakeup list */ tt--; if ( isTrailVal((--tt)->address) ) /* head of wakeup list */ tt--; } deRef2(p, p2); if ( var_occurs_in(p2, p2) ) { if ( mode == OCCURS_CHECK_ERROR ) { Word t = allocGlobalNoShift(1); if ( !t ) return GLOBAL_OVERFLOW; *t = *p2; Undo(m); rc = failed_unify_with_occurs_check(p, t, mode); } rc = FALSE; break; } } } return rc; } static PRED_IMPL("unify_with_occurs_check", 2, unify_with_occurs_check, 0) { PRED_LD occurs_check_t old = LD->prolog_flag.occurs_check; int rc; LD->prolog_flag.occurs_check = OCCURS_CHECK_TRUE; rc = PL_unify(A1, A2); LD->prolog_flag.occurs_check = old; return rc; } /******************************** * TYPE CHECKING * *********************************/ static PRED_IMPL("nonvar", 1, nonvar, 0) { PRED_LD return PL_is_variable(A1) ? FALSE : TRUE; } static PRED_IMPL("var", 1, var, 0) { PRED_LD return PL_is_variable(A1); } static PRED_IMPL("integer", 1, integer, 0) { return PL_is_integer(A1); } static PRED_IMPL("float", 1, float, 0) { return PL_is_float(A1); } #if O_BIGNUM static PRED_IMPL("rational", 1, rational, 0) { return PL_is_rational(A1); } #endif #if O_STRING static PRED_IMPL("string", 1, string, 0) { return PL_is_string(A1); } #endif /* O_STRING */ static PRED_IMPL("number", 1, number, 0) { return PL_is_number(A1); } static PRED_IMPL("atom", 1, atom, 0) { PRED_LD return PL_is_atom(A1); } static PRED_IMPL("atomic", 1, atomic, 0) { PRED_LD return PL_is_atomic(A1); } /******************************* * GROUND * *******************************/ typedef enum { ph_mark, ph_unmark } phase; static inline int ph_visitedWord(Word p, phase ph) { switch(ph) { case ph_mark: if ( is_marked(p) ) succeed; set_marked(p); break; case ph_unmark: if ( !is_marked(p) ) succeed; clear_marked(p); } fail; } static inline int ph_visited(Functor f, phase ph) { Word p = &f->definition; return ph_visitedWord(p, ph); } #define ph_ground(p, ph) LDFUNC(ph_ground, p, ph) static Word ph_ground(DECL_LD Word p, phase ph) /* Phase 1 marking */ { term_agenda agenda; initTermAgenda(&agenda, 1, p); while((p=nextTermAgenda(&agenda))) { if ( canBind(*p) ) { clearTermAgenda(&agenda); return p; } if ( isTerm(*p) ) { Functor f = valueTerm(*p); if ( !ph_visited(f, ph) ) { pushWorkAgenda(&agenda, arityFunctor(f->definition), f->arguments); } } } return NULL; } Word ground(DECL_LD Word p) { Word rc1, rc2; deRef(p); if ( canBind(*p) ) return p; if ( !isTerm(*p) ) return NULL; rc1 = ph_ground(p, ph_mark); /* mark functors */ rc2 = ph_ground(p, ph_unmark); /* unmark the very same functors */ assert(rc1 == rc2); (void)rc2; return rc1; } int PL_is_ground(term_t t) { GET_LD return ground(valTermRef(t)) == NULL; } static PRED_IMPL("ground", 1, ground, PL_FA_ISO) { PRED_LD return ground(valTermRef(A1)) == NULL; } static PRED_IMPL("nonground", 2, nonground, 0) { PRED_LD Word p; if ( (p=ground(valTermRef(A1))) ) return unify_ptrs(valTermRef(A2), p, ALLOW_GC|ALLOW_SHIFT); return FALSE; } static PRED_IMPL("compound", 1, compound, 0) { return PL_is_compound(A1); } static PRED_IMPL("callable", 1, callable, PL_FA_ISO) { return PL_is_callable(A1); } /******************************* * COMPLEXITY * *******************************/ #define term_size(p, max) LDFUNC(term_size, p, max) static size_t term_size(DECL_LD Word p, size_t max) { size_t count = 0; term_agenda agenda; Word t; initvisited(); initTermAgenda(&agenda, 1, p); while((t=nextTermAgenda(&agenda))) { if ( isAttVar(*t) ) { Word p = valPAttVar(*t); if ( ++count > max ) break; assert(onGlobalArea(p)); pushWorkAgenda(&agenda, 1, p); } else if ( isIndirect(*t) ) { Word p = addressIndirect(*t); count += wsizeofInd(*p)+2; if ( count > max ) break; } else if ( isTerm(*t) ) { Functor f = valueTerm(*t); size_t arity = arityFunctor(f->definition); if ( visited(f) ) continue; count += arity+1; if ( count > max ) break; pushWorkAgenda(&agenda, arity, f->arguments); } } clearTermAgenda(&agenda); unvisit(); return count; } /** $term_size(+Term, +Max, -Size) Size represents the total size of Term on the stack, counted in cells. */ static PRED_IMPL("$term_size", 3, term_size, 0) { PRED_LD size_t c, m; term_t t = A1; term_t mx = A2; term_t count = A3; if ( PL_is_variable(mx) ) m = (size_t)-1; else if ( !PL_get_size_ex(mx, &m) ) return FALSE; c = term_size(valTermRef(t), m); if ( c > m ) return FALSE; return PL_unify_integer(count, c); } /******************************* * CYCLIC * *******************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - A DFS search is used to iterate over all 'term chains' in a term graph. A term chain is a list of terms where term N+1 is the last argument of term N. Terms are 'TEMP' marked as we find them. When the end of a term chain has been reached all terms in the chain are 'PERM' marked as we know that all terms in that chain are acyclic. If we reach a term that was already TEMP marked then we terminate the search as a cycle has been detected. If we reach a term that has already been PERM marked then we backtrack as a shared term that we know to be acyclic has been reached. Two strategies are used to avoid repeated pop+push cycles of the same term chain: 1. aggressively cache new term chains for all args of the tail term. 2. only cache the current term chain if we know at least one arg of the tail term is itself a term. Author: Keri Harris - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define ACYCLIC_TEMP_MASK FIRST_MASK #define ACYCLIC_PERM_MASK MARK_MASK #define set_acyclic_temp(p) do { *(p) |= ACYCLIC_TEMP_MASK; } while(0) #define set_acyclic_perm(p) do { *(p) |= ACYCLIC_PERM_MASK; } while(0) #define clear_acyclic_temp(p) do { *(p) &= ~ACYCLIC_TEMP_MASK; } while(0) #define clear_acyclic_perm(p) do { *(p) &= ~ACYCLIC_PERM_MASK; } while(0) #define clear_acyclic_both(p) \ do { *(p) &= ~(ACYCLIC_TEMP_MASK|ACYCLIC_PERM_MASK); } while(0) #define is_acyclic_temp(p) (*(p) & ACYCLIC_TEMP_MASK) #define is_acyclic_perm(p) (*(p) & ACYCLIC_PERM_MASK) #define is_acyclic_or_temp(p) (*(p) & (ACYCLIC_TEMP_MASK|ACYCLIC_PERM_MASK)) typedef struct termChain { Functor head; Functor tail; Word p; } termChain; typedef struct term_chain_agenda { termChain work; segstack stack; } term_chain_agenda; #define ph_acyclic_mark(p) LDFUNC(ph_acyclic_mark, p) static int ph_acyclic_mark(DECL_LD Word p) { term_chain_agenda agenda; termChain chains[32]; Functor top = valueTerm(*p); Functor head = top; Functor tail = top; Functor iter; Word pdef; int arity; initSegStack(&agenda.stack, sizeof(termChain), sizeof(chains), chains); while ( TRUE ) { if ( is_acyclic_temp(&tail->definition) ) { if ( is_acyclic_perm(&tail->definition) ) { goto end_of_chain; } else { clearSegStack(&agenda.stack); return FALSE; } } set_acyclic_temp(&tail->definition); arity = arityFunctor(tail->definition); if ( arity > 1 ) { int i; int new_workspace = FALSE; iter = tail; for( i = arity-2; i >= 0; i-- ) { p = iter->arguments + i; deRef(p); if ( isTerm(*p) ) { if ( !new_workspace ) { if ( !pushSegStack(&agenda.stack, agenda.work, termChain) ) outOfCore(); agenda.work.head = head; agenda.work.tail = tail; agenda.work.p = iter->arguments + arity-1; head = tail = valueTerm(*p); new_workspace = TRUE; } else { if ( !pushSegStack(&agenda.stack, agenda.work, termChain) ) outOfCore(); agenda.work.head = agenda.work.tail = valueTerm(*p); agenda.work.p = NULL; } } } if ( new_workspace ) continue; } p = tail->arguments + arity-1; deRef(p); process_p: if ( isTerm(*p) ) { tail = valueTerm(*p); } else { end_of_chain: if ( head == top ) return TRUE; iter = head; pdef = &iter->definition; while ( iter != tail ) { set_acyclic_perm(pdef); p = iter->arguments + arityFunctor(*pdef) - 1; deRef(p); iter = valueTerm(*p); pdef = &iter->definition; } set_acyclic_perm(pdef); head = agenda.work.head; tail = agenda.work.tail; p = agenda.work.p; if ( !popSegStack(&agenda.stack, &agenda.work, termChain) ) { assert(0); } if ( p ) { deRef(p); goto process_p; } } } return TRUE; } #define ph_acyclic_unmark(p) LDFUNC(ph_acyclic_unmark, p) static int ph_acyclic_unmark(DECL_LD Word p) { term_agenda agenda; initTermAgenda(&agenda, 1, p); while((p=nextTermAgenda(&agenda))) { if ( isTerm(*p) ) { Functor f = valueTerm(*p); Word p = &f->definition; if ( is_acyclic_temp(p) ) { clear_acyclic_both(p); } else { continue; } pushWorkAgenda(&agenda, arityFunctor(f->definition), f->arguments); } } return TRUE; } int is_acyclic(DECL_LD Word p) { int rc1; deRef(p); if ( isTerm(*p) ) { rc1 = ph_acyclic_mark(p); ph_acyclic_unmark(p); return rc1; } return TRUE; } #define PL_is_acyclic(t) LDFUNC(PL_is_acyclic, t) static int PL_is_acyclic(DECL_LD term_t t) { int rc; if ( (rc=is_acyclic(valTermRef(t))) == TRUE ) return TRUE; if ( rc == MEMORY_OVERFLOW ) rc = PL_error(NULL, 0, NULL, ERR_NOMEM); return rc; } API_STUB(int) (PL_is_acyclic)(term_t t) ( return PL_is_acyclic(t); ) static PRED_IMPL("acyclic_term", 1, acyclic_term, PL_FA_ISO) { PRED_LD return PL_is_acyclic(A1); } static PRED_IMPL("cyclic_term", 1, cyclic_term, 0) { PRED_LD int rc; if ( (rc=is_acyclic(valTermRef(A1))) == TRUE ) return FALSE; if ( rc == FALSE ) return TRUE; return PL_error(NULL, 0, NULL, ERR_NOMEM); } /******************************* * FACTORIZE * *******************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Factorizing a term based on the internal sharing. This takes the following steps: 1. scan_shared() walks the term and a. Set MARK_MASK on all visited terms and FIRST_MASK on those find twice. b. Create a list Var=Term for all terms found twice. c. Returns the count of places that must be shared. 2. reverse_factor_pointers() walks through the created list, placing the functor in Var and creating a reference from the location of the original functor. 3. link_shared() walks the term and a. If the functor is a reference, follow the reference-chain to find the functor. Link the term into the reference-chain. b. If the functor is marked, unmark it. 4. restore_shared_functors() finishes the job by following the variable-list and putting all functors from the variable back into the term and setting the variable to be a real variable. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define scan_shared(t, vart, count) LDFUNC(scan_shared, t, vart, count) static int scan_shared(DECL_LD Word t, Word vart, size_t *count) { term_agenda agenda; size_t shared = 0; Word p; initTermAgenda(&agenda, 1, t); while( (p=nextTermAgenda(&agenda)) ) { if ( isTerm(*p) ) { Functor f = valueTerm(*p); Word d = &f->definition; if ( is_marked(d) ) { if ( !is_first(d) ) { Word v; if ( !(v=allocGlobalNoShift(6)) ) return GLOBAL_OVERFLOW; v[0] = FUNCTOR_dot2; v[1] = consPtr(&v[3], TAG_COMPOUND|STG_GLOBAL); v[2] = ATOM_nil; v[3] = FUNCTOR_equals2; v[4] = 0; /* For now */ v[5] = consPtr(d, TAG_COMPOUND|STG_GLOBAL); *vart = consPtr(&v[0], TAG_COMPOUND|STG_GLOBAL); vart = &v[2]; set_first(d); shared++; /* this is already the second one */ } shared++; } else { int arity = arityFunctor(f->definition); pushWorkAgenda(&agenda, arity, f->arguments); set_marked(d); } } } clearTermAgenda(&agenda); *count = shared; return TRUE; } /* Needed to restore if we run out of stack */ #define unscan_shared(t) LDFUNC(unscan_shared, t) static int unscan_shared(DECL_LD Word t) { term_agenda agenda; Word p; initTermAgenda(&agenda, 1, t); while( (p=nextTermAgenda(&agenda)) ) { if ( isTerm(*p) ) { Functor f = valueTerm(*p); Word d = &f->definition; if ( is_marked(d) ) { int arity; clear_marked(d); clear_first(d); arity = arityFunctor(f->definition); pushWorkAgenda(&agenda, arity, f->arguments); } } } clearTermAgenda(&agenda); return TRUE; } #define reverse_factor_pointers(vars) LDFUNC(reverse_factor_pointers, vars) static void reverse_factor_pointers(DECL_LD Word vars) { while(*vars != ATOM_nil) { Word v = (Word)valueTerm(*vars); Functor t = valueTerm(v[5]); v[4] = t->definition & ~(MARK_MASK|FIRST_MASK); /* v[4] is the variable */ t->definition = makeRefG(&v[4])|MARK_MASK|FIRST_MASK; vars = &v[2]; } } #define restore_shared_functors(vars) LDFUNC(restore_shared_functors, vars) static void restore_shared_functors(DECL_LD Word vars) { while(*vars != ATOM_nil) { Word v = (Word)valueTerm(*vars); Functor t = valueTerm(v[5]); Word p = &v[4]; deRef(p); t->definition = *p; setVar(*p); vars = &v[2]; } } #define link_shared(t) LDFUNC(link_shared, t) static int link_shared(DECL_LD Word t) { term_agenda agenda; Word p; initTermAgenda(&agenda, 1, t); while( (p=nextTermAgenda(&agenda)) ) { if ( isTerm(*p) ) { Functor f = valueTerm(*p); Word d = &f->definition; if ( isRef(*d) ) /* shared term */ { Word v; v = unRef(*d & ~(FIRST_MASK|MARK_MASK)); deRef(v); if ( is_marked(d) ) { int arity = arityFunctor(*v); pushWorkAgenda(&agenda, arity, f->arguments); } if ( v < p ) { TrailAssignment(p); *p = makeRefG(v); } else { TrailAssignment(p); *p = *v; *v = makeRefG(p); } } else if ( is_marked(d) ) { int arity; word fun = f->definition & ~(FIRST_MASK|MARK_MASK); clear_marked(d); arity = arityFunctor(fun); pushWorkAgenda(&agenda, arity, f->arguments); } } } clearTermAgenda(&agenda); return TRUE; } int PL_factorize_term(term_t term, term_t template, term_t factors) { GET_LD fid_t fid; term_t vars, wrapped; Word t; size_t count; int rc; for(;;) { if ( !(fid = PL_open_foreign_frame()) || !(wrapped = PL_new_term_ref()) || !(vars = PL_new_term_ref()) || !PL_unify_term(wrapped, PL_FUNCTOR, FUNCTOR_var1, PL_TERM, term) ) return FALSE; PL_put_nil(vars); t = valTermRef(wrapped); DEBUG(CHK_SECURE, checkStacks(NULL)); switch( (rc=scan_shared(t, valTermRef(vars), &count)) ) { case TRUE: if ( tTop + 2*count > tMax ) rc = TRAIL_OVERFLOW; else if ( gTop + count > gMax ) rc = GLOBAL_OVERFLOW; else break; /*FALLTHROUGH*/ default: unscan_shared(t); PL_discard_foreign_frame(fid); if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) ) return FALSE; continue; } break; } reverse_factor_pointers(valTermRef(vars)); link_shared(t); restore_shared_functors(valTermRef(vars)); PL_close_foreign_frame(fid); DEBUG(CHK_SECURE, checkStacks(NULL)); _PL_get_arg(1, wrapped, wrapped); return ( PL_unify(template, wrapped) && PL_unify(factors, vars) ); } static PRED_IMPL("$factorize_term", 3, factorize_term, 0) { return PL_factorize_term(A1, A2, A3); } /******************************* * META-CALL SUPPORT * *******************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deterministic(-Bool) Bool = true if no choicepoint has been created in the current clause. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static PRED_IMPL("deterministic", 1, deterministic, 0) { PRED_LD LocalFrame FR = environment_frame->parent; Choice BFR = LD->choicepoints; for( ; BFR; BFR = BFR->parent) { switch(BFR->type) { case CHP_CLAUSE: if ( BFR->frame == FR ) return PL_unify_atom(A1, ATOM_true); case CHP_JUMP: if ( (void *)BFR > (void *)FR ) return PL_unify_atom(A1, ATOM_false); else return PL_unify_atom(A1, ATOM_true); default: continue; } } return PL_unify_atom(A1, ATOM_true); } #ifdef O_TERMHASH /******************************* * TERM-HASH * *******************************/ #define termHashValue(term, depth, hval) LDFUNC(termHashValue, term, depth, hval) static bool termHashValue(DECL_LD word term, long depth, unsigned int *hval) { for(;;) { switch(tag(term)) { case TAG_VAR: case TAG_ATTVAR: fail; case TAG_ATOM: { *hval = MurmurHashAligned2(&atomValue(term)->hash_value, sizeof(unsigned int), *hval); succeed; } case TAG_STRING: { size_t len; char *s; s = getCharsString(term, &len); *hval = MurmurHashAligned2(s, len, *hval); succeed; } case TAG_INTEGER: if ( storage(term) == STG_INLINE ) { int64_t v = valInt(term); *hval = MurmurHashAligned2(&v, sizeof(v), *hval); succeed; } /*FALLTHROUGH*/ case TAG_FLOAT: { Word p = addressIndirect(term); size_t n = wsizeofInd(*p); *hval = MurmurHashAligned2(p+1, n*sizeof(word), *hval); succeed; } case TAG_COMPOUND: { Functor t = valueTerm(term); FunctorDef fd; int arity; Word p; unsigned int atom_hashvalue; if ( visited(t) ) { *hval = MurmurHashAligned2(hval, sizeof(*hval), *hval); succeed; } fd = valueFunctor(t->definition); arity = fd->arity; atom_hashvalue = atomValue(fd->name)->hash_value + arity; *hval = MurmurHashAligned2(&atom_hashvalue, sizeof(atom_hashvalue), *hval); if ( --depth != 0 ) { for(p = t->arguments; arity-- > 0; p++) { if ( !termHashValue(*p, depth, hval) ) { popVisited(); fail; } } } popVisited(); succeed; } case TAG_REFERENCE: { term = *unRef(term); continue; } default: assert(0); } } } /* term_hash(+Term, +Depth, +Range, -HashKey) */ static PRED_IMPL("term_hash", 4, term_hash4, 0) { PRED_LD Word p = valTermRef(A1); unsigned int hraw = MURMUR_SEED; long depth; int range; int rc = TRUE; if ( !PL_get_long_ex(A2, &depth) ) fail; if ( depth < -1 ) return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_zero, A2); if ( !PL_get_integer_ex(A3, &range) ) fail; if ( range < 1 ) return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_one, A2); if ( depth != 0 ) { initvisited(); rc = termHashValue(*p, depth, &hraw); DEBUG(CHK_SECURE, assert(empty_visited())); } if ( rc ) { hraw = hraw % range; return PL_unify_integer(A4, hraw); } succeed; } #endif /*O_TERMHASH*/ /******************************** * STANDARD ORDER * *********************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - There are atoms of different type. We only define comparison between atoms of the same type, except for mixed ISO Latin-1 and UCS atoms. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ int compareAtoms(atom_t w1, atom_t w2) { if ( w1 == w2 ) return CMP_EQUAL; Atom a1 = atomValue(w1); Atom a2 = atomValue(w2); if ( a1->type == a2->type ) { if ( a1->type->compare ) { return (*a1->type->compare)(w1, w2); } else { size_t l = (a1->length <= a2->length ? a1->length : a2->length); int v; if ( (v=memcmp(a1->name, a2->name, l)) != 0 ) return SCALAR_TO_CMP(v, 0); else return SCALAR_TO_CMP(a1->length, a2->length); } } else if ( true(a1->type, PL_BLOB_TEXT) && true(a2->type, PL_BLOB_TEXT) ) { PL_chars_t t1, t2; size_t len; get_atom_text(w1, &t1); get_atom_text(w2, &t2); len = t1.length > t2.length ? t1.length : t2.length; return PL_cmp_text(&t1, 0, &t2, 0, len); } else { return SCALAR_TO_CMP(a1->type->rank, a2->type->rank); } } #define compareStrings(w1, w2) LDFUNC(compareStrings, w1, w2) static int compareStrings(DECL_LD word w1, word w2) { PL_chars_t t1, t2; size_t len; get_string_text(w1, &t1); get_string_text(w2, &t2); len = (t1.length > t2.length ? t1.length : t2.length); return PL_cmp_text(&t1, 0, &t2, 0, len); } /* Compare two floats know to be non-equal. As we do standard order comparison, we may not return equal and must decide on one to be the greatest. */ static int compare_neq_floats(double f1, double f2) { if ( isnan(f1) ) { if ( isnan(f2) ) { double nf1 = NaN_value(f1); double nf2 = NaN_value(f2); if ( nf1 < nf2 ) { return CMP_LESS; } else if ( nf1 > nf2 ) { return CMP_GREATER; } else if ( signbit(nf1) != signbit(nf2) ) { return signbit(nf1) ? CMP_LESS : CMP_GREATER; } else { return CMP_EQUAL; } } return CMP_LESS; } else if ( isnan(f2) ) { return CMP_GREATER; } if ( f1 < f2 ) { return CMP_LESS; } else if ( f1 > f2 ) { return CMP_GREATER; } else { assert(signbit(f1) != signbit(f2)); return signbit(f1) ? CMP_LESS : CMP_GREATER; } } #define compare_mixed_float_rational(w1, w2) \ LDFUNC(compare_mixed_float_rational, w1, w2) static int compare_mixed_float_rational(DECL_LD word w1, word w2) { number left, right; int rc; get_number(w1, &left); get_number(w2, &right); if ( left.type == V_FLOAT && isnan(left.value.f) ) rc = CMP_LESS; else if ( right.type == V_FLOAT && isnan(right.value.f) ) rc = CMP_GREATER; else { rc = cmpReals(&left, &right); assert(rc != CMP_NOTEQ); } clearNumber(&left); clearNumber(&right); if ( rc == CMP_EQUAL ) rc = (tag(w1) == TAG_FLOAT) ? CMP_LESS : CMP_GREATER; return rc; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - compareStandard(Word p1, Word p2, int eq) Rules: Var @< AttVar @< Number @< String @< Atom < Term OldVar < NewVar (not relyable) Atom: alphabetically Strings: alphabetically number: value Term: arity / alphabetically / recursive If eq == TRUE, only test for equality. In this case expensive inequality tests (alphabetical order) are skipped and the call returns NOTEQ. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define compare_primitives(p1, p2, eq) LDFUNC(compare_primitives, p1, p2, eq) static int compare_primitives(DECL_LD Word p1, Word p2, int eq) { word t1, t2; word w1, w2; w1 = *p1; w2 = *p2; if ( w1 == w2 ) { if ( isVar(w1) ) return SCALAR_TO_CMP(p1, p2); return CMP_EQUAL; } t1 = tag(w1); t2 = tag(w2); if ( t1 != t2 ) { if ( eq ) return CMP_NOTEQ; if ( (t1|t2) == (TAG_INTEGER|TAG_FLOAT) && /* quick test first */ !truePrologFlag(PLFLAG_ISO) && ( (t1 == TAG_INTEGER && t2 == TAG_FLOAT) || (t1 == TAG_FLOAT && t2 == TAG_INTEGER) ) ) return compare_mixed_float_rational(w1, w2); static_assert(TAG_VAR == 0 && TAG_ATTVAR==1, "Think twice before reordering the tags"); if ( (t1|t2) > TAG_ATTVAR ) /* actually `t1 > TAG_ATTVAR || t2 > TAG_ATTVAR` */ return t1 < t2 ? CMP_LESS : CMP_GREATER; } switch(t1) { case TAG_VAR: case TAG_ATTVAR: return SCALAR_TO_CMP(p1, p2); case TAG_INTEGER: { number n1, n2; int rc; if ( storage(w1) == STG_INLINE && storage(w2) == STG_INLINE ) return SCALAR_TO_CMP(valInt(w1), valInt(w2)); get_rational(w1, &n1); get_rational(w2, &n2); if ( eq && (n1.type != n2.type) ) return CMP_NOTEQ; rc = cmpNumbers(&n1, &n2); clearNumber(&n1); clearNumber(&n2); return rc; } case TAG_FLOAT: { if ( equalIndirect(w1,w2) ) return CMP_EQUAL; else if ( eq ) return CMP_NOTEQ; else return compare_neq_floats(valFloat(w1), valFloat(w2)); } case TAG_ATOM: return eq ? CMP_NOTEQ : compareAtoms(w1, w2); case TAG_STRING: return compareStrings(w1, w2); case TAG_COMPOUND: return CMP_COMPOUND; default: assert(0); return CMP_ERROR; } } static int compare_functors(word f1, word f2, int eq) { if ( eq ) { return CMP_NOTEQ; } else { FunctorDef fd1 = valueFunctor(f1); FunctorDef fd2 = valueFunctor(f2); if ( fd1->arity != fd2->arity ) return fd1->arity > fd2->arity ? CMP_GREATER : CMP_LESS; return compareAtoms(fd1->name, fd2->name); } } #define do_compare(agenda, f1, f2, eq) LDFUNC(do_compare, agenda, f1, f2, eq) static int do_compare(DECL_LD term_agendaLR *agenda, Functor f1, Functor f2, int eq) { Word p1, p2; goto compound; while( nextTermAgendaLR(agenda, &p1, &p2) ) { int rc; deRef(p1); deRef(p2); if ( (rc=compare_primitives(p1, p2, eq)) != CMP_COMPOUND ) { if ( rc == CMP_EQUAL ) continue; return rc; } else { f1 = (Functor)valPtr(*p1); f2 = (Functor)valPtr(*p2); #if O_CYCLIC while ( isRef(f1->definition) ) f1 = (Functor)unRef(f1->definition); while ( isRef(f2->definition) ) f2 = (Functor)unRef(f2->definition); if ( f1 == f2 ) continue; #endif if ( f1->definition != f2->definition ) { return compare_functors(f1->definition, f2->definition, eq); } else { int arity; compound: arity = arityFunctor(f1->definition); linkTermsCyclic(f1, f2); if ( !pushWorkAgendaLR(agenda, arity, f1->arguments, f2->arguments) ) { PL_error(NULL, 0, NULL, ERR_RESOURCE, ATOM_memory); return CMP_ERROR; } continue; } } } return CMP_EQUAL; } int compareStandard(DECL_LD Word p1, Word p2, int eq) { int rc; deRef(p1); deRef(p2); if ( (rc=compare_primitives(p1, p2, eq)) != CMP_COMPOUND ) { return rc; } else { Functor f1 = (Functor)valPtr(*p1); Functor f2 = (Functor)valPtr(*p2); if ( f1->definition != f2->definition ) { return compare_functors(f1->definition, f2->definition, eq); } else { term_agendaLR agenda; initCyclic(); initTermAgendaLR0(&agenda); rc = do_compare(&agenda, f1, f2, eq); clearTermAgendaLR(&agenda); exitCyclic(); return rc; } } } /* compare(-Diff, +T1, +T2) */ static PRED_IMPL("compare", 3, compare, PL_FA_ISO) { PRED_LD Word d = valTermRef(A1); Word p1 = valTermRef(A2); Word p2 = p1+1; int val; atom_t a; deRef(d); if ( canBind(*d) ) { a = 0; } else { if ( isAtom(*d) ) { a = *d; if ( a == ATOM_equals ) return compareStandard(p1, p2, TRUE) == CMP_EQUAL ? TRUE : FALSE; if ( a != ATOM_smaller && a != ATOM_larger ) return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_order, A1); } else return PL_type_error("atom", A1); } if ( (val = compareStandard(p1, p2, FALSE)) == CMP_ERROR ) return FALSE; if ( a ) { if ( a == ATOM_smaller ) return val < 0; else return val > 0; } else { a = val < 0 ? ATOM_smaller : val > 0 ? ATOM_larger : ATOM_equals; return PL_unify_atom(A1, a); } } static PRED_IMPL("@<", 2, std_lt, 0) { PRED_LD Word p1 = valTermRef(A1); Word p2 = p1+1; int rc; if ( (rc=compareStandard(p1, p2, FALSE)) == CMP_ERROR ) return FALSE; return rc < 0 ? TRUE : FALSE; } static PRED_IMPL("@=<", 2, std_leq, 0) { PRED_LD Word p1 = valTermRef(A1); Word p2 = p1+1; int rc; if ( (rc=compareStandard(p1, p2, FALSE)) == CMP_ERROR ) return FALSE; return rc <= 0 ? TRUE : FALSE; } static PRED_IMPL("@>", 2, std_gt, 0) { PRED_LD Word p1 = valTermRef(A1); Word p2 = p1+1; int rc; if ( (rc=compareStandard(p1, p2, FALSE)) == CMP_ERROR ) return FALSE; return rc > 0 ? TRUE : FALSE; } static PRED_IMPL("@>=", 2, std_geq, 0) { PRED_LD Word p1 = valTermRef(A1); Word p2 = p1+1; int rc; if ( (rc=compareStandard(p1, p2, FALSE)) == CMP_ERROR ) return FALSE; return rc >= 0 ? TRUE : FALSE; } /******************************** * EQUALITY * *********************************/ static PRED_IMPL("==", 2, equal, 0) { PRED_LD Word p1 = valTermRef(A1); Word p2 = p1+1; int rc; if ( (rc=compareStandard(p1, p2, TRUE)) == CMP_ERROR ) return FALSE; return rc == CMP_EQUAL ? TRUE : FALSE; } static PRED_IMPL("\\==", 2, nonequal, 0) { PRED_LD Word p1 = valTermRef(A1); Word p2 = p1+1; int rc; if ( (rc=compareStandard(p1, p2, TRUE)) == CMP_ERROR ) return FALSE; return rc == CMP_EQUAL ? FALSE : TRUE; } /** ?=(@X, @Y) is semidet. True if we can decide for now and forever that X and Y are either equal or non-equal. I.e. X and Y are equal or they cannot unify. */ static PRED_IMPL("?=", 2, can_compare, 0) { PRED_LD fid_t fid = PL_open_foreign_frame(); int rc; rc = PL_unify(A1, A2); if ( rc ) { FliFrame fr = (FliFrame) valTermRef(fid); assert(fr->magic == FLI_MAGIC); if ( fr->mark.trailtop != tTop ) rc = FALSE; } else if ( exception_term ) { PL_close_foreign_frame(fid); /* keep exception */ return FALSE; } else { rc = TRUE; /* could not unify */ } PL_discard_foreign_frame(fid); return rc; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - same_term(@T1, @T2) is semidet. True if T1 and T2 is really the same term, so setarg/3 affects both terms. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ int PL_same_term(DECL_LD term_t T1, term_t T2) { Word t1 = valTermRef(T1); Word t2 = valTermRef(T2); deRef(t1); deRef(t2); if ( isVar(*t1) ) return t1 == t2; if ( *t1 == *t2 ) succeed; if ( isIndirect(*t1) && isIndirect(*t2) ) return equalIndirect(*t1, *t2); fail; } static PRED_IMPL("same_term", 2, same_term, 0) { PRED_LD return PL_same_term(A1, A2); } static PRED_IMPL("$term_id", 2, term_id, 0) { PRED_LD Word t1 = valTermRef(A1); deRef(t1); if ( isTerm(*t1) ) { Functor f = valueTerm(*t1); return PL_unify_int64(A2, (Word)f-gBase); } return PL_type_error("compound", A1); } /******************************** * TERM HACKING * *********************************/ /* functor(+Term, -Name, -Arity) */ /* functor(-Term, +Name, +Arity) */ static PRED_IMPL("functor", 3, functor, 0) { PRED_LD size_t arity; atom_t name; Word p = valTermRef(A1); deRef(p); if ( isTerm(*p) ) { FunctorDef fd = valueFunctor(functorTerm(*p)); if ( fd->arity == 0 ) return PL_domain_error("compound_non_zero_arity", A1); if ( !PL_unify_atom(A2, fd->name) || !PL_unify_integer(A3, fd->arity) ) fail; succeed; } if ( isAtomic(*p) ) { if ( !PL_unify(A2, A1) || !PL_unify_integer(A3, 0) ) fail; succeed; } if ( !PL_is_atomic(A2) ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atomic, A2); if ( !PL_get_size_ex(A3, &arity) ) fail; if ( arity == 0 ) return PL_unify(A1, A2); if ( PL_get_atom_ex(A2, &name) ) return PL_unify_functor(A1, PL_new_functor(name, arity)); fail; } /* compound_name_arity(+Compound, -Name, -Arity) */ /* compound_name_arity(-Compound, +Name, +Arity) */ static PRED_IMPL("compound_name_arity", 3, compound_name_arity, 0) { PRED_LD size_t arity; atom_t name; Word p = valTermRef(A1); deRef(p); if ( isTerm(*p) ) { FunctorDef fd = valueFunctor(functorTerm(*p)); if ( !PL_unify_atom(A2, fd->name) || !PL_unify_integer(A3, fd->arity) ) fail; succeed; } if ( !canBind(*p) ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_compound, A1); if ( !PL_get_atom_ex(A2, &name) || !PL_get_size_ex(A3, &arity) ) fail; return PL_unify_compound(A1, PL_new_functor(name, arity)); } /* functor(+Callable, -Name, -Arity, -Type) */ /* functor(-Callable, +Name, +Arity, +Type) */ #define match_functor_type(Type, atype, type) LDFUNC(match_functor_type, Type, atype, type) static int match_functor_type(DECL_LD term_t Type, atom_t atype, atom_t type) { if ( !atype ) return PL_unify_atom(Type, type); if ( atype == type ) return TRUE; if ( atype == ATOM_callable && ( type == ATOM_atom || type == ATOM_compound ) ) return TRUE; return FALSE; } static PRED_IMPL("functor", 4, functor, 0) { PRED_LD size_t arity; atom_t name; atom_t type; Word p; if ( !PL_get_atom(A4, &type) ) { if ( PL_is_variable(A4) ) type = 0; else return PL_type_error("atom", A4); } p = valTermRef(A1); deRef(p); if ( isTerm(*p) ) { FunctorDef fd = valueFunctor(functorTerm(*p)); return ( PL_unify_atom(A2, fd->name) && PL_unify_integer(A3, fd->arity) && match_functor_type(A4, type, ATOM_compound) ); } else if ( isAtom(*p) ) { return ( PL_unify_atom(A2, *p) && PL_unify_integer(A3, 0) && match_functor_type(A4, type, ATOM_atom) ); } else if ( !canBind(*p) ) { return ( PL_unify(A2, A1) && PL_unify_integer(A3, 0) && match_functor_type(A4, type, ATOM_atomic) ); } if ( !PL_get_size_ex(A3, &arity) ) return FALSE; if ( arity > 0 ) { return ( PL_get_atom_ex(A2, &name) && match_functor_type(A4, type, ATOM_compound) && PL_unify_compound(A1, PL_new_functor(name, arity)) ); } else if ( PL_get_atom(A2, &name) ) { if ( type == ATOM_compound ) return PL_unify_compound(A1, PL_new_functor(name, 0)); else if ( type == ATOM_callable || type == ATOM_atom ) return PL_unify_atom(A1, name); else if ( type == ATOM_atomic ) return FALSE; else return PL_domain_error("functor_type", A4); } else if ( PL_is_atomic(A2) ) { return ( PL_unify(A2, A1) && match_functor_type(A4, type, ATOM_atomic) ); } else { return PL_type_error("atomic", A2); } } /** '$filled_array'(-Compound, +Name, +Arity, +Value) is det. * Created an array (compound) with all arguments set to Value. */ static PRED_IMPL("$filled_array", 4, filled_array, 0) { PRED_LD size_t arity; atom_t name; functor_t f; Word p, v; term_t compound = PL_new_term_ref(); size_t i; if ( !PL_get_atom_ex(A2, &name) || !PL_get_size_ex(A3, &arity) ) return FALSE; f = PL_new_functor(name, arity); if ( !(p = allocGlobal(arity+1)) ) return FALSE; v = valTermRef(A4); deRef(v); p[0] = f; if ( arity > 0 ) { word w; bArgVar(&p[1], v); w = isVar(p[1]) ? makeRefG(&p[1]) : p[1]; for(i=2; i<=arity; i++) p[i] = w; } *valTermRef(compound) = consPtr(p, TAG_COMPOUND|STG_GLOBAL); return PL_unify(A1, compound); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - int get_arg_integer_ex(term_t t, intptr_t *n) Get argument position from t. Returns: TRUE if t is a small non-negative integer -1 if t is unbound FALSE - with exception if t is not an integer or negative - without exception if t is 0 or a large positive integer - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define get_arg_integer_ex(t, n) LDFUNC(get_arg_integer_ex, t, n) static int get_arg_integer_ex(DECL_LD term_t t, size_t *n) { Word p = valTermRef(t); deRef(p); if ( isTaggedInt(*p) ) { intptr_t v = valInt(*p); if ( v > 0 ) { *n = v; return TRUE; } if ( v == 0 ) return FALSE; } if ( isInteger(*p) ) { number n; get_integer(*p, &n); if ( ar_sign_i(&n) < 0 ) PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_zero, t); return FALSE; } if ( canBind(*p) ) return -1; PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, t); return FALSE; } static PRED_IMPL("arg", 3, arg, PL_FA_NONDETERMINISTIC) { PRED_LD size_t arity; size_t argn; term_t n = A1; term_t term = A2; term_t arg = A3; switch( CTX_CNTRL ) { case FRG_FIRST_CALL: { size_t idx; int rc; Word p = valTermRef(term); deRef(p); if ( isTerm(*p) ) arity = arityTerm(*p); else return PL_error("arg", 3, NULL, ERR_TYPE, ATOM_compound, term); if ( (rc=get_arg_integer_ex(n, &idx)) == TRUE ) { if ( idx <= arity ) { Word ap = argTermP(*p, idx-1); return unify_ptrs(valTermRef(arg), ap, ALLOW_GC|ALLOW_SHIFT); } fail; } if ( rc == -1 ) /* variable */ { argn = 1; goto genarg; } return FALSE; /* bigint, negative or type error */ } case FRG_REDO: { term_t a; fid_t fid; int rc; Word p = valTermRef(term); deRef(p); arity = arityTerm(*p); argn = (unsigned)CTX_INT + 1; genarg: rc = FALSE; if ( !(fid=PL_open_foreign_frame()) || !(a = PL_new_term_ref()) ) return FALSE; for(; argn <= arity; argn++) { _PL_get_arg(argn, term, a); if ( PL_unify(arg, a) ) { if ( !PL_unify_integer(n, argn) ) break; if ( argn == arity ) { rc = TRUE; break; } PL_close_foreign_frame(fid); ForeignRedoInt(argn); } if ( exception_term ) break; PL_rewind_foreign_frame(fid); } PL_close_foreign_frame(fid); return rc; } default: succeed; } } #define SETARG_BACKTRACKABLE 0x1 #define SETARG_LINK 0x2 /* unify_vp() assumes *vp is a variable and binds it to val. The assignment is *not* trailed. As no allocation takes place, there are no error conditions. It is *not* allowed for *both* vp and val to be local stack pointers. */ void unify_vp(DECL_LD Word vp, Word val) { deRef(val); if ( isVar(*val) ) { if ( val < vp ) { DEBUG(0, assert(val < (Word)lBase)); *vp = makeRefG(val); } else if ( vp < val ) { setVar(*vp); DEBUG(0, assert(vp < (Word)lBase)); *val = makeRefG(vp); } else setVar(*vp); } else if ( isAttVar(*val) ) { *vp = makeRefG(val); } else *vp = *val; } #define setarg(n, term, value, flags) LDFUNC(setarg, n, term, value, flags) static word setarg(DECL_LD term_t n, term_t term, term_t value, int flags) { size_t arity, argn; atom_t name; Word a, v; if ( !PL_get_size_ex(n, &argn) ) return FALSE; if ( argn == 0 ) return FALSE; if ( !PL_get_name_arity(term, &name, &arity) ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_compound, term); if ( argn > arity ) return FALSE; if ( (flags & SETARG_BACKTRACKABLE) ) { Word a2; a = valTermRef(term); deRef(a); a = argTermP(*a, argn-1); deRef2(a, a2); if ( isVar(*a2) ) { return unify_ptrs(valTermRef(value), a, ALLOW_GC|ALLOW_SHIFT); } else { if ( !hasGlobalSpace(0) ) { int rc; if ( (rc=ensureGlobalSpace(0, ALLOW_GC)) != TRUE ) return raiseStackOverflow(rc); a = valTermRef(term); deRef(a); a = argTermP(*a, argn-1); } TrailAssignment(a); } } else { v = valTermRef(value); deRef(v); if ( storage(*v) == STG_GLOBAL ) { if ( isTerm(*v) && !(flags & SETARG_LINK) ) { term_t copy = PL_new_term_ref(); if ( !duplicate_term(value, copy) ) fail; value = copy; } freezeGlobal(); } a = valTermRef(term); /* duplicate may shift stacks */ deRef(a); a = argTermP(*a, argn-1); } /* this is unify(), but the */ /* assignment must *not* be trailed */ v = valTermRef(value); unify_vp(a, v); return TRUE; } static PRED_IMPL("setarg", 3, setarg, 0) { PRED_LD return setarg(A1, A2, A3, SETARG_BACKTRACKABLE); } static PRED_IMPL("nb_setarg", 3, nb_setarg, 0) { PRED_LD return setarg(A1, A2, A3, 0); } static PRED_IMPL("nb_linkarg", 3, nb_linkarg, 0) { PRED_LD return setarg(A1, A2, A3, SETARG_LINK); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Cycle detection for lists using Brent's algorithm. skip_list() was originally added to SWI-Prolog by Ulrich Neumerkel. The code below is a clean-room re-implementation by Keri Harris. See http://en.wikipedia.org/wiki/Cycle_detection#Brent.27s_algorithm - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ intptr_t skip_list(DECL_LD Word l, Word *tailp) { deRef(l); if ( !isList(*l) ) { *tailp = l; return 0; } else { Word checkCell, currentCell; intptr_t length = 0; int power, lam; checkCell = currentCell = l; lam = 0; power = 1; while ( TRUE ) { currentCell = TailList(currentCell); deRef(currentCell); length++; if ( !isList(*currentCell) || (*checkCell == *currentCell) ) break; lam++; if ( power == lam ) { checkCell = currentCell; power *= 2; lam = 0; } } *tailp = currentCell; return length; } } /** '$skip_list'(-Length, +Xs0, -Xs) is det. Xs0, Xs is a pair of list differences. Xs0 is the input list and Xs is the minimal remaining list. Examination of Xs permits to classify the list Xs0: Xs | list type of Xs0 | Length [] ... | well formed | length Var ... | partial | elements skipped [_|_] ... | infinite | upper bound for cycle Term ... | malformed | elements skipped */ static PRED_IMPL("$skip_list", 3, skip_list, 0) { PRED_LD Word tail; intptr_t len; len = skip_list(valTermRef(A2), &tail); if ( unify_ptrs(valTermRef(A3), tail, ALLOW_GC|ALLOW_SHIFT) && PL_unify_integer(A1, len) ) return TRUE; return FALSE; } /** '$seek_list'(+Count, +List, -RestCount, -Rest) */ static PRED_IMPL("$seek_list", 4, seek_list, 0) { PRED_LD int64_t size; Word tail; if ( !PL_get_int64_ex(A1, &size) ) return FALSE; tail = valTermRef(A2); while(size > 0) { deRef(tail); if ( isList(*tail) ) { tail = TailList(tail); size--; if ( size%1024 == 0 && PL_handle_signals() < 0 ) return FALSE; } else break; } return ( unify_ptrs(valTermRef(A4), tail, ALLOW_GC|ALLOW_SHIFT) && PL_unify_integer(A3, size) ); } /* Determine the length of a list. Returns: len >= 0 if list is proper len == -1 if list is not a list len == -2 if list is incomplete (i.e. tail is unbound) ** Mon Apr 18 16:29:01 1988 jan@swivax.UUCP (Jan Wielemaker) */ intptr_t lengthList(term_t list, int errors) { GET_LD intptr_t length = 0; Word l = valTermRef(list); Word tail; length = skip_list(l, &tail); if ( isNil(*tail) ) return length; if ( errors ) { PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, pushWordAsTermRef(l)); popTermRef(); } return isVar(*tail) ? -2 : -1; } static PRED_IMPL("=..", 2, univ, PL_FA_ISO) { GET_LD term_t t = A1; term_t list = A2; Word p; int n; if ( PL_is_variable(t) ) { atom_t name; intptr_t arity; term_t tail = PL_copy_term_ref(list); term_t head = PL_new_term_ref(); if ( !PL_get_list(tail, head, tail) ) { if ( PL_get_nil(tail) ) return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_non_empty_list, tail); return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, tail); } if ( PL_get_nil(tail) ) /* A =.. [H] */ { if ( !PL_is_atomic(head) ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atomic, head); return PL_unify(t, head); } if ( !PL_get_atom_ex(head, &name) ) fail; if ( (arity = lengthList(tail, FALSE)) < 0 ) { if ( arity == -1 ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list); else return PL_error(NULL, 0, NULL, ERR_INSTANTIATION); } if ( (p = allocGlobal(arity+1)) ) { Word l = valTermRef(tail); *valTermRef(head) = consPtr(p, TAG_COMPOUND|STG_GLOBAL); *p++ = PL_new_functor(name, arity); deRef(l); while(isList(*l)) { Word h = HeadList(l); deRef(h); *p++ = needsRef(*h) ? makeRefG(h) : *h; l = TailList(l); deRef(l); } return PL_unify(t, head); } return FALSE; } p = valTermRef(t); deRef(p); if ( isTerm(*p) ) { FunctorDef fd = valueFunctor(functorTerm(*p)); term_t head, l; if ( fd->arity == 0 ) return PL_domain_error("compound_non_zero_arity", A1); head = PL_new_term_ref(); l = PL_new_term_ref(); if ( !PL_unify_list_ex(list, head, l) || !PL_unify_atom(head, fd->name) ) return FALSE; for(n = 1; n <= fd->arity; n++) { if ( !PL_unify_list_ex(l, head, l) || !PL_unify_arg(n, t, head) ) return FALSE; } return PL_unify_nil_ex(l); } if ( PL_is_atomic(t) ) /* 3 =.. X, 3.4 =.. X, "foo" =.. X */ { term_t head = PL_new_term_ref(); term_t l = PL_new_term_ref(); if ( PL_unify_list_ex(list, head, l) && PL_unify(head, t) && PL_unify_nil_ex(l) ) succeed; } fail; } /** compound_name_arguments(-Term, +Name, +Arguments) compound_name_arguments(+Term, -Name, -Arguments) */ static PRED_IMPL("compound_name_arguments", 3, compound_name_arguments, 0) { GET_LD term_t t = A1; term_t list = A3; intptr_t len; size_t arity; atom_t name; size_t n; if ( PL_is_variable(t) ) { term_t tail = PL_copy_term_ref(list); term_t head = PL_new_term_ref(); if ( !PL_get_atom_ex(A2, &name) ) return FALSE; if ( (len = lengthList(tail, FALSE)) < 0 ) { if ( len == -1 ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, list); else return PL_error(NULL, 0, NULL, ERR_INSTANTIATION); } if ( !PL_unify_compound(t, PL_new_functor(name, (size_t)len)) ) fail; for(n=1; PL_get_list(tail, head, tail); n++) { if ( !PL_unify_arg(n, t, head) ) fail; } succeed; } /* 1st arg is term */ if ( PL_get_compound_name_arity(t, &name, &arity) ) { term_t head = PL_new_term_ref(); term_t l = PL_copy_term_ref(list); if ( !PL_unify_atom(A2, name) ) fail; for(n = 1; n <= arity; n++) { if ( !PL_unify_list_ex(l, head, l) || !PL_unify_arg(n, t, head) ) fail; } return PL_unify_nil_ex(l); } return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_compound, A1); } /******************************* * NUMBERVARS * *******************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Returns >= 0: Number for next variable variable -1: Error < -1: Out of stack error or ALREADY_NUMBERED or CONTAINS_ATTVAR TBD: when using the `singletons' mode, the predicate is not cycle safe (this is an error) and does not exploit sharing. We could fix this using both flags: - Not marked: go in there - Marked, but not alt-mark: map vars in there _-->n - both-marked: done - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define ALREADY_NUMBERED (-10) #define CONTAINS_ATTVAR (-11) #define REPRESENTATION_ERROR (-12) #define do_number_vars(p, options, n, m) LDFUNC(do_number_vars, p, options, n, m) static intptr_t do_number_vars(DECL_LD Word p, nv_options *options, intptr_t n, mark *m) { term_agenda agenda; intptr_t start = n; initTermAgenda(&agenda, 1, p); while((p=nextTermAgenda(&agenda))) { if ( canBind(*p) ) { Word a; word v; if ( isAttVar(*p) ) { switch(options->on_attvar) { case AV_SKIP: continue; case AV_ERROR: n = CONTAINS_ATTVAR; goto out; case AV_BIND: break; } } if ( !hasGlobalSpace(2) ) { n = overflowCode(2); goto out; } a = gTop; a[0] = options->functor; if ( options->singletons ) { a[1] = ATOM_anonvar; } else { intptr_t v = n+options->offset; a[1] = consInt(v); if ( valInt(a[1]) != v ) { n = REPRESENTATION_ERROR; goto out; } n++; } gTop += 2; v = consPtr(a, TAG_COMPOUND|STG_GLOBAL); bindConst(p, v); } else if ( isTerm(*p) ) { Functor f = valueTerm(*p); if ( f->definition == options->functor ) { if ( (Word)f >= m->globaltop ) /* new one we created ourselves */ { if ( options->singletons ) { Word p = &f->arguments[0]; if ( options->singletons == 1 ) { if ( *p == ATOM_anonvar ) { intptr_t v = n+options->offset; word w = consInt(v); if ( valInt(w) != v ) { n = REPRESENTATION_ERROR; goto out; } *p = ATOM_var; n++; } } else { if ( *p == ATOM_var ) { intptr_t v = n+options->offset; *p = consInt(v); n++; } } } } else { Word p = &f->arguments[0]; deRef(p); if ( options->numbered_check && isInteger(*p) ) { intptr_t i = (intptr_t)valInteger(*p); /* cannot be bigger */ if ( i >= (intptr_t)start ) { n = ALREADY_NUMBERED; goto out; } } if ( isVar(*p) || isTerm(*p) ) goto do_number; /* number '$VAR'(_) */ } continue; } do_number: if ( !options->singletons && visited(f) ) continue; if ( !pushWorkAgenda(&agenda, arityFunctor(f->definition), f->arguments) ) { n = MEMORY_OVERFLOW; goto out; } } } out: clearTermAgenda(&agenda); return n; /* anything else */ } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Returns >= 0: Number for next variable variable -1: Error. Exception is left in the environment - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ intptr_t numberVars(DECL_LD term_t t, nv_options *options, intptr_t n) { if ( !inTaggedNumRange(n) ) { PL_representation_error("tagged_integer"); return NV_ERROR; } options->offset = n; for(;;) { mark m; intptr_t rc; Mark(m); initvisited(); rc = do_number_vars(valTermRef(t), options, 0, &m); unvisit(); if ( rc >= 0 ) /* all ok */ { DiscardMark(m); if ( options->singletons ) { intptr_t rc2; options->singletons = 2; initvisited(); rc2 = do_number_vars(valTermRef(t), options, 0, &m); unvisit(); assert(rc == rc2); (void)rc2; } return rc + options->offset; } else { switch( rc ) { case CONTAINS_ATTVAR: DiscardMark(m); PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_free_of_attvar, t); return NV_ERROR; case ALREADY_NUMBERED: DiscardMark(m); PL_error(NULL, 0, "already numbered", ERR_PERMISSION, ATOM_numbervars, ATOM_term, t); return NV_ERROR; case REPRESENTATION_ERROR: DiscardMark(m); PL_representation_error("tagged_integer"); return NV_ERROR; default: Undo(m); DiscardMark(m); if ( !makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT) ) return NV_ERROR; } } } } static const PL_option_t numbervar_options[] = { { ATOM_attvar, OPT_ATOM }, { ATOM_functor_name, OPT_ATOM }, { ATOM_singletons, OPT_BOOL }, { NULL_ATOM, 0 } }; /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - numbervars(+Term, +Start, -End, +Options) numbervars(+Term, +Functor, +Start, -End) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static PRED_IMPL("numbervars", 4, numbervars, 0) { GET_LD intptr_t n; atom_t name = ATOM_isovar; /* '$VAR' */ atom_t av = ATOM_error; term_t t, end, options; nv_options opts; opts.singletons = FALSE; opts.numbered_check = FALSE; t = PL_copy_term_ref(A1); if ( PL_get_intptr_ex(A2, &n) ) { end = A3; options = A4; } else return FALSE; if ( options && !PL_scan_options(options, 0, "numbervar_option", numbervar_options, &av, &name, &opts.singletons) ) fail; if ( av == ATOM_error ) opts.on_attvar = AV_ERROR; else if ( av == ATOM_skip ) opts.on_attvar = AV_SKIP; else if ( av == ATOM_bind ) opts.on_attvar = AV_BIND; else return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_numbervar_option, options); if ( opts.singletons ) /* Hack */ { if ( !is_acyclic(valTermRef(A1)) ) opts.singletons = FALSE; } opts.functor = PL_new_functor(name, 1); n = numberVars(t, &opts, n); if ( n != NV_ERROR ) return PL_unify_int64(end, n); return FALSE; } static PRED_IMPL("var_number", 2, var_number, 0) { PRED_LD term_t t = A1; Word p = valTermRef(t); deRef(p); if ( isTerm(*p) ) { Functor f = valueTerm(*p); if ( f->definition == FUNCTOR_isovar1 ) { Word a = &f->arguments[0]; deRef(a); if ( isAtom(*a) || isInteger(*a) ) return _PL_unify_atomic(A2, *a); } } return FALSE; } /******************************* * TEMPLATE * *******************************/ /** '$unbind_template'(+Template) is det. * * Assuming Template is a term v(A1, A2, ...) where A1, ... are * initially references into another term for example created using * term_variables/2 followed by =../2. This predicate is designed to * unify the template with concrete values and subsequently unbind the * template such that we can unify it with a new set of concrete values * without copying the entire term. * * @see used by foreach/2. */ static PRED_IMPL("$unbind_template", 1, unbind_template, 0) { PRED_LD Word p = valTermRef(A1); deRef(p); if ( isTerm(*p) ) { Functor f = valueTerm(*p); size_t i, arity = arityFunctor(f->definition); for(i=0; iarguments[i]; if ( isRef(w) ) { Word tp = unRef(w); setVar(*tp); } else { return PL_type_error("template", A1); } } } else if ( !isAtom(*p) ) { return PL_type_error("template", A1); } return TRUE; } /******************************* * TERM-VARIABLES * *******************************/ #define TV_ATTVAR 0x1 /* attributed vars only */ #define TV_SINGLETON 0x2 /* singletons */ #define TV_SHARED 0x4 /* non-singletons */ #define TV_ATTS 0x8 /* recurse into attributes */ #define TV_EXCEPTION ((size_t)-1) #define TV_NOSPACE ((size_t)-2) #define TV_NOMEM ((size_t)-3) #define term_variables_loop(agenda, maxcount, flags) LDFUNC(term_variables_loop, agenda, maxcount, flags) static size_t term_variables_loop(DECL_LD term_agenda *agenda, size_t maxcount, int flags) { Word p; size_t count = 0; while( (p=nextTermAgenda(agenda)) ) { word w; again: w = *p; if ( canBind(w) ) { term_t v; if ( visitedWord(p) ) { if ( (flags&(TV_SINGLETON|TV_SHARED)) ) (*p) |= FIRST_MASK; continue; } if ( (flags&TV_ATTVAR) && !isAttVar(w) ) continue; if ( ++count > maxcount ) return count; if ( !(v = PL_new_term_ref_noshift()) ) return TV_NOSPACE; *valTermRef(v) = makeRefG(p); if ( (flags&TV_ATTS) ) { Word p2 = valPAttVar(w); deRef2(p2, p); goto again; } } else if ( isTerm(w) ) { Functor f = valueTerm(w); if ( visited(f) && !(flags&(TV_SINGLETON|TV_SHARED)) ) continue; if ( !pushWorkAgenda(agenda, arityFunctor(f->definition), f->arguments) ) return TV_NOMEM; } } return count; } #define term_variables_to_termv(t, vp, maxcount, flags) LDFUNC(term_variables_to_termv, t, vp, maxcount, flags) static size_t term_variables_to_termv(DECL_LD term_t t, term_t *vp, size_t maxcount, int flags) { term_agenda agenda; term_t v0 = PL_new_term_refs(0); size_t count; initvisited(); initTermAgenda(&agenda, 1, valTermRef(t)); count = term_variables_loop(&agenda, maxcount, flags); clearTermAgenda(&agenda); if ( (flags&(TV_SINGLETON|TV_SHARED)) && (ssize_t)count >= 0 ) { size_t o = 0; size_t i; for(i=0; i maxcount ) return FALSE; break; } for(i=0; idefinition == FUNCTOR_dot2 ) { Word tail; (void)skip_list(p, &tail); if ( isNil(*tail) ) { Word l = p; int rc = TRUE; while( isList(*l) ) { Word h = HeadList(l); deRef(h); if ( !isVar(*h) ) { rc = FALSE; break; } set_marked(h); l = TailList(l); deRef(l); } l = p; while( isList(*l) ) { Word h = HeadList(l); deRef(h); if ( is_marked(h) ) { clear_marked(h); l = TailList(l); deRef(l); } else { break; } } return rc; } } else { size_t arity = arityFunctor(t->definition); size_t i, j; int rc = TRUE; for(i=0; iarguments[i]; deRef(a); if ( !isVar(*a) ) { rc = FALSE; break; } set_marked(a); } for(j=0; jarguments[j]; deRef(a); clear_marked(a); } return rc; } } return FALSE; } static PRED_IMPL("is_most_general_term", 1, is_most_general_term, 0) { PRED_LD return is_most_general_term(valTermRef(A1)); } /******************************* * SUBSUMES * *******************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subsumes is defined as subsumes(General, Specific) :- term_variables(Specific, SVars), General = Specific, term_variables(SVars, SVars). Below is the implementation, but we keep the array of variables instead of creating an array and we check whether these are all unique variables by scanning the array. This saves both time and space. We tried to do this using a one-sided unification implementation. Most of this is fairly trivial, but we must make sure we know when left argument (general) becomes a pointer in the specific term. There are three cases for this to happen. One is following a cycle-reference, two is following a previously bound term and three is following a reference pointer from a variable that was shared between general and specific before the entry of subsumes/2. The first two are easily fixed. I don't know how to fix the latter without a complete scan on specific. If we need to do that anyway, we can just as well use the below simple algorithm. We can enhance on this by combining this with the one-sided unification. We could delay scanning specific until we bind the first variable. This will not have any significant inpact on performance for a succeeding subsumes check, but can result in early failure and avoiding the scan of specific. This works because the one-sided unification algorithm can only succeed in places where it should fail. The latest version of the old algorithm is in the GIT commit f68eb71a9d5d0b9b6055483842d9654c30e29550 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define subsumes(general, specific) LDFUNC(subsumes, general, specific) static int subsumes(DECL_LD term_t general, term_t specific) { term_t v0; size_t i, n; term_t ex = 0; int rc; int omode; for(;;) { n = term_variables_to_termv(specific, &v0, ~0, 0); if ( n == TV_EXCEPTION ) return FALSE; if ( n == TV_NOSPACE ) { PL_reset_term_refs(v0); if ( !makeMoreStackSpace(LOCAL_OVERFLOW, ALLOW_SHIFT) ) return FALSE; /* GC does not help */ continue; } if ( n == TV_NOMEM ) return PL_error(NULL, 0, NULL, ERR_NOMEM); break; } omode = LD->prolog_flag.occurs_check; LD->prolog_flag.occurs_check = OCCURS_CHECK_FALSE; rc = PL_unify(general, specific); LD->prolog_flag.occurs_check = omode; if ( rc && (ex = PL_new_term_ref()) && foreignWakeup(ex) ) { int rc = TRUE; initvisited(); for(i=0; idefinition; /* modified by visited */ if ( visited(f) ) { if ( !in_goal && !existential ) { *valTermRef(goal) = *t; in_goal = TRUE; } continue; } if ( !in_goal ) { if ( fd == FUNCTOR_hat2 && existential == FALSE ) { if ( !pushWorkAgenda(&agenda, 1, &f->arguments[1]) || !pushWorkAgenda(&agenda, 1, &mark) || !pushWorkAgenda(&agenda, 1, &f->arguments[0]) ) return TV_NOMEM; existential = TRUE; continue; } if ( fd == FUNCTOR_colon2 && !existential ) { Word a1; deRef2(&f->arguments[0], a1); if ( isAtom(*a1) ) *mname = *a1; t = &f->arguments[1]; goto again; } else if ( !existential ) { *valTermRef(goal) = *t; in_goal = TRUE; } } if ( !pushWorkAgenda(&agenda, arityFunctor(fd), f->arguments) ) return TV_NOMEM; continue; } else if ( !in_goal && !existential) /* non-term goal (atom or invalid) */ { *valTermRef(goal) = needsRef(*t) ? makeRefG(t) : *t; in_goal = TRUE; } } out: clearTermAgenda(&agenda); return n; } static PRED_IMPL("$free_variable_set", 3, free_variable_set, 0) { GET_LD for(;;) { term_t goal = PL_new_term_ref(); term_t v0 = PL_new_term_refs(0); size_t n; atom_t mname = (atom_t)0; initvisited(); n = free_variables_loop(valTermRef(A1), &mname, goal); unvisit(); if ( n == TV_NOSPACE ) { PL_reset_term_refs(goal); if ( !makeMoreStackSpace(LOCAL_OVERFLOW, ALLOW_SHIFT) ) return FALSE; continue; } if ( n == TV_NOMEM ) return PL_error(NULL, 0, NULL, ERR_NOMEM); if ( PL_unify_functor(A3, PL_new_functor(ATOM_v, (int)n)) ) { int i, m = (int)n; for(i=0; iprolog_flag.occurs_check) { case OCCURS_CHECK_FALSE: return TRUE; case OCCURS_CHECK_TRUE: case OCCURS_CHECK_ERROR: { Word p1 = valTermRef(t1); Word p2 = valTermRef(t2); deRef(p1); if ( !var_occurs_in(p1, p2) ) return TRUE; return failed_unify_with_occurs_check(p1, p2, LD->prolog_flag.occurs_check); } default: assert(0); fail; } } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Same as unify_ptrs(), but ensures that all assignments are trailed by setting LD->mark_bar to the top of the memory. Note that NO_MARK_BAR also needs support in garbageCollect() and growStacks(). - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define unify_all_trail_ptrs(t1, t2, m) LDFUNC(unify_all_trail_ptrs, t1, t2, m) static bool unify_all_trail_ptrs(DECL_LD Word t1, Word t2, mark *m) { for(;;) { int rc; Mark(*m); LD->mark_bar = NO_MARK_BAR; rc = raw_unify_ptrs(t1, t2); if ( rc == TRUE ) /* Terms unified */ { return rc; } else if ( rc == FALSE ) /* Terms did not unify */ { if ( !exception_term ) /* Check for occurs error */ Undo(*m); DiscardMark(*m); return rc; } else /* Stack overflow */ { int rc2; Undo(*m); DiscardMark(*m); PushPtr(t1); PushPtr(t2); rc2 = makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT); PopPtr(t2); PopPtr(t1); if ( !rc2 ) return FALSE; } } } #define unifiable(t1, t2, subst) LDFUNC(unifiable, t1, t2, subst) static ssize_t unifiable(DECL_LD term_t t1, term_t t2, term_t subst) { mark m; int rc; if ( PL_is_variable(t1) ) { if ( PL_compare(t1, t2) == 0 ) { return PL_unify_atom(subst, ATOM_nil); } else { if ( !unifiable_occurs_check(t1, t2) ) fail; return PL_unify_term(subst, PL_FUNCTOR, FUNCTOR_dot2, PL_FUNCTOR, FUNCTOR_equals2, PL_TERM, t1, PL_TERM, t2, PL_ATOM, ATOM_nil); } } if ( PL_is_variable(t2) ) { if ( !unifiable_occurs_check(t2, t1) ) fail; return PL_unify_term(subst, PL_FUNCTOR, FUNCTOR_dot2, PL_FUNCTOR, FUNCTOR_equals2, PL_TERM, t2, PL_TERM, t1, PL_ATOM, ATOM_nil); } retry: if ( unify_all_trail_ptrs(valTermRef(t1), /* can do shift/gc */ valTermRef(t2), &m) ) { TrailEntry tt = tTop; TrailEntry mt = m.trailtop; if ( tt > mt ) { ssize_t needed = (tt-mt)*6+1; Word list, gp, tail; if ( !hasGlobalSpace(needed) ) /* See (*) */ { int rc = overflowCode(needed); Undo(m); DiscardMark(m); rc = makeMoreStackSpace(rc, ALLOW_GC|ALLOW_SHIFT); if ( rc ) goto retry; return FALSE; } DiscardMark(m); tail = list = gTop; gp = list+1; *list = ATOM_nil; while(--tt >= mt) { Word p = tt->address; *tail = consPtr(&gp[0], TAG_COMPOUND|STG_GLOBAL); gp[0] = FUNCTOR_dot2; gp[1] = consPtr(&gp[3], TAG_COMPOUND|STG_GLOBAL); gp[2] = ATOM_nil; tail = &gp[2]; gp[3] = FUNCTOR_equals2; if ( isTrailVal(p) ) { Word p2 = tt[-1].address; gp[4] = makeRefG(p2); gp[5] = *p2; } else { gp[5] = *p; assert(onGlobalArea(p)); gp[4] = makeRefG(p); setVar(*p); } gp += 6; if ( isTrailVal(p) ) { assert(isAttVar(trailVal(p))); tt--; /* re-insert the attvar */ *tt->address = trailVal(p); tt--; /* restore tail of wakeup list */ p = tt->address; if ( isTrailVal(p) ) { tt--; *tt->address = trailVal(p); } else { setVar(*p); } tt--; /* restore head of wakeup list */ p = tt->address; if ( isTrailVal(p) ) { tt--; *tt->address = trailVal(p); } else { setVar(*p); } assert(tt>=mt); } } gTop = gp; /* may not have used all space */ tTop = m.trailtop; rc = PL_unify(pushWordAsTermRef(list), subst); popTermRef(); return rc; } else { DiscardMark(m); return PL_unify_atom(subst, ATOM_nil); } } else { return FALSE; } } static PRED_IMPL("unifiable", 3, unifiable, 0) { PRED_LD return unifiable(A1, A2, A3); } /******************************* * ATOMS * *******************************/ #define text_length(s, len, flags) \ LDFUNC(text_length, s, len, flags) static foreign_t text_length(DECL_LD term_t s, term_t len, int flags) { PL_chars_t txt; flags |= CVT_EXCEPTION|BUF_ALLOW_STACK; if ( PL_get_text(s, &txt, flags) ) { int rc = PL_unify_int64_ex(len, PL_text_length(&txt)); PL_free_text(&txt); return rc; } return FALSE; } static PRED_IMPL("atom_length", 2, atom_length, PL_FA_ISO) { PRED_LD int flags; if ( truePrologFlag(PLFLAG_ISO) ) flags = CVT_ATOM|CVT_STRING; else flags = CVT_ALL; return text_length(A1, A2, flags); } #define X_AUTO 0x00 #define X_ATOM 0x01 #define X_NUMBER 0x02 #define X_MASK 0x0f #define X_CHARS 0x10 #define X_STRING 0x20 #define X_NO_SYNTAX_ERROR 0x40 #define X_NO_LEADING_WHITE 0x80 #define x_chars(pred, atom, string, how) \ LDFUNC(x_chars, pred, atom, string, how) static int x_chars(DECL_LD const char *pred, term_t atom, term_t string, int how) { PL_chars_t atext, stext; int arg1; int flags2 = CVT_STRING|CVT_LIST|CVT_EXCEPTION; arg1 = PL_get_text(atom, &atext, (how & X_NUMBER) ? CVT_NUMBER : CVT_ATOMIC); if ( arg1 ) /* +,? */ { int ok; int out_type; fid_t fid = PL_open_foreign_frame(); out_type = (how&X_CHARS ? PL_CHAR_LIST : how&X_STRING ? PL_STRING : PL_CODE_LIST); ok = PL_unify_text(string, 0, &atext, out_type); if ( ok ) { PL_close_foreign_frame(fid); return ok; } flags2 |= CVT_VARNOFAIL; PL_discard_foreign_frame(fid); } else if ( !PL_is_variable(atom) ) { atom_t type; how &= X_MASK; type = (how == X_ATOM ? ATOM_atom : how == X_NUMBER ? ATOM_number : ATOM_atomic); return PL_error(pred, 2, NULL, ERR_TYPE, type, atom); } if ( PL_get_text(string, &stext, flags2) != TRUE ) return FALSE; switch(how&X_MASK) { case X_ATOM: case_atom: { int rc = PL_unify_text(atom, 0, &stext, PL_ATOM); PL_free_text(&stext); return rc; } case X_NUMBER: case X_AUTO: { strnumstat rc; if ( stext.encoding == ENC_ISO_LATIN_1 || stext.encoding == ENC_UTF8 ) { unsigned char *q, *s; number n; utf8: s = (unsigned char *)stext.text.t; if ( (how&X_MASK) == X_NUMBER && !(how&X_NO_LEADING_WHITE) ) { while(*s && isBlank(*s)) /* ISO: number_codes(X, " 42") */ s++; } if ( (rc=str_number(s, &q, &n, 0)) == NUM_OK ) { if ( *q == EOS ) { int rc2 = PL_unify_number(atom, &n); clearNumber(&n); PL_free_text(&stext); return rc2; } else rc = NUM_ERROR; clearNumber(&n); } } else if ( stext.encoding == ENC_WCHAR ) { wchar_t *ws = stext.text.w; if ( (how&X_MASK) == X_NUMBER && !(how&X_NO_LEADING_WHITE) ) { while(*ws && isBlankW(*ws)) /* ISO: number_codes(X, " 42") */ ws++; } if ( *ws == '-' || *ws == '+' ) ws++; if ( f_is_decimal(*ws) ) { if ( !PL_mb_text(&stext, REP_UTF8) ) { PL_free_text(&stext); return FALSE; } goto utf8; } else rc = NUM_ERROR; } else rc = NUM_ERROR; if ( (how&X_MASK) == X_AUTO ) { goto case_atom; } else { PL_free_text(&stext); if ( !(how & X_NO_SYNTAX_ERROR) ) return PL_error(pred, 2, NULL, ERR_SYNTAX, str_number_error(rc)); else return FALSE; } } default: assert(0); return FALSE; } } static PRED_IMPL("name", 2, name, 0) { PRED_LD return x_chars("name", A1, A2, X_AUTO); } static PRED_IMPL("atom_chars", 2, atom_chars, PL_FA_ISO) { PRED_LD return x_chars("atom_chars", A1, A2, X_ATOM|X_CHARS); } static PRED_IMPL("atom_codes", 2, atom_codes, PL_FA_ISO) { PRED_LD return x_chars("atom_codes", A1, A2, X_ATOM); } static PRED_IMPL("number_chars", 2, number_chars, PL_FA_ISO) { PRED_LD return x_chars("number_chars", A1, A2, X_NUMBER|X_CHARS); } static PRED_IMPL("number_codes", 2, number_codes, PL_FA_ISO) { PRED_LD return x_chars("number_codes", A1, A2, X_NUMBER); } static PRED_IMPL("number_string", 2, number_string, 0) { PRED_LD return x_chars("number_string", A1, A2, X_NUMBER|X_STRING|X_NO_SYNTAX_ERROR|X_NO_LEADING_WHITE); } static PRED_IMPL("char_code", 2, char_code, PL_FA_ISO) { PRED_LD int n; term_t atom = A1; term_t chr = A2; int vatom = PL_is_variable(atom); int vchr = PL_is_variable(chr); int achr = -1; int cchr = -1; if ( vatom && vchr ) return PL_error(NULL, 0, NULL, ERR_INSTANTIATION); if ( !vatom ) { atom_t a; if ( !PL_get_atom(atom, &a) || (achr = charCode(a)) == -1 ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_character, atom); } if ( !vchr ) { if ( !PL_get_integer_ex(chr, &n) ) return FALSE; if ( !VALID_CODE_POINT(n) ) return PL_type_error("character_code", chr); cchr = n; } if ( achr == cchr ) return TRUE; if ( vatom ) return PL_unify_atom(atom, codeToAtom(cchr)); else return PL_unify_integer(chr, achr); } static int is_code(word w) { if ( isTaggedInt(w) ) { intptr_t code = valInt(w); return VALID_CODE_POINT(code); } return FALSE; } static int is_char(word w) { PL_chars_t text; return ( isAtom(w) && get_atom_text(w, &text) && PL_text_length(&text) == 1 ); } static PRED_IMPL("$is_char_code", 1, is_char_code, 0) { PRED_LD; Word p = valTermRef(A1); deRef(p); return is_code(*p); return FALSE; } static PRED_IMPL("$is_char", 1, is_char, 0) { PRED_LD; Word p = valTermRef(A1); deRef(p); return is_char(*p); } #define is_text_list(text, lent, test) LDFUNC(is_text_list, text, lent, test) static int is_text_list(DECL_LD term_t text, term_t lent, int (*test)(word)) { Word p = valTermRef(text); intptr_t len = 0; deRef(p); while(isList(*p)) { Word av = HeadList(p); Word h; deRef2(av, h); if ( !(*test)(*h) ) return FALSE; deRef2(av+1, p); if ( ++len == 1000 ) { Word tail; skip_list(p, &tail); if ( !isNil(*tail) ) return FALSE; } } return ( isNil(*p) && PL_unify_int64(lent, len) ); } static PRED_IMPL("$is_code_list", 2, is_code_list, 0) { PRED_LD return is_text_list(A1, A2, is_code); } static PRED_IMPL("$is_char_list", 2, is_char_list, 0) { PRED_LD return is_text_list(A1, A2, is_char); } static PRED_IMPL("atom_number", 2, atom_number, 0) { PRED_LD char *s; size_t len; if ( PL_get_nchars(A1, &len, &s, REP_UTF8|CVT_ATOM|CVT_STRING) ) { number n; unsigned char *q; strnumstat rc; if ( (rc=str_number((unsigned char *)s, &q, &n, 0) == NUM_OK) ) { if ( *q == EOS ) { int rc = PL_unify_number(A2, &n); clearNumber(&n); return rc; } else { clearNumber(&n); return FALSE; } } else { return FALSE; } } else if ( PL_get_nchars(A2, &len, &s, CVT_NUMBER) ) { return PL_unify_atom_nchars(A1, len, s); } if ( !PL_is_variable(A2) ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_number, A2); else if ( !PL_is_atom(A1) ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, A1); else return FALSE; } /* MacOS X Mavericks and Yosemite write a char (nul) too many if the * buffer is short. Thanks to Samer Abdallah for sorting this out. */ #ifdef __APPLE__ #define WCSXFRM_BUFFER_OVERRUN 1 #else #define WCSXFRM_BUFFER_OVERRUN 0 #endif static PRED_IMPL("collation_key", 2, collation_key, 0) { #ifdef HAVE_WCSXFRM wchar_t *s; size_t len; wchar_t buf[256]; size_t buflen = sizeof(buf)/sizeof(wchar_t) - WCSXFRM_BUFFER_OVERRUN; wchar_t *o = buf; size_t n; if ( !PL_get_wchars(A1, &len, &s, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) ) fail; for(;;) { if ( (n=wcsxfrm(o, s, buflen)) < buflen ) { int rc = PL_unify_wchars(A2, PL_STRING, n, o); if ( o != buf ) PL_free(o); return rc; } else { assert(o == buf); buflen = n+1; o = PL_malloc(buflen*sizeof(wchar_t)); } } #else GET_LD return PL_unify(A1, A2); #endif } #define SIZE_NOT_SET ((size_t)-1) #define SIZE_GIVEN(v) ((v) != SIZE_NOT_SET) #define concat(a1, a2, a3, bidirectional, ctx, accept, otype) \ LDFUNC(concat, a1, a2, a3, bidirectional, ctx, accept, otype) static word concat(DECL_LD term_t a1, term_t a2, term_t a3, int bidirectional, /* FALSE: only mode +,+,- */ control_t ctx, int accept, /* CVT_* */ int otype) /* PL_ATOM or PL_STRING */ { PL_chars_t t1, t2, t3; int rc; int inmode = bidirectional ? CVT_VARNOFAIL : 0; size_t l1 = SIZE_NOT_SET; size_t l2 = SIZE_NOT_SET; size_t l3 = SIZE_NOT_SET; #define L1 (SIZE_GIVEN(l1) ? l1 : (l1=PL_text_length(&t1))) #define L2 (SIZE_GIVEN(l2) ? l2 : (l2=PL_text_length(&t2))) #define L3 (SIZE_GIVEN(l3) ? l3 : (l3=PL_text_length(&t3))) if ( ForeignControl(ctx) == FRG_CUTTED ) succeed; t1.text.t = t2.text.t = t3.text.t = NULL; if ( !PL_get_text(a1, &t1, accept|inmode|CVT_EXCEPTION) || !PL_get_text(a2, &t2, accept|inmode|CVT_EXCEPTION) || !PL_get_text(a3, &t3, accept|CVT_EXCEPTION|CVT_VARNOFAIL) ) fail; if ( t1.text.t && t2.text.t ) { if ( t3.text.t ) { rc = ( L1 + L2 == L3 && PL_cmp_text(&t1, 0, &t3, 0, L1) == 0 && PL_cmp_text(&t2, 0, &t3, L1, L2) == 0 ); goto out; } else { PL_chars_t c; PL_chars_t *v[2]; v[0] = &t1; v[1] = &t2; PL_concat_text(2, v, &c); rc = PL_unify_text(a3, 0, &c, otype); PL_free_text(&c); goto out; } } if ( !t3.text.t ) return PL_error(NULL, 0, NULL, ERR_INSTANTIATION); if ( t1.text.t ) /* +, -, + */ { (void)L1; if ( l1 <= L3 && PL_cmp_text(&t1, 0, &t3, 0, l1) == 0 ) return PL_unify_text_range(a2, &t3, l1, L3-l1, otype); fail; } else if ( t2.text.t ) /* -, +, + */ { (void)L2; if ( l2 <= L3 && PL_cmp_text(&t2, 0, &t3, L3-l2, l2) == 0 ) return PL_unify_text_range(a1, &t3, 0, L3-l2, otype); fail; } else /* -, -, + */ { size_t at_n; switch ( ForeignControl(ctx) ) { case FRG_FIRST_CALL: if ( PL_same_term(a1, a2) ) /* sharing variables */ { if ( L3 % 2 ) { rc = FALSE; goto out; } else { at_n = L3/2; if ( PL_cmp_text(&t3, 0, &t3, at_n, at_n) == 0 ) { PL_unify_text_range(a1, &t3, 0, at_n, otype); rc = TRUE; } else { rc = FALSE; } goto out; } } at_n = 0; break; case FRG_REDO: at_n = ForeignContextInt(ctx); break; default: succeed; } PL_unify_text_range(a2, &t3, at_n, L3-at_n, otype); PL_unify_text_range(a1, &t3, 0, at_n, otype); if ( at_n < L3 ) ForeignRedoInt(at_n+1); rc = TRUE; } out: if ( t1.text.t ) PL_free_text(&t1); if ( t2.text.t ) PL_free_text(&t2); if ( t3.text.t ) PL_free_text(&t3); #undef L1 #undef L2 #undef L3 return rc; } static PRED_IMPL("atom_concat", 3, atom_concat, PL_FA_NONDETERMINISTIC|PL_FA_ISO) { PRED_LD return concat(A1, A2, A3, TRUE, PL__ctx, CVT_ATOMIC, PL_ATOM); } static PRED_IMPL("atomic_concat", 3, atomic_concat, PL_FA_ISO) { PRED_LD return concat(A1, A2, A3, FALSE, PL__ctx, CVT_ATOMIC, PL_ATOM); } #define split_atom(list, st, atom) LDFUNC(split_atom, list, st, atom) static int split_atom(DECL_LD term_t list, PL_chars_t *st, term_t atom) { PL_chars_t at; size_t i, last; term_t tail = PL_copy_term_ref(list); term_t head = PL_new_term_ref(); size_t sep_len = st->length; if ( !PL_get_text(atom, &at, CVT_ATOMIC|CVT_EXCEPTION) ) return FALSE; for(last=i=0; (ssize_t)i<=(ssize_t)(at.length-sep_len); ) { if ( PL_cmp_text(st, 0, &at, i, sep_len) == 0 ) { if ( !PL_unify_list(tail, head, tail) || !PL_unify_text_range(head, &at, last, i-last, PL_ATOM) ) fail; i += sep_len; last = i; } else i++; } if ( !PL_unify_list(tail, head, tail) || !PL_unify_text_range(head, &at, last, at.length-last, PL_ATOM) ) fail; return PL_unify_nil(tail); } static void append_text_to_buffer(Buffer b, PL_chars_t *txt, IOENC *enc) { if ( txt->encoding == *enc ) { if ( txt->encoding == ENC_ISO_LATIN_1 ) { addMultipleBuffer(b, txt->text.t, txt->length, char); } else { addMultipleBuffer(b, txt->text.w, txt->length, pl_wchar_t); } } else if ( txt->encoding == ENC_ISO_LATIN_1 ) { const unsigned char *s = (const unsigned char*)txt->text.t; const unsigned char *e = &s[txt->length]; for( ;stext.w, txt->length, pl_wchar_t); } } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - atomic_list_concat() implements atomic_list_concat/2,3 and atomics_to_string/2,3. (*) Note that the atom-version for historical reasons supports the mode (-,+,+) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define atomic_list_concat(list, sep, atom, ret_type) LDFUNC(atomic_list_concat, list, sep, atom, ret_type) static foreign_t atomic_list_concat(DECL_LD term_t list, term_t sep, term_t atom, int ret_type) { term_t l = PL_copy_term_ref(list); term_t head = PL_new_term_ref(); IOENC enc = ENC_ISO_LATIN_1; tmp_buffer b; PL_chars_t st; /* separator text */ int ntxt = 0; if ( sep && !PL_get_text(sep, &st, CVT_ATOMIC) ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, sep); initBuffer(&b); while( PL_get_list(l, head, l) ) { PL_chars_t txt; int ok = 1; PL_STRINGS_MARK(); if ( PL_get_text(head, &txt, CVT_ATOMIC) ) { if ( ntxt > 0 && sep ) append_text_to_buffer((Buffer)&b, &st, &enc); append_text_to_buffer((Buffer)&b, &txt, &enc); PL_free_text(&txt); } else { if ( PL_is_variable(head) && sep && ret_type == PL_ATOM ) /* see (*) */ ok = -1; else ok = PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, head); } PL_STRINGS_RELEASE(); if ( ok == 1 && ++ntxt == 100 && lengthList(l, TRUE) < 0 ) ok = 0; if ( ok != 1 ) { discardBuffer(&b); if ( ok == -1 ) goto split; if ( ok == 0 ) return FALSE; } } if ( PL_get_nil(l) ) { PL_chars_t sum; int rc; sum.encoding = enc; sum.storage = PL_CHARS_HEAP; sum.canonical = TRUE; if ( enc == ENC_ISO_LATIN_1 ) { sum.text.t = baseBuffer(&b, char); sum.length = entriesBuffer(&b, char); } else { sum.text.w = baseBuffer(&b, pl_wchar_t); sum.length = entriesBuffer(&b, pl_wchar_t); } rc = PL_unify_text(atom, 0, &sum, ret_type); discardBuffer(&b); return rc; } else if ( !PL_is_variable(l) ) { return PL_type_error("list", l); } discardBuffer(&b); split: if ( !sep || st.length == 0 ) { if ( !sep ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, l); return PL_domain_error("non_empty_atom", sep); } return split_atom(list, &st, atom); } static PRED_IMPL("atomic_list_concat", 3, atomic_list_concat, 0) { PRED_LD return atomic_list_concat(A1, A2, A3, PL_ATOM); } static PRED_IMPL("atomic_list_concat", 2, atomic_list_concat, 0) { PRED_LD return atomic_list_concat(A1, 0, A2, PL_ATOM); } static PRED_IMPL("atomics_to_string", 3, atomics_to_string, 0) { PRED_LD return atomic_list_concat(A1, A2, A3, PL_STRING); } static PRED_IMPL("atomics_to_string", 2, atomics_to_string, 0) { PRED_LD return atomic_list_concat(A1, 0, A2, PL_STRING); } /** sub_atom_icasechk(+Haystack, ?Start, +Needle) is semidet. */ static PRED_IMPL("sub_atom_icasechk", 3, sub_atom_icasechk, 0) { PRED_LD char *needleA=NULL, *haystackA=NULL; pl_wchar_t *needleW=NULL, *haystackW=NULL; size_t l1, l2, offset; int has_offset; term_t haystack = A1; term_t start = A2; term_t needle = A3; if ( PL_is_variable(start) ) has_offset = FALSE, offset = 0; else if ( PL_get_size_ex(start, &offset) ) has_offset = TRUE; else return FALSE; if ( PL_get_nchars(needle, &l1, &needleA, CVT_ALL|BUF_STACK) && PL_get_nchars(haystack, &l2, &haystackA, CVT_ALL) ) { char *s, *q, *s2 = haystackA + offset; const char *eq = (const char *)&needleA[l1]; const char *es = (const char *)&haystackA[l2]; for (; s2<=es-l1; s2++) { for(q=needleA, s=s2; q= a+ls ) { size_t off = la-a-ls; if ( PL_cmp_text(&ta, off, &ts, 0, ls) == CMP_EQUAL ) { return ( PL_unify_integer(len, ls) && PL_unify_integer(before, off) ); } } return FALSE; } state = allocForeignState(sizeof(*state)); state->type = SUB_SEARCH; state->n1 = 0; state->n2 = la; state->n3 = ls; break; } if ( SIZE_GIVEN(b) ) /* before given */ { if ( b > la ) return FALSE; if ( SIZE_GIVEN(l) ) /* len given */ { if ( b+l <= la ) /* deterministic fit */ { if ( PL_unify_text_range(sub, &ta, b, l, type) && PL_unify_integer(after, la-b-l) ) return TRUE; } return FALSE; } if ( SIZE_GIVEN(a) ) /* after given */ { if ( la >= a+b ) { size_t l2 = la-a-b; if ( PL_unify_text_range(sub, &ta, b, l2, type) && PL_unify_integer(len, l2) ) return TRUE; } return FALSE; } state = allocForeignState(sizeof(*state)); state->type = SUB_SPLIT_TAIL; state->n1 = 0; /* len of the split */ state->n2 = la; /* length of the atom */ state->n3 = b; /* length before */ break; } if ( SIZE_GIVEN(l) ) /* no before, len given */ { if ( l > la ) return FALSE; if ( SIZE_GIVEN(a) ) /* len and after */ { if ( la >= a+l ) { size_t b2 = la-a-l; if ( PL_unify_text_range(sub, &ta, b2, l, type) && PL_unify_integer(before, b2) ) return TRUE; } return FALSE; } state = allocForeignState(sizeof(*state)); state->type = SUB_SPLIT_LEN; state->n1 = 0; /* before */ state->n2 = l; /* length */ state->n3 = la; break; } if ( SIZE_GIVEN(a) ) /* only after given */ { if ( a > la ) return FALSE; state = allocForeignState(sizeof(*state)); state->type = SUB_SPLIT_HEAD; state->n1 = 0; /* before */ state->n2 = la; state->n3 = a; break; } state = allocForeignState(sizeof(*state)); state->type = SUB_ENUM; state->n1 = 0; /* before */ state->n2 = 0; /* len */ state->n3 = la; /* total length */ break; } case FRG_REDO: state = ForeignContextPtr(h); PL_get_text(atom, &ta, CVT_ATOMIC|BUF_ALLOW_STACK); break; case FRG_CUTTED: state = ForeignContextPtr(h); if ( state ) freeForeignState(state, sizeof(*state)); return TRUE; default: assert(0); return FALSE; } fid = PL_open_foreign_frame(); again: switch(state->type) { case SUB_SEARCH: { PL_get_text(sub, &ts, CVT_ATOMIC|BUF_ALLOW_STACK); lab = state->n2; lsb = state->n3; for( ; state->n1+ls <= la; state->n1++ ) { if ( PL_cmp_text(&ta, state->n1, &ts, 0, ls) == 0 ) { match = (PL_unify_integer(before, state->n1) && PL_unify_integer(len, ls) && PL_unify_integer(after, la-ls-state->n1)); if ( ++state->n1 + ls > la ) goto exit_succeed; else goto next; } } goto exit_fail; } case SUB_SPLIT_TAIL: /* before given, rest unbound */ { lab = state->n2; b = state->n3; l = state->n1++; match = (PL_unify_text_range(sub, &ta, b, l, type) && PL_unify_integer(len, l) && PL_unify_integer(after, la-b-l)); out: if ( b+l < (int)la ) goto next; else if ( match ) goto exit_succeed; else goto exit_fail; } case SUB_SPLIT_LEN: { b = state->n1++; l = state->n2; lab = state->n3; match = (PL_unify_text_range(sub, &ta, b, l, type) && PL_unify_integer(before, b) && PL_unify_integer(after, la-b-l)); goto out; } case SUB_SPLIT_HEAD: { b = state->n1++; lab = state->n2; a = state->n3; l = la - a - b; match = (PL_unify_text_range(sub, &ta, b, l, type) && PL_unify_integer(before, b) && PL_unify_integer(len, l)); if ( l > 0 ) goto next; else if ( match ) goto exit_succeed; else goto exit_fail; } case SUB_ENUM: { b = state->n1; l = state->n2++; lab = state->n3; a = la-b-l; match = (PL_unify_text_range(sub, &ta, b, l, type) && PL_unify_integer(before, b) && PL_unify_integer(len, l) && PL_unify_integer(after, a)); if ( a == 0 ) { if ( b == (int)la ) { if ( match ) goto exit_succeed; else goto exit_fail; } state->n2 = 0; state->n1++; } goto next; } } exit_fail: freeForeignState(state, sizeof(*state)); return FALSE; exit_succeed: freeForeignState(state, sizeof(*state)); return TRUE; next: if ( match ) { ForeignRedoPtr(state); } else { if ( !PL_exception(0) ) { PL_rewind_foreign_frame(fid); goto again; } else { goto exit_fail; } } #undef la #undef ls } foreign_t pl_sub_atom(term_t atom, term_t before, term_t len, term_t after, term_t sub, control_t h) { GET_LD return sub_text(atom, before, len, after, sub, h, PL_ATOM); } #if O_STRING /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Provisional String manipulation functions. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static PRED_IMPL("string_length", 2, string_length, 0) { PRED_LD return text_length(A1, A2, CVT_ALL); } static PRED_IMPL("string_concat", 3, string_concat, PL_FA_NONDETERMINISTIC) { PRED_LD return concat(A1, A2, A3, TRUE, PL__ctx, CVT_ATOMIC, PL_STRING); } static PRED_IMPL("sub_string", 5, sub_string, PL_FA_NONDETERMINISTIC) { PRED_LD return sub_text(A1, A2, A3, A4, A5, PL__ctx, PL_STRING); } #endif /* O_STRING */ /******************************** * CONTROL * *********************************/ word pl_repeat(control_t h) { switch( ForeignControl(h) ) { case FRG_FIRST_CALL: case FRG_REDO: ForeignRedoInt(2L); case FRG_CUTTED: default: succeed; } } word pl_fail() /* just to define it */ { fail; } word pl_true() /* just to define it */ { succeed; } word pl_halt(term_t code) { GET_LD int status; atom_t a; if ( PL_get_atom(code, &a) ) { if ( a == ATOM_abort ) { PL_abort_process(); return FALSE; /* not reached */ } else if ( PL_get_signum_ex(code, &status) ) { status += 128; status |= PL_CLEANUP_NO_CANCEL; } else return FALSE; } else if ( !PL_get_integer_ex(code, &status) ) { return FALSE; } PL_halt(status); fail; /* exception? */ } #if defined(O_LIMIT_DEPTH) || defined(O_INFERENCE_LIMIT) #define unify_det(t) LDFUNC(unify_det, t) static foreign_t unify_det(DECL_LD term_t t) { Choice ch; for(ch=LD->choicepoints; ch; ch = ch->parent) { if ( ch->frame == environment_frame ) continue; /* choice from I_FOPENNDET */ switch(ch->type) { case CHP_CATCH: case CHP_DEBUG: continue; default: break; } break; } if ( ch && ch->frame == environment_frame->parent ) { return PL_unify_atom(t, ATOM_cut); } else { if ( PL_unify_atom(t, ATOM_true) ) ForeignRedoInt(1); return FALSE; } } #endif #ifdef O_LIMIT_DEPTH /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - The predicates below provide the infrastructure for call_with_depth_limit/3. This predicate was included on request by Steve Moyle, for improving the implementation of a theorem prover. The implementation of call_with_depth_limit/3 in pl-prims.pl is ``` call_with_depth_limit(G, Limit, Result) :- $depth_limit(Limit, OLimit, OReached), ( catch(G, E, depth_limit_except(OLimit, OReached, E)), $depth_limit_true(Limit, OLimit, OReached, Result, Cut), Cut ; $depth_limit_false(OLimit, OReached, Result) ). ``` $depth_limit/3 sets the new limit and fetches the old values so they can be restored by the other calls. '$depth_limit_true'/5 restores the old limits, and unifies Result with the maximum depth reached during the proof. Cut is unified with ! if G succeeded deterministically, and `true' otherwise and ensures the wrapper maintains the determistic properties of G. It can be debated whether this is worthwhile ... Finally, '$depth_limit_false'/4 checks for a depth-overflow, and unifies result with `depth_limit_exceeded' if an overflow has occurred and just fails otherwise. Of course it always restores the outer environment. Note that call_with_depth_limit/3 cannot be written as a simple foreign call using PL_open_query(), etc, as the non-deterministic predicate is not allowed to return to the parent environment without closing the query. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ /* $depth_limit(+Limit, -OldLimit, -DepthReached) */ #define unify_depth_LD(t, depth) LDFUNC(unify_depth_LD, t, depth) static int unify_depth_LD(DECL_LD term_t t, size_t depth) { if ( depth == DEPTH_NO_LIMIT ) return PL_unify_atom(t, ATOM_inf); else return PL_unify_uint64(t, depth); } #define get_depth_LD(t, depth) LDFUNC(get_depth_LD, t, depth) static int get_depth_LD(DECL_LD term_t t, size_t *depth) { atom_t a; if ( PL_get_atom(t, &a) && a == ATOM_inf ) { *depth = DEPTH_NO_LIMIT; return TRUE; } return PL_get_size_ex(t, depth); } #define unify_depth(t, d) unify_depth_LD(t, d) #define get_depth(t, d) get_depth_LD(t, d) static PRED_IMPL("$depth_limit", 3, pl_depth_limit, 0) { GET_LD size_t levels; size_t clevel = levelFrame(environment_frame) - 1; if ( PL_get_size_ex(A1, &levels) ) { if ( unify_depth(A2, LD->depth_info.limit) && unify_depth(A3, LD->depth_info.reached) ) { size_t newlimit = clevel + levels + 1; /* 1 for the catch/3 */ if ( newlimit < clevel ) return PL_representation_error("depth_limit"); LD->depth_info.limit = newlimit; LD->depth_info.reached = clevel; updateAlerted(LD); return TRUE; } } return FALSE; } static PRED_IMPL("$depth_limit_true", 5, pl_depth_limit_true, PL_FA_NONDETERMINISTIC) { PRED_LD term_t limit = A1; term_t olimit = A2; term_t oreached = A3; term_t res = A4; term_t cut = A5; switch( CTX_CNTRL ) { case FRG_FIRST_CALL: { size_t l, ol, or; if ( get_depth(limit, &l) && get_depth(olimit, &ol) && get_depth(oreached, &or) ) { intptr_t clevel = levelFrame(environment_frame) - 1; intptr_t used = LD->depth_info.reached - clevel - 1; LD->depth_info.limit = ol; LD->depth_info.reached = or; updateAlerted(LD); if ( used < 1 ) used = 1; if ( !PL_unify_integer(res, used) ) return FALSE; return unify_det(cut); } break; } case FRG_REDO: { size_t levels; size_t clevel = levelFrame(environment_frame) - 1; if ( !get_depth(limit, &levels) ) return FALSE; LD->depth_info.limit = clevel + levels + 1; /* 1 for catch/3 */ LD->depth_info.reached = clevel; updateAlerted(LD); return FALSE; /* backtrack to goal */ } case FRG_CUTTED: return TRUE; case FRG_RESUME: assert(0); } return FALSE; } static PRED_IMPL("$depth_limit_false", 3, depth_limit_false, 0) { PRED_LD size_t ol, or; if ( get_depth(A1, &ol) && get_depth(A2, &or) ) { int exceeded = (LD->depth_info.reached > LD->depth_info.limit); LD->depth_info.limit = ol; LD->depth_info.reached = or; updateAlerted(LD); if ( exceeded ) return PL_unify_atom(A3, ATOM_depth_limit_exceeded); } return FALSE; } static PRED_IMPL("$depth_limit_except", 3, depth_limit_except, 0) { PRED_LD size_t ol, or; if ( get_depth(A1, &ol) && get_depth(A2, &or) ) { LD->depth_info.limit = ol; LD->depth_info.reached = or; updateAlerted(LD); return PL_raise_exception(A3); } fail; } #endif /*O_LIMIT_DEPTH*/ #ifdef O_INFERENCE_LIMIT #define INFERENCE_LIMIT_OVERHEAD 2 static PRED_IMPL("$inference_limit", 2, pl_inference_limit, 0) { PRED_LD int64_t limit; if ( PL_get_int64_ex(A1, &limit) && PL_unify_int64(A2, LD->inference_limit.limit) ) { int64_t nlimit = LD->statistics.inferences + limit + INFERENCE_LIMIT_OVERHEAD; if ( limit < 0 ) return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_zero, A1); DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("Install %lld --> %lld\n", LD->inference_limit.limit, nlimit)); if ( nlimit < LD->inference_limit.limit ) LD->inference_limit.limit = nlimit; updateAlerted(LD); return TRUE; } return FALSE; } /** '$inference_limit_true'(+Limit, +OldLimit, ?Result) On first call: 1. If Result is nonvar, there was the inference limit is exceeded. The limit is already reset by '$inference_limit_except'/3, so we just indicate that our result is deterministic. 2. Else, restore the limit and indicate determinism in Det. On redo, use Limit to set a new limit and fail to continue retrying the guarded goal. */ static PRED_IMPL("$inference_limit_true", 3, pl_inference_limit_true, PL_FA_NONDETERMINISTIC) { PRED_LD switch( CTX_CNTRL ) { case FRG_FIRST_CALL: { int64_t olimit; if ( !PL_is_variable(A3) ) return TRUE; if ( PL_get_int64_ex(A2, &olimit) ) { DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("true (det) --> %lld\n", olimit)); LD->inference_limit.limit = olimit; updateAlerted(LD); return unify_det(A3); } return FALSE; } case FRG_REDO: { int64_t limit; if ( PL_get_int64_ex(A1, &limit) ) { LD->inference_limit.limit = LD->statistics.inferences + limit + INFERENCE_LIMIT_OVERHEAD; DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("true (ndet) --> %lld\n", LD->inference_limit.limit)); updateAlerted(LD); } return FALSE; } case FRG_CUTTED: return TRUE; case FRG_RESUME: assert(0); } return FALSE; } static PRED_IMPL("$inference_limit_false", 1, inference_limit_false, 0) { PRED_LD int64_t olimit; if ( PL_get_int64_ex(A1, &olimit) ) { LD->inference_limit.limit = olimit; DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("false --> %lld\n", olimit)); updateAlerted(LD); } return FALSE; } /** '$inference_limit_except'(+OldLimit, +Exception, -Result) Restore the limit. If exception is =inference_limit_exceeded=, unify Result with this, otherwise re-throw the exception. */ static PRED_IMPL("$inference_limit_except", 3, inference_limit_except, 0) { PRED_LD int64_t olimit; if ( PL_get_int64_ex(A1, &olimit) ) { atom_t a; DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("except --> %lld\n", olimit)); LD->inference_limit.limit = olimit; updateAlerted(LD); if ( PL_get_atom(A2, &a) && a == ATOM_inference_limit_exceeded ) { return PL_unify_atom(A3, a); } else { return PL_raise_exception(A2); } } return FALSE; } void raiseInferenceLimitException(void) { GET_LD fid_t fid; Definition def = environment_frame->predicate; int64_t olimit; int i; if ( LD->exception.processing ) return; /* Do not throw here */ olimit = LD->inference_limit.limit; LD->inference_limit.limit = INFERENCE_NO_LIMIT; DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("Got inference limit in %s\n", predicateName(def))); #define not_exceed GD->inference_limit.not_exceed_ if ( !GD->inference_limit.initialized ) { not_exceed[0] = PL_predicate("$inference_limit_true", 3, "system"); not_exceed[1] = PL_predicate("$inference_limit_false", 1, "system"); not_exceed[2] = PL_predicate("$inference_limit_except", 3, "system"); not_exceed[3] = PL_predicate("$inference_limit", 2, "system"); not_exceed[4] = PL_predicate("call_with_inference_limit", 3, "system"); not_exceed[5] = GD->procedures.catch3; } for(i=0; i<6; i++) { if ( not_exceed[i]->definition == def ) { LD->inference_limit.limit = olimit; DEBUG(MSG_INFERENCE_LIMIT, Sdprintf("--> Ignored\n")); return; } } if ( (fid = PL_open_foreign_frame()) ) { term_t t; LD->exception.processing = TRUE; t = PL_new_term_ref(); PL_put_atom(t, ATOM_inference_limit_exceeded); PL_raise_exception(t); PL_close_foreign_frame(fid); } } #endif /*O_INFERENCE_LIMIT*/ /******************************** * STATISTICS * *********************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Fetch runtime statistics. There are two standards here. One is based on old C-Prolog compatibility, exended as required by SWI-Prolog and the other is defined by Quintus/SICStus. The latter is included if QP_STATISTICS is defined. The compatibility is pretty complete, except the `atoms' key that is defined by both and this ambiguous. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static size_t programSpace(void) { size_t allocated = heapUsed(); if ( allocated ) return allocated - GD->statistics.stack_space; return 0; } #define QP_STATISTICS 1 #ifdef QP_STATISTICS #define qp_statistics(key, v) LDFUNC(qp_statistics, key, v) static int qp_statistics(DECL_LD atom_t key, int64_t v[]) { int vn; if ( key == ATOM_runtime ) /* compat: exclude gc-time */ { v[0] = (int64_t)((LD->statistics.user_cputime - LD->gc.stats.totals.time - GD->atoms.gc_time) * 1000.0); v[1] = v[0] - LD->statistics.last_cputime; LD->statistics.last_cputime = v[0]; vn = 2; } else if ( key == ATOM_system_time ) { v[0] = (int64_t)(LD->statistics.system_cputime * 1000.0); v[1] = v[0] - LD->statistics.last_systime; LD->statistics.last_systime = v[0]; vn = 2; } else if ( key == ATOM_real_time ) { v[0] = (int64_t)WallTime(); v[1] = v[0] - LD->statistics.last_real_time; LD->statistics.last_real_time = v[0]; vn = 2; } else if ( key == ATOM_walltime ) { double wt = WallTime(); if ( !LD->statistics.last_walltime ) LD->statistics.last_walltime = LD->statistics.start_time; v[0] = (int64_t)((wt - LD->statistics.start_time) * 1000.0); v[1] = (int64_t)((wt - LD->statistics.last_walltime) * 1000.0); LD->statistics.last_walltime = wt; vn = 2; } else if ( key == ATOM_memory || key == ATOM_core ) { v[0] = UsedMemory(); v[1] = FreeMemory(); vn = 2; } else if ( key == ATOM_stacks ) { v[0] = usedStack(global); v[1] = usedStack(local); vn = 2; } else if ( key == ATOM_global_stack ) { v[0] = usedStack(global); v[1] = roomStack(global); vn = 2; } else if ( key == ATOM_local_stack ) { v[0] = usedStack(local); v[1] = roomStack(local); vn = 2; } else if ( key == ATOM_trail ) { v[0] = usedStack(trail); v[1] = roomStack(trail); vn = 2; } else if ( key == ATOM_program ) { v[0] = programSpace(); v[1] = 0; vn = 2; } else if ( key == ATOM_garbage_collection ) { vn=0; gc_stats *stats = &LD->gc.stats; gc_stat *last = last_gc_stats(stats); v[vn++] = stats->totals.collections; v[vn++] = stats->totals.trail_gained + stats->totals.global_gained; v[vn++] = (int64_t)(stats->totals.time * 1000.0); v[vn++] = last->trail_after + last->global_after; } else if ( key == ATOM_stack_shifts ) { v[0] = LD->shift_status.global_shifts; v[1] = LD->shift_status.local_shifts; v[2] = (int64_t)(LD->shift_status.time * 1000.0); vn = 3; } else if ( key == ATOM_atoms ) { v[0] = GD->statistics.atoms; v[1] = GD->statistics.atom_string_space; v[2] = 0; vn = 3; } else if ( key == ATOM_atom_garbage_collection ) { #ifdef O_ATOMGC v[0] = GD->atoms.gc; v[1] = GD->statistics.atom_string_space_freed; v[2] = (int64_t)(GD->atoms.gc_time * 1000.0); vn = 3; #else vn = 0; /* no values */ #endif } else if ( key == ATOM_clause_garbage_collection ) { #ifdef O_CLAUSEGC v[0] = GD->clauses.cgc_count; v[1] = GD->clauses.cgc_reclaimed; v[2] = (int64_t)(GD->clauses.cgc_time * 1000.0); vn = 3; #else vn = 0; /* no values */ #endif } else vn = -1; /* unknown key */ return vn; } #endif /*QP_STATISTICS*/ #ifdef O_PLMT #define SUBTHREAD_TIME() (LD->thread.child_cputime) #define SUBTHREAD_INFERENCES() (LD->thread.child_inferences) #else #define SUBTHREAD_TIME() (0) #define SUBTHREAD_INFERENCES() (0) #endif #define swi_statistics(key, v) LDFUNC(swi_statistics, key, v) static int swi_statistics(DECL_LD atom_t key, Number v) { v->type = V_INTEGER; /* most of them */ if (key == ATOM_self_cputime) /* time */ { v->type = V_FLOAT; v->value.f = LD->statistics.user_cputime; } else if (key == ATOM_cputime) /* time */ { v->type = V_FLOAT; v->value.f = LD->statistics.user_cputime + SUBTHREAD_TIME(); } else if (key == ATOM_process_cputime) /* time */ { v->type = V_FLOAT; v->value.f = GD->statistics.user_cputime; } else if (key == ATOM_self_inferences) /* inferences */ v->value.i = LD->statistics.inferences; else if (key == ATOM_inferences) /* inferences */ v->value.i = LD->statistics.inferences + SUBTHREAD_INFERENCES(); else if (key == ATOM_stack) v->value.i = GD->statistics.stack_space; else if (key == ATOM_stack_limit) v->value.i = LD->stacks.limit; else if (key == ATOM_local) /* local stack */ v->value.i = sizeStack(local); else if (key == ATOM_localused) v->value.i = usedStack(local); else if (key == ATOM_trail) /* trail */ v->value.i = sizeStack(trail); else if (key == ATOM_trailused) v->value.i = usedStack(trail); else if (key == ATOM_global) /* global */ v->value.i = sizeStack(global); else if (key == ATOM_globalused ) v->value.i = usedStack(global); else if (key == ATOM_c_stack) v->value.i = CStackSize(); else if (key == ATOM_atoms) /* atoms */ v->value.i = GD->statistics.atoms; else if (key == ATOM_atom_space) /* atom_space */ v->value.i = atom_space(); else if (key == ATOM_functors) /* functors */ v->value.i = GD->statistics.functors; else if (key == ATOM_functor_space) /* functor_space */ v->value.i = functor_space(); else if (key == ATOM_predicates) /* predicates */ v->value.i = GD->statistics.predicates; else if (key == ATOM_clauses) /* clauses */ v->value.i = GD->statistics.clauses; else if (key == ATOM_modules) /* modules */ v->value.i = GD->statistics.modules; else if (key == ATOM_codes) /* codes */ v->value.i = GD->statistics.codes; else if (key == ATOM_epoch) { v->type = V_FLOAT; v->value.f = LD->statistics.start_time; } else if (key == ATOM_process_epoch) { v->type = V_FLOAT; v->value.f = PL_local_data.statistics.start_time; } else if (key == ATOM_gctime) { v->type = V_FLOAT; v->value.f = LD->gc.stats.totals.time; } else if (key == ATOM_collections) v->value.i = LD->gc.stats.totals.collections; else if (key == ATOM_collected) v->value.i = LD->gc.stats.totals.trail_gained + LD->gc.stats.totals.global_gained; else if (key == ATOM_heapused) /* heap usage */ v->value.i = programSpace(); #ifdef O_ATOMGC else if (key == ATOM_agc) v->value.i = GD->atoms.gc; else if (key == ATOM_agc_gained) v->value.i = GD->atoms.collected; else if (key == ATOM_agc_time) { v->type = V_FLOAT; v->value.f = GD->atoms.gc_time; } #endif #ifdef O_CLAUSEGC else if (key == ATOM_cgc) v->value.i = GD->clauses.cgc_count; else if (key == ATOM_cgc_gained) v->value.i = GD->clauses.cgc_reclaimed; else if (key == ATOM_cgc_time) { v->type = V_FLOAT; v->value.f = GD->clauses.cgc_time; } #endif else if (key == ATOM_global_shifts) v->value.i = LD->shift_status.global_shifts; else if (key == ATOM_local_shifts) v->value.i = LD->shift_status.local_shifts; else if (key == ATOM_trail_shifts) v->value.i = LD->shift_status.trail_shifts; else if (key == ATOM_shift_time) { v->type = V_FLOAT; v->value.f = LD->shift_status.time; } #ifdef O_PLMT else if ( key == ATOM_threads ) v->value.i = GD->statistics.threads_created - GD->statistics.engines_created - GD->statistics.threads_finished + GD->statistics.engines_finished; else if ( key == ATOM_engines ) v->value.i = GD->statistics.engines_created - GD->statistics.engines_finished; else if ( key == ATOM_threads_created ) v->value.i = GD->statistics.threads_created - GD->statistics.engines_created; else if ( key == ATOM_engines_created ) v->value.i = GD->statistics.engines_created; else if ( key == ATOM_thread_cputime ) { v->type = V_FLOAT; v->value.f = GD->statistics.thread_cputime; } else if ( key == ATOM_threads_peak ) v->value.i = GD->thread.peak_id; #endif else if (key == ATOM_table_space_used) { alloc_pool *pool; if ( (pool=LD->tabling.node_pool) ) v->value.i = pool->size; else v->value.i = 0; } else if (key == ATOM_indexes_created) v->value.i = GD->statistics.indexes.created; else if (key == ATOM_indexes_destroyed) v->value.i = GD->statistics.indexes.destroyed; else if (key == ATOM_warnings) v->value.i = GD->statistics.warnings; else if (key == ATOM_errors) v->value.i = GD->statistics.errors; else return -1; /* unknown key */ succeed; } int pl_statistics_ld(DECL_LD term_t k, term_t value, PL_local_data_t *ld) { number result; /* make compiler happy */ atom_t key; int rc; #ifdef QP_STATISTICS int64_t v[4]; #endif if ( !PL_get_atom_ex(k, &key) ) fail; if ( !PL_is_list(value) ) { switch(swi_statistics(PASS_AS_LD(ld) key, &result)) { case TRUE: return PL_unify_number(value, &result); case FALSE: fail; case -1: break; } } #ifdef QP_STATISTICS if ( (rc=qp_statistics(PASS_AS_LD(ld) key, v)) >= 0 ) { int64_t *p; term_t tail = PL_copy_term_ref(value); term_t head = PL_new_term_ref(); for(p = v; rc-- > 0; p++) { if ( !PL_unify_list(tail, head, tail) ) { if ( PL_unify_nil(tail) ) succeed; fail; } if ( !PL_unify_int64(head, *p) ) fail; } return PL_unify_nil(tail); } #endif /*QP_STATISTICS*/ return PL_error("statistics", 2, NULL, ERR_DOMAIN, PL_new_atom("statistics_key"), k); } static PRED_IMPL("statistics", 2, statistics, 0) { GET_LD atom_t k; if ( PL_get_atom(A1, &k) ) { if ( k == ATOM_process_cputime ) GD->statistics.user_cputime = CpuTime(CPU_USER); if ( k == ATOM_cputime || k == ATOM_runtime ) LD->statistics.user_cputime = ThreadCPUTime(CPU_USER); else if ( k == ATOM_system_time ) LD->statistics.system_cputime = ThreadCPUTime(CPU_SYSTEM); } return pl_statistics_ld(A1, A2, LD); } /******************************** * OPTIONS * *********************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - $cmd_option_val/3, provides access to the option structure from Prolog. This is halfway a generic structure package ... Anyway, it is better then direct coded access, as the indirect approach allows us to enumerate the options and generalise the option processing from the saved-states. See also pl-init.c, which exploits set_pl_option() to parse the options resource member. Please note this code doesn't use atoms as set_pl_option() is called before the Prolog system is initialised. This code should be moved into another file. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ typedef struct { const char *name; int type; void *address; } optdef, *OptDef; #define CMDOPT_BOOL 0 #define CMDOPT_SIZE_T 1 #define CMDOPT_STRING 2 #define CMDOPT_LIST 3 static const optdef optdefs[] = { { "stack_limit", CMDOPT_SIZE_T, &GD->options.stackLimit }, { "goals", CMDOPT_LIST, &GD->options.goals }, { "toplevel", CMDOPT_STRING, &GD->options.topLevel }, { "init_file", CMDOPT_STRING, &GD->options.initFile }, { "system_init_file", CMDOPT_STRING, &GD->options.systemInitFile }, { "script_file", CMDOPT_LIST, &GD->options.scriptFiles }, { "config", CMDOPT_STRING, &GD->options.config }, { "compileout", CMDOPT_STRING, &GD->options.compileOut }, { "class", CMDOPT_STRING, &GD->options.saveclass }, { "search_paths", CMDOPT_LIST, &GD->options.search_paths }, { "pldoc_server", CMDOPT_STRING, &GD->options.pldoc_server }, { "nosignals", CMDOPT_BOOL, &GD->options.nosignals }, #ifdef __WINDOWS__ { "win_app", CMDOPT_BOOL, &GD->options.win_app }, #endif { "home", CMDOPT_STRING, &GD->defaults.home }, { NULL, 0, NULL } }; static PRED_IMPL("$cmd_option_val", 2, cmd_option_val, 0) { PRED_LD char *k; term_t key = A1; term_t val = A2; if ( PL_get_atom_chars(key, &k) ) { OptDef d = (OptDef)optdefs; for( ; d->name; d++ ) { if ( streq(k, d->name) ) { switch(d->type) { case CMDOPT_BOOL: { bool *lp = d->address; return PL_unify_bool(val, *lp); } case CMDOPT_SIZE_T: { size_t *lp = d->address; return PL_unify_int64(val, *lp); } case CMDOPT_STRING: { char **sp = d->address; if ( *sp ) return PL_unify_chars(val, PL_ATOM|REP_FN, (size_t)-1, *sp); return FALSE; } case CMDOPT_LIST: { opt_list **list = d->address; opt_list *l; term_t tail = PL_copy_term_ref(val); term_t head = PL_new_term_ref(); for( l=*list; l; l = l->next) { if ( !PL_unify_list(tail, head, tail) || !PL_unify_chars(head, PL_ATOM|REP_FN, (size_t)-1, l->opt_val) ) return FALSE; } return PL_unify_nil(tail); } } } } } return PL_existence_error("cmd_option", key); } static PRED_IMPL("$cmd_option_set", 2, cmd_option_set, 0) { char *k, *v; term_t key = A1; term_t val = A2; if ( PL_get_chars(key, &k, CVT_ALL|CVT_EXCEPTION|REP_FN) && PL_get_chars(val, &v, CVT_ALL|CVT_EXCEPTION|REP_FN) ) { return set_pl_option(k, v); } return FALSE; } int set_pl_option(const char *name, const char *value) { OptDef d = (OptDef)optdefs; if ( streq(name, "goal") ) name = "goals"; /* HACK */ for( ; d->name; d++ ) { if ( streq(name, d->name) ) { switch(d->type) { case CMDOPT_BOOL: { bool *val = d->address; if ( streq(value, "true") ) *val = TRUE; else if ( streq(value, "false") ) *val = FALSE; else assert(0); return TRUE; } case CMDOPT_SIZE_T: { size_t *val = d->address; number n; unsigned char *q; if ( str_number((unsigned char *)value, &q, &n, 0) == NUM_OK && *q == EOS && intNumber(&n) ) { *val = (size_t)n.value.i; succeed; } fail; } case CMDOPT_STRING: { char **val = d->address; *val = store_string(value); succeed; } case CMDOPT_LIST: { opt_list **l = d->address; opt_append(l, value); succeed; } default: assert(0); } } } fail; } /******************************** * STYLE CHECK * *********************************/ static PRED_IMPL("$style_check", 2, style_check, 0) { PRED_LD int n; term_t old = A1; term_t new = A2; if ( PL_unify_integer(old, debugstatus.styleCheck) && PL_get_integer(new, &n) ) { debugstatus.styleCheck = n; succeed; } fail; } /******************************* * THROW * *******************************/ static PRED_IMPL("throw", 1, throw, 0) { PRED_LD if ( PL_is_variable(A1) ) return PL_error(NULL, 0, NULL, ERR_INSTANTIATION); return PL_raise_exception(A1); } static PRED_IMPL("$urgent_exception", 3, urgent_exception, 0) { PRED_LD except_class c1 = classify_exception(A1); except_class c2 = classify_exception(A2); return PL_unify(A3, c2 > c1 ? A2 : A1); } /******************************* * PUBLISH PREDICATES * *******************************/ BeginPredDefs(prims) PRED_DEF("=", 2, unify, PL_FA_ISO) PRED_DEF("\\=", 2, not_unify, PL_FA_ISO) PRED_DEF("unify_with_occurs_check", 2, unify_with_occurs_check, PL_FA_ISO) PRED_DEF("subsumes_term", 2, subsumes_term, PL_FA_ISO) PRED_DEF("nonvar", 1, nonvar, PL_FA_ISO) PRED_DEF("var", 1, var, PL_FA_ISO) PRED_DEF("integer", 1, integer, PL_FA_ISO) PRED_DEF("float", 1, float, PL_FA_ISO) #ifdef O_BIGNUM PRED_DEF("rational", 1, rational, 0) #endif PRED_DEF("number", 1, number, PL_FA_ISO) PRED_DEF("arg", 3, arg, PL_FA_NONDETERMINISTIC|PL_FA_ISO) PRED_DEF("atomic", 1, atomic, PL_FA_ISO) PRED_DEF("atom", 1, atom, PL_FA_ISO) PRED_DEF("string", 1, string, 0) PRED_DEF("ground", 1, ground, PL_FA_ISO) PRED_DEF("nonground", 2, nonground, 0) PRED_DEF("$term_size", 3, term_size, 0) PRED_DEF("acyclic_term", 1, acyclic_term, PL_FA_ISO) PRED_DEF("cyclic_term", 1, cyclic_term, 0) PRED_DEF("$factorize_term", 3, factorize_term, 0) PRED_DEF("compound", 1, compound, PL_FA_ISO) PRED_DEF("callable", 1, callable, PL_FA_ISO) PRED_DEF("==", 2, equal, PL_FA_ISO) PRED_DEF("\\==", 2, nonequal, PL_FA_ISO) PRED_DEF("compare", 3, compare, PL_FA_ISO) PRED_DEF("@<", 2, std_lt, PL_FA_ISO) PRED_DEF("@=<", 2, std_leq, PL_FA_ISO) PRED_DEF("@>", 2, std_gt, PL_FA_ISO) PRED_DEF("@>=", 2, std_geq, PL_FA_ISO) PRED_DEF("?=", 2, can_compare, 0) PRED_DEF("same_term", 2, same_term, 0) PRED_DEF("$term_id", 2, term_id, 0) PRED_DEF("functor", 3, functor, PL_FA_ISO) PRED_DEF("functor", 4, functor, 0) PRED_DEF("=..", 2, univ, PL_FA_ISO) PRED_DEF("compound_name_arity", 3, compound_name_arity, 0) PRED_DEF("compound_name_arguments", 3, compound_name_arguments, 0) PRED_DEF("$filled_array", 4, filled_array, 0) PRED_DEF("$unbind_template", 1, unbind_template, 0) PRED_DEF("numbervars", 4, numbervars, 0) PRED_DEF("var_number", 2, var_number, 0) PRED_DEF("term_variables", 2, term_variables2, PL_FA_ISO) PRED_DEF("$term_attvar_variables", 2, term_attvar_variables, 0) PRED_DEF("term_variables", 3, term_variables3, 0) PRED_DEF("term_singletons", 2, term_singletons, 0) PRED_DEF("$term_multitons", 2, term_multitons, 0) PRED_DEF("term_attvars", 2, term_attvars, 0) PRED_DEF("is_most_general_term", 1, is_most_general_term, 0) PRED_DEF("$free_variable_set", 3, free_variable_set, 0) PRED_DEF("unifiable", 3, unifiable, 0) #ifdef O_TERMHASH PRED_DEF("term_hash", 4, term_hash4, 0) #endif #ifdef O_LIMIT_DEPTH PRED_DEF("$depth_limit_except", 3, depth_limit_except, 0) PRED_DEF("$depth_limit_false", 3, depth_limit_false, 0) PRED_DEF("$depth_limit", 3, pl_depth_limit, 0) PRED_DEF("$depth_limit_true", 5, pl_depth_limit_true, PL_FA_NONDETERMINISTIC) #endif #ifdef O_INFERENCE_LIMIT PRED_DEF("$inference_limit", 2, pl_inference_limit, 0) PRED_DEF("$inference_limit_true", 3, pl_inference_limit_true, PL_FA_NONDETERMINISTIC) PRED_DEF("$inference_limit_false", 1, inference_limit_false, 0) PRED_DEF("$inference_limit_except", 3, inference_limit_except, 0) #endif PRED_DEF("atom_length", 2, atom_length, PL_FA_ISO) PRED_DEF("name", 2, name, 0) PRED_DEF("atom_chars", 2, atom_chars, PL_FA_ISO) PRED_DEF("atom_codes", 2, atom_codes, PL_FA_ISO) PRED_DEF("atom_concat", 3, atom_concat, PL_FA_NONDETERMINISTIC|PL_FA_ISO) PRED_DEF("atomic_concat", 3, atomic_concat, 0) PRED_DEF("number_chars", 2, number_chars, PL_FA_ISO) PRED_DEF("number_codes", 2, number_codes, PL_FA_ISO) PRED_DEF("number_string", 2, number_string, 0) PRED_DEF("char_code", 2, char_code, PL_FA_ISO) PRED_DEF("$is_char_code", 1, is_char_code, 0) PRED_DEF("$is_char", 1, is_char, 0) PRED_DEF("$is_code_list", 2, is_code_list, 0) PRED_DEF("$is_char_list", 2, is_char_list, 0) PRED_DEF("atom_number", 2, atom_number, 0) PRED_DEF("collation_key", 2, collation_key, 0) PRED_DEF("atomic_list_concat", 3, atomic_list_concat, 0) PRED_DEF("atomic_list_concat", 2, atomic_list_concat, 0) PRED_DEF("string_concat", 3, string_concat, PL_FA_NONDETERMINISTIC) PRED_DEF("sub_string", 5, sub_string, PL_FA_NONDETERMINISTIC) PRED_DEF("string_length", 2, string_length, 0) PRED_DEF("atomics_to_string", 3, atomics_to_string, 0) PRED_DEF("atomics_to_string", 2, atomics_to_string, 0) PRED_DEF("sub_atom_icasechk", 3, sub_atom_icasechk, 0) PRED_DEF("statistics", 2, statistics, 0) PRED_DEF("$cmd_option_val", 2, cmd_option_val, 0) PRED_DEF("$cmd_option_set", 2, cmd_option_set, 0) PRED_DEF("$style_check", 2, style_check, 0) PRED_DEF("deterministic", 1, deterministic, 0) PRED_DEF("setarg", 3, setarg, 0) PRED_DEF("nb_setarg", 3, nb_setarg, 0) PRED_DEF("nb_linkarg", 3, nb_linkarg, 0) PRED_DEF("$skip_list", 3, skip_list, 0) PRED_DEF("$seek_list", 4, seek_list, 0) PRED_DEF("throw", 1, throw, PL_FA_ISO) PRED_DEF("$urgent_exception", 3, urgent_exception, 0) EndPredDefs