diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

update chr

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@2143 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2008-03-13 14:38:02 +00:00
parent 785ddd56af
commit d02bc3de81
39 changed files with 17685 additions and 4127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
C/compiler.c
View File

@ -11,8 +11,12 @@
* File: compiler.c *
* comments: Clause compiler *
* *
* Last rev: $Date: 2007-12-18 17:46:58 $,$Author: vsc $ *
* Last rev: $Date: 2008-03-13 14:37:58 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.87 2007/12/18 17:46:58 vsc
* purge_clauses does not need to do anything if there are no clauses
* fix gprof bugs.
*
* Revision 1.86 2007/11/26 23:43:08 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
@ -1871,7 +1875,7 @@ c_goal(Term Goal, int mod, compiler_struct *cglobs)
}
}
else {
if (p->PredFlags & (CPredFlag | AsmPredFlag)) {
if (p->PredFlags & (CPredFlag | AsmPredFlag | ModuleTransparentPredFlag)) {
#ifdef YAPOR
if (p->PredFlags & SyncPredFlag)
Yap_emit(sync_op, (CELL)p, (CELL)(p->ArityOfPE), &cglobs->cint);

23
C/modules.c
View File

@ -242,6 +242,28 @@ p_strip_module(void)
Yap_unify(ARG2, tmod);
}
static Int
p_context_module(void)
{
yamop *parentcp = P;
CELL *yenv;
PredEntry *ap = EnvPreg(parentcp);
if (ap->ModuleOfPred &&
!(ap->PredFlags & MetaPredFlag))
return Yap_unify(ARG1, ap->ModuleOfPred);
parentcp = CP;
yenv = ENV;
do {
ap = EnvPreg(parentcp);
if (ap->ModuleOfPred &&
!(ap->PredFlags & MetaPredFlag))
return Yap_unify(ARG1, ap->ModuleOfPred);
parentcp = (yamop *)yenv[E_CP];
yenv = (CELL *)yenv[E_E];
} while(yenv);
return Yap_unify(ARG1, CurrentModule);
}
void
Yap_InitModulesC(void)
{
@ -249,6 +271,7 @@ Yap_InitModulesC(void)
Yap_InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$change_module", 1, p_change_module, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("strip_module", 3, p_strip_module, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("context_module", 1, p_context_module, 0);
Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module, cont_current_module,
SafePredFlag|SyncPredFlag|HiddenPredFlag);
}

21
C/utilpreds.c
View File

@ -2086,6 +2086,26 @@ cont_current_atom(void)
}
}
static Int
p_unifiable(void)
{
tr_fr_ptr trp;
Term tf = TermNil;
if (!Yap_unify(ARG1,ARG2)) {
return FALSE;
}
trp = TR;
while (trp != B->cp_tr) {
Term t[2];
--trp;
t[0] = TrailTerm(trp);
t[1] = *(CELL *)t[0];
tf = MkPairTerm(Yap_MkApplTerm(FunctorEq,2,t),tf);
RESET_VARIABLE(t[0]);
}
return Yap_unify(ARG3, tf);
}
void Yap_InitUtilCPreds(void)
{
Term cm = CurrentModule;
@ -2102,6 +2122,7 @@ void Yap_InitUtilCPreds(void)
Yap_InitCPred("term_hash", 4, GvNTermHash, SafePredFlag);
Yap_InitCPred("variant", 2, p_variant, 0);
Yap_InitCPred("subsumes", 2, p_subsumes, SafePredFlag);
Yap_InitCPred("protected_unifiable", 3, p_unifiable, 0);
CurrentModule = cm;
#ifdef DEBUG
Yap_InitCPred("$force_trail_expansion", 1, p_force_trail_expansion, SafePredFlag|HiddenPredFlag);

75
CLPBN/clpbn/dists.yap
View File

@ -2,25 +2,31 @@
% distribution
%
:- module(clpbn_dist,[
dist/1,
dist/3,
dists/1,
get_dist/4,
get_dist_matrix/5,
get_dist_domain/2,
get_dist_params/2,
get_dist_domain_size/2,
get_dist_tparams/2,
get_evidence_position/3,
get_evidence_from_position/3,
dist_to_term/2
:- module(clpbn_dist,
[
dist/1,
dist/3,
dists/1,
dist_new_table/2,
get_dist/4,
get_dist_matrix/5,
get_dist_domain/2,
get_dist_params/2,
get_dist_domain_size/2,
get_dist_tparams/2,
get_evidence_position/3,
get_evidence_from_position/3,
dist_to_term/2,
empty_dist/2,
dist_new_table/2
]).
:- use_module(library(lists),[is_list/1,nth0/3]).
:- use_module(library(matrix),
[matrix_new/4,
matrix_new/3,
matrix_to_list/2,
matrix_to_logs/1]).
@ -95,49 +101,58 @@ dist(p(Type, CPT), Id, FParents) :-
distribution(bool, trans(CPT), Id, Parents, FParents) :-
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents),
add_dist([t,f], trans, Tab, Id).
add_dist([t,f], trans, Tab, ParentsId).
distribution(bool, CPT, Id, Parents, Parents) :-
is_list(CPT), !,
add_dist([t,f], tab, CPT, Id).
distribution(aminoacids, trans(CPT), Id, Parents, FParents) :-
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents),
add_dist([a,c,d,e,f,g,h,i,k,l,m,n,p,q,r,s,t,v,w,y], trans, Tab, Id).
add_dist([a,c,d,e,f,g,h,i,k,l,m,n,p,q,r,s,t,v,w,y], trans, Tab, FParents, Id).
distribution(aminoacids, CPT, Id, Parents, Parents) :-
is_list(CPT), !,
add_dist([a,c,d,e,f,g,h,i,k,l,m,n,p,q,r,s,t,v,w,y], tab, CPT, Id).
add_dist([a,c,d,e,f,g,h,i,k,l,m,n,p,q,r,s,t,v,w,y], tab, CPT, Parents, Id).
distribution(dna, trans(CPT), Id, Parents, FParents) :-
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents),
add_dist([a,c,g,t], trans, Tab, Id).
add_dist([a,c,g,t], trans, Tab, FParents, Id).
distribution(dna, CPT, Id, Parents, Parents) :-
is_list(CPT), !,
add_dist([a,c,g,t], tab, CPT, Id).
distribution(rna, trans(CPT), Id, Parents, FParents) :-
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents),
compress_hmm_table(CPT, Parents, Tab, FParents, FParents),
add_dist([a,c,g,u], trans, Tab, Id).
distribution(rna, CPT, Id, Parents, Parents) :-
is_list(CPT), !,
add_dist([a,c,g,u], tab, CPT, Id).
add_dist([a,c,g,u], tab, CPT, Parents, Id).
distribution(Domain, trans(CPT), Id, Parents, FParents) :-
is_list(Domain),
is_list(CPT), !,
compress_hmm_table(CPT, Parents, Tab, FParents),
add_dist(Domain, trans, Tab, Id).
add_dist(Domain, trans, Tab, FParents, Id).
distribution(Domain, CPT, Id, Parents, Parents) :-
is_list(Domain),
is_list(CPT), !,
add_dist(Domain, tab, CPT, Id).
add_dist(Domain, tab, CPT, Parents, Id).
add_dist(Domain, Type, CPT, Id) :-
add_dist(Domain, Type, CPT, _, Id) :-
recorded(clpbn_dist_db, db(Id, CPT, Type, Domain, _, _), _), !.
add_dist(Domain, Type, CPT, Id) :-
add_dist(Domain, Type, CPT, PSizes, Id) :-
length(CPT, CPTSize),
length(Domain, DSize),
new_id(Id),
record_parent_sizes(Parents, Id, PSizes, [DSize|PSizes]),
recordz(clpbn_dist_db,db(Id, CPT, Type, Domain, CPTSize, DSize),_).
record_parent_sizes([], Id, [], DSizes) :-
recordz(clpbn_dist_psizes,db(Id, DSizes),_).
record_parent_sizes([P|Parents], Id, [Size|Sizes], DSizes) :-
clpbn:get_atts(P,dist(Dist,_)),
get_dist_domain_size(Dist, DSize),
record_parent_sizes(Parents, Id, Sizes, DSizes).
%
% Often, * is used to code empty in HMMs.
%
@ -197,3 +212,17 @@ get_evidence_from_position(El, Id, Pos) :-
throw(error(domain_error(no_distribution,Id),get_evidence_from_position(El, Id, Pos))).
dist_to_term(_Id,_Term).
empty_dist(Dist, TAB) :-
recorded(clpbn_dist_psizes,db(Dist, DSizes),_),
matrix_new(floats, DSizes, TAB).
dist_new_table(Id, NewMAT) :-
matrix_to_list(NewMat, List),
recorded(clpbn_dist_db, db(Id, _, A, B, C, D), R),
erase(R),
recorda(clpbn_dist_db, db(Id, List, A, B, C, D), R),
fail.
dist_new_table(_, _).

15
CLPBN/clpbn/vel.yap
View File

@ -52,19 +52,32 @@
check_if_vel_done(Var) :-
get_atts(Var, [size(_)]), !.
%
% implementation of the well known variable elimination algorithm
%
vel([],_,_) :- !.
vel(LVs,Vs0,AllDiffs) :-
check_for_hidden_vars(Vs0, Vs0, Vs1),
sort(Vs1,Vs),
% LVi will have a list of CLPBN variables
% Tables0 will have the full data on each variable
find_all_clpbn_vars(Vs, LV0, LVi, Tables0),
% construct the graph
find_all_table_deps(Tables0, LV0),
(clpbn:output(xbif(XBifStream)) -> clpbn2xbif(XBifStream,vel,Vs) ; true),
(clpbn:output(gviz(XBifStream)) -> clpbn2gviz(XBifStream,vel,Vs,LVs) ; true),
% variable elimination proper
process(LVi, LVs, tab(Dist,_,_)),
% move from potentials back to probabilities
normalise_CPT(Dist,Ps),
% from array to list
list_from_CPT(Ps, LPs),
% bind Probs back to variables so that they can be output.
clpbn_bind_vals(LVs,LPs,AllDiffs).
%
% just get a list of variables plus associated tables
%
find_all_clpbn_vars([], [], [], []) :- !.
find_all_clpbn_vars([V|Vs], [Var|LV], ProcessedVars, [table(I,Table,Parents,Sizes)|Tables]) :-
var_with_deps(V, Table, Parents, Sizes, Ev, Vals), !,
@ -82,7 +95,9 @@ var_with_deps(V, Table, Deps, Sizes, Ev, Vals) :-
clpbn:get_atts(V, [dist(Id,Parents)]),
get_dist_matrix(Id,Parents,_,Vals,TAB0),
( clpbn:get_atts(V, [evidence(Ev)]) -> true ; true),
% set CPT in canonical form
reorder_CPT([V|Parents],TAB0,Deps0,TAB1,Sizes1),
% remove evidence.
simplify_evidence(Deps0, TAB1, Deps0, Sizes1, Table, Deps, Sizes).
find_all_table_deps(Tables0, LV) :-

4
GPL/aggregate.pl
View File

@ -1,4 +1,4 @@
/* $Id: aggregate.pl,v 1.2 2008-02-12 18:10:48 vsc Exp $
/* $Id: aggregate.pl,v 1.3 2008-03-13 14:37:58 vsc Exp $
Part of SWI-Prolog
@ -524,7 +524,7 @@ var_in_term(Term, Var) :-
Var == Term, !.
var_in_term(Term, Var) :-
compound(Term),
arg(_, Term, Arg),
genarg(_, Term, Arg),
var_in_term(Arg, Var), !.

1
H/Yatom.h
View File

@ -669,6 +669,7 @@ typedef enum
SequentialPredFlag = 0x00000020L, /* may not create parallel choice points! */
ProfiledPredFlag = 0x00000010L, /* pred is being profiled */
MyddasPredFlag = 0x00000008L, /* Myddas Imported pred */
ModuleTransparentPredFlag = 0x00000004L, /* ModuleTransparent pred */
} pred_flag;
/* profile data */

3
LGPL/Makefile.in
View File

@ -31,10 +31,13 @@ PROGRAMS= $(srcdir)/debug.pl \
$(srcdir)/prolog_source.pl \
$(srcdir)/prolog_xref.pl
SWI_PROGRAMS= $(srcdir)/apply_macros.pl
install: $(PROGRAMS)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap; done
for p in $(SWI_PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/swi; done
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/logtalk
for p in $(LOGTALK_PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/logtalk; done

185
LGPL/apply_macros.pl Normal file
View File

@ -0,0 +1,185 @@
/* $Id: apply_macros.pl,v 1.1 2008-03-13 14:37:59 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2007, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(apply_macros,
[
]).
:- use_module(library(lists)).
:- use_module(library(occurs)).
/** <module> Goal expansion rules to avoid meta-calling
This module defines goal_expansion/2 rules to deal with commonly used,
but fundamentally slow meta-predicates. Notable maplist/2... defines a
useful set of predicates, but its exection is considerable slower than a
traditional Prolog loop. Using this library calls to maplist/2... are
translated into an call to a generated auxilary predicate that is
compiled using compile_aux_clauses/1. Currently this module supports:
* maplist/2..
* forall/2
* once/1
* ignore/1
* phrase/2
* phrase/3
@tbd Support more predicates
@author Jan Wielemaker
*/
:- dynamic
user:goal_expansion/2.
:- multifile
user:goal_expansion/2.
%% expand_maplist(+Callable, +Lists, -Goal) is det.
%
% Macro expansion for maplist/2 and higher arity.
expand_maplist(Callable0, Lists, Goal) :-
( Callable0 = _:_
-> strip_module(Callable0, M, Callable),
NextGoal = M:NextCall
; Callable = Callable0,
NextGoal = NextCall
),
Callable =.. [Pred|Args],
length(Args, Argc),
length(Argv, Argc),
length(Lists, N),
length(Vars, N),
MapArity is N + 1,
format(atom(AuxName), '__aux_maplist/~d_~w+~d', [MapArity, Pred, Argc]),
append(Lists, Args, AuxArgs),
Goal =.. [AuxName|AuxArgs],
AuxArity is N+Argc,
prolog_load_context(module, Module),
( current_predicate(Module:AuxName/AuxArity)
-> true
; empty_lists(N, BaseLists),
length(Anon, Argc),
append(BaseLists, Anon, BaseArgs),
BaseClause =.. [AuxName|BaseArgs],
heads_and_tails(N, NextArgs, Vars, Tails),
append(NextArgs, Argv, AllNextArgs),
NextHead =.. [AuxName|AllNextArgs],
append(Argv, Vars, PredArgs),
NextCall =.. [Pred|PredArgs],
append(Tails, Argv, IttArgs),
NextIterate =.. [AuxName|IttArgs],
NextClause = (NextHead :- NextGoal, NextIterate),
( predicate_property(NextGoal, transparent)
-> compile_aux_clauses([ (:- module_transparent(Module:AuxName/AuxArity)),
BaseClause,
NextClause
])
; compile_aux_clauses([BaseClause, NextClause])
)
).
empty_lists(0, []) :- !.
empty_lists(N, [[]|T]) :-
N2 is N - 1,
empty_lists(N2, T).
heads_and_tails(0, [], [], []).
heads_and_tails(N, [[H|T]|L1], [H|L2], [T|L3]) :-
N2 is N - 1,
heads_and_tails(N2, L1, L2, L3).
%% expand_apply(+GoalIn:callable, -GoalOut) is semidet.
%
% Macro expansion for `apply' predicates.
expand_apply(Maplist, Goal) :-
functor(Maplist, maplist, N),
N >= 2,
Maplist =.. [maplist, Callable|Lists],
callable(Callable), !,
expand_maplist(Callable, Lists, Goal).
expand_apply(forall(Cond, Action), \+((Cond, \+(Action)))).
expand_apply(once(Goal), (Goal->true)).
expand_apply(ignore(Goal), (Goal->true;true)).
expand_apply(phrase(NT,Xs), NTXsNil) :-
expand_apply(phrase(NT,Xs,[]), NTXsNil).
expand_apply(phrase(NT,Xs0,Xs), NewGoal) :-
Goal = phrase(NT,Xs0,Xs),
nonvar(NT),
catch('$translate_rule'((pseudo_nt --> NT), Rule),
error(Pat,ImplDep),
( \+ harmless_dcgexception(Pat),
throw(error(Pat,ImplDep))
)),
Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0),
Goal \== NewGoal0,
\+ contains_illegal_dcgnt(NT), !, % apply translation only if we are safe
( var(Xsc), Xsc \== Xs0c
-> Xs = Xsc, NewGoal1 = NewGoal0
; NewGoal1 = (NewGoal0, Xsc = Xs)
),
( var(Xs0c)
-> Xs0 = Xs0c,
NewGoal = NewGoal1
; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal
).
harmless_dcgexception(instantiation_error). % ex: phrase(([1],x:X,[3]),L)
harmless_dcgexception(type_error(callable,_)). % ex: phrase(27,L)
%% contains_illegal_dcgnt(+Term) is semidet.
%
% True if Term contains a non-terminal we cannot deal with using
% goal-expansion. The test is too general approximation, but safe.
contains_illegal_dcgnt(NT) :-
sub_term(I, NT),
nonvar(I),
( I = ! ; I = phrase(_,_,_) ), !.
% write(contains_illegal_nt(NT)), % JW: we do not want to write
% nl.
/*******************************
* ACTIVATE *
*******************************/
% @tbd Should we only apply if optimization is enabled (-O)?
user:goal_expansion(GoalIn, GoalOut) :-
\+ current_prolog_flag(xref, true),
expand_apply(GoalIn, GoalOut).

457
LGPL/chr/builtins.pl
View File

@ -93,16 +93,453 @@ builtin_binds_(atomic(_),L,L).
builtin_binds_(integer(_),L,L).
builtin_binds_(float(_),L,L).
builtin_binds_(_ > _ ,L,L).
builtin_binds_(_ < _ ,L,L).
builtin_binds_(_ =< _,L,L).
builtin_binds_(_ >= _,L,L).
builtin_binds_(_ =:= _,L,L).
builtin_binds_(_ =\= _,L,L).
builtin_binds_(_ == _,L,L).
builtin_binds_(_ \== _,L,L).
builtin_binds_(?=(_, _), L, L).
builtin_binds_(_<_, L, L).
builtin_binds_(_=:=_, L, L).
builtin_binds_(_=<_, L, L).
builtin_binds_(_==_, L, L).
builtin_binds_(_=@=_, L, L).
builtin_binds_(_=\=_, L, L).
builtin_binds_(_>=_, L, L).
builtin_binds_(_>_, L, L).
builtin_binds_(_@<_, L, L).
builtin_binds_(_@=<_, L, L).
builtin_binds_(_@>=_, L, L).
builtin_binds_(_@>_, L, L).
builtin_binds_(_\==_, L, L).
builtin_binds_(_\=@=_, L, L).
builtin_binds_(true,L,L).
% TODO: check all these SWI-Prolog built-ins for binding behavior.
%
% builtin_binds_(format(_,_),L,L).
% builtin_binds_(portray(_), L, L).
% builtin_binds_(write(_), L, L).
% builtin_binds_(write(_),L,L).
% builtin_binds_(write(_, _), L, L).
% builtin_binds_(write_canonical(_), L, L).
% builtin_binds_(write_canonical(_, _), L, L).
% builtin_binds_(write_term(_, _), L, L).
% builtin_binds_(write_term(_, _, _), L, L).
% builtin_binds_(writef(_), L, L).
% builtin_binds_(writef(_, _), L, L).
% builtin_binds_(writeln(_), L, L).
% builtin_binds_(writeln(_),L,L).
% builtin_binds_(writeq(_), L, L).
% builtin_binds_(writeq(_, _), L, L).
%
% builtin_binds_(!(_), L, L).
% builtin_binds_(!, L, L).
% builtin_binds_((_'|'_), L, L).
% builtin_binds_((_*->_), L, L).
% builtin_binds_(abolish(_), L, L).
% builtin_binds_(abolish(_, _), L, L).
% builtin_binds_(abort, L, L).
% builtin_binds_(absolute_file_name(_, _), L, L).
% builtin_binds_(absolute_file_name(_, _, _), L, L).
% builtin_binds_(access_file(_, _), L, L).
% builtin_binds_(acyclic_term(_), L, L).
% builtin_binds_(add_import_module(_, _, _), L, L).
% builtin_binds_(append(_), L, L).
% builtin_binds_(apply(_, _), L, L).
% builtin_binds_(arg(_, _, _), L, L).
% builtin_binds_(arithmetic_function(_), L, L).
% builtin_binds_(assert(_), L, L).
% builtin_binds_(assert(_, _), L, L).
% builtin_binds_(asserta(_), L, L).
% builtin_binds_(asserta(_, _), L, L).
% builtin_binds_(assertz(_), L, L).
% builtin_binds_(assertz(_, _), L, L).
% builtin_binds_(at_end_of_stream(_), L, L).
% builtin_binds_(at_end_of_stream, L, L).
% builtin_binds_(at_halt(_), L, L).
% builtin_binds_(at_initialization(_), L, L).
% builtin_binds_(atom(_), L, L).
% builtin_binds_(atom_chars(_, _), L, L).
% builtin_binds_(atom_codes(_, _), L, L).
% builtin_binds_(atom_concat(_, _, _), L, L).
% builtin_binds_(atom_length(_, _), L, L).
% builtin_binds_(atom_number(_, _), L, L).
% builtin_binds_(atom_prefix(_, _), L, L).
% builtin_binds_(atom_to_term(_, _, _), L, L).
% builtin_binds_(atomic(_), L, L).
% builtin_binds_(attvar(_), L, L).
% builtin_binds_(autoload(_), L, L).
% builtin_binds_(autoload, L, L).
% builtin_binds_(b_getval(_, _), L, L).
% builtin_binds_(b_setval(_, _), L, L).
% builtin_binds_(bagof(_, _, _), L, L).
% builtin_binds_(between(_, _, _), L, L).
% builtin_binds_(block(_, _, _), L, L).
% builtin_binds_(break, L, L).
% builtin_binds_(byte_count(_, _), L, L).
% builtin_binds_(call(_), L, L).
% builtin_binds_(call(_, _), L, L).
% builtin_binds_(call(_, _, _), L, L).
% builtin_binds_(call(_, _, _, _), L, L).
% builtin_binds_(call(_, _, _, _, _), L, L).
% builtin_binds_(call(_, _, _, _, _, _), L, L).
% builtin_binds_(call(_, _, _, _, _, _, _), L, L).
% builtin_binds_(call(_, _, _, _, _, _, _, _), L, L).
% builtin_binds_(call(_, _, _, _, _, _, _, _, _), L, L).
% builtin_binds_(call(_, _, _, _, _, _, _, _, _, _), L, L).
% builtin_binds_(call(_, _, _, _, _, _, _, _, _, _, _), L, L).
% builtin_binds_(call_cleanup(_, _), L, L).
% builtin_binds_(call_cleanup(_, _, _), L, L).
% builtin_binds_(call_shared_object_function(_, _), L, L).
% builtin_binds_(call_with_depth_limit(_, _, _), L, L).
% builtin_binds_(callable(_), L, L).
% builtin_binds_(catch(_, _, _), L, L).
% builtin_binds_(char_code(_, _), L, L).
% builtin_binds_(char_conversion(_, _), L, L).
% builtin_binds_(char_type(_, _), L, L).
% builtin_binds_(character_count(_, _), L, L).
% builtin_binds_(clause(_, _), L, L).
% builtin_binds_(clause(_, _, _), L, L).
% builtin_binds_(clause_property(_, _), L, L).
% builtin_binds_(close(_), L, L).
% builtin_binds_(close(_, _), L, L).
% builtin_binds_(close_shared_object(_), L, L).
% builtin_binds_(code_type(_, _), L, L).
% builtin_binds_(collation_key(_, _), L, L).
% builtin_binds_(compare(_, _, _), L, L).
% builtin_binds_(compile_aux_clauses(_), L, L).
% builtin_binds_(compile_predicates(_), L, L).
% builtin_binds_(compiling, L, L).
% builtin_binds_(compound(_), L, L).
% builtin_binds_(concat_atom(_, _), L, L).
% builtin_binds_(concat_atom(_, _, _), L, L).
% builtin_binds_(consult(_), L, L).
% builtin_binds_(context_module(_), L, L).
% builtin_binds_(copy_stream_data(_, _), L, L).
% builtin_binds_(copy_stream_data(_, _, _), L, L).
% builtin_binds_(copy_term(_, _), L, L).
% builtin_binds_(copy_term_nat(_, _), L, L).
% builtin_binds_(current_arithmetic_function(_), L, L).
% builtin_binds_(current_atom(_), L, L).
% builtin_binds_(current_blob(_, _), L, L).
% builtin_binds_(current_char_conversion(_, _), L, L).
% builtin_binds_(current_flag(_), L, L).
% builtin_binds_(current_format_predicate(_, _), L, L).
% builtin_binds_(current_functor(_, _), L, L).
% builtin_binds_(current_input(_), L, L).
% builtin_binds_(current_key(_), L, L).
% builtin_binds_(current_module(_), L, L).
% builtin_binds_(current_module(_, _), L, L).
% builtin_binds_(current_op(_, _, _), L, L).
% builtin_binds_(current_output(_), L, L).
% builtin_binds_(current_predicate(_), L, L).
% builtin_binds_(current_predicate(_, _), L, L).
% builtin_binds_(current_prolog_flag(_, _), L, L).
% builtin_binds_(current_resource(_, _, _), L, L).
% builtin_binds_(current_signal(_, _, _), L, L).
% builtin_binds_(cyclic_term(_), L, L).
% builtin_binds_(date_time_stamp(_, _), L, L).
% builtin_binds_(debugging, L, L).
% builtin_binds_(default_module(_, _), L, L).
% builtin_binds_(del_attr(_, _), L, L).
% builtin_binds_(delete_directory(_), L, L).
% builtin_binds_(delete_file(_), L, L).
% builtin_binds_(delete_import_module(_, _), L, L).
% builtin_binds_(deterministic(_), L, L).
% builtin_binds_(downcase_atom(_, _), L, L).
% builtin_binds_(duplicate_term(_, _), L, L).
% builtin_binds_(dwim_match(_, _), L, L).
% builtin_binds_(dwim_match(_, _, _), L, L).
% builtin_binds_(dwim_predicate(_, _), L, L).
% builtin_binds_(ensure_loaded(_), L, L).
% builtin_binds_(erase(_), L, L).
% builtin_binds_(eval_license, L, L).
% builtin_binds_(exists_directory(_), L, L).
% builtin_binds_(exists_file(_), L, L).
% builtin_binds_(exit(_, _), L, L).
% builtin_binds_(expand_file_name(_, _), L, L).
% builtin_binds_(expand_file_search_path(_, _), L, L).
% builtin_binds_(expand_goal(_, _), L, L).
% builtin_binds_(expand_term(_, _), L, L).
% builtin_binds_(export(_), L, L).
% builtin_binds_(export_list(_, _), L, L).
% builtin_binds_(fail(_), L, L).
% builtin_binds_(fail, L, L).
% builtin_binds_(file_base_name(_, _), L, L).
% builtin_binds_(file_directory_name(_, _), L, L).
% builtin_binds_(file_name_extension(_, _, _), L, L).
% builtin_binds_(fileerrors(_, _), L, L).
% builtin_binds_(findall(_, _, _), L, L).
% builtin_binds_(findall(_, _, _, _), L, L).
% builtin_binds_(flag(_, _, _), L, L).
% builtin_binds_(float(_), L, L).
% builtin_binds_(flush_output(_), L, L).
% builtin_binds_(flush_output, L, L).
% builtin_binds_(forall(_, _), L, L).
% builtin_binds_(format(_), L, L).
% builtin_binds_(format(_, _), L, L).
% builtin_binds_(format(_, _, _), L, L).
% builtin_binds_(format_predicate(_, _), L, L).
% builtin_binds_(format_time(_, _, _), L, L).
% builtin_binds_(format_time(_, _, _, _), L, L).
% builtin_binds_(freeze(_, _), L, L).
% builtin_binds_(frozen(_, _), L, L).
% builtin_binds_(functor(_, _, _), L, L).
% builtin_binds_(garbage_collect, L, L).
% builtin_binds_(garbage_collect_atoms, L, L).
% builtin_binds_(garbage_collect_clauses, L, L).
% builtin_binds_(get(_), L, L).
% builtin_binds_(get(_, _), L, L).
% builtin_binds_(get0(_), L, L).
% builtin_binds_(get0(_, _), L, L).
% builtin_binds_(get_attr(_, _, _), L, L).
% builtin_binds_(get_attrs(_, _), L, L).
% builtin_binds_(get_byte(_), L, L).
% builtin_binds_(get_byte(_, _), L, L).
% builtin_binds_(get_char(_), L, L).
% builtin_binds_(get_char(_, _), L, L).
% builtin_binds_(get_code(_), L, L).
% builtin_binds_(get_code(_, _), L, L).
% builtin_binds_(get_single_char(_), L, L).
% builtin_binds_(get_time(_), L, L).
% builtin_binds_(getenv(_, _), L, L).
% builtin_binds_(ground(_), L, L).
% builtin_binds_(halt(_), L, L).
% builtin_binds_(halt, L, L).
% builtin_binds_(hash(_), L, L).
% builtin_binds_(hash_term(_, _), L, L).
% builtin_binds_(ignore(_), L, L).
% builtin_binds_(import(_), L, L).
% builtin_binds_(import_module(_, _), L, L).
% builtin_binds_(index(_), L, L).
% builtin_binds_(integer(_), L, L).
% builtin_binds_(is_absolute_file_name(_), L, L).
% builtin_binds_(is_list(_), L, L).
% builtin_binds_(is_stream(_), L, L).
% builtin_binds_(keysort(_, _), L, L).
% builtin_binds_(leash(_), L, L).
% builtin_binds_(length(_, _), L, L).
% builtin_binds_(license(_), L, L).
% builtin_binds_(license(_, _), L, L).
% builtin_binds_(line_count(_, _), L, L).
% builtin_binds_(line_position(_, _), L, L).
% builtin_binds_(load_files(_), L, L).
% builtin_binds_(load_files(_, _), L, L).
% builtin_binds_(make_directory(_), L, L).
% builtin_binds_(make_library_index(_), L, L).
% builtin_binds_(make_library_index(_, _), L, L).
% builtin_binds_(maplist(_, _), L, L).
% builtin_binds_(maplist(_, _, _), L, L).
% builtin_binds_(maplist(_, _, _, _), L, L).
% builtin_binds_(memberchk(_, _), L, L).
% builtin_binds_(message_queue_create(_), L, L).
% builtin_binds_(message_queue_create(_, _), L, L).
% builtin_binds_(message_queue_destroy(_), L, L).
% builtin_binds_(message_queue_property(_, _), L, L).
% builtin_binds_(message_to_string(_, _), L, L).
% builtin_binds_(module(_), L, L).
% builtin_binds_(msort(_, _), L, L).
% builtin_binds_(mutex_create(_), L, L).
% builtin_binds_(mutex_create(_, _), L, L).
% builtin_binds_(mutex_destroy(_), L, L).
% builtin_binds_(mutex_lock(_), L, L).
% builtin_binds_(mutex_property(_, _), L, L).
% builtin_binds_(mutex_statistics, L, L).
% builtin_binds_(mutex_trylock(_), L, L).
% builtin_binds_(mutex_unlock(_), L, L).
% builtin_binds_(mutex_unlock_all, L, L).
% builtin_binds_(name(_, _), L, L).
% builtin_binds_(nb_current(_, _), L, L).
% builtin_binds_(nb_delete(_), L, L).
% builtin_binds_(nb_getval(_, _), L, L).
% builtin_binds_(nb_linkarg(_, _, _), L, L).
% builtin_binds_(nb_linkval(_, _), L, L).
% builtin_binds_(nb_setarg(_, _, _), L, L).
% builtin_binds_(nb_setval(_, _), L, L).
% builtin_binds_(nl(_), L, L).
% builtin_binds_(nl, L, L).
% builtin_binds_(nonvar(_), L, L).
% builtin_binds_(noprofile(_), L, L).
% builtin_binds_(noprotocol, L, L).
% builtin_binds_(nospy(_), L, L).
% builtin_binds_(nospyall, L, L).
% builtin_binds_(not(_), L, L).
% builtin_binds_(notrace(_), L, L).
% builtin_binds_(notrace, L, L).
% builtin_binds_(nth_clause(_, _, _), L, L).
% builtin_binds_(number(_), L, L).
% builtin_binds_(number_chars(_, _), L, L).
% builtin_binds_(number_codes(_, _), L, L).
% builtin_binds_(numbervars(_, _, _), L, L).
% builtin_binds_(numbervars(_, _, _, _), L, L).
% builtin_binds_(on_signal(_, _, _), L, L).
% builtin_binds_(once(_), L, L).
% builtin_binds_(op(_, _, _), L, L).
% builtin_binds_(open(_, _, _), L, L).
% builtin_binds_(open(_, _, _, _), L, L).
% builtin_binds_(open_null_stream(_), L, L).
% builtin_binds_(open_resource(_, _, _), L, L).
% builtin_binds_(open_resource(_, _, _, _), L, L).
% builtin_binds_(open_shared_object(_, _), L, L).
% builtin_binds_(open_shared_object(_, _, _), L, L).
% builtin_binds_(open_xterm(_, _, _, _), L, L).
% builtin_binds_(peek_byte(_), L, L).
% builtin_binds_(peek_byte(_, _), L, L).
% builtin_binds_(peek_char(_), L, L).
% builtin_binds_(peek_char(_, _), L, L).
% builtin_binds_(peek_code(_), L, L).
% builtin_binds_(peek_code(_, _), L, L).
% builtin_binds_(phrase(_, _), L, L).
% builtin_binds_(phrase(_, _, _), L, L).
% builtin_binds_(plus(_, _, _), L, L).
% builtin_binds_(predicate_property(_, _), L, L).
% builtin_binds_(preprocessor(_, _), L, L).
% builtin_binds_(print(_), L, L).
% builtin_binds_(print(_, _), L, L).
% builtin_binds_(print_message(_, _), L, L).
% builtin_binds_(print_message_lines(_, _, _), L, L).
% builtin_binds_(profiler(_, _), L, L).
% builtin_binds_(prolog, L, L).
% builtin_binds_(prolog_choice_attribute(_, _, _), L, L).
% builtin_binds_(prolog_current_frame(_), L, L).
% builtin_binds_(prolog_frame_attribute(_, _, _), L, L).
% builtin_binds_(prolog_load_context(_, _), L, L).
% builtin_binds_(prolog_skip_level(_, _), L, L).
% builtin_binds_(prolog_to_os_filename(_, _), L, L).
% builtin_binds_(prompt(_, _), L, L).
% builtin_binds_(prompt1(_), L, L).
% builtin_binds_(protocol(_), L, L).
% builtin_binds_(protocola(_), L, L).
% builtin_binds_(protocolling(_), L, L).
% builtin_binds_(put(_), L, L).
% builtin_binds_(put(_, _), L, L).
% builtin_binds_(put_attr(_, _, _), L, L).
% builtin_binds_(put_attrs(_, _), L, L).
% builtin_binds_(put_byte(_), L, L).
% builtin_binds_(put_byte(_, _), L, L).
% builtin_binds_(put_char(_), L, L).
% builtin_binds_(put_char(_, _), L, L).
% builtin_binds_(put_code(_), L, L).
% builtin_binds_(put_code(_, _), L, L).
% builtin_binds_(qcompile(_), L, L).
% builtin_binds_(rational(_), L, L).
% builtin_binds_(rational(_, _, _), L, L).
% builtin_binds_(read(_), L, L).
% builtin_binds_(read(_, _), L, L).
% builtin_binds_(read_clause(_), L, L).
% builtin_binds_(read_clause(_, _), L, L).
% builtin_binds_(read_history(_, _, _, _, _, _), L, L).
% builtin_binds_(read_link(_, _, _), L, L).
% builtin_binds_(read_pending_input(_, _, _), L, L).
% builtin_binds_(read_term(_, _), L, L).
% builtin_binds_(read_term(_, _, _), L, L).
% builtin_binds_(recorda(_, _), L, L).
% builtin_binds_(recorda(_, _, _), L, L).
% builtin_binds_(recorded(_, _), L, L).
% builtin_binds_(recorded(_, _, _), L, L).
% builtin_binds_(recordz(_, _), L, L).
% builtin_binds_(recordz(_, _, _), L, L).
% builtin_binds_(redefine_system_predicate(_), L, L).
% builtin_binds_(reload_library_index, L, L).
% builtin_binds_(rename_file(_, _), L, L).
% builtin_binds_(repeat, L, L).
% builtin_binds_(require(_), L, L).
% builtin_binds_(reset_profiler, L, L).
% builtin_binds_(retract(_), L, L).
% builtin_binds_(retractall(_), L, L).
% builtin_binds_(same_file(_, _), L, L).
% builtin_binds_(same_term(_, _), L, L).
% builtin_binds_(see(_), L, L).
% builtin_binds_(seeing(_), L, L).
% builtin_binds_(seek(_, _, _, _), L, L).
% builtin_binds_(seen, L, L).
% builtin_binds_(set_input(_), L, L).
% builtin_binds_(set_output(_), L, L).
% builtin_binds_(set_prolog_IO(_, _, _), L, L).
% builtin_binds_(set_prolog_flag(_, _), L, L).
% builtin_binds_(set_stream(_, _), L, L).
% builtin_binds_(set_stream_position(_, _), L, L).
% builtin_binds_(setarg(_, _, _), L, L).
% builtin_binds_(setenv(_, _), L, L).
% builtin_binds_(setlocale(_, _, _), L, L).
% builtin_binds_(setof(_, _, _), L, L).
% builtin_binds_(setup_and_call_cleanup(_, _, _), L, L).
% builtin_binds_(setup_and_call_cleanup(_, _, _, _), L, L).
% builtin_binds_(shell(_), L, L).
% builtin_binds_(shell(_, _), L, L).
% builtin_binds_(shell, L, L).
% builtin_binds_(size_file(_, _), L, L).
% builtin_binds_(skip(_), L, L).
% builtin_binds_(skip(_, _), L, L).
% builtin_binds_(sleep(_), L, L).
% builtin_binds_(sort(_, _), L, L).
% builtin_binds_(source_file(_), L, L).
% builtin_binds_(source_file(_, _), L, L).
% builtin_binds_(source_location(_, _), L, L).
% builtin_binds_(spy(_), L, L).
% builtin_binds_(stamp_date_time(_, _, _), L, L).
% builtin_binds_(statistics(_, _), L, L).
% builtin_binds_(statistics, L, L).
% builtin_binds_(stream_position_data(_, _, _), L, L).
% builtin_binds_(stream_property(_, _), L, L).
% builtin_binds_(string(_), L, L).
% builtin_binds_(string_concat(_, _, _), L, L).
% builtin_binds_(string_length(_, _), L, L).
% builtin_binds_(string_to_atom(_, _), L, L).
% builtin_binds_(string_to_list(_, _), L, L).
% builtin_binds_(strip_module(_, _, _), L, L).
% builtin_binds_(style_check(_), L, L).
% builtin_binds_(sub_atom(_, _, _, _, _), L, L).
% builtin_binds_(sub_string(_, _, _, _, _), L, L).
% builtin_binds_(succ(_, _), L, L).
% builtin_binds_(swritef(_, _), L, L).
% builtin_binds_(swritef(_, _, _), L, L).
% builtin_binds_(tab(_), L, L).
% builtin_binds_(tab(_, _), L, L).
% builtin_binds_(tell(_), L, L).
% builtin_binds_(telling(_), L, L).
% builtin_binds_(term_to_atom(_, _), L, L).
% builtin_binds_(term_variables(_, _), L, L).
% builtin_binds_(term_variables(_, _, _), L, L).
% builtin_binds_(thread_at_exit(_), L, L).
% builtin_binds_(thread_create(_, _, _), L, L).
% builtin_binds_(thread_detach(_), L, L).
% builtin_binds_(thread_exit(_), L, L).
% builtin_binds_(thread_get_message(_), L, L).
% builtin_binds_(thread_get_message(_, _), L, L).
% builtin_binds_(thread_join(_, _), L, L).
% builtin_binds_(thread_kill(_, _), L, L).
% builtin_binds_(thread_peek_message(_), L, L).
% builtin_binds_(thread_peek_message(_, _), L, L).
% builtin_binds_(thread_property(_, _), L, L).
% builtin_binds_(thread_self(_), L, L).
% builtin_binds_(thread_send_message(_, _), L, L).
% builtin_binds_(thread_setconcurrency(_, _), L, L).
% builtin_binds_(thread_signal(_, _), L, L).
% builtin_binds_(thread_statistics(_, _, _), L, L).
% builtin_binds_(throw(_), L, L).
% builtin_binds_(time_file(_, _), L, L).
% builtin_binds_(tmp_file(_, _), L, L).
% builtin_binds_(told, L, L).
% builtin_binds_(trim_stacks, L, L).
% builtin_binds_(tty_get_capability(_, _, _), L, L).
% builtin_binds_(tty_goto(_, _), L, L).
% builtin_binds_(tty_put(_, _), L, L).
% builtin_binds_(tty_size(_, _), L, L).
% builtin_binds_(ttyflush, L, L).
% builtin_binds_(unifiable(_, _, _), L, L).
% builtin_binds_(unify_with_occurs_check(_, _), L, L).
% builtin_binds_(unsetenv(_), L, L).
% builtin_binds_(upcase_atom(_, _), L, L).
% builtin_binds_(wait_for_input(_, _, _), L, L).
% builtin_binds_(wildcard_match(_, _), L, L).
% builtin_binds_(with_mutex(_, _), L, L).
% builtin_binds_(with_output_to(_, _), L, L).
% builtin_binds_(working_directory(_, _), L, L).
% builtin_binds_(functor(Term, Functor, Arity), [Term,Functor,Arity|T], T).
% builtin_binds_(arg(Arg, Term, Pos), [Arg,Term,Pos|T], T).
% builtin_binds_(term_variables(_, _), L, L).
% builtin_binds_(X=Y, [X,Y|T], T).
builtin_binds_(X is _,[X|L],L).
builtin_binds_((G1,G2),L,T) :-
builtin_binds_(G1,L,R),
@ -141,6 +578,10 @@ binds_(_ == _,L,L).
binds_(_ \== _,L,L).
binds_(true,L,L).
binds_(write(_),L,L).
binds_(writeln(_),L,L).
binds_(format(_,_),L,L).
binds_(X is _,[X|L],L).
binds_((G1,G2),L,T) :-
binds_(G1,L,R),

9
LGPL/chr/chr_compiler_errors.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_compiler_errors.pl,v 1.2 2007-10-16 23:40:07 vsc Exp $
/* $Id: chr_compiler_errors.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -123,6 +123,13 @@ print_chr_error(syntax(Term),Message,Params) :- !,
format(user_error,Message,Params),
long_line_with_equality_signs.
print_chr_error(type_error,Message,Params) :- !,
long_line_with_equality_signs,
format(user_error,'CHR compiler TYPE ERROR:\n',[]),
format(user_error,' `--> ',[]),
format(user_error,Message,Params),
long_line_with_equality_signs.
print_chr_error(internal,Message,Params) :- !,
long_line_with_equality_signs,
format(user_error,'CHR compiler ERROR: something unexpected happened in the CHR compiler.\n',[]),

27
LGPL/chr/chr_compiler_options.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_compiler_options.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_compiler_options.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -200,6 +200,18 @@ option_definition(mode,ModeDecl,[]) :-
option_definition(store,FA-Store,[]) :-
chr_translate:store_type(FA,Store).
%------------------------------------------------------------------------------%
option_definition(declare_stored_constraints,off,[declare_stored_constraints-off]).
option_definition(declare_stored_constraints,on ,[declare_stored_constraints-on]).
option_definition(stored,F/A,[]) :-
chr_translate:stored_assertion(F/A).
%------------------------------------------------------------------------------%
option_definition(experiment,off,[experiment-off]).
option_definition(experiment,on,[experiment-on]).
option_definition(experimental,off,[experiment-off]).
option_definition(experimental,on,[experiment-on]).
%------------------------------------------------------------------------------%
option_definition(debug,off,Flags) :-
option_definition(optimize,full,Flags2),
Flags = [ debugable - off | Flags2].
@ -280,6 +292,12 @@ option_definition(dynattr,on,Flags) :-
option_definition(dynattr,off,Flags) :-
Flags = [dynattr - off].
option_definition(verbose,off,[verbose-off]).
option_definition(verbose,on,[verbose-on]).
option_definition(dump,off,[dump-off]).
option_definition(dump,on,[dump-on]).
init_chr_pp_flags :-
chr_pp_flag_definition(Name,[DefaultValue|_]),
set_chr_pp_flag(Name,DefaultValue),
@ -323,6 +341,13 @@ chr_pp_flag_definition(ht_removal,[off,on]).
chr_pp_flag_definition(mixed_stores,[off,on]).
chr_pp_flag_definition(line_numbers,[off,on]).
chr_pp_flag_definition(dynattr,[off,on]).
chr_pp_flag_definition(experiment,[off,on]).
% emit compiler inferred code
chr_pp_flag_definition(verbose,[off,on]).
% emit input code and output code
chr_pp_flag_definition(dump,[off,on]).
chr_pp_flag_definition(declare_stored_constraints,[off,on]).
chr_pp_flag(Name,Value) :-
atom_concat('$chr_pp_',Name,GlobalVar),

102
LGPL/chr/chr_compiler_utility.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_compiler_utility.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_compiler_utility.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -28,9 +28,9 @@
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- if(current_prolog_flag(dialect, swi)).
:- module(chr_compiler_utility,
[ is_variant/2
, time/2
[ time/2
, replicate/3
, pair_all_with/3
, conj2list/2
@ -45,44 +45,63 @@
, my_term_copy/3
, my_term_copy/4
, atom_concat_list/2
%vsc , atomic_concat/3
, atomic_concat/3
, init/2
, member2/3
, select2/6
, set_elems/2
, instrument_goal/4
, sort_by_key/3
, arg1/3
, wrap_in_functor/3
, tree_set_empty/1
, tree_set_memberchk/2
, tree_set_add/3
]).
:- else.
% ugly: this is because YAP also has atomic_concat
% so we cannot export it from chr_compiler_utility.
:- module(chr_compiler_utility,
[ time/2
, replicate/3
, pair_all_with/3
, conj2list/2
, list2conj/2
, disj2list/2
, list2disj/2
, variable_replacement/3
, variable_replacement/4
, identical_rules/2
, identical_guarded_rules/2
, copy_with_variable_replacement/3
, my_term_copy/3
, my_term_copy/4
, atom_concat_list/2
, init/2
, member2/3
, select2/6
, set_elems/2
, instrument_goal/4
, sort_by_key/3
, arg1/3
, wrap_in_functor/3
, tree_set_empty/1
, tree_set_memberchk/2
, tree_set_add/3
]).
:- endif.
:- use_module(pairlist).
:- use_module(library(lists), [permutation/2]).
:- use_module(library(assoc)).
%% SICStus begin
%% use_module(library(terms),[term_variables/2]).
%% SICStus end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
is_variant(A,B) :-
copy_term_nat(A,AC),
copy_term_nat(B,BC),
term_variables(AC,AVars),
term_variables(BC,BVars),
AC = BC,
is_variant1(AVars),
is_variant2(BVars).
is_variant1([]).
is_variant1([X|Xs]) :-
var(X),
X = '$test',
is_variant1(Xs).
is_variant2([]).
is_variant2([X|Xs]) :-
X == '$test',
is_variant2(Xs).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% time(Phase,Goal) :-
% statistics(runtime,[T1|_]),
@ -260,12 +279,13 @@ atom_concat_list([X|Xs],A) :-
atom_concat_list(Xs,B),
atomic_concat(X,B,A).
/* vsc
:- if(current_prolog_flag(dialect, swi)).
atomic_concat(A,B,C) :-
make_atom(A,AA),
make_atom(B,BB),
atom_concat(AA,BB,C).
*/
:- endif.
make_atom(A,AA) :-
(
atom(A) ->
@ -301,3 +321,31 @@ sort_by_key(List,Keys,SortedList) :-
pairup(Keys,List,Pairs),
sort(Pairs,SortedPairs),
once(pairup(_,SortedList,SortedPairs)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
arg1(Term,Index,Arg) :- arg(Index,Term,Arg).
wrap_in_functor(Functor,X,Term) :-
Term =.. [Functor,X].
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
tree_set_empty(TreeSet) :- empty_assoc(TreeSet).
tree_set_memberchk(Element,TreeSet) :- get_assoc(Element,TreeSet,_).
tree_set_add(TreeSet,Element,NTreeSet) :- put_assoc(Element,TreeSet,x,NTreeSet).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- dynamic
user:goal_expansion/2.
:- multifile
user:goal_expansion/2.
user:goal_expansion(arg1(Term,Index,Arg), arg(Index,Term,Arg)).
user:goal_expansion(wrap_in_functor(Functor,In,Out), Goal) :-
( atom(Functor), var(Out) ->
Out =.. [Functor,In],
Goal = true
;
Goal = (Out =.. [Functor,In])
).

2
LGPL/chr/chr_debug.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_debug.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_debug.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
Part of CHR (Constraint Handling Rules)

707
LGPL/chr/chr_hashtable_store.pl
View File

@ -1,296 +1,411 @@
/* $Id: chr_hashtable_store.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
% author: Tom Schrijvers
% email: Tom.Schrijvers@cs.kuleuven.be
% copyright: K.U.Leuven, 2004
:- module(chr_hashtable_store,
[ new_ht/1,
lookup_ht/3,
insert_ht/3,
insert_ht/4,
delete_ht/3,
delete_first_ht/3,
value_ht/2
]).
:- use_module(pairlist).
:- use_module(hprolog).
:- use_module(library(lists)).
:- use_module(library(terms)). %yap
:- multifile user:goal_expansion/2.
:- dynamic user:goal_expansion/2.
user:goal_expansion(term_hash(Term,Hash),hash_term(Term,Hash)).
% term_hash(Term,Hash) :-
% hash_term(Term,Hash).
initial_capacity(1).
new_ht(HT) :-
initial_capacity(Capacity),
new_ht(Capacity,HT).
new_ht(Capacity,HT) :-
functor(T1,t,Capacity),
HT = ht(Capacity,0,Table),
Table = T1.
lookup_ht(HT,Key,Values) :-
term_hash(Key,Hash),
HT = ht(Capacity,_,Table),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
nonvar(Bucket),
( Bucket = K-Vs ->
K == Key,
Values = Vs
;
lookup(Bucket,Key,Values)
).
lookup_pair_eq([P | KVs],Key,Pair) :-
P = K-_,
( K == Key ->
P = Pair
;
lookup_pair_eq(KVs,Key,Pair)
).
insert_ht(HT,Key,Value) :-
term_hash(Key,Hash),
HT = ht(Capacity0,Load,Table0),
LookupIndex is (Hash mod Capacity0) + 1,
arg(LookupIndex,Table0,LookupBucket),
( var(LookupBucket) ->
LookupBucket = Key - [Value]
; LookupBucket = K-Values ->
( K == Key ->
setarg(2,LookupBucket,[Value|Values])
;
setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
)
;
( lookup_pair_eq(LookupBucket,Key,Pair) ->
Pair = _-Values,
setarg(2,Pair,[Value|Values])
;
setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
)
),
NLoad is Load + 1,
setarg(2,HT,NLoad),
( Load == Capacity0 ->
expand_ht(HT,_Capacity)
;
true
).
% LDK: insert version with extra argument denoting result
insert_ht(HT,Key,Value,Result) :-
HT = ht(Capacity,Load,Table),
term_hash(Key,Hash),
LookupIndex is (Hash mod Capacity) + 1,
arg(LookupIndex,Table,LookupBucket),
( var(LookupBucket)
-> Result = [Value],
LookupBucket = Key - Result,
NewLoad is Load + 1
; LookupBucket = K - V
-> ( K = Key
-> Result = [Value|V],
setarg(2,LookupBucket,Result),
NewLoad = Load
; Result = [Value],
setarg(LookupIndex,Table,[Key - Result,LookupBucket]),
NewLoad is Load + 1
)
; ( lookup_pair_eq(LookupBucket,Key,Pair)
-> Pair = _-Values,
Result = [Value|Values],
setarg(2,Pair,Result),
NewLoad = Load
; Result = [Value],
setarg(LookupIndex,Table,[Key - Result|LookupBucket]),
NewLoad is Load + 1
)
),
setarg(2,HT,NewLoad),
( NewLoad > Capacity
-> expand_ht(HT,_)
; true
).
% LDK: deletion of the first element of a bucket
delete_first_ht(HT,Key,Values) :-
HT = ht(Capacity,Load,Table),
term_hash(Key,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( Bucket = _-[_|Values]
-> ( Values = []
-> setarg(Index,Table,_),
NewLoad is Load - 1
; setarg(2,Bucket,Values),
NewLoad = Load
)
; lookup_pair_eq(Bucket,Key,Pair)
-> Pair = _-[_|Values],
( Values = []
-> pairlist_delete_eq(Bucket,Key,NewBucket),
( NewBucket = []
-> setarg(Index,Table,_)
; NewBucket = [OtherPair]
-> setarg(Index,Table,OtherPair)
; setarg(Index,Table,NewBucket)
),
NewLoad is Load - 1
; setarg(2,Pair,Values),
NewLoad = Load
)
).
delete_ht(HT,Key,Value) :-
HT = ht(Capacity,Load,Table),
NLoad is Load - 1,
term_hash(Key,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( var(Bucket) ->
true
;
( Bucket = K-Vs ->
( K == Key,
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
setarg(Index,Table,_)
;
setarg(2,Bucket,NVs)
)
;
true
)
;
( lookup_pair_eq(Bucket,Key,Pair),
Pair = _-Vs,
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
pairlist_delete_eq(Bucket,Key,NBucket),
( NBucket = [Singleton] ->
setarg(Index,Table,Singleton)
;
setarg(Index,Table,NBucket)
)
;
setarg(2,Pair,NVs)
)
;
true
)
)
).
delete_first_fail([X | Xs], Y, Zs) :-
( X == Y ->
Zs = Xs
;
Zs = [X | Zs1],
delete_first_fail(Xs, Y, Zs1)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
value_ht(HT,Value) :-
HT = ht(Capacity,_,Table),
value_ht(1,Capacity,Table,Value).
value_ht(I,N,Table,Value) :-
I =< N,
arg(I,Table,Bucket),
(
nonvar(Bucket),
( Bucket = _-Vs ->
true
;
member(_-Vs,Bucket)
),
member(Value,Vs)
;
J is I + 1,
value_ht(J,N,Table,Value)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
expand_ht(HT,NewCapacity) :-
HT = ht(Capacity,_,Table),
NewCapacity is Capacity * 2,
functor(NewTable,t,NewCapacity),
setarg(1,HT,NewCapacity),
setarg(3,HT,NewTable),
expand_copy(Table,1,Capacity,NewTable,NewCapacity).
expand_copy(Table,I,N,NewTable,NewCapacity) :-
( I > N ->
true
;
arg(I,Table,Bucket),
( var(Bucket) ->
true
; Bucket = Key - Value ->
expand_insert(NewTable,NewCapacity,Key,Value)
;
expand_inserts(Bucket,NewTable,NewCapacity)
),
J is I + 1,
expand_copy(Table,J,N,NewTable,NewCapacity)
).
expand_inserts([],_,_).
expand_inserts([K-V|R],Table,Capacity) :-
expand_insert(Table,Capacity,K,V),
expand_inserts(R,Table,Capacity).
expand_insert(Table,Capacity,K,V) :-
term_hash(K,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( var(Bucket) ->
Bucket = K - V
; Bucket = _-_ ->
setarg(Index,Table,[K-V,Bucket])
;
setarg(Index,Table,[K-V|Bucket])
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/* $Id: chr_hashtable_store.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
% author: Tom Schrijvers
% email: Tom.Schrijvers@cs.kuleuven.be
% copyright: K.U.Leuven, 2004
:- module(chr_hashtable_store,
[ new_ht/1,
lookup_ht/3,
lookup_ht1/4,
lookup_ht2/4,
insert_ht/3,
insert_ht/4,
delete_ht/3,
delete_ht1/4,
delete_first_ht/3,
value_ht/2,
stats_ht/1,
stats_ht/1
]).
:- use_module(pairlist).
:- use_module(hprolog).
:- use_module(library(lists)).
:- if(current_prolog_flag(dialect, swi)).
:- multifile user:goal_expansion/2.
:- dynamic user:goal_expansion/2.
user:goal_expansion(term_hash(Term,Hash),hash_term(Term,Hash)).
:- else.
:- use_module(library(terms), [term_hash/2]).
:- endif.
% term_hash(Term,Hash) :-
% hash_term(Term,Hash).
initial_capacity(89).
new_ht(HT) :-
initial_capacity(Capacity),
new_ht(Capacity,HT).
new_ht(Capacity,HT) :-
functor(T1,t,Capacity),
HT = ht(Capacity,0,Table),
Table = T1.
lookup_ht(HT,Key,Values) :-
term_hash(Key,Hash),
HT = ht(Capacity,_,Table),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
nonvar(Bucket),
( Bucket = K-Vs ->
K == Key,
Values = Vs
;
lookup(Bucket,Key,Values)
).
lookup_ht1(HT,Hash,Key,Values) :-
HT = ht(Capacity,_,Table),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
nonvar(Bucket),
( Bucket = K-Vs ->
K == Key,
Values = Vs
;
lookup(Bucket,Key,Values)
).
lookup_ht2(HT,Key,Values,Index) :-
term_hash(Key,Hash),
HT = ht(Capacity,_,Table),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
nonvar(Bucket),
( Bucket = K-Vs ->
K == Key,
Values = Vs
;
lookup(Bucket,Key,Values)
).
lookup_pair_eq([P | KVs],Key,Pair) :-
P = K-_,
( K == Key ->
P = Pair
;
lookup_pair_eq(KVs,Key,Pair)
).
insert_ht(HT,Key,Value) :-
term_hash(Key,Hash),
HT = ht(Capacity0,Load,Table0),
LookupIndex is (Hash mod Capacity0) + 1,
arg(LookupIndex,Table0,LookupBucket),
( var(LookupBucket) ->
LookupBucket = Key - [Value]
; LookupBucket = K-Values ->
( K == Key ->
setarg(2,LookupBucket,[Value|Values])
;
setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
)
;
( lookup_pair_eq(LookupBucket,Key,Pair) ->
Pair = _-Values,
setarg(2,Pair,[Value|Values])
;
setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
)
),
NLoad is Load + 1,
setarg(2,HT,NLoad),
( Load == Capacity0 ->
expand_ht(HT,_Capacity)
;
true
).
insert_ht1(HT,Key,Hash,Value) :-
HT = ht(Capacity0,Load,Table0),
LookupIndex is (Hash mod Capacity0) + 1,
arg(LookupIndex,Table0,LookupBucket),
( var(LookupBucket) ->
LookupBucket = Key - [Value]
; LookupBucket = K-Values ->
( K == Key ->
setarg(2,LookupBucket,[Value|Values])
;
setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
)
;
( lookup_pair_eq(LookupBucket,Key,Pair) ->
Pair = _-Values,
setarg(2,Pair,[Value|Values])
;
setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
)
),
NLoad is Load + 1,
setarg(2,HT,NLoad),
( Load == Capacity0 ->
expand_ht(HT,_Capacity)
;
true
).
% LDK: insert version with extra argument denoting result
insert_ht(HT,Key,Value,Result) :-
HT = ht(Capacity,Load,Table),
term_hash(Key,Hash),
LookupIndex is (Hash mod Capacity) + 1,
arg(LookupIndex,Table,LookupBucket),
( var(LookupBucket)
-> Result = [Value],
LookupBucket = Key - Result,
NewLoad is Load + 1
; LookupBucket = K - V
-> ( K = Key
-> Result = [Value|V],
setarg(2,LookupBucket,Result),
NewLoad = Load
; Result = [Value],
setarg(LookupIndex,Table,[Key - Result,LookupBucket]),
NewLoad is Load + 1
)
; ( lookup_pair_eq(LookupBucket,Key,Pair)
-> Pair = _-Values,
Result = [Value|Values],
setarg(2,Pair,Result),
NewLoad = Load
; Result = [Value],
setarg(LookupIndex,Table,[Key - Result|LookupBucket]),
NewLoad is Load + 1
)
),
setarg(2,HT,NewLoad),
( NewLoad > Capacity
-> expand_ht(HT,_)
; true
).
% LDK: deletion of the first element of a bucket
delete_first_ht(HT,Key,Values) :-
HT = ht(Capacity,Load,Table),
term_hash(Key,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( Bucket = _-[_|Values]
-> ( Values = []
-> setarg(Index,Table,_),
NewLoad is Load - 1
; setarg(2,Bucket,Values),
NewLoad = Load
)
; lookup_pair_eq(Bucket,Key,Pair)
-> Pair = _-[_|Values],
( Values = []
-> pairlist_delete_eq(Bucket,Key,NewBucket),
( NewBucket = []
-> setarg(Index,Table,_)
; NewBucket = [OtherPair]
-> setarg(Index,Table,OtherPair)
; setarg(Index,Table,NewBucket)
),
NewLoad is Load - 1
; setarg(2,Pair,Values),
NewLoad = Load
)
).
delete_ht(HT,Key,Value) :-
HT = ht(Capacity,Load,Table),
NLoad is Load - 1,
term_hash(Key,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( /* var(Bucket) ->
true
; */ Bucket = _K-Vs ->
( /* _K == Key, */
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
setarg(Index,Table,_)
;
setarg(2,Bucket,NVs)
)
;
true
)
;
( lookup_pair_eq(Bucket,Key,Pair),
Pair = _-Vs,
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
pairlist_delete_eq(Bucket,Key,NBucket),
( NBucket = [Singleton] ->
setarg(Index,Table,Singleton)
;
setarg(Index,Table,NBucket)
)
;
setarg(2,Pair,NVs)
)
;
true
)
).
delete_first_fail([X | Xs], Y, Zs) :-
( X == Y ->
Zs = Xs
;
Zs = [X | Zs1],
delete_first_fail(Xs, Y, Zs1)
).
delete_ht1(HT,Key,Value,Index) :-
HT = ht(_Capacity,Load,Table),
NLoad is Load - 1,
% term_hash(Key,Hash),
% Index is (Hash mod _Capacity) + 1,
arg(Index,Table,Bucket),
( /* var(Bucket) ->
true
; */ Bucket = _K-Vs ->
( /* _K == Key, */
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
setarg(Index,Table,_)
;
setarg(2,Bucket,NVs)
)
;
true
)
;
( lookup_pair_eq(Bucket,Key,Pair),
Pair = _-Vs,
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
pairlist_delete_eq(Bucket,Key,NBucket),
( NBucket = [Singleton] ->
setarg(Index,Table,Singleton)
;
setarg(Index,Table,NBucket)
)
;
setarg(2,Pair,NVs)
)
;
true
)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
value_ht(HT,Value) :-
HT = ht(Capacity,_,Table),
value_ht(1,Capacity,Table,Value).
value_ht(I,N,Table,Value) :-
I =< N,
arg(I,Table,Bucket),
(
nonvar(Bucket),
( Bucket = _-Vs ->
true
;
member(_-Vs,Bucket)
),
member(Value,Vs)
;
J is I + 1,
value_ht(J,N,Table,Value)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
expand_ht(HT,NewCapacity) :-
HT = ht(Capacity,_,Table),
NewCapacity is Capacity * 2 + 1,
functor(NewTable,t,NewCapacity),
setarg(1,HT,NewCapacity),
setarg(3,HT,NewTable),
expand_copy(Table,1,Capacity,NewTable,NewCapacity).
expand_copy(Table,I,N,NewTable,NewCapacity) :-
( I > N ->
true
;
arg(I,Table,Bucket),
( var(Bucket) ->
true
; Bucket = Key - Value ->
expand_insert(NewTable,NewCapacity,Key,Value)
;
expand_inserts(Bucket,NewTable,NewCapacity)
),
J is I + 1,
expand_copy(Table,J,N,NewTable,NewCapacity)
).
expand_inserts([],_,_).
expand_inserts([K-V|R],Table,Capacity) :-
expand_insert(Table,Capacity,K,V),
expand_inserts(R,Table,Capacity).
expand_insert(Table,Capacity,K,V) :-
term_hash(K,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( var(Bucket) ->
Bucket = K - V
; Bucket = _-_ ->
setarg(Index,Table,[K-V,Bucket])
;
setarg(Index,Table,[K-V|Bucket])
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
stats_ht(HT) :-
HT = ht(Capacity,Load,Table),
format('HT load = ~w / ~w\n',[Load,Capacity]),
( between(1,Capacity,Index),
arg(Index,Table,Entry),
( var(Entry) -> Size = 0
; Entry = _-_ -> Size = 1
; length(Entry,Size)
),
format('~w : ~w\n',[Index,Size]),
fail
;
true
).

2
LGPL/chr/chr_integertable_store.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_integertable_store.pl,v 1.2 2007-10-16 23:40:07 vsc Exp $
/* $Id: chr_integertable_store.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
Part of CHR (Constraint Handling Rules)

2
LGPL/chr/chr_messages.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_messages.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_messages.pl,v 1.3 2008-03-13 14:37:59 vsc Exp $
Part of CHR (Constraint Handling Rules)

3
LGPL/chr/chr_op.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_op.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_op.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -47,3 +47,4 @@
:- op(1150, fx, chr_type).
:- op(1130, xfx, --->).
:- op(1150, fx, (?)).
:- op(1150, fx, chr_declaration).

2
LGPL/chr/chr_op2.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_op2.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_op2.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
Part of CHR (Constraint Handling Rules)

2
LGPL/chr/chr_runtime.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_runtime.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_runtime.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
Part of CHR (Constraint Handling Rules)

6
LGPL/chr/chr_swi.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_swi.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_swi.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -43,6 +43,7 @@
op(1190, xfx, pragma),
op( 500, yfx, #),
op(1150, fx, chr_type),
op(1150, fx, chr_declaration),
op(1130, xfx, --->),
op(1150, fx, (?)),
chr_show_store/1, % +Module
@ -130,6 +131,7 @@ chr_expandable((constraints _)).
chr_expandable((:- chr_constraint _)).
chr_expandable((:- chr_type _)).
chr_expandable((chr_type _)).
chr_expandable((:- chr_declaration _)).
chr_expandable(option(_, _)).
chr_expandable((:- chr_option(_, _))).
chr_expandable((handler _)).
@ -165,7 +167,7 @@ chr_expand(Term, []) :-
add_pragma_to_chr_rule(Term,line_number(LineNumber),NTerm),
assert(chr_term(File, LineNumber, NTerm)).
chr_expand(Term, []) :-
Term = (:- chr_preprocessor(Preprocessor)), !,
Term = ((:- chr_preprocessor Preprocessor)), !,
prolog_load_context(file,File),
assert(chr_pp(File, Preprocessor)).
chr_expand(end_of_file, FinalProgram) :-

7
LGPL/chr/chr_swi_bootstrap.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_swi_bootstrap.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_swi_bootstrap.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -76,7 +76,7 @@ chr_compile(From, To, MsgLevel) :-
print_message(MsgLevel, chr(end(From, To))).
%% SWI begin with yap change
%% SWI begin
specific_declarations([(:- use_module('chr_runtime')),
(:- style_check(-discontiguous))|Tail], Tail).
%% SWI end
@ -130,7 +130,8 @@ writeheader(File, Out) :-
format_date(Out) :-
get_time(Now),
convert_time(Now, Date),
format(Out, ' Date: ~s~n~n', [Date]). % yap change
% vsc: this is a string
format(Out, ' Date: ~s~n~n', [Date]).
%% SWI end
%% SICStus begin

2
LGPL/chr/chr_test.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_test.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_test.pl,v 1.3 2008-03-13 14:38:00 vsc Exp $
Part of CHR (Constraint Handling Rules)

2063
LGPL/chr/chr_translate.chr
View File

File diff suppressed because it is too large Load Diff

41
LGPL/chr/chr_translate_bootstrap.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_translate_bootstrap.pl,v 1.5 2008-02-23 01:32:30 vsc Exp $
/* $Id: chr_translate_bootstrap.pl,v 1.6 2008-03-13 14:38:00 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -122,7 +122,7 @@
[ chr_translate/2 % +Decls, -TranslatedDecls
]).
%% SWI begin
:- use_module(library(lists),[member/2,append/3,permutation/2,reverse/2]).
:- use_module(library(lists),[member/2,append/3,append/2,permutation/2,reverse/2]).
:- use_module(library(ordsets)).
%% SWI end
:- use_module(hprolog).
@ -536,13 +536,13 @@ generate_attach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :-
RecursiveCall =.. [Fct,Vars,Susp],
or_pattern(Position,Pattern),
make_attr(Total,Mask,SuspsList,Attr),
nth(Position,SuspsList,Susps),
nth1(Position,SuspsList,Susps),
substitute_eq(Susps,SuspsList,[Susp|Susps],SuspsList1),
make_attr(Total,Mask,SuspsList1,NewAttr1),
substitute_eq(Susps,SuspsList,[Susp],SuspsList2),
make_attr(Total,NewMask,SuspsList2,NewAttr2),
copy_term_nat(SuspsList,SuspsList3),
nth(Position,SuspsList3,[Susp]),
nth1(Position,SuspsList3,[Susp]),
chr_delete(SuspsList3,[Susp],RestSuspsList),
set_elems(RestSuspsList,[]),
make_attr(Total,Pattern,SuspsList3,NewAttr3),
@ -609,6 +609,7 @@ generate_detach_a_constraint_1_1(CFct / CAty,Mod,Clause) :-
RecursiveCall
),
Clause = (Head :- Body).
generate_detach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :-
atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
Args = [[Var|Vars],Susp],
@ -617,7 +618,7 @@ generate_detach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :-
or_pattern(Position,Pattern),
and_pattern(Position,DelPattern),
make_attr(Total,Mask,SuspsList,Attr),
nth(Position,SuspsList,Susps),
nth1(Position,SuspsList,Susps),
substitute_eq(Susps,SuspsList,[],SuspsList1),
make_attr(Total,NewMask,SuspsList1,Attr1),
substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
@ -1419,9 +1420,9 @@ rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,Act
( N == 1 ->
VarSusps = Attr
;
nth(Pos,Constraints,Fct/Aty), !,
nth1(Pos,Constraints,Fct/Aty), !,
make_attr(N,_Mask,SuspsList,Attr),
nth(Pos,SuspsList,VarSusps)
nth1(Pos,SuspsList,VarSusps)
),
different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
create_get_mutable_ref(active,State,GetMutable),
@ -1460,7 +1461,7 @@ check_unique_keys([V|Vs],Dict) :-
% Generates tests to ensure the found constraint differs from previously found constraints
different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
( bagof(DiffSuspGoal, Pos ^ ( nth1(Pos,Heads,PreHead), \+ Head \= PreHead, nth1(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
list2conj(DiffSuspGoalList,DiffSuspGoals)
;
DiffSuspGoals = true
@ -1468,7 +1469,7 @@ different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
passive_head_via(Head,PrevHeads,AttrDict,Constraints,Mod,VarDict,Goal,Attr,NewAttrDict) :-
functor(Head,F,A),
nth(Pos,Constraints,F/A),!,
nth1(Pos,Constraints,F/A),!,
common_variables(Head,PrevHeads,CommonVars),
translate(CommonVars,VarDict,Vars),
or_pattern(Pos,Bit),
@ -1699,9 +1700,9 @@ simpagation_head2_prelude(Head,Head1,Rest,F/A,_I,N,Constraints,Mod,Id1,L,T) :-
AllSusps = Attr
;
functor(Head1,F1,A1),
nth(Pos,Constraints,F1/A1), !,
nth1(Pos,Constraints,F1/A1), !,
make_attr(N,_,SuspsList,Attr),
nth(Pos,SuspsList,AllSusps)
nth1(Pos,SuspsList,AllSusps)
),
( Id1 == [0] -> % create suspension
@ -1941,8 +1942,8 @@ propagation_prelude(Head,[First|Rest],Rule,F/A,N,Constraints,Mod,Id,L,T) :-
;
functor(First,FirstFct,FirstAty),
make_attr(N,_Mask,SuspsList,Attr),
nth(Pos,Constraints,FirstFct/FirstAty), !,
nth(Pos,SuspsList,Susps)
nth1(Pos,Constraints,FirstFct/FirstAty), !,
nth1(Pos,SuspsList,Susps)
),
( Id == [0] ->
@ -2120,9 +2121,9 @@ propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,N,C
( N == 1 ->
NextSusps = Attr
;
nth(Position,Constraints,NextF/NextA), !,
nth1(Position,Constraints,NextF/NextA), !,
make_attr(N,_Mask,SuspsList,Attr),
nth(Position,SuspsList,NextSusps)
nth1(Position,SuspsList,NextSusps)
),
inc_id(Id,NestedId),
ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
@ -2286,6 +2287,7 @@ create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
%% SICStus end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@ -2456,6 +2458,8 @@ list2conj([G|Gs],C) :-
list2conj(Gs,R)
).
:- if(current_prolog_flag(dialect, swi)).
atom_concat_list([X],X) :- ! .
atom_concat_list([X|Xs],A) :-
atom_concat_list(Xs,B),
@ -2476,6 +2480,12 @@ make_atom(A,AA) :-
atom_codes(AA,AL)
).
:- else.
atom_concat_list(L,X) :-
atomic_concat(L, X).
:- endif.
set_elems([],_).
set_elems([X|Xs],X) :-
@ -2505,4 +2515,3 @@ verbosity_on :- prolog_flag(verbose,V), V == yes.
%% SICStus begin
%% verbosity_on. % at the moment
%% SICStus end

1
LGPL/chr/chr_translate_bootstrap1.chr
View File

@ -14,6 +14,7 @@
:- style_check(- (discontiguous)).
:- use_module(library(lists),
[ append/3,
append/2,
member/2,
permutation/2,
reverse/2

14
LGPL/chr/chr_translate_bootstrap2.chr
View File

@ -1,4 +1,4 @@
/* $Id: chr_translate_bootstrap2.chr,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: chr_translate_bootstrap2.chr,v 1.3 2008-03-13 14:38:01 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -113,7 +113,7 @@
[ chr_translate/2 % +Decls, -TranslatedDecls
]).
%% SWI begin
:- use_module(library(lists),[append/3,member/2,delete/3,reverse/2,permutation/2]).
:- use_module(library(lists),[append/3,append/2,member/2,delete/3,reverse/2,permutation/2,min_list/2]).
:- use_module(library(ordsets)).
%% SWI end
@ -410,7 +410,7 @@ store_management_preds(Constraints,Clauses) :-
,Clauses).
%% SWI begin vsc: yap changes
%% SWI begin
specific_declarations([(:- use_module('chr_runtime'))
,(:- use_module('chr_hashtable_store'))
,(:- style_check(-discontiguous))
@ -3558,6 +3558,8 @@ list2disj([G|Gs],C) :-
list2disj(Gs,R)
).
:- if(current_prolog_flag(dialect, swi)).
atom_concat_list([X],X) :- ! .
atom_concat_list([X|Xs],A) :-
atom_concat_list(Xs,B),
@ -3577,6 +3579,12 @@ make_atom(A,AA) :-
number_codes(A,AL),
atom_codes(AA,AL)
).
:- else.
atom_concat_list(L,X) :-
atomic_concat(L, X).
:- endif.
make_name(Prefix,F/A,Name) :-

99
LGPL/chr/clean_code.pl
View File

@ -10,10 +10,9 @@
%% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, |
%% |___/
%%
%% removes redundant 'true's and other trivial but potentially non-free constructs
% TODO
% Remove last clause with Body = fail
%%
%% To be done:
%% inline clauses
:- module(clean_code,
[
@ -22,10 +21,24 @@
:- use_module(hprolog).
clean_clauses([],[]).
clean_clauses([C|Cs],[NC|NCs]) :-
clean_clauses(Clauses,NClauses) :-
clean_clauses1(Clauses,Clauses1),
merge_clauses(Clauses1,NClauses).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% CLEAN CLAUSES
%
% - move neck unification into the head of the clause
% - drop true body
% - specialize control flow goal wrt true and fail
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
clean_clauses1([],[]).
clean_clauses1([C|Cs],[NC|NCs]) :-
clean_clause(C,NC),
clean_clauses(Cs,NCs).
clean_clauses1(Cs,NCs).
clean_clause(Clause,NClause) :-
( Clause = (Head :- Body) ->
@ -128,20 +141,6 @@ move_unification_into_head_([G|Gs],Head,NHead,NBody) :-
list2conj([G|Gs],NBody)
).
% move_unification_into_head(Head,Body,NHead,NBody) :-
% ( Body = (X = Y, More) ; Body = (X = Y), More = true), !,
% ( var(X), term_variables(More,MoreVars), \+ memberchk_eq(X,MoreVars) ->
% X = Y,
% move_unification_into_head(Head,More,NHead,NBody)
% ; var(Y) ->
% move_unification_into_head(Head,(Y = X,More),NHead,NBody)
% ;
% NHead = Head,
% NBody = Body
% ).
%
% move_unification_into_head(Head,Body,Head,Body).
conj2list(Conj,L) :- %% transform conjunctions to list
conj2list(Conj,L,[]).
@ -165,3 +164,61 @@ list2conj([G|Gs],C) :-
C = (G,R),
list2conj(Gs,R)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% MERGE CLAUSES
%
% Find common prefixes of successive clauses and share them.
%
% Note: we assume that the prefix does not generate a side effect.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
merge_clauses([],[]).
merge_clauses([C],[C]).
merge_clauses([X,Y|Clauses],NClauses) :-
( merge_two_clauses(X,Y,Clause) ->
merge_clauses([Clause|Clauses],NClauses)
;
NClauses = [X|RClauses],
merge_clauses([Y|Clauses],RClauses)
).
merge_two_clauses('$source_location'(F1,L1) : C1,
'$source_location'(_F2,_L2) : C2,
Result) :- !,
merge_two_clauses(C1,C2,C),
Result = '$source_location'(F1,L1) : C.
merge_two_clauses((H1 :- B1), (H2 :- B2), (H :- B)) :-
H1 =@= H2,
H1 = H,
conj2list(B1,List1),
conj2list(B2,List2),
merge_lists(List1,List2,H1,H2,Unifier,List,NList1,NList2),
List \= [],
H1 = H2,
call(Unifier),
list2conj(List,Prefix),
list2conj(NList1,NB1),
( NList2 == (!) ->
B = Prefix
;
list2conj(NList2,NB2),
B = (Prefix,(NB1 ; NB2))
).
merge_lists([],[],_,_,true,[],[],[]).
merge_lists([],L2,_,_,true,[],[],L2).
merge_lists([!|Xs],_,_,_,true,[!|Xs],[],!) :- !.
merge_lists([X|Xs],[],_,_,true,[],[X|Xs],[]).
merge_lists([X|Xs],[Y|Ys],H1,H2,Unifier,Common,N1,N2) :-
( H1-X =@= H2-Y ->
Unifier = (X = Y, RUnifier),
Common = [X|NCommon],
merge_lists(Xs,Ys,H1/X,H2/Y,RUnifier,NCommon,N1,N2)
;
Unifier = true,
Common = [],
N1 = [X|Xs],
N2 = [Y|Ys]
).

14
LGPL/chr/find.pl
View File

@ -1,4 +1,4 @@
/* $Id: find.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: find.pl,v 1.3 2008-03-13 14:38:01 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -61,3 +61,15 @@ forall(X,L,G) :-
forsome(X,L,G) :-
member(X,L),
call(G), !.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- dynamic
user:goal_expansion/2.
:- multifile
user:goal_expansion/2.
user:goal_expansion(forall(Element,List,Test), GoalOut) :-
nonvar(Test),
Test =.. [Functor,Arg],
Arg == Element,
GoalOut = once(maplist(Functor,List)).

17545
LGPL/chr/guard_entailment.pl
View File

File diff suppressed because it is too large Load Diff

35
LGPL/chr/hprolog.pl
View File

@ -1,7 +1,5 @@
:- module(hprolog,
[ append/2, % +ListOfLists, -List
nth/3, % ?Index, ?List, ?Element
substitute_eq/4, % +OldVal, +OldList, +NewVal, -NewList
[ substitute_eq/4, % +OldVal, +OldList, +NewVal, -NewList
memberchk_eq/2, % +Val, +List
intersect_eq/3, % +List1, +List2, -Intersection
list_difference_eq/3, % +List, -Subtract, -Rest
@ -12,7 +10,6 @@
or_list/2, % +ListOfInts, -BitwiseOr
sublist/2, % ?Sublist, +List
bounded_sublist/3, % ?Sublist, +List, +Bound
min_list/2,
chr_delete/3,
init_store/2,
get_store/2,
@ -53,27 +50,6 @@ make_update_store_goal(Name,Value,Goal) :- Goal = b_setval(Name,Value).
* MORE LIST OPERATIONS *
*******************************/
% append(+ListOfLists, -List)
%
% Convert a one-level nested list into a flat one. E.g.
% append([[a,b], [c]], X) --> X = [a,b,c]. See also
% flatten/3.
append([],[]).
append([X],X) :- !.
append([X|Xs],L) :-
append(X,T,L),
append(Xs,T).
% nth(?Index, ?List, ?Element)
%
% Same as nth1/3
nth(Index, List, Element) :-
nth1(Index, List, Element).
% substitute_eq(+OldVal, +OldList, +NewVal, -NewList)
%
% Substitute OldVal by NewVal in OldList and unify the result
@ -204,15 +180,6 @@ bounded_sublist(Sublist,[H|List],Bound) :-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
min_list([H|T], Min) :-
'$min_list1'(T, H, Min).
'$min_list1'([], Min, Min).
'$min_list1'([H|T], X, Min) :-
( H>=X ->
'$min_list1'(T, X, Min)
; '$min_list1'(T, H, Min)
).
chr_delete([], _, []).
chr_delete([H|T], X, L) :-

2
LGPL/chr/listmap.pl
View File

@ -1,4 +1,4 @@
/* $Id: listmap.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
/* $Id: listmap.pl,v 1.3 2008-03-13 14:38:01 vsc Exp $
Part of CHR (Constraint Handling Rules)

1
Makefile.in
View File

@ -593,6 +593,7 @@ install_unix: startup libYap.a
@INSTALL_DLLS@ $(INSTALL_DATA) -m 755 @YAPLIB@ $(DESTDIR)$(LIBDIR)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/pl
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/swi
for f in $(PL_SOURCES); do $(INSTALL) $$f $(DESTDIR)$(SHAREDIR)/Yap/pl; done
@INSTALL_DLLS@ (cd library/random; make install)
@INSTALL_DLLS@ (cd library/regex; make install)

1
library/Makefile.in
View File

@ -52,6 +52,7 @@ PROGRAMS= $(srcdir)/apply_macros.yap \
$(srcdir)/readutil.yap \
$(srcdir)/regexp.yap \
$(srcdir)/splay.yap \
$(srcdir)/stringutils.yap \
$(srcdir)/swi.yap \
$(srcdir)/system.yap \
$(srcdir)/terms.yap \

109
library/swi.yap
View File

@ -15,15 +15,62 @@
:- use_module(library(charsio),[write_to_chars/2,read_from_chars/2]).
:- use_module(library(lists),[nth/3]).
:- use_module(library(lists),[append/3,
delete/3,
member/2,
memberchk/2,
min_list/2,
nth/3]).
:- use_module(library(system),[datime/1,
mktime/2]).
:- use_module(library(system),
[datime/1,
mktime/2]).
:- use_module(library(terms),[term_variables/2,
term_variables/3,
term_hash/2,
variant/2]).
:- use_module(library(arg),
[genarg/3]).
:- use_module(library(terms),
[subsumes/2,
term_variables/2,
term_variables/3,
term_hash/2,
unifiable/3,
variant/2]).
:- unhide('$system_library_directories'),
unhide('$dir_separator').
% make sure we also use
:- user:library_directory(X),
atom(X),
atom_concat([X,'/swi'],SwiDir),
\+ user:library_directory(SwiDir),
asserta(user:library_directory(SwiDir)),
fail
;
true.
:- use_module(library(maplist)).
:- multifile swi_predicate_table/4.
swi_predicate_table(_,maplist(X,Y),maplist,maplist(X,Y)).
swi_predicate_table(_,maplist(X,Y,Z),maplist,maplist(X,Y,Z)).
swi_predicate_table(_,maplist(X,Y,Z,W),maplist,maplist(X,Y,Z,W)).
swi_predicate_table(_,is_list(X),lists,is_list(X)).
swi_predicate_table(_,min_list(X,Y),lists,min_list(X,Y)).
swi_predicate_table(_,nth(X,Y,Z),lists,nth(X,Y,Z)).
swi_predicate_table(_,delete(X,Y,Z),lists,delete(X,Y,Z)).
swi_predicate_table(_,nth1(X,Y,Z),lists,nth(X,Y,Z)).
swi_predicate_table(_,memberchk(X,Y),lists,memberchk(X,Y)).
swi_predicate_table(_,member(X,Y),lists,member(X,Y)).
swi_predicate_table(_,append(X,Y,Z),lists,append(X,Y,Z)).
swi_predicate_table(_,select(X,Y,Z),lists,select(X,Y,Z)).
swi_predicate_table(_,term_variables(X,Y),terms,term_variables(X,Y)).
swi_predicate_table(_,term_variables(X,Y,Z),terms,term_variables(X,Y,Z)).
swi_predicate_table(_,subsumes(X,Y),terms,subsumes(X,Y)).
swi_predicate_table(_,unifiable(X,Y,Z),terms,unifiable(X,Y,Z)).
swi_predicate_table(_,genarg(X,Y,Z),arg,genarg(X,Y,Z)).
:- dynamic
prolog:message/3.
@ -37,10 +84,6 @@
:- dynamic
user:file_search_path/2.
prolog:is_list(L) :- var(L), !, fail.
prolog:is_list([]).
prolog:is_list([_|List]) :- prolog:is_list(List).
user:file_search_path(swi, Home) :-
current_prolog_flag(home, Home).
user:file_search_path(foreign, swi(ArchLib)) :-
@ -172,8 +215,6 @@ add_separator_to_list([H|T], Separator, [H,Separator|NT]) :-
prolog:setenv(X,Y) :- unix(putenv(X,Y)).
prolog:nth1(I,L,A) :- nth(I,L,A).
prolog:prolog_to_os_filename(X,X).
prolog:is_absolute_file_name(X) :-
@ -238,26 +279,6 @@ cvt_bindings([[Name|Value]|L],[AName=Value|Bindings]) :-
'$messages':prolog_message(_,L,L).
prolog:append([],L,L).
prolog:append([X|L0],L,[X|Lf]) :-
prolog:append(L0,L,Lf).
prolog:member(X,[X|_]).
prolog:member(X,[_|L0]) :-
prolog:member(X,L0).
prolog:select(Element, [Element|Rest], Rest).
prolog:select(Element, [Head|Tail], [Head|Rest]) :-
prolog:select(Element, Tail, Rest).
tv(Term,List) :- term_variables(Term,List).
prolog:term_variables(Term,List) :- tv(Term,List).
tv(Term,List,Tail) :- term_variables(Term,List,Tail).
prolog:term_variables(Term,List,Tail) :- tv(Term,List,Tail).
prolog:working_directory(OCWD,NCWD) :-
getcwd(OCWD),
(var(NCWD) -> true ; cd(NCWD)).
@ -284,34 +305,12 @@ prolog:atom_concat(A,B,C) :- atomic_concat(A,B,C).
prolog:hash_term(X,Y) :- term_hash(X,Y).
:- meta_predicate prolog:maplist(:,?), prolog:maplist(:,?,?), prolog:maplist(:,?,?).
prolog:maplist(_, []).
prolog:maplist(G, [H|L]) :-
call(G,H),
prolog:maplist(G, L).
prolog:maplist(_, [], []).
prolog:maplist(G, [H1|L1], [H2|L2]) :-
call(G,H1,H2),
prolog:maplist(G, L1, L2).
prolog:maplist(_, [], [], []).
prolog:maplist(G, [H1|L1], [H2|L2], [H3|L3]) :-
call(G,H1,H2,H3),
prolog:maplist(G, L1, L2, L3).
prolog:make.
prolog:source_location(File,Line) :-
prolog_load_context(file, File),
prolog_load_context(term_position, '$stream_position'(_,Line,_)).
prolog:memberchk(Element, [Element|_]) :- !.
prolog:memberchk(Element, [_|Rest]) :-
prolog:memberchk(Element, Rest).
% copied from SWI lists library.
prolog:intersection([], _, []) :- !.
prolog:intersection([X|T], L, Intersect) :-

5
library/terms.yap
View File

@ -21,6 +21,7 @@
term_variables/2,
term_variables/3,
variant/2,
unifiable/3,
subsumes/2,
subsumes_chk/2,
cyclic_term/1,
@ -37,7 +38,9 @@ term_hash(T,H) :-
subsumes_chk(X,Y) :-
\+ \+ subsumes(X,Y).
unifiable(X,Y,Z) :-
protected_unifiable(X,Y,Z), !.
unifiable(_,_,_) :- fail.

50
pl/arith.yap
View File

@ -30,51 +30,47 @@ compile_expressions :- set_value('$c_arith',true).
do_not_compile_expressions :- set_value('$c_arith',[]).
'$c_built_in'(IN, M, OUT, MT) :-
'$c_built_in'(IN, M, OUT) :-
get_value('$c_arith',true), !,
'$do_c_built_in'(IN, M, OUT, MT).
'$c_built_in'(IN, _, IN, _).
'$do_c_built_in'(IN, M, OUT).
'$c_built_in'(IN, _, IN).
'$do_c_built_in'(G, M, OUT, MT) :- var(G), !,
(MT = on -> NG = G ; NG = M:G),
'$do_c_built_in'(call(NG), M, OUT, MT).
'$do_c_built_in'(Mod:G, _, GN, MT) :- !,
'$do_c_built_in'(G, Mod, GN0, MT),
'$do_c_built_in'(G, M, OUT) :- var(G), !,
'$do_c_built_in'(call(G), M, OUT).
'$do_c_built_in'(Mod:G, _, GN) :- !,
'$do_c_built_in'(G, Mod, GN0),
(GN0 = (_,_) -> GN = GN0 ; GN = Mod:GN0).
'$do_c_built_in'(\+ G, _, OUT, _) :-
'$do_c_built_in'(\+ G, _, OUT) :-
nonvar(G),
G = (A = B),
!,
OUT = (A \= B).
'$do_c_built_in'(call(G), _, OUT, _) :-
'$do_c_built_in'(call(G), _, OUT) :-
nonvar(G),
G = (Mod:G1), !,
'$do_c_built_metacall'(G1, Mod, OUT).
'$do_c_built_in'(call(G), M, OUT, off) :-
var(G), !,
'$do_c_built_metacall'(G, M, OUT).
'$do_c_built_in'(depth_bound_call(G,D), M, OUT, MT) :- !,
'$do_c_built_in'(G, M, NG, MT),
'$do_c_built_in'(depth_bound_call(G,D), M, OUT) :- !,
'$do_c_built_in'(G, M, NG),
% make sure we don't have something like (A,B) -> $depth_next(D), A, B.
( '$composed_built_in'(NG) ->
OUT = depth_bound_call(NG,D)
;
OUT = ('$set_depth_limit_for_next_call'(D),NG)
).
'$do_c_built_in'(once(G), M, (yap_hacks:current_choice_point(CP),NG,'$$cut_by'(CP)), MT) :- !,
'$do_c_built_in'(G,M,NG0, MT),
'$do_c_built_in'(once(G), M, (yap_hacks:current_choice_point(CP),NG,'$$cut_by'(CP))) :- !,
'$do_c_built_in'(G,M,NG0),
'$clean_cuts'(NG0, NG).
'$do_c_built_in'(if(G,A,B), M, (yap_hacks:current_choicepoint(DCP),NG,yap_hacks:cut_at(DCP),NA; NB), MT) :- !,
'$do_c_built_in'(A,M,NA0, MT),
'$do_c_built_in'(if(G,A,B), M, (yap_hacks:current_choicepoint(DCP),NG,yap_hacks:cut_at(DCP),NA; NB)) :- !,
'$do_c_built_in'(A,M,NA0),
'$clean_cuts'(NA0, NA),
'$do_c_built_in'(B,M,NB, MT).
'$do_c_built_in'((G*->A), M, (NG,NA), MT) :- !,
'$do_c_built_in'(G,M,NG0, MT),
'$do_c_built_in'(B,M,NB).
'$do_c_built_in'((G*->A), M, (NG,NA)) :- !,
'$do_c_built_in'(G,M,NG0),
'$clean_cuts'(NG0, NG),
'$do_c_built_in'(A,M,NA, MT).
'$do_c_built_in'('C'(A,B.C), _, (A=[B|C]), _) :- !.
'$do_c_built_in'(X is Y, _, P, _) :-
'$do_c_built_in'(A,M,NA).
'$do_c_built_in'('C'(A,B.C), _, (A=[B|C])) :- !.
'$do_c_built_in'(X is Y, _, P) :-
nonvar(Y), % Don't rewrite variables
!,
(
@ -84,7 +80,7 @@ do_not_compile_expressions :- set_value('$c_arith',[]).
'$drop_is'(X0, X, P1),
'$do_and'(P0, P1, P)
).
'$do_c_built_in'(Comp0, _, R), _ :- % now, do it for comparisons
'$do_c_built_in'(Comp0, _, R) :- % now, do it for comparisons
'$compop'(Comp0, Op, E, F),
!,
'$compop'(Comp, Op, U, V),
@ -92,7 +88,7 @@ do_not_compile_expressions :- set_value('$c_arith',[]).
'$expand_expr'(F, Q, V),
'$do_and'(P, Q, R0),
'$do_and'(R0, Comp, R).
'$do_c_built_in'(P, _, P, _).
'$do_c_built_in'(P, _, P).
'$do_c_built_metacall'(G1, Mod, '$execute_wo_mod'(G1,Mod)) :-
var(Mod), !.

8
pl/boot.yap
View File

@ -870,7 +870,13 @@ not(G) :- \+ '$execute'(G).
true
;
'$enter_undefp',
once('$find_undefp_handler'(G,M,Goal,NM))
(
swi:swi_predicate_table(M,G,NM,Goal)
->
'$exit_undefp'
;
once('$find_undefp_handler'(G,M,Goal,NM))
)
),
!,
'$execute0'(Goal,NM).

159
pl/modules.yap
View File

@ -90,8 +90,8 @@ module(N) :-
'$process_exports'([],_,[]).
'$process_exports'([Name/Arity|Exports],Mod,[Name/Arity|ExportedPreds]):- !,
'$process_exports'(Exports,Mod,ExportedPreds).
'$process_exports'([op(_Prio,_Assoc,_Name)|Exports],Mod,ExportedPreds) :- !,
% '$opdec'(_Prio,_Assoc,_Name,Mod),
'$process_exports'([op(Prio,Assoc,Name)|Exports],Mod,ExportedPreds) :- !,
op(Prio,Assoc,Name),
'$process_exports'(Exports,Mod,ExportedPreds).
'$process_exports'([Trash|_],Mod,_) :-
'$do_error'(type_error(predicate_indicator,Trash),module(Mod,[Trash])).
@ -168,7 +168,7 @@ module(N) :-
get0(C), '$skipeol'(C),
( C is "y" -> erase(R), !;
C is "n" -> !, fail;
write(user_error, ' Please answer with ''y'' or ''n'' '), fail
format(user_error, ' Please answer with ''y'' or ''n'' ',[]), fail
).
'$check_import'(_,_,_,_).
@ -181,38 +181,37 @@ module(N) :-
% expand module names in a clause
'$module_expansion'(((Mod:H) :-B ),((Mod:H) :- B1),((Mod:H) :- BO),M) :- !,
'$is_mt'(Mod,H,MT),
'$prepare_body_with_correct_modules'(B, M, MT, B0),
'$module_expansion'(((Mod:H) :- B ),((Mod:H) :- B1),((Mod:H) :- BO),M) :- !,
'$is_mt'(Mod,H,B,IB,MM),
'$prepare_body_with_correct_modules'(IB, M, B0),
'$module_u_vars'(H,UVars,M), % collect head variables in
% expanded positions
'$module_expansion'(B0,B1,BO,M,M,M,UVars,MT). % expand body
'$module_expansion'(B0,B1,BO,M,MM,M,UVars). % expand body
'$module_expansion'((H:-B),(H:-B1),(H:-BO),M) :-
'$is_mt'(Mod,H,MT),
'$is_mt'(M,H,B,IB,MM),
'$module_u_vars'(H,UVars,M), % collect head variables in
% expanded positions
'$module_expansion'(B,B1,BO,M,M,M,UVars,MT).% expand body
'$module_expansion'(IB,B1,BO,M,MM,M,UVars).
% $trace_module((H:-B),(H:-B1)).
% expand module names in a body
'$prepare_body_with_correct_modules'(V,M,MT,call(G)) :- var(V), !,
(MT = on -> G = M:V ; G = V).
'$prepare_body_with_correct_modules'((A,B),M,MT,(A1,B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,MT,A1),
'$prepare_body_with_correct_modules'(B,M,MT,B1).
'$prepare_body_with_correct_modules'((A;B),M,MT,(A1;B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,MT,A1),
'$prepare_body_with_correct_modules'(B,M,MT,B1).
'$prepare_body_with_correct_modules'((A->B),M,MT,(A1->B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,MT,A1),
'$prepare_body_with_correct_modules'(B,M,MT,B1).
'$prepare_body_with_correct_modules'(true,_,_,true) :- !.
'$prepare_body_with_correct_modules'(fail,_,_,fail) :- !.
'$prepare_body_with_correct_modules'(false,_,_,false) :- !.
'$prepare_body_with_correct_modules'(M:G,_,M:G) :- !.
'$prepare_body_with_correct_modules'(G,M,MT,G) :-
'$prepare_body_with_correct_modules'(V,M,M:call(V)) :- var(V), !.
'$prepare_body_with_correct_modules'((A,B),M,(A1,B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,A1),
'$prepare_body_with_correct_modules'(B,M,B1).
'$prepare_body_with_correct_modules'((A;B),M,(A1;B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,A1),
'$prepare_body_with_correct_modules'(B,M,B1).
'$prepare_body_with_correct_modules'((A->B),M,(A1->B1)) :- !,
'$prepare_body_with_correct_modules'(A,M,A1),
'$prepare_body_with_correct_modules'(B,M,B1).
'$prepare_body_with_correct_modules'(true,_,true) :- !.
'$prepare_body_with_correct_modules'(fail,_,fail) :- !.
'$prepare_body_with_correct_modules'(false,_,false) :- !.
'$prepare_body_with_correct_modules'(M:G,M:G) :- !.
'$prepare_body_with_correct_modules'(G,M,G) :-
'$system_predicate'(G,M), !.
'$prepare_body_with_correct_modules'(G,M,MT,M:G).
'$prepare_body_with_correct_modules'(G,M,M:G).
'$trace_module'(X) :-
@ -242,38 +241,37 @@ module(N) :-
% current module for fixing up meta-call arguments
% current module for predicate
% head variables.
'$module_expansion'(V,call(G),call(G),_M,MM,_TM,_,MT) :- var(V), !,
(MT = on -> G = V ; G = MM:V).
'$module_expansion'((A,B),(A1,B1),(AO,BO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT).
'$module_expansion'((A*->B;C),(A1*->B1;C1),(yap_hacks:current_choicepoint(DCP),AO,yap_hacks:cut_at(DCP),BO; CO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AOO,M,MM,TM,HVars,MT),
'$module_expansion'(V,call(G),call(MM:G),_M,MM,_TM,_) :- var(V), !.
'$module_expansion'((A,B),(A1,B1),(AO,BO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars).
'$module_expansion'((A*->B;C),(A1*->B1;C1),(yap_hacks:current_choicepoint(DCP),AO,yap_hacks:cut_at(DCP),BO; CO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AOO,M,MM,TM,HVars),
'$clean_cuts'(AOO, AO),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT),
'$module_expansion'(C,C1,CO,M,MM,TM,HVars,MT).
'$module_expansion'((A;B),(A1;B1),(AO;BO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT).
'$module_expansion'((A|B),(A1|B1),(AO|BO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT).
'$module_expansion'((A->B),(A1->B1),(AO->BO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AOO,M,MM,TM,HVars,MT),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars),
'$module_expansion'(C,C1,CO,M,MM,TM,HVars).
'$module_expansion'((A;B),(A1;B1),(AO;BO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars).
'$module_expansion'((A|B),(A1|B1),(AO|BO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars).
'$module_expansion'((A->B),(A1->B1),(AO->BO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AOO,M,MM,TM,HVars),
'$clean_cuts'(AOO, AO),
'$module_expansion'(B,B1,BO,M,MM,TM,HVars,MT).
'$module_expansion'(\+A,\+A1,\+AO,M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT).
'$module_expansion'(not(A),not(A1),not(AO),M,MM,TM,HVars,MT) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars,MT).
'$module_expansion'(B,B1,BO,M,MM,TM,HVars).
'$module_expansion'(\+A,\+A1,\+AO,M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars).
'$module_expansion'(not(A),not(A1),not(AO),M,MM,TM,HVars) :- !,
'$module_expansion'(A,A1,AO,M,MM,TM,HVars).
'$module_expansion'(true,true,true,_,_,_,_) :- !.
'$module_expansion'(fail,fail,fail,_,_,_,_) :- !.
'$module_expansion'(false,false,false,_,_,_,_) :- !.
% if I don't know what the module is, I cannot do anything to the goal,
% so I just put a call for later on.
'$module_expansion'(M:G,call(M:G),'$execute_wo_mod'(G,M),_,_,_,_,_) :- var(M), !.
'$module_expansion'(M:G,G1,GO,_,_,TM,HVars,MT) :-
'$module_expansion'(G,G1,GO,M,M,TM,HVars,MT).
'$module_expansion'(M:G,call(M:G),'$execute_wo_mod'(G,M),_,_,_,_) :- var(M), !.
'$module_expansion'(M:G,G1,GO,_,_,TM,HVars) :-
'$module_expansion'(G,G1,GO,M,M,TM,HVars).
% if M1 is given explicitly process G within M1's context.
% '$module_expansion'(M:G,G1,GO,_Mod,_MM,TM,HVars) :- !,
% % is this imported from some other module M1?
@ -291,26 +289,37 @@ module(N) :-
%
% next, check if this is something imported.
%
'$module_expansion'(G, G1, GO, CurMod, MM, TM, HVars,MT) :-
'$module_expansion'(G, G1, GO, CurMod, MM, TM, HVars) :-
% is this imported from some other module M1?
( '$imported_pred'(G, CurMod, GG, M1) ->
'$module_expansion'(GG, G1, GO, M1, MM, TM, HVars,MT)
'$module_expansion'(GG, G1, GO, M1, MM, TM, HVars)
;
(
% only expand meta-predicates if we are not module transparent!
MT = off,
'$meta_expansion'(CurMod, MM, G, GI, HVars)
;
GI = G
),
'$complete_goal_expansion'(GI, CurMod, MM, TM, G1, GO, HVars, MT)
(
'$meta_expansion'(CurMod, MM, G, GI, HVars)
->
true
;
GI = G
),
'$complete_goal_expansion'(GI, CurMod, MM, TM, G1, GO, HVars)
).
% be careful here not to generate an undefined exception.
'$imported_pred'(G, ImportingMod, G0, ExportingMod) :-
'$enter_undefp',
'$undefined'(G, ImportingMod),
recorded('$import','$import'(ExportingMod,ImportingMod,G0,G,_,_),_),
ExportingMod \= ImportingMod.
ExportingMod \= ImportingMod, !,
'$exit_undefp'.
'$imported_pred'(G, ImportingMod, G0, ExportingMod) :-
'$undefined'(G, ImportingMod),
swi:swi_predicate_table(ImportingMod,G,ExportingMod,G0),
ExportingMod \= ImportingMod,
'$exit_undefp'.
'$imported_pred'(G, ImportingMod, _, _) :-
'$exit_undefp',
fail.
% args are:
% goal to expand
@ -319,15 +328,15 @@ module(N) :-
% goal to pass to compiler
% goal to pass to listing
% head variables.
'$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars, MT) :-
'$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars) :-
'$pred_goal_expansion_on',
user:goal_expansion(G,M,GI), !,
'$module_expansion'(GI, G1, G2, M, CM, TM, HVars, MT).
'$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars, MT) :-
'$module_expansion'(GI, G1, G2, M, CM, TM, HVars).
'$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars) :-
'$all_system_predicate'(G,M), !,
'$c_built_in'(G, M, Gi, MT),
'$c_built_in'(G, M, Gi),
(Gi \== G ->
'$module_expansion'(Gi, _, G2, M, CM, TM, HVars, MT),
'$module_expansion'(Gi, _, G2, M, CM, TM, HVars),
% make built-in processing transparent.
(TM = M -> G1 = G ; G1 = M:G)
; TM = M ->
@ -335,8 +344,8 @@ module(N) :-
;
G2 = M:G, G1 = M:G % atts:
).
'$complete_goal_expansion'(G, Mod, _, Mod, G, G, _, _) :- !.
'$complete_goal_expansion'(G, GMod, _, _, GMod:G, GMod:G, _, _).
'$complete_goal_expansion'(G, Mod, _, Mod, G, G, _) :- !.
'$complete_goal_expansion'(G, GMod, _, _, GMod:G, GMod:G, _).
% module_transparent declaration
@ -349,14 +358,18 @@ module(N) :-
'$module_transparent'(Ps, M).
'$module_transparent'(M:D, _) :- !,
'$module_transparent'(D, M).
'$module_transparent'(F/N, M) :-
'$module_transparent'(F,M,N,_), !.
'$module_transparent'(F/N, M) :-
functor(P,F,N),
( retractall('$module_transparent'(F,M,N,_)), fail ; true),
asserta(prolog:'$module_transparent'(F,M,N,P)).
asserta(prolog:'$module_transparent'(F,M,N,P)),
'$flags'(P, M, Fl, Fl),
NFlags is Fl \/ 0x200004,
'$flags'(P, M, Fl, NFlags).
'$is_mt'(Mod,H,on) :-
'$is_mt'(M,H0,B,(context_module(CM),B),CM) :-
'$module_transparent'(_,M,_,H), !.
'$is_mt'(_,_,off).
'$is_mt'(M,_,B,B,M).
% meta_predicate declaration
% records $meta_predicate(SourceModule,Functor,Arity,Declaration)