change SWI stuff to swi directory.
This commit is contained in:
Vitor Santos Costa
64
swi/library/Makefile.in
Normal file
64
swi/library/Makefile.in
Normal file
@@ -0,0 +1,64 @@
|
||||
#
|
||||
# default base directory for YAP installation
|
||||
#
|
||||
ROOTDIR = @prefix@
|
||||
#
|
||||
# where the binary should be
|
||||
#
|
||||
BINDIR = $(ROOTDIR)/bin
|
||||
#
|
||||
# where YAP should look for binary libraries
|
||||
#
|
||||
LIBDIR=@libdir@/Yap
|
||||
#
|
||||
# where YAP should look for architecture-independent Prolog libraries
|
||||
#
|
||||
SHAREDIR=$(ROOTDIR)/share
|
||||
#
|
||||
#
|
||||
# You shouldn't need to change what follows.
|
||||
#
|
||||
INSTALL=@INSTALL@
|
||||
INSTALL_DATA=@INSTALL_DATA@
|
||||
INSTALL_PROGRAM=@INSTALL_PROGRAM@
|
||||
srcdir=@srcdir@
|
||||
YAP_EXTRAS=@YAP_EXTRAS@
|
||||
|
||||
PROGRAMS= \
|
||||
$(srcdir)/aggregate.pl \
|
||||
$(srcdir)/base64.pl \
|
||||
$(srcdir)/broadcast.pl \
|
||||
$(srcdir)/ctypes.pl \
|
||||
$(srcdir)/date.pl \
|
||||
$(srcdir)/debug.pl \
|
||||
$(srcdir)/error.pl \
|
||||
$(srcdir)/main.pl \
|
||||
$(srcdir)/maplist.pl \
|
||||
$(srcdir)/menu.pl \
|
||||
$(srcdir)/nb_set.pl \
|
||||
$(srcdir)/occurs.yap \
|
||||
$(srcdir)/operators.pl \
|
||||
$(srcdir)/option.pl \
|
||||
$(srcdir)/pairs.pl \
|
||||
$(srcdir)/predicate_options.pl \
|
||||
$(srcdir)/predopts.pl \
|
||||
$(srcdir)/prolog_clause.pl \
|
||||
$(srcdir)/prolog_colour.pl \
|
||||
$(srcdir)/prolog_source.pl \
|
||||
$(srcdir)/prolog_xref.pl \
|
||||
$(srcdir)/quintus.pl \
|
||||
$(srcdir)/readutil.pl \
|
||||
$(srcdir)/record.pl \
|
||||
$(srcdir)/settings.pl \
|
||||
$(srcdir)/shlib.pl \
|
||||
$(srcdir)/thread_pool.pl \
|
||||
$(srcdir)/url.pl \
|
||||
$(srcdir)/utf8.pl \
|
||||
$(srcdir)/win_menu.pl \
|
||||
$(srcdir)/www_browser.pl
|
||||
|
||||
|
||||
install: $(PROGRAMS)
|
||||
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
|
||||
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap; done
|
||||
|
||||
544
swi/library/aggregate.pl
Normal file
544
swi/library/aggregate.pl
Normal file
@@ -0,0 +1,544 @@
|
||||
/* $Id: aggregate.pl,v 1.4 2008-07-22 23:34:49 vsc Exp $
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2008, 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(aggretate,
|
||||
[ foreach/2, % :Generator, :Goal
|
||||
aggregate/3, % +Templ, :Goal, -Result
|
||||
aggregate/4, % +Templ, +Discrim, :Goal, -Result
|
||||
aggregate_all/3, % +Templ, :Goal, -Result
|
||||
aggregate_all/4, % +Templ, +Discrim, :Goal, -Result
|
||||
free_variables/4 % :Generator, :Template, +Vars0, -Vars
|
||||
]).
|
||||
:- use_module(library(ordsets)).
|
||||
:- use_module(library(pairs)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
:- meta_predicate
|
||||
foreach(0,0),
|
||||
aggregate(?,0,-),
|
||||
aggregate(?,?,0,-),
|
||||
aggregate_all(?,0,-),
|
||||
aggregate_all(?,?,0,-).
|
||||
|
||||
/** <module> Aggregation operators on backtrackable predicates
|
||||
|
||||
This library provides aggregating operators over the solutions of a
|
||||
predicate. The operations are a generalisation of the bagof/3, setof/3
|
||||
and findall/3 built-in predicates. The defined aggregation operations
|
||||
are counting, computing the sum, minimum, maximum, a bag of solutions
|
||||
and a set of solutions. We first give a simple example, computing the
|
||||
country with the smallest area:
|
||||
|
||||
==
|
||||
average_country_area(Name, Area) :-
|
||||
aggregate(min(A, N), country(N, A), min(Area, Name)).
|
||||
==
|
||||
|
||||
There are four aggregation predicates, distinguished on two properties.
|
||||
|
||||
$ aggregate vs. aggregate_all :
|
||||
The aggregate predicates use setof/3 (aggregate/4) or bagof/3
|
||||
(aggregate/3), dealing with existential qualified variables
|
||||
(Var^Goal) and providing multiple solutions for the remaining free
|
||||
variables in Goal. The aggregate_all/3 predicate uses findall/3,
|
||||
implicitely qualifying all free variables and providing exactly one
|
||||
solution, while aggregate_all/4 uses sort/2 over solutions and
|
||||
Distinguish (see below) generated using findall/3.
|
||||
|
||||
$ The Distinguish argument :
|
||||
The versions with 4 arguments provide a Distinguish argument that
|
||||
allow for keeping duplicate bindings of a variable in the result.
|
||||
For example, if we wish to compute the total population of all
|
||||
countries we do not want to loose results because two countries
|
||||
have the same population. Therefore we use:
|
||||
|
||||
==
|
||||
aggregate(sum(P), Name, country(Name, P), Total)
|
||||
==
|
||||
|
||||
All aggregation predicates support the following operator below in
|
||||
Template. In addition, they allow for an arbitrary named compound term
|
||||
where each of the arguments is a term from the list below. I.e. the term
|
||||
r(min(X), max(X)) computes both the minimum and maximum binding for X.
|
||||
|
||||
* count
|
||||
Count number of solutions. Same as sum(1).
|
||||
* sum(Expr)
|
||||
Sum of Expr for all solutions.
|
||||
* min(Expr)
|
||||
Minimum of Expr for all solutions.
|
||||
* min(Expr, Witness)
|
||||
A term min(Min, Witness), where Min is the minimal version
|
||||
of Expr over all Solution and Witness is any other template
|
||||
the applied to the solution that produced Min. If multiple
|
||||
solutions provide the same minimum, Witness corresponds to
|
||||
the first solution.
|
||||
* max(Expr)
|
||||
Maximum of Expr for all solutions.
|
||||
* max(Expr, Witness)
|
||||
As min(Expr, Witness), but producing the maximum result.
|
||||
* set(X)
|
||||
An ordered set with all solutions for X.
|
||||
* bag(X)
|
||||
A list of all solutions for X.
|
||||
|
||||
---+++ Acknowledgements
|
||||
|
||||
_|The development of this library was sponsored by SecuritEase,
|
||||
http://www.securitease.com
|
||||
|_
|
||||
|
||||
@compat Quintus, SICStus 4. The forall/2 is a SWI-Prolog built-in and
|
||||
term_variables/3 is a SWI-Prolog with a *|different definition|*.
|
||||
@tbd Analysing the aggregation template and compiling a predicate
|
||||
for the list aggregation can be done at compile time.
|
||||
@tbd aggregate_all/3 can be rewritten to run in constant space using
|
||||
non-backtrackable assignment on a term.
|
||||
*/
|
||||
|
||||
/*******************************
|
||||
* AGGREGATE *
|
||||
*******************************/
|
||||
|
||||
%% aggregate(+Template, :Goal, -Result) is nondet.
|
||||
%
|
||||
% Aggregate bindings in Goal according to Template. The aggregate/3
|
||||
% version performs bagof/3 on Goal.
|
||||
|
||||
aggregate(Template, Goal0, Result) :-
|
||||
template_to_pattern(bag, Template, Pattern, Goal0, Goal, Aggregate),
|
||||
bagof(Pattern, Goal, List),
|
||||
aggregate_list(Aggregate, List, Result).
|
||||
|
||||
%% aggregate(+Template, +Discriminator, :Goal, -Result) is nondet.
|
||||
%
|
||||
% Aggregate bindings in Goal according to Template. The aggregate/3
|
||||
% version performs setof/3 on Goal.
|
||||
|
||||
aggregate(Template, Discriminator, Goal0, Result) :-
|
||||
template_to_pattern(bag, Template, Pattern, Goal0, Goal, Aggregate),
|
||||
setof(Discriminator-Pattern, Goal, Pairs),
|
||||
pairs_values(Pairs, List),
|
||||
aggregate_list(Aggregate, List, Result).
|
||||
|
||||
%% aggregate_all(+Template, :Goal, -Result) is semidet.
|
||||
%
|
||||
% Aggregate bindings in Goal according to Template. The aggregate_all/3
|
||||
% version performs findall/3 on Goal.
|
||||
|
||||
aggregate_all(Template, Goal0, Result) :-
|
||||
template_to_pattern(all, Template, Pattern, Goal0, Goal, Aggregate),
|
||||
findall(Pattern, Goal, List),
|
||||
aggregate_list(Aggregate, List, Result).
|
||||
|
||||
%% aggregate_all(+Template, +Discriminator, :Goal, -Result) is semidet.
|
||||
%
|
||||
% Aggregate bindings in Goal according to Template. The aggregate_all/3
|
||||
% version performs findall/3 followed by sort/2 on Goal.
|
||||
|
||||
aggregate_all(Template, Discriminator, Goal0, Result) :-
|
||||
template_to_pattern(all, Template, Pattern, Goal0, Goal, Aggregate),
|
||||
findall(Discriminator-Pattern, Goal, Pairs0),
|
||||
sort(Pairs0, Pairs),
|
||||
pairs_values(Pairs, List),
|
||||
aggregate_list(Aggregate, List, Result).
|
||||
|
||||
|
||||
template_to_pattern(_All, Template, Pattern, Goal0, Goal, Aggregate) :-
|
||||
template_to_pattern(Template, Pattern, Post, Vars, Aggregate),
|
||||
existential_vars(Goal0, Goal1, AllVars, Vars),
|
||||
clean_body((Goal1, Post), Goal2),
|
||||
add_existential_vars(AllVars, Goal2, Goal).
|
||||
|
||||
existential_vars(Var, Var) -->
|
||||
{ var(Var) }, !.
|
||||
existential_vars(Var^G0, G) --> !,
|
||||
[Var],
|
||||
existential_vars(G0, G).
|
||||
existential_vars(G, G) -->
|
||||
[].
|
||||
|
||||
add_existential_vars([], G, G).
|
||||
add_existential_vars([H|T], G0, H^G1) :-
|
||||
add_existential_vars(T, G0, G1).
|
||||
|
||||
|
||||
%% clean_body(+Goal0, -Goal) is det.
|
||||
%
|
||||
% Remove redundant =true= from Goal0.
|
||||
|
||||
clean_body((Goal0,Goal1), Goal) :- !,
|
||||
clean_body(Goal0, GoalA),
|
||||
clean_body(Goal1, GoalB),
|
||||
( GoalA == true
|
||||
-> Goal = GoalB
|
||||
; GoalB == true
|
||||
-> Goal = GoalA
|
||||
; Goal = (GoalA,GoalB)
|
||||
).
|
||||
clean_body(Goal, Goal).
|
||||
|
||||
|
||||
%% template_to_pattern(+Template, -Pattern, -Post, -Vars, -Agregate)
|
||||
%
|
||||
% Determine which parts of the goal we must remember in the
|
||||
% findall/3 pattern.
|
||||
%
|
||||
% @param Post is a body-term that evaluates expressions to reduce
|
||||
% storage requirements.
|
||||
% @param Vars is a list of intermediate variables that must be
|
||||
% added to the existential variables for bagof/3.
|
||||
% @param Agregate defines the aggregation operation to execute.
|
||||
|
||||
template_to_pattern(sum(X), X, true, [], sum) :- var(X), !.
|
||||
template_to_pattern(sum(X0), X, X is X0, [X0], sum) :- !.
|
||||
template_to_pattern(count, 1, true, [], count) :- !.
|
||||
template_to_pattern(min(X), X, true, [], min) :- var(X), !.
|
||||
template_to_pattern(min(X0), X, X is X0, [X0], min) :- !.
|
||||
template_to_pattern(min(X0, Witness), X-Witness, X is X0, [X0], min_witness) :- !.
|
||||
template_to_pattern(max(X0), X, X is X0, [X0], max) :- !.
|
||||
template_to_pattern(max(X0, Witness), X-Witness, X is X0, [X0], max_witness) :- !.
|
||||
template_to_pattern(set(X), X, true, [], set) :- !.
|
||||
template_to_pattern(bag(X), X, true, [], bag) :- !.
|
||||
template_to_pattern(Term, Pattern, Goal, Vars, term(MinNeeded, Functor, AggregateArgs)) :-
|
||||
compound(Term), !,
|
||||
Term =.. [Functor|Args0],
|
||||
templates_to_patterns(Args0, Args, Goal, Vars, AggregateArgs),
|
||||
needs_one(AggregateArgs, MinNeeded),
|
||||
Pattern =.. [Functor|Args].
|
||||
template_to_pattern(Term, _, _, _, _) :-
|
||||
type_error(aggregate_template, Term).
|
||||
|
||||
templates_to_patterns([], [], true, [], []).
|
||||
templates_to_patterns([H0], [H], G, Vars, [A]) :- !,
|
||||
template_to_pattern(H0, H, G, Vars, A).
|
||||
templates_to_patterns([H0|T0], [H|T], (G0,G), Vars, [A0|A]) :-
|
||||
template_to_pattern(H0, H, G0, V0, A0),
|
||||
append(V0, RV, Vars),
|
||||
templates_to_patterns(T0, T, G, RV, A).
|
||||
|
||||
%% needs_one(+Ops, -OneOrZero)
|
||||
%
|
||||
% If one of the operations in Ops needs at least one answer,
|
||||
% unify OneOrZero to 1. Else 0.
|
||||
|
||||
needs_one(Ops, 1) :-
|
||||
member(Op, Ops),
|
||||
needs_one(Op), !.
|
||||
needs_one(_, 0).
|
||||
|
||||
needs_one(min).
|
||||
needs_one(min_witness).
|
||||
needs_one(max).
|
||||
needs_one(max_witness).
|
||||
|
||||
%% aggregate_list(+Op, +List, -Answer) is semidet.
|
||||
%
|
||||
% Aggregate the answer from the list produced by findall/3,
|
||||
% bagof/3 or setof/3. The latter two cases deal with compound
|
||||
% answers.
|
||||
%
|
||||
% @tbd Compile code for incremental state update, which we will use
|
||||
% for aggregate_all/3 as well. We should be using goal_expansion
|
||||
% to generate these clauses.
|
||||
|
||||
aggregate_list(bag, List0, List) :- !,
|
||||
List = List0.
|
||||
aggregate_list(set, List, Set) :- !,
|
||||
sort(List, Set).
|
||||
aggregate_list(sum, List, Sum) :-
|
||||
sumlist(List, Sum).
|
||||
aggregate_list(count, List, Count) :-
|
||||
length(List, Count).
|
||||
aggregate_list(max, List, Sum) :-
|
||||
max_list(List, Sum).
|
||||
aggregate_list(max_witness, List, max(Max, Witness)) :-
|
||||
max_pair(List, Max, Witness).
|
||||
aggregate_list(min, List, Sum) :-
|
||||
min_list(List, Sum).
|
||||
aggregate_list(min_witness, List, min(Min, Witness)) :-
|
||||
min_pair(List, Min, Witness).
|
||||
aggregate_list(term(0, Functor, Ops), List, Result) :- !,
|
||||
maplist(state0, Ops, StateArgs, FinishArgs),
|
||||
State0 =.. [Functor|StateArgs],
|
||||
aggregate_term_list(List, Ops, State0, Result0),
|
||||
finish_result(Ops, FinishArgs, Result0, Result).
|
||||
aggregate_list(term(1, Functor, Ops), [H|List], Result) :-
|
||||
H =.. [Functor|Args],
|
||||
maplist(state1, Ops, Args, StateArgs, FinishArgs),
|
||||
State0 =.. [Functor|StateArgs],
|
||||
aggregate_term_list(List, Ops, State0, Result0),
|
||||
finish_result(Ops, FinishArgs, Result0, Result).
|
||||
|
||||
aggregate_term_list([], _, State, State).
|
||||
aggregate_term_list([H|T], Ops, State0, State) :-
|
||||
step_term(Ops, H, State0, State1),
|
||||
aggregate_term_list(T, Ops, State1, State).
|
||||
|
||||
|
||||
%% min_pair(+Pairs, -Key, -Value) is det.
|
||||
%% max_pair(+Pairs, -Key, -Value) is det.
|
||||
%
|
||||
% True if Key-Value has the smallest/largest key in Pairs. If
|
||||
% multiple pairs share the smallest/largest key, the first pair is
|
||||
% returned.
|
||||
|
||||
min_pair([M0-W0|T], M, W) :-
|
||||
min_pair(T, M0, W0, M, W).
|
||||
|
||||
min_pair([], M, W, M, W).
|
||||
min_pair([M0-W0|T], M1, W1, M, W) :-
|
||||
( M0 > M1
|
||||
-> min_pair(T, M0, W0, M, W)
|
||||
; min_pair(T, M1, W1, M, W)
|
||||
).
|
||||
|
||||
max_pair([M0-W0|T], M, W) :-
|
||||
max_pair(T, M0, W0, M, W).
|
||||
|
||||
max_pair([], M, W, M, W).
|
||||
max_pair([M0-W0|T], M1, W1, M, W) :-
|
||||
( M0 > M1
|
||||
-> max_pair(T, M0, W0, M, W)
|
||||
; max_pair(T, M1, W1, M, W)
|
||||
).
|
||||
|
||||
%% step(+AggregateAction, +New, +State0, -State1).
|
||||
|
||||
step(bag, X, [X|L], L).
|
||||
step(set, X, [X|L], L).
|
||||
step(count, _, X0, X1) :-
|
||||
succ(X0, X1).
|
||||
step(sum, X, X0, X1) :-
|
||||
X1 is X0+X.
|
||||
step(max, X, X0, X1) :-
|
||||
X1 is max(X0, X).
|
||||
step(min, X, X0, X1) :-
|
||||
X1 is min(X0, X).
|
||||
step(max_witness, X-W, X0-W0, X1-W1) :-
|
||||
( X > X0
|
||||
-> X1 = X, W1 = W
|
||||
; X1 = X0, W1 = W0
|
||||
).
|
||||
step(min_witness, X-W, X0-W0, X1-W1) :-
|
||||
( X < X0
|
||||
-> X1 = X, W1 = W
|
||||
; X1 = X0, W1 = W0
|
||||
).
|
||||
step(term(Ops), Row, Row0, Row1) :-
|
||||
step_term(Ops, Row, Row0, Row1).
|
||||
|
||||
step_term(Ops, Row, Row0, Row1) :-
|
||||
functor(Row, Name, Arity),
|
||||
functor(Row1, Name, Arity),
|
||||
step_list(Ops, 1, Row, Row0, Row1).
|
||||
|
||||
step_list([], _, _, _, _).
|
||||
step_list([Op|OpT], Arg, Row, Row0, Row1) :-
|
||||
arg(Arg, Row, X),
|
||||
arg(Arg, Row0, X0),
|
||||
arg(Arg, Row1, X1),
|
||||
step(Op, X, X0, X1),
|
||||
succ(Arg, Arg1),
|
||||
step_list(OpT, Arg1, Row, Row0, Row1).
|
||||
|
||||
finish_result(Ops, Finish, R0, R) :-
|
||||
functor(R0, Functor, Arity),
|
||||
functor(R, Functor, Arity),
|
||||
finish_result(Ops, Finish, 1, R0, R).
|
||||
|
||||
finish_result([], _, _, _, _).
|
||||
finish_result([Op|OpT], [F|FT], I, R0, R) :-
|
||||
arg(I, R0, A0),
|
||||
arg(I, R, A),
|
||||
finish_result1(Op, F, A0, A),
|
||||
succ(I, I2),
|
||||
finish_result(OpT, FT, I2, R0, R).
|
||||
|
||||
finish_result1(bag, Bag0, [], Bag) :- !,
|
||||
Bag = Bag0.
|
||||
finish_result1(set, Bag, [], Set) :- !,
|
||||
sort(Bag, Set).
|
||||
finish_result1(max_witness, _, M-W, R) :- !,
|
||||
R = max(M,W).
|
||||
finish_result1(min_witness, _, M-W, R) :- !,
|
||||
R = min(M,W).
|
||||
finish_result1(_, _, A, A).
|
||||
|
||||
%% state0(+Op, -State, -Finish)
|
||||
|
||||
state0(bag, L, L).
|
||||
state0(set, L, L).
|
||||
state0(count, 0, _).
|
||||
state0(sum, 0, _).
|
||||
|
||||
%% state1(+Op, +First, -State, -Finish)
|
||||
|
||||
state1(bag, X, [X|L], L).
|
||||
state1(set, X, [X|L], L).
|
||||
state1(_, X, X, _).
|
||||
|
||||
|
||||
/*******************************
|
||||
* FOREACH *
|
||||
*******************************/
|
||||
|
||||
%% foreach(:Generator, :Goal)
|
||||
%
|
||||
% True if the conjunction of instances of Goal using the bindings
|
||||
% from Generator is true. Unlike forall/2, which runs a
|
||||
% failure-driven loop that proves Goal for each solution of
|
||||
% Generator, foreach creates a conjunction. Each member of the
|
||||
% conjunction is a copy of Goal, where the variables it shares
|
||||
% with Generator are filled with the values from the corresponding
|
||||
% solution.
|
||||
%
|
||||
% The implementation executes forall/2 if Goal does not contain
|
||||
% any variables that are not shared with Generator.
|
||||
%
|
||||
% Here is an example:
|
||||
%
|
||||
% ==
|
||||
% ?- foreach(between(1,4,X), dif(X,Y)), Y = 5.
|
||||
% Y = 5
|
||||
% ?- foreach(between(1,4,X), dif(X,Y)), Y = 3.
|
||||
% No
|
||||
% ==
|
||||
%
|
||||
% @bug Goal is copied repeatetly, which may cause problems if
|
||||
% attributed variables are involved.
|
||||
|
||||
foreach(Generator, Goal0) :-
|
||||
strip_module(Goal0, M, G),
|
||||
Goal = M:G,
|
||||
term_variables(Generator, GenVars0), sort(GenVars0, GenVars),
|
||||
term_variables(Goal, GoalVars0), sort(GoalVars0, GoalVars),
|
||||
ord_subtract(GoalVars, GenVars, SharedGoalVars),
|
||||
( SharedGoalVars == []
|
||||
-> \+ (Generator, \+Goal) % = forall(Generator, Goal)
|
||||
; ord_intersection(GenVars, GoalVars, SharedVars),
|
||||
Templ =.. [v|SharedVars],
|
||||
SharedTempl =.. [v|SharedGoalVars],
|
||||
findall(Templ, Generator, List),
|
||||
prove_list(List, Templ, SharedTempl, Goal)
|
||||
).
|
||||
|
||||
prove_list([], _, _, _).
|
||||
prove_list([H|T], Templ, SharedTempl, Goal) :-
|
||||
copy_term(Templ+SharedTempl+Goal,
|
||||
H+SharedTempl+Copy),
|
||||
Copy,
|
||||
prove_list(T, Templ, SharedTempl, Goal).
|
||||
|
||||
|
||||
%% free_variables(:Generator, +Template, +VarList0, -VarList) is det.
|
||||
%
|
||||
% In order to handle variables properly, we have to find all the
|
||||
% universally quantified variables in the Generator. All variables
|
||||
% as yet unbound are universally quantified, unless
|
||||
%
|
||||
% 1. they occur in the template
|
||||
% 2. they are bound by X^P, setof, or bagof
|
||||
%
|
||||
% free_variables(Generator, Template, OldList, NewList) finds this
|
||||
% set, using OldList as an accumulator.
|
||||
%
|
||||
% @author Richard O'Keefe
|
||||
% @author Jan Wielemaker (made some SWI-Prolog enhancements)
|
||||
% @license Public domain (from DEC10 library).
|
||||
% @tbd Distinguish between control-structures and data terms.
|
||||
% @tbd Exploit our built-in term_variables/2 at some places?
|
||||
|
||||
free_variables(Term, Bound, VarList, [Term|VarList]) :-
|
||||
var(Term),
|
||||
term_is_free_of(Bound, Term),
|
||||
list_is_free_of(VarList, Term), !.
|
||||
free_variables(Term, _Bound, VarList, VarList) :-
|
||||
var(Term), !.
|
||||
free_variables(Term, Bound, OldList, NewList) :-
|
||||
explicit_binding(Term, Bound, NewTerm, NewBound), !,
|
||||
free_variables(NewTerm, NewBound, OldList, NewList).
|
||||
free_variables(Term, Bound, OldList, NewList) :-
|
||||
functor(Term, _, N),
|
||||
free_variables(N, Term, Bound, OldList, NewList).
|
||||
|
||||
free_variables(0, _, _, VarList, VarList) :- !.
|
||||
free_variables(N, Term, Bound, OldList, NewList) :-
|
||||
arg(N, Term, Argument),
|
||||
free_variables(Argument, Bound, OldList, MidList),
|
||||
M is N-1, !,
|
||||
free_variables(M, Term, Bound, MidList, NewList).
|
||||
|
||||
% explicit_binding checks for goals known to existentially quantify
|
||||
% one or more variables. In particular \+ is quite common.
|
||||
|
||||
explicit_binding(\+ _Goal, Bound, fail, Bound ) :- !.
|
||||
explicit_binding(not(_Goal), Bound, fail, Bound ) :- !.
|
||||
explicit_binding(Var^Goal, Bound, Goal, Bound+Var) :- !.
|
||||
explicit_binding(setof(Var,Goal,Set), Bound, Goal-Set, Bound+Var) :- !.
|
||||
explicit_binding(bagof(Var,Goal,Bag), Bound, Goal-Bag, Bound+Var) :- !.
|
||||
|
||||
%% term_is_free_of(+Term, +Var) is semidet.
|
||||
%
|
||||
% True if Var does not appear in Term. This has been rewritten
|
||||
% from the DEC10 library source to exploit our non-deterministic
|
||||
% arg/3.
|
||||
|
||||
term_is_free_of(Term, Var) :-
|
||||
\+ var_in_term(Term, Var).
|
||||
|
||||
var_in_term(Term, Var) :-
|
||||
Var == Term, !.
|
||||
var_in_term(Term, Var) :-
|
||||
compound(Term),
|
||||
genarg(_, Term, Arg),
|
||||
var_in_term(Arg, Var), !.
|
||||
|
||||
|
||||
%% list_is_free_of(+List, +Var) is semidet.
|
||||
%
|
||||
% True if Var is not in List.
|
||||
|
||||
list_is_free_of([Head|Tail], Var) :-
|
||||
Head \== Var, !,
|
||||
list_is_free_of(Tail, Var).
|
||||
list_is_free_of([], _).
|
||||
|
||||
|
||||
% term_variables(+Term, +Vars0, -Vars) is det.
|
||||
%
|
||||
% True if Vars is the union of variables in Term and Vars0.
|
||||
% We cannot have this as term_variables/3 is already defined
|
||||
% as a difference-list version of term_variables/2.
|
||||
|
||||
%term_variables(Term, Vars0, Vars) :-
|
||||
% term_variables(Term+Vars0, Vars).
|
||||
230
swi/library/base64.pl
Normal file
230
swi/library/base64.pl
Normal file
@@ -0,0 +1,230 @@
|
||||
/* $Id$
|
||||
|
||||
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(base64,
|
||||
[ base64/2, % ?PlainText, ?Encoded
|
||||
base64//1 % ?PlainText
|
||||
]).
|
||||
|
||||
/** <module> Base64 encoding and decoding
|
||||
|
||||
Prolog-based base64 encoding using DCG rules. Encoding according to
|
||||
rfc2045. For example:
|
||||
|
||||
==
|
||||
1 ?- base64('Hello World', X).
|
||||
|
||||
X = 'SGVsbG8gV29ybGQ='
|
||||
|
||||
Yes
|
||||
2 ?- base64(H, 'SGVsbG8gV29ybGQ=').
|
||||
|
||||
H = 'Hello World'
|
||||
==
|
||||
|
||||
@tbd Stream I/O
|
||||
@tbd White-space introduction and parsing
|
||||
@author Jan Wielemaker
|
||||
*/
|
||||
|
||||
%% base64(+Plain, -Encoded) is det.
|
||||
%% base64(-Plain, +Encoded) is det.
|
||||
%
|
||||
% Translates between plaintext and base64 encoded atom or string.
|
||||
% See also base64//1.
|
||||
|
||||
base64(Plain, Encoded) :-
|
||||
nonvar(Plain), !,
|
||||
atom_codes(Plain, PlainCodes),
|
||||
phrase(base64(PlainCodes), EncCodes),
|
||||
atom_codes(Encoded, EncCodes).
|
||||
base64(Plain, Encoded) :-
|
||||
nonvar(Encoded), !,
|
||||
atom_codes(Encoded, EncCodes),
|
||||
phrase(base64(PlainCodes), EncCodes),
|
||||
atom_codes(Plain, PlainCodes).
|
||||
base64(_, _) :-
|
||||
throw(error(instantiation_error, _)).
|
||||
|
||||
|
||||
%% base64(+PlainText)// is det.
|
||||
%% base64(-PlainText)// is det.
|
||||
%
|
||||
% Encode/decode list of character codes using _base64_. See also
|
||||
% base64/2.
|
||||
|
||||
base64(Input) -->
|
||||
{ nonvar(Input) }, !,
|
||||
encode(Input).
|
||||
base64(Output) -->
|
||||
decode(Output).
|
||||
|
||||
|
||||
/*******************************
|
||||
* ENCODING *
|
||||
*******************************/
|
||||
|
||||
encode([I0, I1, I2|Rest]) --> !,
|
||||
[O0, O1, O2, O3],
|
||||
{ A is (I0<<16)+(I1<<8)+I2,
|
||||
O00 is (A>>18) /\ 0x3f,
|
||||
O01 is (A>>12) /\ 0x3f,
|
||||
O02 is (A>>6) /\ 0x3f,
|
||||
O03 is A /\ 0x3f,
|
||||
base64_char(O00, O0),
|
||||
base64_char(O01, O1),
|
||||
base64_char(O02, O2),
|
||||
base64_char(O03, O3)
|
||||
},
|
||||
encode(Rest).
|
||||
encode([I0, I1]) --> !,
|
||||
[O0, O1, O2, 0'=],
|
||||
{ A is (I0<<16)+(I1<<8),
|
||||
O00 is (A>>18) /\ 0x3f,
|
||||
O01 is (A>>12) /\ 0x3f,
|
||||
O02 is (A>>6) /\ 0x3f,
|
||||
base64_char(O00, O0),
|
||||
base64_char(O01, O1),
|
||||
base64_char(O02, O2)
|
||||
}.
|
||||
encode([I0]) --> !,
|
||||
[O0, O1, 0'=, 0'=],
|
||||
{ A is (I0<<16),
|
||||
O00 is (A>>18) /\ 0x3f,
|
||||
O01 is (A>>12) /\ 0x3f,
|
||||
base64_char(O00, O0),
|
||||
base64_char(O01, O1)
|
||||
}.
|
||||
encode([]) -->
|
||||
[].
|
||||
|
||||
|
||||
/*******************************
|
||||
* DECODE *
|
||||
*******************************/
|
||||
|
||||
decode(Text) -->
|
||||
[C0, C1, C2, C3], !,
|
||||
{ base64_char(B0, C0),
|
||||
base64_char(B1, C1)
|
||||
}, !,
|
||||
{ C3 == 0'=
|
||||
-> ( C2 == 0'=
|
||||
-> A is (B0<<18) + (B1<<12),
|
||||
I0 is (A>>16) /\ 0xff,
|
||||
Text = [I0|Rest]
|
||||
; base64_char(B2, C2)
|
||||
-> A is (B0<<18) + (B1<<12) + (B2<<6),
|
||||
I0 is (A>>16) /\ 0xff,
|
||||
I1 is (A>>8) /\ 0xff,
|
||||
Text = [I0,I1|Rest]
|
||||
)
|
||||
; base64_char(B2, C2),
|
||||
base64_char(B3, C3)
|
||||
-> A is (B0<<18) + (B1<<12) + (B2<<6) + B3,
|
||||
I0 is (A>>16) /\ 0xff,
|
||||
I1 is (A>>8) /\ 0xff,
|
||||
I2 is A /\ 0xff,
|
||||
Text = [I0,I1,I2|Rest]
|
||||
},
|
||||
decode(Rest).
|
||||
decode([]) -->
|
||||
[].
|
||||
|
||||
|
||||
/*******************************
|
||||
* BASIC CHARACTER ENCODING *
|
||||
*******************************/
|
||||
|
||||
base64_char(00, 0'A).
|
||||
base64_char(01, 0'B).
|
||||
base64_char(02, 0'C).
|
||||
base64_char(03, 0'D).
|
||||
base64_char(04, 0'E).
|
||||
base64_char(05, 0'F).
|
||||
base64_char(06, 0'G).
|
||||
base64_char(07, 0'H).
|
||||
base64_char(08, 0'I).
|
||||
base64_char(09, 0'J).
|
||||
base64_char(10, 0'K).
|
||||
base64_char(11, 0'L).
|
||||
base64_char(12, 0'M).
|
||||
base64_char(13, 0'N).
|
||||
base64_char(14, 0'O).
|
||||
base64_char(15, 0'P).
|
||||
base64_char(16, 0'Q).
|
||||
base64_char(17, 0'R).
|
||||
base64_char(18, 0'S).
|
||||
base64_char(19, 0'T).
|
||||
base64_char(20, 0'U).
|
||||
base64_char(21, 0'V).
|
||||
base64_char(22, 0'W).
|
||||
base64_char(23, 0'X).
|
||||
base64_char(24, 0'Y).
|
||||
base64_char(25, 0'Z).
|
||||
base64_char(26, 0'a).
|
||||
base64_char(27, 0'b).
|
||||
base64_char(28, 0'c).
|
||||
base64_char(29, 0'd).
|
||||
base64_char(30, 0'e).
|
||||
base64_char(31, 0'f).
|
||||
base64_char(32, 0'g).
|
||||
base64_char(33, 0'h).
|
||||
base64_char(34, 0'i).
|
||||
base64_char(35, 0'j).
|
||||
base64_char(36, 0'k).
|
||||
base64_char(37, 0'l).
|
||||
base64_char(38, 0'm).
|
||||
base64_char(39, 0'n).
|
||||
base64_char(40, 0'o).
|
||||
base64_char(41, 0'p).
|
||||
base64_char(42, 0'q).
|
||||
base64_char(43, 0'r).
|
||||
base64_char(44, 0's).
|
||||
base64_char(45, 0't).
|
||||
base64_char(46, 0'u).
|
||||
base64_char(47, 0'v).
|
||||
base64_char(48, 0'w).
|
||||
base64_char(49, 0'x).
|
||||
base64_char(50, 0'y).
|
||||
base64_char(51, 0'z).
|
||||
base64_char(52, 0'0).
|
||||
base64_char(53, 0'1).
|
||||
base64_char(54, 0'2).
|
||||
base64_char(55, 0'3).
|
||||
base64_char(56, 0'4).
|
||||
base64_char(57, 0'5).
|
||||
base64_char(58, 0'6).
|
||||
base64_char(59, 0'7).
|
||||
base64_char(60, 0'8).
|
||||
base64_char(61, 0'9).
|
||||
base64_char(62, 0'+).
|
||||
base64_char(63, 0'/).
|
||||
177
swi/library/broadcast.pl
Normal file
177
swi/library/broadcast.pl
Normal file
@@ -0,0 +1,177 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2006, 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(broadcast,
|
||||
[ listen/3, % Listener x Templ x Goal
|
||||
listen/2, % Templ x Goal
|
||||
unlisten/1, % Listener
|
||||
unlisten/2, % Listener x Templ
|
||||
unlisten/3, % Listener x Templ x Goal
|
||||
listening/3, % Listener x Templ x Goal
|
||||
broadcast/1, % Templ
|
||||
broadcast_request/1 % Templ
|
||||
]).
|
||||
:- meta_predicate
|
||||
listen(+, :),
|
||||
listen(+, +, :),
|
||||
unlisten(+, +, :).
|
||||
|
||||
:- dynamic
|
||||
listener/4.
|
||||
|
||||
/** <module> Event service
|
||||
|
||||
Generic broadcasting service. Broadcasts are made using the predicate
|
||||
broadcast(+Templ). All registered `listeners' will have their goal
|
||||
called. Success or failure of this is ignored. The listener can not bind
|
||||
arguments.
|
||||
|
||||
This library is particulary useful for disconnecting modules in an
|
||||
application. Modules can broadcast events such as changes, anticipating
|
||||
other modules need to react on such changes. For example, settings.pl
|
||||
broadcasts changes to settings, allowing dependent modules to react on
|
||||
changes:
|
||||
|
||||
==
|
||||
:- listing(setting(changed(http:workers, New)),
|
||||
change_workers(New)).
|
||||
|
||||
change_workers(New) :-
|
||||
setting(http:port, Port),
|
||||
http_workers(Port, New).
|
||||
==
|
||||
*/
|
||||
|
||||
%% listen(+Listener, +Templ, :Goal) is det.
|
||||
%% listen(+Templ, :Goal) is det.
|
||||
%
|
||||
% Open a channel for listening for events of the given `Templ'.
|
||||
|
||||
listen(Listener0, Templ, Goal) :-
|
||||
canonical_listener(Listener0, Listener),
|
||||
strip_module(Goal, Module, TheGoal),
|
||||
assert_listener(Templ, Listener, Module, TheGoal).
|
||||
|
||||
listen(Templ, Goal) :-
|
||||
strip_module(Goal, Module, TheGoal),
|
||||
assert_listener(Templ, Module, Module, TheGoal).
|
||||
|
||||
|
||||
%% unlisten(+Listener) is det.
|
||||
%% unlisten(+Listener, +Templ) is det.
|
||||
%% unlisten(+Listener, +Templ, :Goal) is det.
|
||||
%
|
||||
% Destroy a channel. All arguments may be variables, removing the
|
||||
% all matching listening channals.
|
||||
|
||||
unlisten(Listener0) :-
|
||||
canonical_listener(Listener0, Listener),
|
||||
retractall(listener(_, Listener, _, _)).
|
||||
unlisten(Listener0, Templ) :-
|
||||
canonical_listener(Listener0, Listener),
|
||||
retractall(listener(Templ, Listener, _, _)).
|
||||
unlisten(Listener0, Templ, Goal) :-
|
||||
canonical_listener(Listener0, Listener),
|
||||
( var(Goal)
|
||||
-> true
|
||||
; strip_module(Goal, Module, TheGoal)
|
||||
),
|
||||
retract_listener(Templ, Listener, Module, TheGoal).
|
||||
|
||||
|
||||
%% listening(?Listener, ?Templ, ?Goal) is nondet.
|
||||
%
|
||||
% returns currently open channels
|
||||
|
||||
listening(Listener0, Templ, Module:Goal) :-
|
||||
canonical_listener(Listener0, Listener),
|
||||
listener(Templ, Listener, Module, Goal).
|
||||
|
||||
|
||||
%% broadcast(+Templ) is det.
|
||||
%
|
||||
% Broadcast given event.
|
||||
|
||||
broadcast(Templ) :-
|
||||
( listener(Templ, _Listener, Module, Goal),
|
||||
( Module:Goal
|
||||
-> fail
|
||||
)
|
||||
; true
|
||||
).
|
||||
|
||||
|
||||
%% broadcast_request(+Templ) is nonet.
|
||||
%
|
||||
% Broadcast given event till accepted. Succeeds then, fail if no
|
||||
% listener accepts the call. Bindings made by the listener goal
|
||||
% are maintained. May be used to make broadcast requests.
|
||||
|
||||
broadcast_request(Templ) :-
|
||||
listener(Templ, _Listener, Module, Goal),
|
||||
Module:Goal.
|
||||
|
||||
|
||||
% {assert,retract}_listener(+Templ, +Listener, +Module, +Goal)
|
||||
%
|
||||
% Implemented as sub-predicate to ensure storage in this module.
|
||||
% Second registration is ignored. Is this ok? It avoids problems
|
||||
% using multiple registration of global listen channels.
|
||||
|
||||
assert_listener(Templ, Listener, Module, TheGoal) :-
|
||||
listener(Templ, Listener, Module, TheGoal), !.
|
||||
assert_listener(Templ, Listener, Module, TheGoal) :-
|
||||
asserta(listener(Templ, Listener, Module, TheGoal)).
|
||||
|
||||
retract_listener(Templ, Listener, Module, TheGoal) :-
|
||||
retractall(listener(Templ, Listener, Module, TheGoal)).
|
||||
|
||||
%% canonical_listener(+Raw, -Canonical)
|
||||
%
|
||||
% Entry for later optimization.
|
||||
|
||||
canonical_listener(Templ, Templ).
|
||||
|
||||
|
||||
/*******************************
|
||||
* GOAL EXPANSION *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
user:goal_expansion/2.
|
||||
|
||||
user:goal_expansion(listen(L,T,G0), listen(L,T,G)) :-
|
||||
expand_goal(G0, G).
|
||||
user:goal_expansion(listen(T,G0), listen(T,G)) :-
|
||||
expand_goal(G0, G).
|
||||
user:goal_expansion(unlisten(L,T,G0), unlisten(L,T,G)) :-
|
||||
expand_goal(G0, G).
|
||||
|
||||
32
swi/library/clp/Makefile.in
Normal file
32
swi/library/clp/Makefile.in
Normal file
@@ -0,0 +1,32 @@
|
||||
#
|
||||
# default base directory for YAP installation
|
||||
#
|
||||
ROOTDIR = @prefix@
|
||||
#
|
||||
# where the binary should be
|
||||
#
|
||||
BINDIR = $(ROOTDIR)/bin
|
||||
#
|
||||
# where YAP should look for binary libraries
|
||||
#
|
||||
LIBDIR=@libdir@/Yap
|
||||
#
|
||||
# where YAP should look for architecture-independent Prolog libraries
|
||||
#
|
||||
SHAREDIR=$(ROOTDIR)/share
|
||||
#
|
||||
#
|
||||
# You shouldn't need to change what follows.
|
||||
#
|
||||
INSTALL=@INSTALL@
|
||||
INSTALL_DATA=@INSTALL_DATA@
|
||||
INSTALL_PROGRAM=@INSTALL_PROGRAM@
|
||||
srcdir=@srcdir@
|
||||
|
||||
PROGRAMS= $(srcdir)/clp_events.pl
|
||||
|
||||
install: $(PROGRAMS)
|
||||
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
|
||||
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/clp
|
||||
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/clp; done
|
||||
|
||||
89
swi/library/clp/clp_events.pl
Normal file
89
swi/library/clp/clp_events.pl
Normal file
@@ -0,0 +1,89 @@
|
||||
/* $Id: clp_events.pl,v 1.1 2005-10-28 17:53:27 vsc Exp $
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Tom Schrijvers
|
||||
E-mail: tom.schrijvers@cs.kuleuven.ac.be
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2005, 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.
|
||||
*/
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%
|
||||
% Module for managing constraint solver events.
|
||||
%
|
||||
% Author: Tom Schrijvers
|
||||
% E-mail: tom.schrijvers@cs.kuleuven.ac.be
|
||||
% Copyright: 2005, K.U.Leuven
|
||||
%
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
:-module(clp_events,
|
||||
[
|
||||
notify/2,
|
||||
subscribe/4,
|
||||
unsubscribe/2
|
||||
]).
|
||||
|
||||
notify(V,NMod) :-
|
||||
( get_attr(V,clp_events,List) ->
|
||||
notify_list(List,NMod)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
subscribe(V,NMod,SMod,Goal) :-
|
||||
( get_attr(V,clp_events,List) ->
|
||||
put_attr(V,clp_events,[entry(NMod,SMod,Goal)|List])
|
||||
;
|
||||
put_attr(V,clp_events,[entry(NMod,SMod,Goal)])
|
||||
).
|
||||
|
||||
unsubscribe(V,SMod) :-
|
||||
( get_attr(V,clp_events,List) ->
|
||||
unsubscribe_list(List,SMod,NList),
|
||||
put_attr(V,clp_events,NList)
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
notify_list([],_).
|
||||
notify_list([entry(Mod,_,Goal)|Rest],NMod) :-
|
||||
( Mod == NMod ->
|
||||
call(Goal)
|
||||
;
|
||||
true
|
||||
),
|
||||
notify_list(Rest,NMod).
|
||||
|
||||
unsubscribe_list([],_,_).
|
||||
unsubscribe_list([Entry|Rest],SMod,List) :-
|
||||
Entry = entry(_,Mod,_),
|
||||
( Mod == SMod ->
|
||||
List = Rest
|
||||
;
|
||||
List = [Entry|Tail],
|
||||
unsubscribe_list(Rest,SMod,Tail)
|
||||
).
|
||||
|
||||
attr_unify_hook(_,_).
|
||||
134
swi/library/ctypes.pl
Normal file
134
swi/library/ctypes.pl
Normal file
@@ -0,0 +1,134 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2006, 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 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.
|
||||
*/
|
||||
|
||||
:- module(ctypes,
|
||||
[ is_alnum/1,
|
||||
is_alpha/1,
|
||||
is_ascii/1,
|
||||
is_cntrl/1,
|
||||
is_csym/1,
|
||||
is_csymf/1,
|
||||
is_digit/1,
|
||||
is_digit/3,
|
||||
is_endfile/1,
|
||||
is_endline/1,
|
||||
is_graph/1,
|
||||
is_lower/1,
|
||||
is_newline/1,
|
||||
is_newpage/1,
|
||||
is_paren/2,
|
||||
is_period/1,
|
||||
is_print/1,
|
||||
is_punct/1,
|
||||
is_quote/1,
|
||||
is_space/1,
|
||||
is_upper/1,
|
||||
is_white/1,
|
||||
to_lower/2,
|
||||
to_upper/2
|
||||
]).
|
||||
|
||||
/** <module> Character code classification
|
||||
|
||||
This file implements the functionality of the corresponding Quintus
|
||||
library based on SWI-Prolog's code_type/2 predicate. Please check the
|
||||
documentation of this predicate to find the definitions of the classes.
|
||||
|
||||
@see code_type/2
|
||||
@see char_type/2
|
||||
*/
|
||||
|
||||
is_alnum(C) :- code_type(C, alnum).
|
||||
is_alpha(C) :- code_type(C, alpha).
|
||||
is_ascii(C) :- code_type(C, ascii).
|
||||
is_cntrl(C) :- code_type(C, cntrl).
|
||||
is_csym(C) :- code_type(C, csym).
|
||||
is_csymf(C) :- code_type(C, csymf).
|
||||
is_digit(C) :- code_type(C, digit).
|
||||
is_graph(C) :- code_type(C, graph).
|
||||
is_lower(C) :- code_type(C, lower).
|
||||
is_upper(C) :- code_type(C, upper).
|
||||
is_period(C) :- code_type(C, period).
|
||||
is_endline(C) :- code_type(C, end_of_line).
|
||||
is_print(C) :- is_graph(C).
|
||||
is_punct(C) :- code_type(C, punct).
|
||||
is_quote(C) :- code_type(C, quote).
|
||||
is_space(C) :- code_type(C, space).
|
||||
is_white(C) :- code_type(C, white).
|
||||
|
||||
is_endfile(-1).
|
||||
is_newpage(12). % Control-L
|
||||
is_newline(10).
|
||||
|
||||
%% is_paren(?Open, ?Close) is semidet.
|
||||
%
|
||||
% True if Open is the open-parenthesis of Close.
|
||||
|
||||
is_paren(0'(, 0')). % Prolog is too good at this
|
||||
is_paren(0'[, 0']).
|
||||
is_paren(0'{, 0'}).
|
||||
|
||||
%% to_lower(+U, -L) is det.
|
||||
%% to_lower(-U, +L) is det.
|
||||
%
|
||||
% Succeeds if `U' is upper case character and `L' is the
|
||||
% corresponding lower case character or `U' is an ascii character,
|
||||
% but not an upper case letter and `L' is equal to `U'.
|
||||
|
||||
to_lower(U, L) :-
|
||||
code_type(L, to_lower(U)).
|
||||
|
||||
to_upper(U, L) :-
|
||||
code_type(L, to_upper(U)).
|
||||
|
||||
%% is_digit(+C, +Base, -Weight) is det.
|
||||
%% is_digit(-C, +Base, +Weight) is det.
|
||||
%
|
||||
% Succeeds if `C' is a digit using `Base' as base and `Weight'
|
||||
% represents its value. Only the base-10 case is handled by code_type.
|
||||
|
||||
is_digit(C, Base, Weight) :-
|
||||
Base == 10, !,
|
||||
code_type(C, digit(Weight)).
|
||||
is_digit(C, Base, Weight) :-
|
||||
between(2, 36, Base),
|
||||
succ(X, Base),
|
||||
between(0, X, Weight),
|
||||
is_digit(C, Weight).
|
||||
|
||||
is_digit(C, Weight) :-
|
||||
Weight < 10, !,
|
||||
plus(Weight, 0'0, C).
|
||||
is_digit(C, Weight) :-
|
||||
plus(Weight, 87, C), !. /* `a`-10 */
|
||||
is_digit(C, Weight) :-
|
||||
plus(Weight, 55, C). /* `A`-10 */
|
||||
|
||||
254
swi/library/date.pl
Normal file
254
swi/library/date.pl
Normal file
@@ -0,0 +1,254 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker and Willem Robert van Hage
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2005, 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(date,
|
||||
[ date_time_value/3, % ?Field, ?DaTime, ?Value
|
||||
parse_time/2, % +Date, -Stamp
|
||||
parse_time/3, % +Date, ?Format, -Stamp
|
||||
day_of_the_week/2 % +Date, -DayOfTheWeek
|
||||
]).
|
||||
|
||||
%% date_time_value(?Field:atom, +Struct:datime, -Value) is nondet.
|
||||
%
|
||||
% Extract values from a date-time structure. Provided fields are
|
||||
%
|
||||
% | year | integer | |
|
||||
% | month | 1..12 | |
|
||||
% | day | 1..31 | |
|
||||
% | hour | 0..23 | |
|
||||
% | minute | 0..59 | |
|
||||
% | second | 0.0..60.0 | |
|
||||
% | utc_offset | integer | Offset to UTC in seconds (positive is west) |
|
||||
% | daylight_saving | bool | Name of timezone; fails if unknown |
|
||||
% | date | date(Y,M,D) | |
|
||||
% | time | time(H,M,S) | |
|
||||
|
||||
date_time_value(year, date(Y,_,_,_,_,_,_,_,_), Y).
|
||||
date_time_value(month, date(_,M,_,_,_,_,_,_,_), M).
|
||||
date_time_value(day, date(_,_,D,_,_,_,_,_,_), D).
|
||||
date_time_value(hour, date(_,_,_,H,_,_,_,_,_), H).
|
||||
date_time_value(minute, date(_,_,_,_,M,_,_,_,_), M).
|
||||
date_time_value(second, date(_,_,_,_,_,S,_,_,_), S).
|
||||
date_time_value(utc_offset, date(_,_,_,_,_,_,O,_,_), O).
|
||||
date_time_value(time_zone, date(_,_,_,_,_,_,_,Z,_), Z) :- Z \== (-).
|
||||
date_time_value(daylight_saving, date(_,_,_,_,_,_,_,_,D), D) :- D \== (-).
|
||||
|
||||
date_time_value(date, date(Y,M,D,_,_,_,_,_,_), date(Y,M,D)).
|
||||
date_time_value(time, date(_,_,_,H,M,S,_,_,_), time(H,M,S)).
|
||||
|
||||
%% parse_time(+Text, -Stamp) is semidet.
|
||||
%% parse_time(+Text, ?Format, -Stamp) is semidet.
|
||||
%
|
||||
% Stamp is a timestamp created from parsing Text using the
|
||||
% representation Format. Currently supported formats are:
|
||||
%
|
||||
% * rfc_1123
|
||||
% Used for the HTTP protocol to represent time-stamps
|
||||
% * iso_8601
|
||||
% Commonly used in XML documents.
|
||||
|
||||
parse_time(Text, Stamp) :-
|
||||
parse_time(Text, _Format, Stamp).
|
||||
|
||||
parse_time(Text, Format, Stamp) :-
|
||||
atom_codes(Text, Codes),
|
||||
phrase(date(Format, Y,Mon,D,H,Min,S,UTCOffset), Codes), !,
|
||||
date_time_stamp(date(Y,Mon,D,H,Min,S,UTCOffset,-,-), Stamp).
|
||||
|
||||
date(iso_8601, Yr, Mon, D, H, Min, S, 0) --> % BC
|
||||
"-", date(iso_8601, Y, Mon, D, H, Min, S, 0),
|
||||
{ Yr is -1 * Y }.
|
||||
date(iso_8601, Y, Mon, D, H, Min, S, 0) -->
|
||||
year(Y),
|
||||
iso_8601_rest(Y, Mon, D, H, Min, S).
|
||||
date(rfc_1123, Y, Mon, D, H, Min, S, 0) --> % RFC 1123: "Fri, 08 Dec 2006 15:29:44 GMT"
|
||||
day_name(_), ", ", ws,
|
||||
day_of_the_month(D), ws,
|
||||
month_name(Mon), ws,
|
||||
year(Y), ws,
|
||||
hour(H), ":", minute(Min), ":", second(S), ws,
|
||||
( "GMT"
|
||||
-> []
|
||||
; []
|
||||
).
|
||||
|
||||
%% iso_8601_rest(+Year:int, -Mon, -Day, -H, -M, -S)
|
||||
%
|
||||
% Process ISO 8601 time-values after parsing the 4-digit year.
|
||||
|
||||
iso_8601_rest(_, Mon, D, H, Min, S) -->
|
||||
"-", month(Mon), "-", day(D),
|
||||
opt_time(H, Min, S).
|
||||
iso_8601_rest(_, Mon, 0, 0, 0, 0) -->
|
||||
"-", month(Mon).
|
||||
iso_8601_rest(_, Mon, D, H, Min, S) -->
|
||||
month(Mon), day(D),
|
||||
opt_time(H, Min, S).
|
||||
iso_8601_rest(_, 1, D, H, Min, S) -->
|
||||
"-", ordinal(D),
|
||||
opt_time(H, Min, S).
|
||||
iso_8601_rest(Yr, 1, D, H, Min, S) -->
|
||||
"-W", week(W), "-", day_of_the_week(DW),
|
||||
opt_time(H, Min, S),
|
||||
{ week_ordinal(Yr, W, DW, D) }.
|
||||
iso_8601_rest(Yr, 1, D, H, Min, S) -->
|
||||
"W", week(W), day_of_the_week(DW),
|
||||
opt_time(H, Min, S),
|
||||
{ week_ordinal(Yr, W, DW, D) }.
|
||||
iso_8601_rest(Yr, 1, D, 0, 0, 0) -->
|
||||
"W", week(W),
|
||||
{ week_ordinal(Yr, W, 1, D) }.
|
||||
|
||||
opt_time(Hr, Min, Sec) -->
|
||||
"T", !, iso_time(Hr, Min, Sec).
|
||||
opt_time(0, 0, 0) --> "".
|
||||
|
||||
|
||||
% TIMEX2 ISO: "2006-12-08T15:29:44 UTC" or "20061208T"
|
||||
iso_time(Hr, Min, Sec) -->
|
||||
hour(H), ":", minute(M), ":", second(S),
|
||||
timezone(DH, DM, DS),
|
||||
{ Hr is H + DH, Min is M + DM, Sec is S + DS }.
|
||||
iso_time(Hr, Min, Sec) -->
|
||||
hour(H), ":", minute(M),
|
||||
timezone(DH, DM, DS),
|
||||
{ Hr is H + DH, Min is M + DM, Sec is DS }.
|
||||
iso_time(Hr, Min, Sec) -->
|
||||
hour(H), minute(M), second(S),
|
||||
timezone(DH, DM, DS),
|
||||
{ Hr is H + DH, Min is M + DM, Sec is S + DS }.
|
||||
iso_time(Hr, Min, Sec) -->
|
||||
hour(H), minute(M),
|
||||
timezone(DH, DM, DS),
|
||||
{ Hr is H + DH, Min is M + DM, Sec is DS }.
|
||||
iso_time(Hr, Min, Sec) -->
|
||||
hour(H),
|
||||
timezone(DH, DM, DS),
|
||||
{ Hr is H + DH, Min is DM, Sec is DS }.
|
||||
|
||||
% FIXME: deal with leap seconds
|
||||
timezone(Hr, Min, 0) -->
|
||||
"+", hour(H), ":", minute(M), { Hr is -1 * H, Min is -1 * M }.
|
||||
timezone(Hr, Min, 0) -->
|
||||
"+", hour(H), minute(M), { Hr is -1 * H, Min is -1 * M }.
|
||||
timezone(Hr, 0, 0) -->
|
||||
"+", hour(H), { Hr is -1 * H }.
|
||||
timezone(Hr, Min, 0) -->
|
||||
"-", hour(H), ":", minute(M), { Hr is H, Min is M }.
|
||||
timezone(Hr, Min, 0) -->
|
||||
"-", hour(H), minute(M), { Hr is H, Min is M }.
|
||||
timezone(Hr, 0, 0) -->
|
||||
"-", hour(H), { Hr is H }.
|
||||
timezone(0, 0, 0) -->
|
||||
"Z".
|
||||
timezone(0, 0, 0) -->
|
||||
ws, "UTC".
|
||||
timezone(0, 0, 0) -->
|
||||
ws, "GMT". % remove this?
|
||||
timezone(0, 0, 0) -->
|
||||
[].
|
||||
|
||||
day_name(0) --> "Sun".
|
||||
day_name(1) --> "Mon".
|
||||
day_name(2) --> "Tue".
|
||||
day_name(3) --> "Wed".
|
||||
day_name(4) --> "Thu".
|
||||
day_name(5) --> "Fri".
|
||||
day_name(6) --> "Sat".
|
||||
day_name(7) --> "Sun".
|
||||
|
||||
month_name(1) --> "Jan".
|
||||
month_name(2) --> "Feb".
|
||||
month_name(3) --> "Mar".
|
||||
month_name(4) --> "Apr".
|
||||
month_name(5) --> "May".
|
||||
month_name(6) --> "Jun".
|
||||
month_name(7) --> "Jul".
|
||||
month_name(8) --> "Aug".
|
||||
month_name(9) --> "Sep".
|
||||
month_name(10) --> "Oct".
|
||||
month_name(11) --> "Nov".
|
||||
month_name(12) --> "Dec".
|
||||
|
||||
day_of_the_month(N) --> int2digit(N), { between(1, 31, N) }.
|
||||
day_of_the_week(N) --> digit(N), { between(1, 7, N) }.
|
||||
month(M) --> int2digit(M), { between(1, 12, M) }.
|
||||
week(W) --> int2digit(W), { between(1, 53, W) }.
|
||||
day(D) --> int2digit(D), { between(1, 31, D) }.
|
||||
hour(N) --> int2digit(N), { between(0, 23, N) }.
|
||||
minute(N) --> int2digit(N), { between(0, 59, N) }.
|
||||
second(N) --> int2digit(N), { between(0, 60, N) }. % leap second
|
||||
|
||||
int2digit(N) -->
|
||||
digit(D0),
|
||||
digit(D1),
|
||||
{ N is D0*10+D1 }.
|
||||
|
||||
year(Y) -->
|
||||
digit(D0),
|
||||
digit(D1),
|
||||
digit(D2),
|
||||
digit(D3),
|
||||
{ Y is D0*1000+D1*100+D2*10+D3 }.
|
||||
|
||||
ordinal(N) --> % Nth day of the year, jan 1 = 1, dec 31 = 365 or 366
|
||||
digit(D0),
|
||||
digit(D1),
|
||||
digit(D2),
|
||||
{ N is D0*100+D1*10+D2, between(1, 366, N) }.
|
||||
|
||||
digit(D) -->
|
||||
[C],
|
||||
{ code_type(C, digit(D)) }.
|
||||
|
||||
ws -->
|
||||
" ", !,
|
||||
ws.
|
||||
ws -->
|
||||
[].
|
||||
|
||||
%% day_of_the_week(+Date, -DayOfTheWeek) is det.
|
||||
%
|
||||
% Computes the day of the week for a given date.
|
||||
% Days of the week are numbered from one to seven:
|
||||
% monday = 1, tuesday = 2, ..., sunday = 7.
|
||||
%
|
||||
% @param Date is a term of the form date(+Year, +Month, +Day)
|
||||
|
||||
day_of_the_week(date(Year, Mon, Day), DotW) :-
|
||||
format_time(atom(A), '%u', date(Year, Mon, Day, 0, 0, 0, 0, -, -)),
|
||||
atom_number(A, DotW).
|
||||
|
||||
week_ordinal(Year, Week, Day, Ordinal) :-
|
||||
format_time(atom(A), '%w', date(Year, 1, 1, 0, 0, 0, 0, -, -)),
|
||||
atom_number(A, DotW0),
|
||||
Ordinal is ((Week-1) * 7) - DotW0 + Day + 1.
|
||||
|
||||
400
swi/library/debug.pl
Normal file
400
swi/library/debug.pl
Normal file
@@ -0,0 +1,400 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2012, University of Amsterdam
|
||||
VU University 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 Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(prolog_debug,
|
||||
[ debug/3, % +Topic, +Format, :Args
|
||||
debug/1, % +Topic
|
||||
nodebug/1, % +Topic
|
||||
debugging/1, % ?Topic
|
||||
debugging/2, % ?Topic, ?Bool
|
||||
list_debug_topics/0,
|
||||
debug_message_context/1, % (+|-)What
|
||||
|
||||
assertion/1 % :Goal
|
||||
]).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(lists)).
|
||||
:- set_prolog_flag(generate_debug_info, false).
|
||||
|
||||
:- meta_predicate
|
||||
assertion(0),
|
||||
debug(+,+,:).
|
||||
|
||||
:- multifile prolog:assertion_failed/2.
|
||||
:- dynamic prolog:assertion_failed/2.
|
||||
|
||||
/*:- use_module(library(prolog_stack)).*/ % We use the autoloader if needed
|
||||
|
||||
:- if(current_prolog_flag(dialect, yap)).
|
||||
|
||||
:- use_module(library(hacks), [stack_dump/1]).
|
||||
|
||||
% this is as good as I can do.
|
||||
backtrace(N) :-
|
||||
stack_dump(N).
|
||||
|
||||
:- endif.
|
||||
|
||||
%:- set_prolog_flag(generate_debug_info, false).
|
||||
|
||||
:- dynamic
|
||||
debugging/3, % Topic, Enabled, To
|
||||
debug_context/1.
|
||||
|
||||
debug_context(thread).
|
||||
|
||||
/** <module> Print debug messages and test assertions
|
||||
|
||||
This library is a replacement for format/3 for printing debug messages.
|
||||
Messages are assigned a _topic_. By dynamically enabling or disabling
|
||||
topics the user can select desired messages. Debug statements are
|
||||
removed when the code is compiled for optimization.
|
||||
|
||||
See manual for details. With XPCE, you can use the call below to start a
|
||||
graphical monitoring tool.
|
||||
|
||||
==
|
||||
?- prolog_ide(debug_monitor).
|
||||
==
|
||||
|
||||
Using the predicate assertion/1 you can make assumptions about your
|
||||
program explicit, trapping the debugger if the condition does not hold.
|
||||
|
||||
@author Jan Wielemaker
|
||||
*/
|
||||
|
||||
%% debugging(+Topic) is semidet.
|
||||
%% debugging(-Topic) is nondet.
|
||||
%% debugging(?Topic, ?Bool) is nondet.
|
||||
%
|
||||
% Examine debug topics. The form debugging(+Topic) may be used to
|
||||
% perform more complex debugging tasks. A typical usage skeleton
|
||||
% is:
|
||||
%
|
||||
% ==
|
||||
% ( debugging(mytopic)
|
||||
% -> <perform debugging actions>
|
||||
% ; true
|
||||
% ),
|
||||
% ...
|
||||
% ==
|
||||
%
|
||||
% The other two calls are intended to examine existing and enabled
|
||||
% debugging tokens and are typically not used in user programs.
|
||||
|
||||
debugging(Topic) :-
|
||||
debugging(Topic, true, _To).
|
||||
|
||||
debugging(Topic, Bool) :-
|
||||
debugging(Topic, Bool, _To).
|
||||
|
||||
%% debug(+Topic) is det.
|
||||
%% nodebug(+Topic) is det.
|
||||
%
|
||||
% Add/remove a topic from being printed. nodebug(_) removes all
|
||||
% topics. Gives a warning if the topic is not defined unless it is
|
||||
% used from a directive. The latter allows placing debug topics at
|
||||
% the start of a (load-)file without warnings.
|
||||
%
|
||||
% For debug/1, Topic can be a term Topic > Out, where Out is
|
||||
% either a stream or stream-alias or a filename (atom). This
|
||||
% redirects debug information on this topic to the given output.
|
||||
|
||||
debug(Topic) :-
|
||||
debug(Topic, true).
|
||||
nodebug(Topic) :-
|
||||
debug(Topic, false).
|
||||
|
||||
debug(Spec, Val) :-
|
||||
debug_target(Spec, Topic, Out),
|
||||
( ( retract(debugging(Topic, Enabled0, To0))
|
||||
*-> update_debug(Enabled0, To0, Val, Out, Enabled, To),
|
||||
assert(debugging(Topic, Enabled, To)),
|
||||
fail
|
||||
; ( prolog_load_context(file, _)
|
||||
-> true
|
||||
; print_message(warning, debug_no_topic(Topic))
|
||||
),
|
||||
update_debug(false, [], Val, Out, Enabled, To),
|
||||
assert(debugging(Topic, Enabled, To))
|
||||
)
|
||||
-> true
|
||||
; true
|
||||
).
|
||||
|
||||
debug_target(Spec, Topic, To) :-
|
||||
nonvar(Spec),
|
||||
Spec = (Topic > To), !.
|
||||
debug_target(Topic, Topic, -).
|
||||
|
||||
update_debug(_, To0, true, -, true, To) :- !,
|
||||
ensure_output(To0, To).
|
||||
update_debug(true, To0, true, Out, true, Output) :- !,
|
||||
append(To0, [Out], Output).
|
||||
update_debug(false, _, true, Out, true, [Out]) :- !.
|
||||
update_debug(_, _, false, -, false, []) :- !.
|
||||
update_debug(true, [Out], false, Out, false, []) :- !.
|
||||
update_debug(true, To0, false, Out, true, Output) :- !,
|
||||
delete(To0, Out, Output).
|
||||
|
||||
ensure_output([], [user_error]) :- !.
|
||||
ensure_output(List, List).
|
||||
|
||||
%% debug_topic(+Topic) is det.
|
||||
%
|
||||
% Declare a topic for debugging. This can be used to find all
|
||||
% topics available for debugging.
|
||||
|
||||
debug_topic(Topic) :-
|
||||
( debugging(Registered, _, _),
|
||||
Registered =@= Topic
|
||||
-> true
|
||||
; assert(debugging(Topic, false, []))
|
||||
).
|
||||
|
||||
%% list_debug_topics is det.
|
||||
%
|
||||
% List currently known debug topics and their setting.
|
||||
|
||||
list_debug_topics :-
|
||||
format(user_error, '~*t~45|~n', "-"),
|
||||
format(user_error, '~w~t ~w~35| ~w~n',
|
||||
['Debug Topic', 'Activated', 'To']),
|
||||
format(user_error, '~*t~45|~n', "-"),
|
||||
( debugging(Topic, Value, To),
|
||||
format(user_error, '~w~t ~w~35| ~w~n', [Topic, Value, To]),
|
||||
fail
|
||||
; true
|
||||
).
|
||||
|
||||
%% debug_message_context(+What) is det.
|
||||
%
|
||||
% Specify additional context for debug messages. What is one of
|
||||
% +Context or -Context, and Context is one of =thread=, =time= or
|
||||
% time(Format), where Format is a format specification for
|
||||
% format_time/3 (default is =|%T.%3f|=). Initially, debug/3 shows
|
||||
% only thread information.
|
||||
|
||||
debug_message_context(+Topic) :- !,
|
||||
valid_topic(Topic, Del, Add),
|
||||
retractall(debug_context(Del)),
|
||||
assert(debug_context(Add)).
|
||||
debug_message_context(-Topic) :- !,
|
||||
valid_topic(Topic, Del, _),
|
||||
retractall(debug_context(Del)).
|
||||
debug_message_context(Term) :-
|
||||
type_error(debug_message_context, Term).
|
||||
|
||||
valid_topic(thread, thread, thread) :- !.
|
||||
valid_topic(time, time(_), time('%T.%3f')) :- !.
|
||||
valid_topic(time(Format), time(_), time(Format)) :- !.
|
||||
valid_topic(X, _, _) :-
|
||||
domain_error(debug_message_context, X).
|
||||
|
||||
|
||||
%% debug(+Topic, +Format, :Args) is det.
|
||||
%
|
||||
% Format a message if debug topic is enabled. Similar to format/3
|
||||
% to =user_error=, but only prints if Topic is activated through
|
||||
% debug/1. Args is a meta-argument to deal with goal for the
|
||||
% @-command. Output is first handed to the hook
|
||||
% prolog:debug_print_hook/3. If this fails, Format+Args is
|
||||
% translated to text using the message-translation (see
|
||||
% print_message/2) for the term debug(Format, Args) and then
|
||||
% printed to every matching destination (controlled by debug/1)
|
||||
% using print_message_lines/3.
|
||||
%
|
||||
% The message is preceded by '% ' and terminated with a newline.
|
||||
%
|
||||
% @see format/3.
|
||||
|
||||
debug(Topic, Format, Args) :-
|
||||
debugging(Topic, true, To), !,
|
||||
print_debug(Topic, To, Format, Args).
|
||||
debug(_, _, _).
|
||||
|
||||
|
||||
%% prolog:debug_print_hook(+Topic, +Format, +Args) is semidet.
|
||||
%
|
||||
% Hook called by debug/3. This hook is used by the graphical
|
||||
% frontend that can be activated using prolog_ide/1:
|
||||
%
|
||||
% ==
|
||||
% ?- prolog_ide(debug_monitor).
|
||||
% ==
|
||||
|
||||
:- multifile
|
||||
prolog:debug_print_hook/3.
|
||||
|
||||
print_debug(Topic, _To, Format, Args) :-
|
||||
prolog:debug_print_hook(Topic, Format, Args), !.
|
||||
print_debug(_, [], _, _) :- !.
|
||||
print_debug(Topic, To, Format, Args) :-
|
||||
phrase('$messages':translate_message(debug(Format, Args)), Lines),
|
||||
( member(T, To),
|
||||
debug_output(T, Stream),
|
||||
print_message_lines(Stream, kind(debug(Topic)), Lines),
|
||||
fail
|
||||
; true
|
||||
).
|
||||
|
||||
|
||||
debug_output(user, user_error) :- !.
|
||||
debug_output(Stream, Stream) :-
|
||||
is_stream(Stream), !.
|
||||
debug_output(File, Stream) :-
|
||||
open(File, append, Stream,
|
||||
[ close_on_abort(false),
|
||||
alias(File),
|
||||
buffer(line)
|
||||
]).
|
||||
|
||||
|
||||
/*******************************
|
||||
* ASSERTION *
|
||||
*******************************/
|
||||
|
||||
%% assertion(:Goal) is det.
|
||||
%
|
||||
% Acts similar to C assert() macro. It has no effect if Goal
|
||||
% succeeds. If Goal fails or throws an exception, the following
|
||||
% steps are taken:
|
||||
%
|
||||
% * call prolog:assertion_failed/2. If prolog:assertion_failed/2
|
||||
% fails, then:
|
||||
%
|
||||
% - If this is an interactive toplevel thread, print a
|
||||
% message, the stack-trace, and finally trap the debugger.
|
||||
% - Otherwise, throw error(assertion_error(Reason, G),_) where
|
||||
% Reason is one of =fail= or the exception raised.
|
||||
|
||||
assertion(G) :-
|
||||
\+ \+ catch(G,
|
||||
Error,
|
||||
assertion_failed(Error, G)),
|
||||
!.
|
||||
assertion(G) :-
|
||||
assertion_failed(fail, G),
|
||||
assertion_failed. % prevent last call optimization.
|
||||
|
||||
assertion_failed(Reason, G) :-
|
||||
prolog:assertion_failed(Reason, G), !.
|
||||
assertion_failed(Reason, G) :-
|
||||
print_message(error, assertion_failed(Reason, G)),
|
||||
backtrace(10),
|
||||
( current_prolog_flag(break_level, _) % interactive thread
|
||||
-> trace
|
||||
; throw(error(assertion_error(Reason, G), _))
|
||||
).
|
||||
|
||||
assertion_failed.
|
||||
|
||||
%% assume(:Goal) is det.
|
||||
%
|
||||
% Acts similar to C assert() macro. It has no effect of Goal
|
||||
% succeeds. If Goal fails it prints a message, a stack-trace
|
||||
% and finally traps the debugger.
|
||||
%
|
||||
% @deprecated Use assertion/1 in new code.
|
||||
|
||||
/*******************************
|
||||
* EXPANSION *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
system:goal_expansion/2.
|
||||
|
||||
system:goal_expansion(debug(Topic,_,_), true) :-
|
||||
( current_prolog_flag(optimise, true)
|
||||
-> true
|
||||
; debug_topic(Topic),
|
||||
fail
|
||||
).
|
||||
system:goal_expansion(debugging(Topic), fail) :-
|
||||
( current_prolog_flag(optimise, true)
|
||||
-> true
|
||||
; debug_topic(Topic),
|
||||
fail
|
||||
).
|
||||
system:goal_expansion(assertion(_), Goal) :-
|
||||
current_prolog_flag(optimise, true),
|
||||
Goal = true.
|
||||
system:goal_expansion(assume(_), Goal) :-
|
||||
print_message(informational,
|
||||
compatibility(renamed(assume/1, assertion/1))),
|
||||
current_prolog_flag(optimise, true),
|
||||
Goal = true.
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(assertion_failed(_, G)) -->
|
||||
[ 'Assertion failed: ~q'-[G] ].
|
||||
prolog:message(debug(Fmt, Args)) -->
|
||||
show_thread_context,
|
||||
show_time_context,
|
||||
[ Fmt-Args ].
|
||||
prolog:message(debug_no_topic(Topic)) -->
|
||||
[ '~q: no matching debug topic (yet)'-[Topic] ].
|
||||
|
||||
show_thread_context -->
|
||||
{ debug_context(thread),
|
||||
thread_self(Me) ,
|
||||
Me \== main
|
||||
},
|
||||
[ '[Thread ~w] '-[Me] ].
|
||||
show_thread_context -->
|
||||
[].
|
||||
|
||||
show_time_context -->
|
||||
{ debug_context(time(Format)),
|
||||
get_time(Now),
|
||||
format_time(string(S), Format, Now)
|
||||
},
|
||||
[ '[~w] '-[S] ].
|
||||
show_time_context -->
|
||||
[].
|
||||
|
||||
/*******************************
|
||||
* HOOKS *
|
||||
*******************************/
|
||||
|
||||
%% prolog:assertion_failed(+Reason, +Goal) is semidet.
|
||||
%
|
||||
% This hook is called if the Goal of assertion/1 fails. Reason is
|
||||
% unified with either =fail= if Goal simply failed or an exception
|
||||
% call otherwise. If this hook fails, the default behaviour is
|
||||
% activated. If the hooks throws an exception it will be
|
||||
% propagated into the caller of assertion/1.
|
||||
248
swi/library/error.pl
Normal file
248
swi/library/error.pl
Normal file
@@ -0,0 +1,248 @@
|
||||
/* $Id: error.pl,v 1.3 2008-07-22 23:34:49 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(error,
|
||||
[ type_error/2, % +Type, +Term
|
||||
domain_error/2, % +Domain, +Term
|
||||
existence_error/2, % +Type, +Term
|
||||
permission_error/3, % +Action, +Type, +Term
|
||||
instantiation_error/1, % +Term
|
||||
representation_error/1, % +Reason
|
||||
|
||||
must_be/2, % +Type, +Term
|
||||
is_of_type/2 % +Type, +Term
|
||||
]).
|
||||
|
||||
:- if(current_prolog_flag(dialect, yap)).
|
||||
|
||||
:- use_module(library(lists),[memberchk/2]).
|
||||
|
||||
:- endif.
|
||||
|
||||
/** <module> Error generating support
|
||||
|
||||
This module provides predicates to simplify error generation and
|
||||
checking. It's implementation is based on a discussion on the SWI-Prolog
|
||||
mailinglist on best practices in error handling. The utility predicate
|
||||
must_be/2 provides simple run-time type validation. The *_error
|
||||
predicates are simple wrappers around throw/1 to simplify throwing the
|
||||
most common ISO error terms.
|
||||
|
||||
@author Jan Wielemaker
|
||||
@author Richard O'Keefe
|
||||
@see library(debug) and library(prolog_stack).
|
||||
*/
|
||||
|
||||
:- multifile
|
||||
has_type/2.
|
||||
|
||||
%% type_error(+Type, +Term).
|
||||
%% domain_error(+Type, +Term).
|
||||
%% existence_error(+Type, +Term).
|
||||
%% permission_error(+Action, +Type, +Term).
|
||||
%% instantiation_error(+Term).
|
||||
%% representation_error(+Reason).
|
||||
%
|
||||
% Throw ISO compliant error messages.
|
||||
|
||||
type_error(Type, Term) :-
|
||||
throw(error(type_error(Type, Term), _)).
|
||||
domain_error(Type, Term) :-
|
||||
throw(error(domain_error(Type, Term), _)).
|
||||
existence_error(Type, Term) :-
|
||||
throw(error(existence_error(Type, Term), _)).
|
||||
permission_error(Action, Type, Term) :-
|
||||
throw(error(permission_error(Action, Type, Term), _)).
|
||||
instantiation_error(_Term) :-
|
||||
throw(error(instantiation_error, _)).
|
||||
representation_error(Reason) :-
|
||||
throw(error(representation_error(Reason), _)).
|
||||
|
||||
%% must_be(+Type, @Term) is det.
|
||||
%
|
||||
% True if Term satisfies the type constraints for Type. Defined
|
||||
% types are =atom=, =atomic=, =between=, =boolean=, =callable=,
|
||||
% =chars=, =codes=, =text=, =compound=, =constant=, =float=,
|
||||
% =integer=, =nonneg=, =positive_integer=, =negative_integer=,
|
||||
% =nonvar=, =number=, =oneof=, =list=, =list_or_partial_list=,
|
||||
% =symbol=, =var=, =rational= and =string=.
|
||||
%
|
||||
% Most of these types are defined by an arity-1 built-in predicate
|
||||
% of the same name. Below is a brief definition of the other
|
||||
% types.
|
||||
%
|
||||
% | boolean | one of =true= or =false= |
|
||||
% | chars | Proper list of 1-character atoms |
|
||||
% | codes | Proper list of Unicode character codes |
|
||||
% | text | One of =atom=, =string=, =chars= or =codes= |
|
||||
% | between(L,U) | Number between L and U (including L and U) |
|
||||
% | nonneg | Integer >= 0 |
|
||||
% | positive_integer | Integer > 0 |
|
||||
% | negative_integer | Integer < 0 |
|
||||
% | oneof(L) | Ground term that is member of L |
|
||||
% | list(Type) | Proper list with elements of Type |
|
||||
% | list_or_partial_list | A list or an open list (ending in a variable |
|
||||
%
|
||||
% @throws instantiation_error if Term is insufficiently
|
||||
% instantiated and type_error(Type, Term) if Term is not of Type.
|
||||
|
||||
must_be(Type, X) :-
|
||||
( has_type(Type, X)
|
||||
-> true
|
||||
; is_not(Type, X)
|
||||
).
|
||||
|
||||
%% is_not(+Type, @Term)
|
||||
%
|
||||
% Throws appropriate error. It is _known_ that Term is not of type
|
||||
% Type.
|
||||
%
|
||||
% @throws type_error(Type, Term)
|
||||
% @throws instantiation_error
|
||||
|
||||
is_not(list, X) :- !,
|
||||
not_a_list(list, X).
|
||||
is_not(list(_), X) :- !,
|
||||
not_a_list(list, X).
|
||||
is_not(list_or_partial_list, X) :- !,
|
||||
type_error(list, X).
|
||||
is_not(chars, X) :- !,
|
||||
not_a_list(chars, X).
|
||||
is_not(codes, X) :- !,
|
||||
not_a_list(codes, X).
|
||||
is_not(var,_X) :- !,
|
||||
representation_error(variable).
|
||||
is_not(rational, X) :- !,
|
||||
not_a_rational(X).
|
||||
is_not(Type, X) :-
|
||||
( var(X)
|
||||
-> instantiation_error(X)
|
||||
; ground_type(Type), \+ ground(X)
|
||||
-> instantiation_error(X)
|
||||
; type_error(Type, X)
|
||||
).
|
||||
|
||||
ground_type(ground).
|
||||
ground_type(oneof(_)).
|
||||
ground_type(stream).
|
||||
ground_type(text).
|
||||
ground_type(string).
|
||||
|
||||
not_a_list(Type, X) :-
|
||||
'$skip_list'(_, X, Rest),
|
||||
( var(Rest)
|
||||
-> instantiation_error(X)
|
||||
; type_error(Type, X)
|
||||
).
|
||||
|
||||
not_a_rational(X) :-
|
||||
( var(X)
|
||||
-> instantiation_error(X)
|
||||
; X = rdiv(N,D)
|
||||
-> must_be(integer, N), must_be(integer, D),
|
||||
type_error(rational,X)
|
||||
; type_error(rational,X)
|
||||
).
|
||||
|
||||
%% is_of_type(+Type, @Term) is semidet.
|
||||
%
|
||||
% True if Term satisfies Type.
|
||||
|
||||
is_of_type(Type, Term) :-
|
||||
has_type(Type, Term).
|
||||
|
||||
|
||||
%% has_type(+Type, @Term) is semidet.
|
||||
%
|
||||
% True if Term satisfies Type.
|
||||
|
||||
has_type(impossible, _) :- instantiation_error(_).
|
||||
has_type(any, _).
|
||||
has_type(atom, X) :- atom(X).
|
||||
has_type(atomic, X) :- atomic(X).
|
||||
has_type(between(L,U), X) :- ( integer(L)
|
||||
-> integer(X), between(L,U,X)
|
||||
; number(X), X >= L, X =< U
|
||||
).
|
||||
has_type(boolean, X) :- (X==true;X==false), !.
|
||||
has_type(callable, X) :- callable(X).
|
||||
has_type(chars, X) :- chars(X).
|
||||
has_type(codes, X) :- codes(X).
|
||||
has_type(text, X) :- text(X).
|
||||
has_type(compound, X) :- compound(X).
|
||||
has_type(constant, X) :- atomic(X).
|
||||
has_type(float, X) :- float(X).
|
||||
has_type(ground, X) :- ground(X).
|
||||
has_type(integer, X) :- integer(X).
|
||||
has_type(nonneg, X) :- integer(X), X >= 0.
|
||||
has_type(positive_integer, X) :- integer(X), X > 0.
|
||||
has_type(negative_integer, X) :- integer(X), X < 0.
|
||||
has_type(nonvar, X) :- nonvar(X).
|
||||
has_type(number, X) :- number(X).
|
||||
has_type(oneof(L), X) :- ground(X), memberchk(X, L).
|
||||
has_type(proper_list, X) :- is_list(X).
|
||||
has_type(list, X) :- is_list(X).
|
||||
has_type(list_or_partial_list, X) :- is_list_or_partial_list(X).
|
||||
has_type(symbol, X) :- atom(X).
|
||||
has_type(var, X) :- var(X).
|
||||
has_type(rational, X) :- rational(X).
|
||||
has_type(string, X) :- string(X).
|
||||
has_type(stream, X) :- is_stream(X).
|
||||
has_type(list(Type), X) :- is_list(X), element_types(X, Type).
|
||||
|
||||
chars(0) :- !, fail.
|
||||
chars([]).
|
||||
chars([H|T]) :-
|
||||
atom(H), atom_length(H, 1),
|
||||
chars(T).
|
||||
|
||||
codes(x) :- !, fail.
|
||||
codes([]).
|
||||
codes([H|T]) :-
|
||||
integer(H), between(1, 0x10ffff, H),
|
||||
codes(T).
|
||||
|
||||
text(X) :-
|
||||
( atom(X)
|
||||
; string(X)
|
||||
; chars(X)
|
||||
; codes(X)
|
||||
), !.
|
||||
|
||||
element_types([], _).
|
||||
element_types([H|T], Type) :-
|
||||
must_be(Type, H),
|
||||
element_types(T, Type).
|
||||
|
||||
is_list_or_partial_list(L0) :-
|
||||
'$skip_list'(_, L0,L),
|
||||
( var(L) -> true ; L == [] ).
|
||||
|
||||
114
swi/library/main.pl
Normal file
114
swi/library/main.pl
Normal file
@@ -0,0 +1,114 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2011, University of Amsterdam
|
||||
VU University 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 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.
|
||||
*/
|
||||
|
||||
:- module(prolog_main,
|
||||
[ main/0
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
/** <module> Provide entry point for scripts
|
||||
|
||||
This library is intended for supporting PrologScript on Unix using the
|
||||
=|#!|= magic sequence for scripts using commandline options. The entry
|
||||
point main/0 calls the user-supplied predicate main/1 passing a list of
|
||||
commandline options. Below is `echo' in Prolog (adjust /usr/bin/pl to
|
||||
where SWI-Prolog is installed)
|
||||
|
||||
==
|
||||
#!/usr/bin/pl -q -g main -s
|
||||
|
||||
main(Argv) :-
|
||||
echo(Argv).
|
||||
|
||||
echo([]) :- nl.
|
||||
echo([Last]) :- !,
|
||||
write(Last), nl.
|
||||
echo([H|T]) :-
|
||||
write(H), write(' '),
|
||||
echo(T).
|
||||
==
|
||||
|
||||
@see XPCE users should have a look at library(pce_main), which
|
||||
starts the GUI and processes events until all windows have gone.
|
||||
*/
|
||||
|
||||
:- module_transparent
|
||||
main/0.
|
||||
|
||||
%% main
|
||||
%
|
||||
% Call main/1 using the passed command-line arguments.
|
||||
|
||||
main :-
|
||||
context_module(M),
|
||||
set_signals,
|
||||
argv(Av),
|
||||
run_main(M, Av).
|
||||
|
||||
%% run_main(+Module, +Args)
|
||||
%
|
||||
% Run the main routine, guarding for exceptions and failure of the
|
||||
% main/1 routine
|
||||
|
||||
run_main(Module, Av) :-
|
||||
( catch(call(Module:main, Av), E, true)
|
||||
-> ( var(E)
|
||||
-> halt(0)
|
||||
; print_message(error, E),
|
||||
halt(1)
|
||||
)
|
||||
; print_message(error, goal_failed(main(Av))),
|
||||
halt(1)
|
||||
).
|
||||
|
||||
argv(Av) :-
|
||||
current_prolog_flag(argv, Argv),
|
||||
( append(_, [--|Av], Argv)
|
||||
-> true
|
||||
; current_prolog_flag(dialect, yap)
|
||||
-> Argv = Av
|
||||
; current_prolog_flag(windows, true)
|
||||
-> Argv = [_Prog|Av]
|
||||
; Av = []
|
||||
).
|
||||
|
||||
set_signals :-
|
||||
on_signal(int, _, interrupt).
|
||||
|
||||
%% interrupt(+Signal)
|
||||
%
|
||||
% We received an interrupt. This handler is installed using
|
||||
% on_signal/3.
|
||||
|
||||
interrupt(_Sig) :-
|
||||
halt(1).
|
||||
|
||||
103
swi/library/maplist.pl
Normal file
103
swi/library/maplist.pl
Normal file
@@ -0,0 +1,103 @@
|
||||
/* $Id: maplist.pl,v 1.2 2008-06-05 19:33:51 rzf Exp $
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, 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 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.
|
||||
*/
|
||||
|
||||
:- module(maplist,
|
||||
[ maplist/2, % :Goal, +List
|
||||
maplist/3, % :Goal, ?List1, ?List2
|
||||
maplist/4, % :Goal, ?List1, ?List2, ?List3
|
||||
maplist/5, % :Goal, ?List1, ?List2, ?List3, List4
|
||||
forall/2 % :Goal, :Goal
|
||||
]).
|
||||
|
||||
:- module_transparent
|
||||
maplist/2,
|
||||
maplist2/2,
|
||||
maplist/3,
|
||||
maplist2/3,
|
||||
maplist/4,
|
||||
maplist2/4,
|
||||
maplist/5,
|
||||
maplist2/5,
|
||||
forall/2.
|
||||
|
||||
% maplist(:Goal, +List)
|
||||
%
|
||||
% True if Goal can succesfully be applied on all elements of List.
|
||||
% Arguments are reordered to gain performance as well as to make
|
||||
% the predicate deterministic under normal circumstances.
|
||||
|
||||
maplist(Goal, List) :-
|
||||
maplist2(List, Goal).
|
||||
|
||||
maplist2([], _).
|
||||
maplist2([Elem|Tail], Goal) :-
|
||||
call(Goal, Elem),
|
||||
maplist2(Tail, Goal).
|
||||
|
||||
% maplist(:Goal, ?List1, ?List2)
|
||||
%
|
||||
% True if Goal can succesfully be applied to all succesive pairs
|
||||
% of elements of List1 and List2.
|
||||
|
||||
maplist(Goal, List1, List2) :-
|
||||
maplist2(List1, List2, Goal).
|
||||
|
||||
maplist2([], [], _).
|
||||
maplist2([Elem1|Tail1], [Elem2|Tail2], Goal) :-
|
||||
call(Goal, Elem1, Elem2),
|
||||
maplist2(Tail1, Tail2, Goal).
|
||||
|
||||
% maplist(:Goal, ?List1, ?List2, ?List3)
|
||||
%
|
||||
% True if Goal can succesfully be applied to all succesive triples
|
||||
% of elements of List1..List3.
|
||||
|
||||
maplist(Goal, List1, List2, List3) :-
|
||||
maplist2(List1, List2, List3, Goal).
|
||||
|
||||
maplist2([], [], [], _).
|
||||
maplist2([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], Goal) :-
|
||||
call(Goal, Elem1, Elem2, Elem3),
|
||||
maplist2(Tail1, Tail2, Tail3, Goal).
|
||||
|
||||
% maplist(:Goal, ?List1, ?List2, ?List3, List4)
|
||||
%
|
||||
% True if Goal can succesfully be applied to all succesive
|
||||
% quadruples of elements of List1..List4
|
||||
|
||||
maplist(Goal, List1, List2, List3, List4) :-
|
||||
maplist2(List1, List2, List3, List4, Goal).
|
||||
|
||||
maplist2([], [], [], [], _).
|
||||
maplist2([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], [Elem4|Tail4], Goal) :-
|
||||
call(Goal, Elem1, Elem2, Elem3, Elem4),
|
||||
maplist2(Tail1, Tail2, Tail3, Tail4, Goal).
|
||||
|
||||
76
swi/library/menu.pl
Executable file
76
swi/library/menu.pl
Executable file
@@ -0,0 +1,76 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2009, 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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('$win_menu',
|
||||
[ win_insert_menu_item/4, % +PopupName, +Item, +Before, :Goal
|
||||
win_has_menu/0 % Test whether we have menus
|
||||
]).
|
||||
|
||||
:- meta_predicate
|
||||
win_insert_menu_item(+,+,+,:).
|
||||
%:- multifile
|
||||
% prolog:on_menu/1.
|
||||
:- dynamic
|
||||
menu_action/2.
|
||||
:- volatile
|
||||
menu_action/2.
|
||||
|
||||
prolog:on_menu(Label) :-
|
||||
menu_action(Label, Action),
|
||||
catch(Action, Error,
|
||||
print_message(error, Error)).
|
||||
|
||||
% win_has_menu
|
||||
%
|
||||
% Test whether the system provides the menu interface
|
||||
|
||||
prolog:win_has_menu :-
|
||||
current_predicate(_, system:'$win_insert_menu_item'(_, _, _)).
|
||||
|
||||
% win_insert_menu_item(+Popup, +Item, +Before, :Goal)
|
||||
%
|
||||
% Add a menu-item to the PLWIN.EXE menu. See the reference manual
|
||||
% for details.
|
||||
|
||||
prolog:win_insert_menu_item(Popup, --, Before, _Goal) :- !,
|
||||
call(system:'$win_insert_menu_item'(Popup, --, Before)). % fool check/0
|
||||
prolog:win_insert_menu_item(Popup, Item, Before, Goal) :-
|
||||
insert_menu_item(Popup, Item, Before, Goal).
|
||||
|
||||
insert_menu_item(Popup, Item, Before, Goal) :-
|
||||
( menu_action(Item, OldGoal),
|
||||
OldGoal \== Goal
|
||||
-> throw(error(permission_error(redefine, Item),
|
||||
win_insert_menu_item/4))
|
||||
; true
|
||||
),
|
||||
call(system:'$win_insert_menu_item'(Popup, Item, Before)),
|
||||
assert(menu_action(Item, Goal)).
|
||||
124
swi/library/nb_set.pl
Normal file
124
swi/library/nb_set.pl
Normal file
@@ -0,0 +1,124 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2005, 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 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.
|
||||
*/
|
||||
|
||||
:- module(nb_set,
|
||||
[ empty_nb_set/1, % -EmptySet
|
||||
add_nb_set/2, % +Key, !Set
|
||||
add_nb_set/3, % +Key, !Set, ?New
|
||||
gen_nb_set/2, % +Set, -Key
|
||||
size_nb_set/2, % +Set, -Size
|
||||
nb_set_to_list/2 % +Set, -List
|
||||
]).
|
||||
|
||||
|
||||
/** <module> Non-backtrackable sets
|
||||
|
||||
This library provides a non-backtrackabe set. It is based on
|
||||
nb_setarg/3. See the SWI-Prolog manual for details.
|
||||
|
||||
@author Jan Wielemaker
|
||||
@tbd Base this work on AVL trees rather then unbalanced trees.
|
||||
*/
|
||||
|
||||
/*******************************
|
||||
* NON-BACKTRACKABLE SETS *
|
||||
*******************************/
|
||||
|
||||
%% empty_nb_set(-Set)
|
||||
%
|
||||
% Create an empty non-backtrackable set.
|
||||
|
||||
empty_nb_set(nb_set(t)).
|
||||
|
||||
%% add_nb_set(+Key, !Set) is det.
|
||||
%% add_nb_set(+Key, !Set, ?New) is semidet.
|
||||
%
|
||||
% Insert an element into the set. If the element is already in the
|
||||
% set, nothing happens. New is =true= if Key was added as a new
|
||||
% element to the set and =false= otherwise.
|
||||
|
||||
add_nb_set(Key, Set) :-
|
||||
add_nb_set(Key, Set, _).
|
||||
add_nb_set(Key, Set, New) :-
|
||||
( empty_nb_set(Set)
|
||||
-> New = true,
|
||||
nb_setarg(1, Set, t(Key, t, t))
|
||||
; arg(1, Set, Tree),
|
||||
'$btree_find_node'(Key, Tree, Node, Arg),
|
||||
( Arg == 1
|
||||
-> New = false
|
||||
; New = true,
|
||||
nb_setarg(Arg, Node, t(Key, t, t))
|
||||
)
|
||||
).
|
||||
|
||||
|
||||
%% nb_set_to_list(+Set, -List)
|
||||
%
|
||||
% Get the elements of a an nb_set. List is sorted to the standard
|
||||
% order of terms.
|
||||
|
||||
nb_set_to_list(nb_set(Set), List) :-
|
||||
phrase(nb_set_to_list(Set), List).
|
||||
|
||||
nb_set_to_list(t) -->
|
||||
[].
|
||||
nb_set_to_list(t(Val, Left, Right)) -->
|
||||
nb_set_to_list(Left),
|
||||
[Val],
|
||||
nb_set_to_list(Right).
|
||||
|
||||
|
||||
%% gen_nb_set(+Set, -Key)
|
||||
%
|
||||
% Enumerate the members of a set in the standard order of terms.
|
||||
|
||||
gen_nb_set(nb_set(Tree), Key) :-
|
||||
gen_set(Tree, Key).
|
||||
|
||||
gen_set(t(Val, Left, Right), Key) :-
|
||||
( gen_set(Left, Key)
|
||||
; Key = Val
|
||||
; gen_set(Right, Key)
|
||||
).
|
||||
|
||||
%% size_nb_set(+Set, -Size)
|
||||
%
|
||||
% Unify Size with the number of elements in the set
|
||||
|
||||
size_nb_set(nb_set(Tree), Size) :-
|
||||
set_size(Tree, Size).
|
||||
|
||||
set_size(t, 0).
|
||||
set_size(t(_,L,R), Size) :-
|
||||
set_size(L, SL),
|
||||
set_size(R, SR),
|
||||
Size is SL+SR+1.
|
||||
141
swi/library/occurs.yap
Normal file
141
swi/library/occurs.yap
Normal file
@@ -0,0 +1,141 @@
|
||||
/* $Id: occurs.yap,v 1.1 2008-02-12 17:03:52 vsc Exp $
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, 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 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.
|
||||
*/
|
||||
|
||||
:- module(occurs,
|
||||
[ contains_term/2, % +SubTerm, +Term
|
||||
contains_var/2, % +SubTerm, +Term
|
||||
free_of_term/2, % +SubTerm, +Term
|
||||
free_of_var/2, % +SubTerm, +Term
|
||||
occurrences_of_term/3, % +SubTerm, +Term, ?Tally
|
||||
occurrences_of_var/3, % +SubTerm, +Term, ?Tally
|
||||
sub_term/2, % -SubTerm, +Term
|
||||
sub_var/2 % -SubTerm, +Term (SWI extra)
|
||||
]).
|
||||
|
||||
:- use_module(library(arg),
|
||||
[genarg/3]).
|
||||
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
This is a SWI-Prolog implementation of the corresponding Quintus
|
||||
library, based on the generalised arg/3 predicate of SWI-Prolog.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
%% contains_term(+Sub, +Term) is semidet.
|
||||
%
|
||||
% Succeeds if Sub is contained in Term (=, deterministically)
|
||||
|
||||
contains_term(X, X) :- !.
|
||||
contains_term(X, Term) :-
|
||||
compound(Term),
|
||||
genarg(_, Term, Arg),
|
||||
contains_term(X, Arg), !.
|
||||
|
||||
|
||||
%% contains_var(+Sub, +Term) is det.
|
||||
%
|
||||
% Succeeds if Sub is contained in Term (==, deterministically)
|
||||
|
||||
contains_var(X0, X1) :-
|
||||
X0 == X1, !.
|
||||
contains_var(X, Term) :-
|
||||
compound(Term),
|
||||
genarg(_, Term, Arg),
|
||||
contains_var(X, Arg), !.
|
||||
|
||||
%% free_of_term(+Sub, +Term)
|
||||
%
|
||||
% Succeeds of Sub does not unify to any subterm of Term
|
||||
|
||||
free_of_term(Sub, Term) :-
|
||||
\+ contains_term(Sub, Term).
|
||||
|
||||
%% free_of_var(+Sub, +Term)
|
||||
%
|
||||
% Succeeds of Sub is not equal (==) to any subterm of Term
|
||||
|
||||
free_of_var(Sub, Term) :-
|
||||
\+ contains_var(Sub, Term).
|
||||
|
||||
%% occurrences_of_term(+SubTerm, +Term, ?Count)
|
||||
%
|
||||
% Count the number of SubTerms in Term
|
||||
|
||||
occurrences_of_term(Sub, Term, Count) :-
|
||||
count(sub_term(Sub, Term), Count).
|
||||
|
||||
%% occurrences_of_var(+SubTerm, +Term, ?Count)
|
||||
%
|
||||
% Count the number of SubTerms in Term
|
||||
|
||||
occurrences_of_var(Sub, Term, Count) :-
|
||||
count(sub_var(Sub, Term), Count).
|
||||
|
||||
%% sub_term(-Sub, +Term)
|
||||
%
|
||||
% Generates (on backtracking) all subterms of Term.
|
||||
|
||||
sub_term(X, X).
|
||||
sub_term(X, Term) :-
|
||||
compound(Term),
|
||||
genarg(_, Term, Arg),
|
||||
sub_term(X, Arg).
|
||||
|
||||
%% sub_var(-Sub, +Term)
|
||||
%
|
||||
% Generates (on backtracking) all subterms (==) of Term.
|
||||
|
||||
sub_var(X0, X1) :-
|
||||
X0 == X1.
|
||||
sub_var(X, Term) :-
|
||||
compound(Term),
|
||||
genarg(_, Term, Arg),
|
||||
sub_var(X, Arg).
|
||||
|
||||
|
||||
/*******************************
|
||||
* UTIL *
|
||||
*******************************/
|
||||
|
||||
%% count(+Goal, -Count)
|
||||
%
|
||||
% Count number of times Goal succeeds.
|
||||
|
||||
count(Goal, Count) :-
|
||||
State = count(0),
|
||||
( Goal,
|
||||
arg(1, State, N0),
|
||||
N is N0 + 1,
|
||||
nb_setarg(1, State, N),
|
||||
fail
|
||||
; arg(1, State, Count)
|
||||
).
|
||||
|
||||
198
swi/library/operators.pl
Normal file
198
swi/library/operators.pl
Normal file
@@ -0,0 +1,198 @@
|
||||
/* $Id: operators.pl,v 1.1 2008-02-12 17:03:53 vsc Exp $
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2004, 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 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.
|
||||
*/
|
||||
|
||||
|
||||
:- module(prolog_operator,
|
||||
[ push_operators/1, % +List
|
||||
push_operators/2, % +List, -Undo
|
||||
pop_operators/0,
|
||||
pop_operators/1, % +Undo
|
||||
push_op/3 % Precedence, Type, Name
|
||||
]).
|
||||
|
||||
|
||||
/** <module> Manage operators
|
||||
|
||||
Often, one wants to define operators to improve the readibility of some
|
||||
very specific code. Operators in Prolog are global objects and changing
|
||||
operators changes syntax and possible semantics of existing sources. For
|
||||
this reason it is desirable to reset operator declarations after the
|
||||
code that needs them has been read. This module defines a rather cruel
|
||||
-but portable- method to do this.
|
||||
|
||||
Usage:
|
||||
|
||||
==
|
||||
:- push_operators(
|
||||
[ op(900, fx, hello_world)
|
||||
, op(600, xf, *)
|
||||
]).
|
||||
|
||||
hello_world World :-
|
||||
....
|
||||
|
||||
:- pop_operators.
|
||||
==
|
||||
|
||||
While the above are for source-code, the calls push_operators/2 and
|
||||
pop_operators/1 can be used for local processing where it is more
|
||||
comfortable to carry the undo context around.
|
||||
|
||||
NOTE: In recent versions of SWI-Prolog operators are local to a module
|
||||
and can be exported using the syntax below. This is not portable, but
|
||||
otherwise a more structured approach for operator handling.
|
||||
|
||||
==
|
||||
:- module(mymodule,
|
||||
[ mypred/1,
|
||||
op(500, fx, myop)
|
||||
]).
|
||||
==
|
||||
|
||||
@compat SWI-Prolog
|
||||
*/
|
||||
|
||||
:- thread_local
|
||||
operator_stack/1.
|
||||
|
||||
:- module_transparent
|
||||
push_operators/1,
|
||||
push_operators/2,
|
||||
push_op/3.
|
||||
|
||||
%% push_operators(:New) is det.
|
||||
%% push_operators(:New, -Undo) is det.
|
||||
%
|
||||
% Installs the operators from New, where New is a list of op(Prec,
|
||||
% Type, :Name). The modifications to the operator table are undone
|
||||
% in a matching call to pop_operators/0.
|
||||
|
||||
push_operators(New, Undo) :-
|
||||
strip_module(New, Module, Ops0),
|
||||
tag_ops(Ops0, Module, Ops),
|
||||
undo_operators(Ops, Undo),
|
||||
set_operators(Ops).
|
||||
|
||||
push_operators(New) :-
|
||||
push_operators(New, Undo),
|
||||
assert_op(mark),
|
||||
assert_op(Undo).
|
||||
|
||||
%% push_op(+Precedence, +Type, :Name) is det.
|
||||
%
|
||||
% As op/3, but this call must appear between push_operators/1 and
|
||||
% pop_operators/0. The change is undone by the call to
|
||||
% pop_operators/0
|
||||
|
||||
push_op(P, T, A0) :-
|
||||
( A0 = _:_
|
||||
-> A = A0
|
||||
; context_module(M),
|
||||
A = M:A0
|
||||
),
|
||||
undo_operator(op(P,T,A), Undo),
|
||||
assert_op(Undo),
|
||||
op(P, T, A).
|
||||
|
||||
%% pop_operators is det.
|
||||
%
|
||||
% Revert all changes to the operator table realised since the last
|
||||
% push_operators/1.
|
||||
|
||||
pop_operators :-
|
||||
retract_op(Undo),
|
||||
( Undo == mark
|
||||
-> !
|
||||
; set_operators(Undo),
|
||||
fail
|
||||
).
|
||||
|
||||
%% pop_operators(+Undo) is det.
|
||||
%
|
||||
% Reset operators as pushed by push_operators/2.
|
||||
|
||||
pop_operators(Undo) :-
|
||||
set_operators(Undo).
|
||||
|
||||
tag_ops([], _, []).
|
||||
tag_ops([op(P,Tp,N0)|T0], M, [op(P,Tp,N)|T]) :-
|
||||
( N0 = _:_
|
||||
-> N = N0
|
||||
; N = M:N0
|
||||
),
|
||||
tag_ops(T0, M, T).
|
||||
|
||||
set_operators([]).
|
||||
set_operators([H|R]) :-
|
||||
set_operators(H),
|
||||
set_operators(R).
|
||||
set_operators(op(P,T,A)) :-
|
||||
op(P, T, A).
|
||||
|
||||
undo_operators([], []).
|
||||
undo_operators([O0|T0], [U0|T]) :-
|
||||
undo_operator(O0, U0),
|
||||
undo_operators(T0, T).
|
||||
|
||||
undo_operator(op(_P, T, N), op(OP, OT, N)) :-
|
||||
current_op(OP, OT, N),
|
||||
same_op_type(T, OT), !.
|
||||
undo_operator(op(P, T, [H|R]), [OH|OT]) :- !,
|
||||
undo_operator(op(P, T, H), OH),
|
||||
undo_operator(op(P, T, R), OT).
|
||||
undo_operator(op(_, _, []), []) :- !.
|
||||
undo_operator(op(_P, T, N), op(0, T, N)).
|
||||
|
||||
same_op_type(T, OT) :-
|
||||
op_type(T, Type),
|
||||
op_type(OT, Type).
|
||||
|
||||
op_type(fx, prefix).
|
||||
op_type(fy, prefix).
|
||||
op_type(xfx, infix).
|
||||
op_type(xfy, infix).
|
||||
op_type(yfx, infix).
|
||||
op_type(yfy, infix).
|
||||
op_type(xf, postfix).
|
||||
op_type(yf, postfix).
|
||||
|
||||
%% assert_op(+Term) is det.
|
||||
%% retract_op(-Term) is det.
|
||||
%
|
||||
% Force local assert/retract.
|
||||
|
||||
assert_op(Term) :-
|
||||
asserta(operator_stack(Term)).
|
||||
|
||||
retract_op(Term) :-
|
||||
retract(operator_stack(Term)).
|
||||
|
||||
|
||||
256
swi/library/option.pl
Normal file
256
swi/library/option.pl
Normal file
@@ -0,0 +1,256 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2009, 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 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.
|
||||
*/
|
||||
|
||||
:- module(swi_option,
|
||||
[ option/2, % +Term, +List
|
||||
option/3, % +Term, +List, +Default
|
||||
select_option/3, % +Term, +Options, -RestOpts
|
||||
select_option/4, % +Term, +Options, -RestOpts, +Default
|
||||
merge_options/3, % +New, +Old, -Merged
|
||||
meta_options/3 % :IsMeta, :OptionsIn, -OptionsOut
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
|
||||
/** <module> Option list processing
|
||||
|
||||
The library(option) provides some utilities for processing option lists.
|
||||
Option lists are commonly used as an alternative for many arguments.
|
||||
Examples built-in predicates are open/4 and write_term/3. Naming the
|
||||
arguments results in more readable code and the list nature makes it
|
||||
easy to extend the list of options accepted by a predicate. Option lists
|
||||
come in two styles, both of which are handled by this library.
|
||||
|
||||
$ Name(Value) :
|
||||
This is the preferred style.
|
||||
|
||||
$ Name = Value :
|
||||
This is often used, but deprecated.
|
||||
|
||||
Processing options inside time critical code (loops) can cause serious
|
||||
overhead. One possibility is to define a record using library(record)
|
||||
and initialise this using make_<record>/2. In addition to providing good
|
||||
performance, this also provides type-checking and central declaration of
|
||||
defaults.
|
||||
|
||||
==
|
||||
:- record atts(width:integer=100, shape:oneof([box,circle])=box).
|
||||
|
||||
process(Data, Options) :-
|
||||
make_atts(Options, Attributes),
|
||||
action(Data, Attributes).
|
||||
|
||||
action(Data, Attributes) :-
|
||||
atts_shape(Attributes, Shape),
|
||||
...
|
||||
==
|
||||
|
||||
@tbd We should consider putting many options in an assoc or record
|
||||
with appropriate preprocessing to achieve better performance.
|
||||
@tbd We should provide some standard to to automatic type-checking
|
||||
on option lists.
|
||||
@see library(record)
|
||||
*/
|
||||
|
||||
%% option(?Option, +OptionList, +Default)
|
||||
%
|
||||
% Get an option from a OptionList. OptionList can use the
|
||||
% Name=Value as well as the Name(Value) convention.
|
||||
%
|
||||
% @param Option Term of the form Name(?Value).
|
||||
|
||||
option(Opt, Options, Default) :- % make option processing stead-fast
|
||||
arg(1, Opt, OptVal),
|
||||
ground(OptVal), !,
|
||||
functor(Opt, OptName, 1),
|
||||
functor(Gen, OptName, 1),
|
||||
option(Gen, Options, Default),
|
||||
Opt = Gen.
|
||||
option(Opt, Options, _) :-
|
||||
get_option(Opt, Options), !.
|
||||
option(Opt, _, Default) :-
|
||||
arg(1, Opt, Default).
|
||||
|
||||
%% option(?Option, +OptionList)
|
||||
%
|
||||
% Get an option from a OptionList. OptionList can use the
|
||||
% Name=Value as well as the Name(Value) convention. Fails silently
|
||||
% if the option does not appear in OptionList.
|
||||
%
|
||||
% @param Option Term of the form Name(?Value).
|
||||
|
||||
option(Opt, Options) :- % make option processing stead-fast
|
||||
arg(1, Opt, OptVal),
|
||||
nonvar(OptVal), !,
|
||||
functor(Opt, OptName, 1),
|
||||
functor(Gen, OptName, 1),
|
||||
option(Gen, Options),
|
||||
Opt = Gen.
|
||||
option(Opt, Options) :-
|
||||
get_option(Opt, Options), !.
|
||||
|
||||
|
||||
get_option(Opt, Options) :-
|
||||
memberchk(Opt, Options), !.
|
||||
get_option(Opt, Options) :-
|
||||
functor(Opt, OptName, 1),
|
||||
arg(1, Opt, OptVal),
|
||||
memberchk(OptName=OptVal, Options), !.
|
||||
|
||||
|
||||
%% select_option(?Option, +Options, -RestOptions) is semidet.
|
||||
%
|
||||
% Get and remove option from an option list. As option/2, removing
|
||||
% the matching option from Options and unifying the remaining
|
||||
% options with RestOptions.
|
||||
|
||||
select_option(Opt, Options0, Options) :- % stead-fast
|
||||
arg(1, Opt, OptVal),
|
||||
nonvar(OptVal), !,
|
||||
functor(Opt, OptName, 1),
|
||||
functor(Gen, OptName, 1),
|
||||
select_option(Gen, Options0, Options),
|
||||
Opt = Gen.
|
||||
select_option(Opt, Options0, Options) :-
|
||||
get_option(Opt, Options0, Options), !.
|
||||
|
||||
|
||||
get_option(Opt, Options0, Options) :-
|
||||
select(Opt, Options0, Options), !.
|
||||
get_option(Opt, Options0, Options) :-
|
||||
functor(Opt, OptName, 1),
|
||||
arg(1, Opt, OptVal),
|
||||
select(OptName=OptVal, Options0, Options), !.
|
||||
|
||||
%% select_option(?Option, +Options, -RestOptions, +Default) is det.
|
||||
%
|
||||
% Get and remove option with default value. As select_option/3,
|
||||
% but if Option is not in Options, its value is unified with
|
||||
% Default and RestOptions with Options.
|
||||
|
||||
select_option(Option, Options, RestOptions, _Default) :-
|
||||
select_option(Option, Options, RestOptions), !.
|
||||
select_option(Option, Options, Options, Default) :-
|
||||
arg(1, Option, Default).
|
||||
|
||||
|
||||
%% merge_options(+New, +Old, -Merged) is det.
|
||||
%
|
||||
% Merge two option lists. Merged is a sorted list of options using
|
||||
% the canonical format Name(Value) holding all options from New
|
||||
% and Old, after removing conflicting options from Old.
|
||||
|
||||
merge_options([], Old, Merged) :- !, Merged = Old.
|
||||
merge_options(New, [], Merged) :- !, Merged = New.
|
||||
merge_options(New, Old, Merged) :-
|
||||
canonise_options(New, NCanonical),
|
||||
canonise_options(Old, OCanonical),
|
||||
sort(NCanonical, NSorted),
|
||||
sort(OCanonical, OSorted),
|
||||
ord_merge(NSorted, OSorted, Merged).
|
||||
|
||||
ord_merge([], L, L) :- !.
|
||||
ord_merge(L, [], L) :- !.
|
||||
ord_merge([NO|TN], [OO|TO], Merged) :-
|
||||
functor(NO, NName, 1),
|
||||
functor(OO, OName, 1),
|
||||
compare(Diff, NName, OName),
|
||||
ord_merge(Diff, NO, NName, OO, OName, TN, TO, Merged).
|
||||
|
||||
ord_merge(=, NO, _, _, _, TN, TO, [NO|T]) :-
|
||||
ord_merge(TN, TO, T).
|
||||
ord_merge(<, NO, _, OO, OName, TN, TO, [NO|T]) :-
|
||||
( TN = [H|TN2]
|
||||
-> functor(H, NName, 1),
|
||||
compare(Diff, NName, OName),
|
||||
ord_merge(Diff, H, NName, OO, OName, TN2, TO, T)
|
||||
; T = [OO|TO]
|
||||
).
|
||||
ord_merge(>, NO, NName, OO, _, TN, TO, [OO|T]) :-
|
||||
( TO = [H|TO2]
|
||||
-> functor(H, OName, 1),
|
||||
compare(Diff, NName, OName),
|
||||
ord_merge(Diff, NO, NName, H, OName, TN, TO2, T)
|
||||
; T = [NO|TN]
|
||||
).
|
||||
|
||||
|
||||
%% canonise_options(+OptionsIn, -OptionsOut) is det.
|
||||
%
|
||||
% Rewrite option list from possible Name=Value to Name(Value)
|
||||
|
||||
canonise_options(In, Out) :-
|
||||
memberchk(_=_, In), !, % speedup a bit if already ok.
|
||||
canonise_options2(In, Out).
|
||||
canonise_options(Options, Options).
|
||||
|
||||
canonise_options2([], []).
|
||||
canonise_options2([Name=Value|T0], [H|T]) :- !,
|
||||
H =.. [Name,Value],
|
||||
canonise_options2(T0, T).
|
||||
canonise_options2([H|T0], [H|T]) :- !,
|
||||
canonise_options2(T0, T).
|
||||
|
||||
|
||||
%% meta_options(+IsMeta, :Options0, -Options) is det.
|
||||
%
|
||||
% Perform meta-expansion on options that are module-sensitive.
|
||||
% Whether an option name is module sensitive is determined by
|
||||
% calling call(IsMeta, Name). Here is an example:
|
||||
%
|
||||
% ==
|
||||
% meta_options(is_meta, OptionsIn, Options),
|
||||
% ...
|
||||
%
|
||||
% is_meta(callback).
|
||||
% ==
|
||||
|
||||
:- meta_predicate
|
||||
meta_options(1, :, -).
|
||||
|
||||
meta_options(IsMeta, Context:Options0, Options) :-
|
||||
meta_options(Options0, IsMeta, Context, Options).
|
||||
|
||||
meta_options([], _, _, []).
|
||||
meta_options([H0|T0], IM, Context, [H|T]) :-
|
||||
meta_option(H0, IM, Context, H),
|
||||
meta_options(T0, IM, Context, T).
|
||||
|
||||
meta_option(Name=V0, IM, Context, Name=M:V) :-
|
||||
call(IM, Name), !,
|
||||
strip_module(Context:V0, M, V).
|
||||
meta_option(O0, IM, Context, O) :-
|
||||
compound(O0),
|
||||
O0 =.. [Name,V0],
|
||||
call(IM, Name), !,
|
||||
strip_module(Context:V0, M, V),
|
||||
O =.. [Name,M:V].
|
||||
meta_option(O, _, _, O).
|
||||
|
||||
162
swi/library/pairs.pl
Normal file
162
swi/library/pairs.pl
Normal file
@@ -0,0 +1,162 @@
|
||||
/* $Id: pairs.pl,v 1.1 2008-02-12 17:03:52 vsc Exp $
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2006, 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(pairs,
|
||||
[ pairs_keys_values/3,
|
||||
pairs_values/2,
|
||||
pairs_keys/2,
|
||||
group_pairs_by_key/2,
|
||||
transpose_pairs/2,
|
||||
map_list_to_pairs/3
|
||||
]).
|
||||
|
||||
/** <module> Operations on key-value lists
|
||||
|
||||
This module implements common operations on Key-Value lists, also known
|
||||
as _Pairs_. Pairs have great practical value, especially due to
|
||||
keysort/2 and the library assoc.pl.
|
||||
|
||||
This library is based on disussion in the SWI-Prolog mailinglist,
|
||||
including specifications from Quintus and a library proposal by Richard
|
||||
O'Keefe.
|
||||
|
||||
@see keysort/2, library(assoc)
|
||||
@author Jan Wielemaker
|
||||
*/
|
||||
|
||||
%% pairs_keys_values(?Pairs, ?Keys, ?Values) is det.
|
||||
%
|
||||
% True if Keys holds the keys of Pairs and Values the values.
|
||||
%
|
||||
% Deterministic if any argument is instantiated to a finite list
|
||||
% and the others are either free or finite lists.
|
||||
|
||||
pairs_keys_values(Pairs, Keys, Values) :-
|
||||
( nonvar(Pairs) ->
|
||||
pairs_keys_values_(Pairs, Keys, Values)
|
||||
; nonvar(Keys) ->
|
||||
keys_values_pairs(Keys, Values, Pairs)
|
||||
; values_keys_pairs(Values, Keys, Pairs)
|
||||
).
|
||||
|
||||
pairs_keys_values_([], [], []).
|
||||
pairs_keys_values_([K-V|Pairs], [K|Keys], [V|Values]) :-
|
||||
pairs_keys_values_(Pairs, Keys, Values).
|
||||
|
||||
keys_values_pairs([], [], []).
|
||||
keys_values_pairs([K|Ks], [V|Vs], [K-V|Pairs]) :-
|
||||
keys_values_pairs(Ks, Vs, Pairs).
|
||||
|
||||
values_keys_pairs([], [], []).
|
||||
values_keys_pairs([V|Vs], [K|Ks], [K-V|Pairs]) :-
|
||||
values_keys_pairs(Vs, Ks, Pairs).
|
||||
|
||||
%% pairs_values(+Pairs, -Values) is det.
|
||||
%
|
||||
% Remove the keys from a list of Key-Value pairs. Same as
|
||||
% pairs_keys_values(Pairs, _, Values)
|
||||
|
||||
pairs_values([], []).
|
||||
pairs_values([_-V|T0], [V|T]) :-
|
||||
pairs_values(T0, T).
|
||||
|
||||
|
||||
%% pairs_keys(+Pairs, -Keys) is det.
|
||||
%
|
||||
% Remove the values from a list of Key-Value pairs. Same as
|
||||
% pairs_keys_values(Pairs, Keys, _)
|
||||
|
||||
pairs_keys([], []).
|
||||
pairs_keys([K-_|T0], [K|T]) :-
|
||||
pairs_keys(T0, T).
|
||||
|
||||
|
||||
%% group_pairs_by_key(+Pairs, -Joined:list(Key-Values)) is det.
|
||||
%
|
||||
% Group values with the same key. For example:
|
||||
%
|
||||
% ==
|
||||
% ?- group_pairs_by_key([a-2, a-1, b-4], X).
|
||||
%
|
||||
% X = [a-[2,1], b-[4]]
|
||||
% ==
|
||||
%
|
||||
% @param Pairs Key-Value list, sorted to the standard order
|
||||
% of terms (as keysort/2 does)
|
||||
% @param Joined List of Key-Group, where Group is the
|
||||
% list of Values associated with Key.
|
||||
|
||||
group_pairs_by_key([], []).
|
||||
group_pairs_by_key([M-N|T0], [M-[N|TN]|T]) :-
|
||||
same_key(M, T0, TN, T1),
|
||||
group_pairs_by_key(T1, T).
|
||||
|
||||
same_key(M, [M-N|T0], [N|TN], T) :- !,
|
||||
same_key(M, T0, TN, T).
|
||||
same_key(_, L, [], L).
|
||||
|
||||
|
||||
%% transpose_pairs(+Pairs, -Transposed) is det.
|
||||
%
|
||||
% Swap Key-Value to Value-Key and sort the result on Value
|
||||
% (the new key) using keysort/2.
|
||||
|
||||
transpose_pairs(Pairs, Transposed) :-
|
||||
flip_pairs(Pairs, Flipped),
|
||||
keysort(Flipped, Transposed).
|
||||
|
||||
flip_pairs([], []).
|
||||
flip_pairs([Key-Val|Pairs], [Val-Key|Flipped]) :-
|
||||
flip_pairs(Pairs, Flipped).
|
||||
|
||||
|
||||
%% map_list_to_pairs(:Function, +List, -Keyed)
|
||||
%
|
||||
% Create a key-value list by mapping each element of List.
|
||||
% For example, if we have a list of lists we can create a
|
||||
% list of Length-List using
|
||||
%
|
||||
% ==
|
||||
% map_list_to_pairs(length, ListOfLists, Pairs),
|
||||
% ==
|
||||
|
||||
:- module_transparent
|
||||
map_list_to_pairs/3,
|
||||
map_list_to_pairs2/3.
|
||||
|
||||
map_list_to_pairs(Function, List, Pairs) :-
|
||||
map_list_to_pairs2(List, Function, Pairs).
|
||||
|
||||
map_list_to_pairs2([], _, []).
|
||||
map_list_to_pairs2([H|T0], Pred, [K-H|T]) :-
|
||||
call(Pred, H, K),
|
||||
map_list_to_pairs2(T0, Pred, T).
|
||||
|
||||
309
swi/library/persistence.yap
Normal file
309
swi/library/persistence.yap
Normal file
@@ -0,0 +1,309 @@
|
||||
/*
|
||||
persistence.yap - make assertions and retracts persistent
|
||||
|
||||
Copyright (C) 2006, Christian Thaeter <chth@gmx.net>
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License version 2 as
|
||||
published by the Free Software Foundation.
|
||||
|
||||
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 program; if not, contact me.
|
||||
|
||||
*/
|
||||
|
||||
:- module(persistence,
|
||||
[
|
||||
persistent_open/3,
|
||||
persistent_close/1,
|
||||
persistent_assert/1,
|
||||
persistent_retract/1
|
||||
]).
|
||||
|
||||
:- use_module(library(system),[]).
|
||||
|
||||
:- dynamic(persistent_desc/2).
|
||||
|
||||
/*
|
||||
persistent_open(PredDesc, File, Opts).
|
||||
|
||||
declare Module:Functor/Arity (Functor/Arity) to be persistent
|
||||
stored in File's (*.db *.log *log.$PID *.lock *.bak)
|
||||
|
||||
Opts are:
|
||||
db - use dbfile (flat file containing all persistent predicates)
|
||||
log - use logfile (logfile with either +(Term) for asserts and -(Term) for retracts)
|
||||
bak - make backupfiles when regenerating the dbfile
|
||||
sync - flush data always
|
||||
ro - readonly, can load locked files, never changes data on disk
|
||||
wo - (planned) writeonly, implies [log], data is only written to the log and not
|
||||
asserted into prolog, the database will not be loaded at persistent_open.
|
||||
conc - (planned) concurrency, extends the locking for multiple readers/single writer locks
|
||||
trans - (planned) support for transactions (begin/commit/abort)
|
||||
|
||||
Guides:
|
||||
- if the data mutates a lot, use [db,log].
|
||||
- if you mostly append data [log] suffices.
|
||||
- if the data is not important (can be regenerated) and mostly readonly then [db] is ok.
|
||||
- when using only [db] you must not forget to persistent_close!
|
||||
- for extra security against failures add [bak,sync].
|
||||
- don't use [bak] if you need to conserve disk space and the database is huge.
|
||||
- don't use [sync] if you need very fast writes.
|
||||
- turning all on [db,log,bak,sync] is probably the best, if you are undecided.
|
||||
- [ro,db] loads only the last saved db file.
|
||||
- [ro,log] loads the last saved db file if it exists and replays the log.
|
||||
- note that [ro] will fail if the db is not intact (.bak file present).
|
||||
|
||||
(planned features)
|
||||
- [wo] is very limited and only useful if you want to log data to a file
|
||||
- [wo,db] will replay the log at close
|
||||
- [conc] is useful for shareing data between prolog processes, but this is not a
|
||||
high performance solution.
|
||||
- [trans] can improve performance of concurrent access somewhat
|
||||
*/
|
||||
persistent_open(PredDesc, File, Opts) :-
|
||||
module_goal(PredDesc, Module:Functor/Arity),
|
||||
atom(Functor), integer(Arity), atom(File),
|
||||
\+ persistent_desc(Module:Functor/Arity,_),
|
||||
|
||||
atom_concat(File,'.db',DBfile),
|
||||
assertz(persistent_desc(Module:Functor/Arity,dbfile(DBfile))),
|
||||
|
||||
atom_concat(File,'.bak',Backupfile),
|
||||
assertz(persistent_desc(Module:Functor/Arity,backupfile(Backupfile))),
|
||||
|
||||
atom_concat(File,'.log',Logfile),
|
||||
assertz(persistent_desc(Module:Functor/Arity,logfile(Logfile))),
|
||||
|
||||
system:pid(Pid),
|
||||
assertz(persistent_desc(Module:Functor/Arity,pid(Pid))),
|
||||
|
||||
number_atom(Pid,P),
|
||||
atom_concat(Logfile,P,Mylogfile),
|
||||
assertz(persistent_desc(Module:Functor/Arity,mylogfile(Mylogfile))),
|
||||
|
||||
atom_concat(File,'.lock',Lockfile),
|
||||
assertz(persistent_desc(Module:Functor/Arity,lockfile(Lockfile))),
|
||||
|
||||
persistent_opts_store(Module:Functor/Arity,Opts),
|
||||
persistent_load(Module:Functor/Arity),
|
||||
|
||||
( \+ persistent_desc(Module:Functor/Arity, ro), persistent_desc(Module:Functor/Arity, log)
|
||||
-> open(Logfile, append, Log),
|
||||
assertz(persistent_desc(Module:Functor/Arity,logstream(Log)))
|
||||
; true
|
||||
).
|
||||
|
||||
/*
|
||||
closes the database associated with PredDesc ([Module:]Functor/Arity)
|
||||
*/
|
||||
persistent_close(PredDesc0) :-
|
||||
module_goal(PredDesc0,PredDesc),
|
||||
( persistent_desc(PredDesc, logstream(Log))
|
||||
-> close(Log)
|
||||
; true
|
||||
),
|
||||
persistent_save(PredDesc),
|
||||
persistent_desc(PredDesc, backupfile(Backupfile)),
|
||||
(system:delete_file(Backupfile,[ignore]); true),
|
||||
persistent_lock_release(PredDesc),
|
||||
retractall(persistent_desc(PredDesc,_)).
|
||||
|
||||
/*
|
||||
assert data to the database, this is always an assertz, if you need some ordering,
|
||||
then store some kind of key within your data.
|
||||
rules can be asserted too
|
||||
*/
|
||||
persistent_assert(Term) :-
|
||||
Term = (Head0 :- Body),
|
||||
module_goal(Head0, Module:Head),
|
||||
functor(Head, Functor, Arity),
|
||||
once(persistent_desc(Module:Functor/Arity,_)),!,
|
||||
( persistent_desc(Module:Functor/Arity, logstream(Log))
|
||||
-> writeq(Log,+(((Module:Head):-Body))), write(Log,'.\n'),
|
||||
( persistent_desc(Module:Functor/Arity, sync)
|
||||
-> flush_output(Log)
|
||||
; true
|
||||
)
|
||||
; true
|
||||
),
|
||||
assertz((Module:Head:-Body)).
|
||||
persistent_assert(Term0) :-
|
||||
module_goal(Term0, Module:Term),
|
||||
functor(Term,Functor,Arity),
|
||||
once(persistent_desc(Module:Functor/Arity,_)),!,
|
||||
( persistent_desc(Module:Functor/Arity,logstream(Log))
|
||||
-> writeq(Log,+(Module:Term)), write(Log,'.\n'),
|
||||
( persistent_desc(Module:Functor/Arity, sync)
|
||||
-> flush_output(Log)
|
||||
; true
|
||||
)
|
||||
; true
|
||||
),
|
||||
assertz(Module:Term).
|
||||
|
||||
/*
|
||||
retract a persistent Term
|
||||
*/
|
||||
persistent_retract(Term0) :-
|
||||
module_goal(Term0, Module:Term),
|
||||
functor(Term,Functor,Arity),
|
||||
once(persistent_desc(Module:Functor/Arity,_)),!,
|
||||
retract(Module:Term),
|
||||
( persistent_desc(Module:Functor/Arity, logstream(Log))
|
||||
-> writeq(Log,-(Module:Term)), write(Log,'.\n'),
|
||||
( persistent_desc(Module:Functor/Arity, sync)
|
||||
-> flush_output(Log)
|
||||
; true
|
||||
)
|
||||
; true
|
||||
).
|
||||
|
||||
% transaction support for future
|
||||
persistent_begin.
|
||||
persistent_commit.
|
||||
persistent_abort.
|
||||
|
||||
|
||||
/*
|
||||
|
||||
PRIVATE PREDICATES, DONT USE THESE
|
||||
|
||||
*/
|
||||
|
||||
% save all data to a .db file
|
||||
persistent_save(PredDesc) :-
|
||||
\+ persistent_desc(PredDesc,ro),
|
||||
( persistent_desc(PredDesc,db)
|
||||
-> persistent_desc(PredDesc,dbfile(DBfile)),
|
||||
(
|
||||
persistent_desc(PredDesc,bak)
|
||||
-> persistent_desc(PredDesc,backupfile(Backupfile)),
|
||||
( system:file_exists(DBfile)
|
||||
-> system:rename_file(DBfile,Backupfile)
|
||||
; true
|
||||
)
|
||||
; true
|
||||
),
|
||||
open(DBfile, write, S),
|
||||
persistent_writeall(PredDesc,S),
|
||||
close(S),
|
||||
persistent_desc(PredDesc,logfile(Logfile)),
|
||||
(system:delete_file(Logfile,[ignore]); true)
|
||||
; true
|
||||
).
|
||||
|
||||
% write all predicates matching Functor/Arity to stream S
|
||||
persistent_writeall(PredDesc, S) :-
|
||||
module_goal(PredDesc, Module:Functor/Arity),
|
||||
functor(Clause, Functor, Arity),
|
||||
clause(Module:Clause, Body),
|
||||
( Body = true
|
||||
-> writeq(S,Module:Clause)
|
||||
; writeq(S,(Module:Clause:-Body))
|
||||
),
|
||||
write(S,'.\n'),
|
||||
fail.
|
||||
persistent_writeall(_,_).
|
||||
|
||||
% load a database, recover logfile, recreate .db
|
||||
persistent_load(PredDesc) :-
|
||||
persistent_desc(PredDesc,dbfile(DBfile)),
|
||||
persistent_desc(PredDesc,backupfile(Backupfile)),
|
||||
persistent_desc(PredDesc,logfile(Logfile)),
|
||||
|
||||
( persistent_desc(PredDesc,ro)
|
||||
-> \+ system:file_exists(Backupfile),
|
||||
( system:file_exists(DBfile)
|
||||
-> persistent_load_file(DBfile)
|
||||
; true
|
||||
),
|
||||
( persistent_desc(PredDesc,log), system:file_exists(Logfile)
|
||||
-> persistent_load_file(Logfile)
|
||||
; true
|
||||
)
|
||||
;
|
||||
persistent_lock_exclusive(PredDesc),
|
||||
( system:file_exists(Backupfile)
|
||||
-> system:rename_file(Backupfile, DBfile)
|
||||
; true
|
||||
),
|
||||
( system:file_exists(DBfile)
|
||||
-> persistent_load_file(DBfile)
|
||||
; true
|
||||
),
|
||||
( system:file_exists(Logfile)
|
||||
-> persistent_load_file(Logfile),
|
||||
( persistent_desc(PredDesc, db)
|
||||
-> persistent_save(PredDesc)
|
||||
; true
|
||||
)
|
||||
; true
|
||||
)
|
||||
).
|
||||
|
||||
% load a .db file or replay a .log file
|
||||
persistent_load_file(File) :-
|
||||
open(File, read, S),
|
||||
repeat,
|
||||
read(S, TermIn),
|
||||
(
|
||||
TermIn == end_of_file,
|
||||
close(S),
|
||||
!
|
||||
;
|
||||
(
|
||||
TermIn = +(Term),
|
||||
assertz(Term)
|
||||
;
|
||||
TermIn = -(Term),
|
||||
retract(Term)
|
||||
;
|
||||
assertz(TermIn)
|
||||
),
|
||||
fail
|
||||
).
|
||||
|
||||
%lock handling, so far only exclusive locks
|
||||
persistent_lock_exclusive(PredDesc) :-
|
||||
persistent_desc(PredDesc,lockfile(Lockfile)),
|
||||
persistent_desc(PredDesc,pid(Pid)),
|
||||
open(Lockfile, append, Lockappend),
|
||||
write(Lockappend,lock(write,Pid)),write(Lockappend,'.\n'),
|
||||
close(Lockappend),
|
||||
open(Lockfile, read, Lockread),
|
||||
read(Lockread,LPid),
|
||||
close(Lockread),
|
||||
LPid = lock(_,Pid).
|
||||
|
||||
% recover lock
|
||||
persistent_lock_exclusive(PredDesc) :-
|
||||
persistent_desc(PredDesc, lockfile(Lockfile)),
|
||||
open(Lockfile, read, Lockread),
|
||||
read(Lockread,lock(_,LPid)),
|
||||
close(Lockread),
|
||||
\+ catch(kill(LPid,0),_,fail),
|
||||
(system:delete_file(Lockfile,[ignore]); true),
|
||||
%system:sleep(1),
|
||||
persistent_lock_exclusive(PredDesc).
|
||||
|
||||
persistent_lock_release(PredDesc) :-
|
||||
persistent_lock_exclusive(PredDesc),
|
||||
persistent_desc(PredDesc,lockfile(Lockfile)),
|
||||
(system:delete_file(Lockfile,[ignore]); true).
|
||||
|
||||
|
||||
persistent_opts_store(_,[]).
|
||||
persistent_opts_store(PredDesc,[H|T]) :-
|
||||
assertz(persistent_desc(PredDesc,H)),
|
||||
persistent_opts_store(PredDesc,T).
|
||||
|
||||
module_goal(Module:Goal,Module:Goal) :-
|
||||
callable(Goal), nonvar(Module),!.
|
||||
module_goal(Goal,Module:Goal) :-
|
||||
callable(Goal), prolog_flag(typein_module,Module).
|
||||
912
swi/library/predicate_options.pl
Normal file
912
swi/library/predicate_options.pl
Normal file
@@ -0,0 +1,912 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2011, VU University 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(predicate_options,
|
||||
[ predicate_options/3, % +PI, +Arg, +Options
|
||||
assert_predicate_options/4, % +PI, +Arg, +Options, ?New
|
||||
|
||||
current_option_arg/2, % ?PI, ?Arg
|
||||
current_predicate_option/3, % ?PI, ?Arg, ?Option
|
||||
check_predicate_option/3, % +PI, +Arg, +Option
|
||||
% Create declarations
|
||||
current_predicate_options/3, % ?PI, ?Arg, ?Options
|
||||
retractall_predicate_options/0,
|
||||
derived_predicate_options/3, % :PI, ?Arg, ?Options
|
||||
derived_predicate_options/1, % +Module
|
||||
% Checking
|
||||
check_predicate_options/0,
|
||||
derive_predicate_options/0,
|
||||
check_predicate_options/1 % :PredicateIndicator
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(pairs)).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(prolog_clause)).
|
||||
|
||||
:- meta_predicate
|
||||
predicate_options(:, +, +),
|
||||
assert_predicate_options(:, +, +, ?),
|
||||
current_predicate_option(:, ?, ?),
|
||||
check_predicate_option(:, ?, ?),
|
||||
current_predicate_options(:, ?, ?),
|
||||
current_option_arg(:, ?),
|
||||
pred_option(:,-),
|
||||
derived_predicate_options(:,?,?),
|
||||
check_predicate_options(:).
|
||||
|
||||
/** <module> Access and analyse predicate options
|
||||
|
||||
This module provides the developers interface for the directive
|
||||
predicate_options/3. This directive allows us to specify that e.g.,
|
||||
open/4 processes options using the 4th argument and supports the option
|
||||
=type= using the values =text= and =binary=. Declaring options that are
|
||||
processed allows for more reliable handling of predicate options and
|
||||
simplifies porting applications. This libarry provides the following
|
||||
functionality:
|
||||
|
||||
* Query supported options through current_predicate_option/3
|
||||
or current_predicate_options/3. This is intended to support
|
||||
conditional compilation and an IDE.
|
||||
* Derive additional declarations through dataflow analysis using
|
||||
derive_predicate_options/0.
|
||||
* Perform a compile-time analysis of the entire loaded program using
|
||||
check_predicate_options/0.
|
||||
|
||||
Below, we describe some use-cases.
|
||||
|
||||
$ Quick check of a program :
|
||||
This scenario is useful as an occasional check or to assess problems
|
||||
with option-handling for porting an application to SWI-Prolog. It
|
||||
consists of three steps: loading the program (1 and 2), deriving
|
||||
option handling for application predicates (3) and running the
|
||||
checker (4).
|
||||
|
||||
==
|
||||
1 ?- [load].
|
||||
2 ?- autoload.
|
||||
3 ?- derive_predicate_options.
|
||||
4 ?- check_predicate_options.
|
||||
==
|
||||
|
||||
$ Add declaations to your program :
|
||||
Adding declarations about option processes improves the quality of
|
||||
the checking. The analysis of derive_predicate_options/0 may miss
|
||||
options and does not derive the types for options that are processed
|
||||
in Prolog code. The process is similar to the above. In steps 4 and
|
||||
further, the inferred declarations are listed, inspected and added to
|
||||
the source-code of the module.
|
||||
|
||||
==
|
||||
1 ?- [load].
|
||||
2 ?- autoload.
|
||||
3 ?- derive_predicate_options.
|
||||
4 ?- derived_predicate_options(module_1).
|
||||
5 ?- derived_predicate_options(module_2).
|
||||
6 ?- ...
|
||||
==
|
||||
|
||||
$ Declare option processing requirements :
|
||||
If an application requires that open/4 needs to support lock(write),
|
||||
it may do so using the derective below. This directive raises an
|
||||
exception when loaded on a Prolog implementation that does not support
|
||||
this option.
|
||||
|
||||
==
|
||||
:- current_predicate_option(open/4, 4, lock(write)).
|
||||
==
|
||||
|
||||
@see library(option) for accessing options in Prolog code.
|
||||
*/
|
||||
|
||||
:- multifile option_decl/3, pred_option/3.
|
||||
:- dynamic dyn_option_decl/3.
|
||||
|
||||
%% predicate_options(:PI, +Arg, +Options) is det.
|
||||
%
|
||||
% Declare that the predicate PI processes options on Arg. Options
|
||||
% is a list of options processed. Each element is one of:
|
||||
%
|
||||
% * Option(ModeAndType)
|
||||
% PI processes Option. The option-value must comply to
|
||||
% ModeAndType. Mode is one of + or - and Type is a type as
|
||||
% accepted by must_be/2.
|
||||
%
|
||||
% * pass_to(:PI,Arg)
|
||||
% The option-list is passed to the indicated predicate.
|
||||
%
|
||||
% Below is an example that processes the option header(boolean)
|
||||
% and passes all options to open/4:
|
||||
%
|
||||
% ==
|
||||
% :- predicate_options(write_xml_file/3, 3,
|
||||
% [ header(boolean),
|
||||
% pass_to(open/4, 4)
|
||||
% ]).
|
||||
%
|
||||
% write_xml_file(File, XMLTerm, Options) :-
|
||||
% open(File, write, Out, Options),
|
||||
% ( option(header(true), Option, true)
|
||||
% -> write_xml_header(Out)
|
||||
% ; true
|
||||
% ),
|
||||
% ...
|
||||
% ==
|
||||
%
|
||||
% This predicate may only be used as a _directive_ and is
|
||||
% processed by expand_term/2. Option processing can be be
|
||||
% specified at runtime using assert_predicate_options/3, which is
|
||||
% intended to support program analysis.
|
||||
|
||||
predicate_options(PI, Arg, Options) :-
|
||||
throw(error(context_error(nodirective,
|
||||
predicate_options(PI, Arg, Options)), _)).
|
||||
|
||||
|
||||
%% assert_predicate_options(:PI, +Arg, +Options, ?New) is semidet.
|
||||
%
|
||||
% As predicate_options(:PI, +Arg, +Options). New is a boolean
|
||||
% indicating whether the declarations have changed. If new is
|
||||
% provided and =false=, the predicate becomes semidet and fails
|
||||
% without modifications if modifications are required.
|
||||
|
||||
assert_predicate_options(PI, Arg, Options, New) :-
|
||||
canonical_pi(PI, M:Name/Arity),
|
||||
functor(Head, Name, Arity),
|
||||
( dyn_option_decl(Head, M, Arg)
|
||||
-> true
|
||||
; New = true,
|
||||
assertz(dyn_option_decl(Head, M, Arg))
|
||||
),
|
||||
phrase('$predopts':option_clauses(Options, Head, M, Arg),
|
||||
OptionClauses),
|
||||
forall(member(Clause, OptionClauses),
|
||||
assert_option_clause(Clause, New)),
|
||||
( var(New)
|
||||
-> New = false
|
||||
; true
|
||||
).
|
||||
|
||||
assert_option_clause(Clause, New) :-
|
||||
rename_clause(Clause, NewClause,
|
||||
'$pred_option'(A,B,C,D), '$dyn_pred_option'(A,B,C,D)),
|
||||
clause_head(NewClause, NewHead),
|
||||
( clause(NewHead, _)
|
||||
-> true
|
||||
; New = true,
|
||||
assertz(NewClause)
|
||||
).
|
||||
|
||||
clause_head(M:(Head:-_Body), M:Head) :- !.
|
||||
clause_head((M:Head :-_Body), M:Head) :- !.
|
||||
clause_head(Head, Head).
|
||||
|
||||
rename_clause(M:Clause, M:NewClause, Head, NewHead) :- !,
|
||||
rename_clause(Clause, NewClause, Head, NewHead).
|
||||
rename_clause((Head :- Body), (NewHead :- Body), Head, NewHead) :- !.
|
||||
rename_clause(Head, NewHead, Head, NewHead) :- !.
|
||||
rename_clause(Head, Head, _, _).
|
||||
|
||||
|
||||
|
||||
/*******************************
|
||||
* QUERY OPTIONS *
|
||||
*******************************/
|
||||
|
||||
%% current_option_arg(:PI, ?Arg) is nondet.
|
||||
%
|
||||
% True when Arg of PI processes predicate options. Which options
|
||||
% are processed can be accessed using current_predicate_option/3.
|
||||
|
||||
current_option_arg(Module:Name/Arity, Arg) :-
|
||||
current_option_arg(Module:Name/Arity, Arg, _DefM).
|
||||
|
||||
current_option_arg(Module:Name/Arity, Arg, DefM) :-
|
||||
atom(Name), integer(Arity), !,
|
||||
resolve_module(Module:Name/Arity, DefM:Name/Arity),
|
||||
functor(Head, Name, Arity),
|
||||
( option_decl(Head, DefM, Arg)
|
||||
; dyn_option_decl(Head, DefM, Arg)
|
||||
).
|
||||
current_option_arg(M:Name/Arity, Arg, M) :-
|
||||
( option_decl(Head, M, Arg)
|
||||
; dyn_option_decl(Head, M, Arg)
|
||||
),
|
||||
functor(Head, Name, Arity).
|
||||
|
||||
%% current_predicate_option(:PI, ?Arg, ?Option) is nondet.
|
||||
%
|
||||
% True when Arg of PI processes Option. For example, the following
|
||||
% is true:
|
||||
%
|
||||
% ==
|
||||
% ?- current_predicate_option(open/4, 4, type(text)).
|
||||
% true.
|
||||
% ==
|
||||
%
|
||||
% This predicate is intended to support conditional compilation
|
||||
% using if/1 ... endif/0. The predicate
|
||||
% current_predicate_options/3 can be used to access the full
|
||||
% capabilities of a predicate.
|
||||
|
||||
current_predicate_option(Module:PI, Arg, Option) :-
|
||||
current_option_arg(Module:PI, Arg, DefM),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
catch(pred_option(DefM:Head, Option),
|
||||
error(type_error(_,_),_),
|
||||
fail).
|
||||
|
||||
%% check_predicate_option(:PI, +Arg, +Option) is det.
|
||||
%
|
||||
% Similar to current_predicate_option/3, but intended to support
|
||||
% runtime checking.
|
||||
%
|
||||
% @error existence_error(option, OptionName) if the option is not
|
||||
% supported by PI.
|
||||
% @error type_error(Type, Value) if the option is supported but
|
||||
% the value does not match the option type. See must_be/2.
|
||||
|
||||
check_predicate_option(Module:PI, Arg, Option) :-
|
||||
define_predicate(Module:PI),
|
||||
current_option_arg(Module:PI, Arg, DefM),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
( pred_option(DefM:Head, Option)
|
||||
-> true
|
||||
; existence_error(option, Option)
|
||||
).
|
||||
|
||||
|
||||
pred_option(M:Head, Option) :-
|
||||
pred_option(M:Head, Option, []).
|
||||
|
||||
pred_option(M:Head, Option, Seen) :-
|
||||
( has_static_option_decl(M),
|
||||
M:'$pred_option'(Head, _, Option, Seen)
|
||||
; has_dynamic_option_decl(M),
|
||||
M:'$dyn_pred_option'(Head, _, Option, Seen)
|
||||
).
|
||||
|
||||
has_static_option_decl(M) :-
|
||||
'$c_current_predicate'(_, M:'$pred_option'(_,_,_,_)).
|
||||
has_dynamic_option_decl(M) :-
|
||||
'$c_current_predicate'(_, M:'$dyn_pred_option'(_,_,_,_)).
|
||||
|
||||
|
||||
/*******************************
|
||||
* TYPE&MODE CONSTRAINTS *
|
||||
*******************************/
|
||||
|
||||
:- public
|
||||
system:predicate_option_mode/2,
|
||||
system:predicate_option_type/2.
|
||||
|
||||
add_attr(Var, Value) :-
|
||||
( get_attr(Var, predicate_options, Old)
|
||||
-> put_attr(Var, predicate_options, [Value|Old])
|
||||
; put_attr(Var, predicate_options, [Value])
|
||||
).
|
||||
|
||||
system:predicate_option_type(Type, Arg) :-
|
||||
var(Arg), !,
|
||||
add_attr(Arg, option_type(Type)).
|
||||
system:predicate_option_type(Type, Arg) :-
|
||||
must_be(Type, Arg).
|
||||
|
||||
system:predicate_option_mode(Mode, Arg) :-
|
||||
var(Arg), !,
|
||||
add_attr(Arg, option_mode(Mode)).
|
||||
system:predicate_option_mode(Mode, Arg) :-
|
||||
check_mode(Mode, Arg).
|
||||
|
||||
check_mode(input, Arg) :-
|
||||
( nonvar(Arg)
|
||||
-> true
|
||||
; instantiation_error(Arg)
|
||||
).
|
||||
check_mode(output, Arg) :-
|
||||
( var(Arg)
|
||||
-> true
|
||||
; instantiation_error(Arg) % TBD: Uninstantiated
|
||||
).
|
||||
|
||||
attr_unify_hook([], _).
|
||||
attr_unify_hook([H|T], Var) :-
|
||||
option_hook(H, Var),
|
||||
attr_unify_hook(T, Var).
|
||||
|
||||
option_hook(option_type(Type), Value) :-
|
||||
is_of_type(Type, Value).
|
||||
option_hook(option_mode(Mode), Value) :-
|
||||
check_mode(Mode, Value).
|
||||
|
||||
|
||||
attribute_goals(Var) -->
|
||||
{ get_attr(Var, predicate_options, Attrs) },
|
||||
option_goals(Attrs, Var).
|
||||
|
||||
option_goals([], _) --> [].
|
||||
option_goals([H|T], Var) -->
|
||||
option_goal(H, Var),
|
||||
option_goals(T, Var).
|
||||
|
||||
option_goal(option_type(Type), Var) --> [predicate_option_type(Type, Var)].
|
||||
option_goal(option_mode(Mode), Var) --> [predicate_option_mode(Mode, Var)].
|
||||
|
||||
|
||||
/*******************************
|
||||
* OUTPUT DECLARATIONS *
|
||||
*******************************/
|
||||
|
||||
%% current_predicate_options(:PI, ?Arg, ?Options) is nondet.
|
||||
%
|
||||
% True when Options is the current active option declaration for
|
||||
% PI on Arg. See predicate_options/3 for the argument
|
||||
% descriptions. If PI is ground and refers to an undefined
|
||||
% predicate, the autoloader is used to obtain a definition of the
|
||||
% predicate.
|
||||
|
||||
current_predicate_options(PI, Arg, Options) :-
|
||||
define_predicate(PI),
|
||||
setof(Arg-Option,
|
||||
current_predicate_option_decl(PI, Arg, Option),
|
||||
Options0),
|
||||
group_pairs_by_key(Options0, Grouped),
|
||||
member(Arg-Options, Grouped).
|
||||
|
||||
current_predicate_option_decl(PI, Arg, Option) :-
|
||||
current_predicate_option(PI, Arg, Option0),
|
||||
Option0 =.. [Name|Values],
|
||||
maplist(mode_and_type, Values, Types),
|
||||
Option =.. [Name|Types].
|
||||
|
||||
mode_and_type(Value, ModeAndType) :-
|
||||
copy_term(Value,_,Goals),
|
||||
( memberchk(predicate_option_mode(output, _), Goals)
|
||||
-> ModeAndType = -(Type)
|
||||
; ModeAndType = Type
|
||||
),
|
||||
( memberchk(predicate_option_type(Type, _), Goals)
|
||||
-> true
|
||||
; Type = any
|
||||
).
|
||||
|
||||
define_predicate(PI) :-
|
||||
ground(PI), !,
|
||||
PI = M:Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
once(predicate_property(M:Head, _)).
|
||||
define_predicate(_).
|
||||
|
||||
%% derived_predicate_options(:PI, ?Arg, ?Options) is nondet.
|
||||
%
|
||||
% True when Options is the current _derived_ active option
|
||||
% declaration for PI on Arg.
|
||||
|
||||
derived_predicate_options(PI, Arg, Options) :-
|
||||
define_predicate(PI),
|
||||
setof(Arg-Option,
|
||||
derived_predicate_option(PI, Arg, Option),
|
||||
Options0),
|
||||
group_pairs_by_key(Options0, Grouped),
|
||||
member(Arg-Options1, Grouped),
|
||||
PI = M:_,
|
||||
phrase(expand_pass_to_options(Options1, M), Options2),
|
||||
sort(Options2, Options).
|
||||
|
||||
derived_predicate_option(PI, Arg, Decl) :-
|
||||
current_option_arg(PI, Arg, DefM),
|
||||
PI = _:Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
has_dynamic_option_decl(DefM),
|
||||
( has_static_option_decl(DefM),
|
||||
DefM:'$pred_option'(Head, Decl, _, [])
|
||||
; DefM:'$dyn_pred_option'(Head, Decl, _, [])
|
||||
).
|
||||
|
||||
%% expand_pass_to_options(+OptionsIn, +Module, -OptionsOut)// is det.
|
||||
%
|
||||
% Expand the options of pass_to(PI,Arg) if PI does not refer to a
|
||||
% public predicate.
|
||||
|
||||
expand_pass_to_options([], _) --> [].
|
||||
expand_pass_to_options([H|T], M) -->
|
||||
expand_pass_to(H, M),
|
||||
expand_pass_to_options(T, M).
|
||||
|
||||
expand_pass_to(pass_to(PI, Arg), Module) -->
|
||||
{ strip_module(Module:PI, M, Name/Arity),
|
||||
functor(Head, Name, Arity),
|
||||
\+ ( predicate_property(M:Head, exported)
|
||||
; predicate_property(M:Head, public)
|
||||
; M == system
|
||||
), !,
|
||||
current_predicate_options(M:Name/Arity, Arg, Options)
|
||||
},
|
||||
list(Options).
|
||||
expand_pass_to(Option, _) -->
|
||||
[Option].
|
||||
|
||||
list([]) --> [].
|
||||
list([H|T]) --> [H], list(T).
|
||||
|
||||
%% derived_predicate_options(+Module) is det.
|
||||
%
|
||||
% Derive predicate option declarations for the given module and
|
||||
% print them to the current output.
|
||||
|
||||
derived_predicate_options(Module) :-
|
||||
var(Module), !,
|
||||
forall(current_module(Module),
|
||||
derived_predicate_options(Module)).
|
||||
derived_predicate_options(Module) :-
|
||||
findall(predicate_options(Module:PI, Arg, Options),
|
||||
( derived_predicate_options(Module:PI, Arg, Options),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
( predicate_property(Module:Head, exported)
|
||||
-> true
|
||||
; predicate_property(Module:Head, public)
|
||||
)
|
||||
),
|
||||
Decls0),
|
||||
maplist(qualify_decl(Module), Decls0, Decls1),
|
||||
sort(Decls1, Decls),
|
||||
( Decls \== []
|
||||
-> format('~N~n~n% Predicate option declarations for module ~q~n~n',
|
||||
[Module]),
|
||||
forall(member(Decl, Decls),
|
||||
portray_clause((:-Decl)))
|
||||
; true
|
||||
).
|
||||
|
||||
qualify_decl(M,
|
||||
predicate_options(PI0, Arg, Options0),
|
||||
predicate_options(PI1, Arg, Options1)) :-
|
||||
qualify(PI0, M, PI1),
|
||||
maplist(qualify_option(M), Options0, Options1).
|
||||
|
||||
qualify_option(M, pass_to(PI0, Arg), pass_to(PI1, Arg)) :- !,
|
||||
qualify(PI0, M, PI1).
|
||||
qualify_option(_, Opt, Opt).
|
||||
|
||||
qualify(M:Term, M, Term) :- !.
|
||||
qualify(QTerm, _, QTerm).
|
||||
|
||||
|
||||
/*******************************
|
||||
* CLEANUP *
|
||||
*******************************/
|
||||
|
||||
%% retractall_predicate_options is det.
|
||||
%
|
||||
% Remove all dynamically (derived) predicate options.
|
||||
|
||||
retractall_predicate_options :-
|
||||
forall(retract(dyn_option_decl(_,M,_)),
|
||||
abolish(M:'$dyn_pred_option'/4)).
|
||||
|
||||
|
||||
/*******************************
|
||||
* COMPILE-TIME CHECKER *
|
||||
*******************************/
|
||||
|
||||
|
||||
:- thread_local
|
||||
new_decl/1.
|
||||
|
||||
%% check_predicate_options is det.
|
||||
%
|
||||
% Analyse loaded program for errornous options. This predicate
|
||||
% decompiles the current program and searches for calls to
|
||||
% predicates that process options. For each option list, it
|
||||
% validates whether the provided options are supported and
|
||||
% validates the argument type. This predicate performs partial
|
||||
% dataflow analysis to track option-lists inside a clause.
|
||||
%
|
||||
% @see derive_predicate_options/0 can be used to derive
|
||||
% declarations for predicates that pass options. This
|
||||
% predicate should normally be called before
|
||||
% check_predicate_options/0.
|
||||
|
||||
check_predicate_options :-
|
||||
forall(current_module(Module),
|
||||
check_predicate_options_module(Module)).
|
||||
|
||||
%% derive_predicate_options is det.
|
||||
%
|
||||
% Derive new predicate option declarations. This predicate
|
||||
% analyses the loaded program to find clauses that process options
|
||||
% using one of the predicates from library(option) or passes
|
||||
% options to other predicates that are known to process options.
|
||||
% The process is repeated until no new declarations are retrieved.
|
||||
%
|
||||
% @see autoload/0 may be used to complete the loaded program.
|
||||
|
||||
derive_predicate_options :-
|
||||
derive_predicate_options(NewDecls),
|
||||
( NewDecls == []
|
||||
-> true
|
||||
; print_message(informational, check_options(new(NewDecls))),
|
||||
new_decls(NewDecls),
|
||||
derive_predicate_options
|
||||
).
|
||||
|
||||
new_decls([]).
|
||||
new_decls([predicate_options(PI, A, O)|T]) :-
|
||||
assert_predicate_options(PI, A, O, _),
|
||||
new_decls(T).
|
||||
|
||||
|
||||
derive_predicate_options(NewDecls) :-
|
||||
call_cleanup(
|
||||
( forall(
|
||||
current_module(Module),
|
||||
forall(
|
||||
( predicate_in_module(Module, PI),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
catch(Module:clause(Head, Body, Ref), _, fail)
|
||||
),
|
||||
check_clause((Head:-Body), Module, Ref, decl))),
|
||||
( setof(Decl, retract(new_decl(Decl)), NewDecls)
|
||||
-> true
|
||||
; NewDecls = []
|
||||
)
|
||||
),
|
||||
retractall(new_decl(_))).
|
||||
|
||||
|
||||
check_predicate_options_module(Module) :-
|
||||
forall(predicate_in_module(Module, PI),
|
||||
check_predicate_options(Module:PI)).
|
||||
|
||||
predicate_in_module(Module, PI) :-
|
||||
current_predicate(Module:PI),
|
||||
PI = Name/Arity,
|
||||
functor(Head, Name, Arity),
|
||||
\+ predicate_property(Module:Head, imported_from(_)).
|
||||
|
||||
%% check_predicate_options(:PredicateIndicator) is det.
|
||||
%
|
||||
% Verify calls to predicates that have options in all clauses of
|
||||
% the predicate indicated by PredicateIndicator.
|
||||
|
||||
check_predicate_options(Module:Name/Arity) :-
|
||||
debug(predicate_options, 'Checking ~q', [Module:Name/Arity]),
|
||||
functor(Head, Name, Arity),
|
||||
forall(catch(Module:clause(Head, Body, Ref), _, fail),
|
||||
check_clause((Head:-Body), Module, Ref, check)).
|
||||
|
||||
%% check_clause(+Clause, +Module, +Ref, +Action) is det.
|
||||
%
|
||||
% Action is one of
|
||||
%
|
||||
% * decl
|
||||
% Create additional declarations
|
||||
% * check
|
||||
% Produce error messages
|
||||
|
||||
check_clause((Head:-Body), M, ClauseRef, Action) :- !,
|
||||
catch(check_body(Body, M, _, Action), E, true),
|
||||
( var(E)
|
||||
-> option_decl(M:Head, Action)
|
||||
; ( clause_info(ClauseRef, File, TermPos, _NameOffset),
|
||||
TermPos = term_position(_,_,_,_,[_,BodyPos]),
|
||||
catch(check_body(Body, M, BodyPos, Action),
|
||||
error(Formal, ArgPos), true),
|
||||
compound(ArgPos),
|
||||
arg(1, ArgPos, CharCount),
|
||||
integer(CharCount)
|
||||
-> Location = file_char_count(File, CharCount)
|
||||
; Location = clause(ClauseRef),
|
||||
E = error(Formal, _)
|
||||
),
|
||||
print_message(error, predicate_option_error(Formal, Location))
|
||||
).
|
||||
|
||||
|
||||
%% check_body(+Body, +Module, +TermPos, +Action)
|
||||
|
||||
check_body(Var, _, _, _) :-
|
||||
var(Var), !.
|
||||
check_body(M:G, _, term_position(_,_,_,_,[_,Pos]), Action) :- !,
|
||||
check_body(G, M, Pos, Action).
|
||||
check_body((A,B), M, term_position(_,_,_,_,[PA,PB]), Action) :- !,
|
||||
check_body(A, M, PA, Action),
|
||||
check_body(B, M, PB, Action).
|
||||
check_body(A=B, _, _, _) :- % partial evaluation
|
||||
unify_with_occurs_check(A,B), !.
|
||||
check_body(Goal, M, term_position(_,_,_,_,ArgPosList), Action) :-
|
||||
callable(Goal),
|
||||
functor(Goal, Name, Arity),
|
||||
( '$get_predicate_attribute'(M:Goal, imported, DefM)
|
||||
-> true
|
||||
; DefM = M
|
||||
),
|
||||
( eval_option_pred(DefM:Goal)
|
||||
-> true
|
||||
; current_option_arg(DefM:Name/Arity, OptArg), !,
|
||||
arg(OptArg, Goal, Options),
|
||||
nth1(OptArg, ArgPosList, ArgPos),
|
||||
check_options(DefM:Name/Arity, OptArg, Options, ArgPos, Action)
|
||||
).
|
||||
check_body(Goal, M, _, Action) :-
|
||||
prolog:called_by(Goal, Called), !,
|
||||
check_called_by(Called, M, Action).
|
||||
check_body(Meta, M, term_position(_,_,_,_,ArgPosList), Action) :-
|
||||
'$get_predicate_attribute'(M:Meta, meta_predicate, Head), !,
|
||||
check_meta_args(1, Head, Meta, M, ArgPosList, Action).
|
||||
check_body(_, _, _, _).
|
||||
|
||||
check_meta_args(I, Head, Meta, M, [ArgPos|ArgPosList], Action) :-
|
||||
arg(I, Head, AS), !,
|
||||
( AS == 0
|
||||
-> arg(I, Meta, MA),
|
||||
check_body(MA, M, ArgPos, Action)
|
||||
; true
|
||||
),
|
||||
succ(I, I2),
|
||||
check_meta_args(I2, Head, Meta, M, ArgPosList, Action).
|
||||
check_meta_args(_,_,_,_, _, _).
|
||||
|
||||
%% check_called_by(+CalledBy, +M, +Action) is det.
|
||||
%
|
||||
% Handle results from prolog:called_by/2.
|
||||
|
||||
check_called_by([], _, _).
|
||||
check_called_by([H|T], M, Action) :-
|
||||
( H = G+N
|
||||
-> ( extend(G, N, G2)
|
||||
-> check_body(G2, M, _, Action)
|
||||
; true
|
||||
)
|
||||
; check_body(H, M, _, Action)
|
||||
),
|
||||
check_called_by(T, M, Action).
|
||||
|
||||
extend(Goal, N, GoalEx) :-
|
||||
callable(Goal),
|
||||
Goal =.. List,
|
||||
length(Extra, N),
|
||||
append(List, Extra, ListEx),
|
||||
GoalEx =.. ListEx.
|
||||
|
||||
|
||||
%% check_options(:Predicate, +OptionArg, +Options, +ArgPos, +Action)
|
||||
%
|
||||
% Verify the list Options, that is passed into Predicate on
|
||||
% argument OptionArg. ArgPos is a term-position term describing
|
||||
% the location of the Options list. If Options is a partial list,
|
||||
% the tail is annotated with pass_to(PI, OptArg).
|
||||
|
||||
check_options(PI, OptArg, QOptions, ArgPos, Action) :-
|
||||
debug(predicate_options, '\tChecking call to ~q', [PI]),
|
||||
remove_qualifier(QOptions, Options),
|
||||
must_be(list_or_partial_list, Options),
|
||||
check_option_list(Options, PI, OptArg, Options, ArgPos, Action).
|
||||
|
||||
remove_qualifier(X, X) :-
|
||||
var(X), !.
|
||||
remove_qualifier(_:X, X) :- !.
|
||||
remove_qualifier(X, X).
|
||||
|
||||
check_option_list(Var, PI, OptArg, _, _, _) :-
|
||||
var(Var), !,
|
||||
annotate(Var, pass_to(PI, OptArg)).
|
||||
check_option_list([], _, _, _, _, _).
|
||||
check_option_list([H|T], PI, OptArg, Options, ArgPos, Action) :-
|
||||
check_option(PI, OptArg, H, ArgPos, Action),
|
||||
check_option_list(T, PI, OptArg, Options, ArgPos, Action).
|
||||
|
||||
check_option(_, _, _, _, decl) :- !.
|
||||
check_option(PI, OptArg, Opt, ArgPos, _) :-
|
||||
catch(check_predicate_option(PI, OptArg, Opt), E, true), !,
|
||||
( var(E)
|
||||
-> true
|
||||
; E = error(Formal,_),
|
||||
throw(error(Formal,ArgPos))
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* ANNOTATIONS *
|
||||
*******************************/
|
||||
|
||||
%% annotate(+Var, +Term) is det.
|
||||
%
|
||||
% Use constraints to accumulate annotations about variables. If
|
||||
% two annotated variables are unified, the attributes are joined.
|
||||
|
||||
annotate(Var, Term) :-
|
||||
( get_attr(Var, predopts_analysis, Old)
|
||||
-> put_attr(Var, predopts_analysis, [Term|Old])
|
||||
; var(Var)
|
||||
-> put_attr(Var, predopts_analysis, [Term])
|
||||
; true
|
||||
).
|
||||
|
||||
annotations(Var, Annotations) :-
|
||||
get_attr(Var, predopts_analysis, Annotations).
|
||||
|
||||
predopts_analysis:attr_unify_hook(Opts, Value) :-
|
||||
get_attr(Value, predopts_analysis, Others), !,
|
||||
append(Opts, Others, All),
|
||||
put_attr(Value, predopts_analysis, All).
|
||||
predopts_analysis:attr_unify_hook(_, _).
|
||||
|
||||
|
||||
/*******************************
|
||||
* PARTIAL EVAL *
|
||||
*******************************/
|
||||
|
||||
eval_option_pred(swi_option:option(Opt, Options)) :-
|
||||
processes(Opt, Spec),
|
||||
annotate(Options, Spec).
|
||||
eval_option_pred(swi_option:option(Opt, Options, _Default)) :-
|
||||
processes(Opt, Spec),
|
||||
annotate(Options, Spec).
|
||||
eval_option_pred(swi_option:select_option(Opt, Options, Rest)) :-
|
||||
ignore(unify_with_occurs_check(Rest, Options)),
|
||||
processes(Opt, Spec),
|
||||
annotate(Options, Spec).
|
||||
eval_option_pred(swi_option:select_option(Opt, Options, Rest, _Default)) :-
|
||||
ignore(unify_with_occurs_check(Rest, Options)),
|
||||
processes(Opt, Spec),
|
||||
annotate(Options, Spec).
|
||||
eval_option_pred(swi_option:meta_options(_Cond, QOptionsIn, QOptionsOut)) :-
|
||||
remove_qualifier(QOptionsIn, OptionsIn),
|
||||
remove_qualifier(QOptionsOut, OptionsOut),
|
||||
ignore(unify_with_occurs_check(OptionsIn, OptionsOut)).
|
||||
|
||||
processes(Opt, Spec) :-
|
||||
compound(Opt),
|
||||
functor(Opt, OptName, 1),
|
||||
Spec =.. [OptName,any].
|
||||
|
||||
|
||||
/*******************************
|
||||
* NEW DECLARTIONS *
|
||||
*******************************/
|
||||
|
||||
%% option_decl(:Head, +Action) is det.
|
||||
%
|
||||
% Add new declarations based on attributes left by the analysis
|
||||
% pass. We do not add declarations for system modules or modules
|
||||
% that already contain static declarations.
|
||||
%
|
||||
% @tbd Should we add a mode to include generating declarations
|
||||
% for system modules and modules with static declarations?
|
||||
|
||||
option_decl(_, check) :- !.
|
||||
option_decl(M:_, _) :-
|
||||
system_module(M), !.
|
||||
option_decl(M:_, _) :-
|
||||
has_static_option_decl(M), !.
|
||||
option_decl(M:Head, _) :-
|
||||
arg(AP, Head, QA),
|
||||
remove_qualifier(QA, A),
|
||||
annotations(A, Annotations0),
|
||||
functor(Head, Name, Arity),
|
||||
PI = M:Name/Arity,
|
||||
delete(Annotations0, pass_to(PI,AP), Annotations),
|
||||
Annotations \== [],
|
||||
Decl = predicate_options(PI, AP, Annotations),
|
||||
( new_decl(Decl)
|
||||
-> true
|
||||
; assert_predicate_options(M:Name/Arity, AP, Annotations, false)
|
||||
-> true
|
||||
; assertz(new_decl(Decl)),
|
||||
debug(predicate_options(decl), '~q', [Decl])
|
||||
),
|
||||
fail.
|
||||
option_decl(_, _).
|
||||
|
||||
system_module(system) :- !.
|
||||
system_module(Module) :-
|
||||
sub_atom(Module, 0, _, _, $).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MISC *
|
||||
*******************************/
|
||||
|
||||
canonical_pi(M:Name//Arity, M:Name/PArity) :-
|
||||
integer(Arity),
|
||||
PArity is Arity+2.
|
||||
canonical_pi(PI, PI).
|
||||
|
||||
%% resolve_module(:PI, -DefPI) is det.
|
||||
%
|
||||
% Find the real predicate indicator pointing to the definition
|
||||
% module of PI. This is similar to using predicate_property/3 with
|
||||
% the property imported_from, but using
|
||||
% '$get_predicate_attribute'/3 avoids auto-importing the
|
||||
% predicate.
|
||||
|
||||
resolve_module(Module:Name/Arity, DefM:Name/Arity) :-
|
||||
functor(Head, Name, Arity),
|
||||
( '$get_predicate_attribute'(Module:Head, imported, M)
|
||||
-> DefM = M
|
||||
; DefM = Module
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
:- multifile
|
||||
prolog:message//1.
|
||||
|
||||
prolog:message(predicate_option_error(Formal, Location)) -->
|
||||
error_location(Location),
|
||||
'$messages':term_message(Formal). % TBD: clean interface
|
||||
prolog:message(check_options(new(Decls))) -->
|
||||
[ 'Inferred declarations:'-[], nl ],
|
||||
new_decls(Decls).
|
||||
|
||||
error_location(file_char_count(File, CharPos)) -->
|
||||
{ filepos_line(File, CharPos, Line, LinePos) },
|
||||
[ '~w:~d:~d: '-[File, Line, LinePos] ].
|
||||
error_location(clause(ClauseRef)) -->
|
||||
{ clause_property(ClauseRef, file(File)),
|
||||
clause_property(ClauseRef, line_count(Line))
|
||||
}, !,
|
||||
[ '~w:~d: '-[File, Line] ].
|
||||
error_location(clause(ClauseRef)) -->
|
||||
[ 'Clause ~q: '-[ClauseRef] ].
|
||||
|
||||
filepos_line(File, CharPos, Line, LinePos) :-
|
||||
setup_call_cleanup(
|
||||
( open(File, read, In),
|
||||
open_null_stream(Out)
|
||||
),
|
||||
( Skip is CharPos-1,
|
||||
copy_stream_data(In, Out, Skip),
|
||||
stream_property(In, position(Pos)),
|
||||
stream_position_data(line_count, Pos, Line),
|
||||
stream_position_data(line_position, Pos, LinePos)
|
||||
),
|
||||
( close(Out),
|
||||
close(In)
|
||||
)).
|
||||
|
||||
new_decls([]) --> [].
|
||||
new_decls([H|T]) -->
|
||||
[ ' :- ~q'-[H], nl ],
|
||||
new_decls(T).
|
||||
|
||||
|
||||
/*******************************
|
||||
* SYSTEM DECLARATIONS *
|
||||
*******************************/
|
||||
|
||||
:- use_module(library(dialect/swi/syspred_options)).
|
||||
141
swi/library/predopts.pl
Normal file
141
swi/library/predopts.pl
Normal file
@@ -0,0 +1,141 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2011, VU University 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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('$predopts',
|
||||
[
|
||||
]).
|
||||
|
||||
:- multifile
|
||||
predicate_options:option_decl/3,
|
||||
predicate_options:pred_option/3.
|
||||
:- multifile % provided by library(predicate_options)
|
||||
system:predicate_option_type/2,
|
||||
system:predicate_option_mode/2.
|
||||
|
||||
:- public
|
||||
option_clauses//4.
|
||||
|
||||
%% expand_predicate_options(:PI, +Arg, +OptionList, -Clauses) is det.
|
||||
%
|
||||
% Term-expansion code for predicate_options(PI, Arg, OptionList).
|
||||
|
||||
expand_predicate_options(PI, Arg, Options,
|
||||
[ predicate_options:option_decl(Head, M, Arg),
|
||||
(:-multifile(M:'$pred_option'/4))
|
||||
| OptionClauses
|
||||
]) :-
|
||||
canonical_pi(PI, CPI),
|
||||
prolog_load_context(module, M0),
|
||||
strip_module(M0:CPI, M, Name/Arity),
|
||||
functor(Head, Name, Arity),
|
||||
( is_list(Options)
|
||||
-> true
|
||||
; throw(error(type_error(list, Options), _))
|
||||
),
|
||||
phrase(option_clauses(Options, Head, M, Arg), OptionClauses0),
|
||||
qualify_list(OptionClauses0, M0, OptionClauses).
|
||||
|
||||
qualify_list([], _, []).
|
||||
qualify_list([H0|T0], M, [H|T]) :-
|
||||
qualify(H0, M, H),
|
||||
qualify_list(T0, M, T).
|
||||
|
||||
qualify(M:Term, M, Term) :- !.
|
||||
qualify(QTerm, _, QTerm).
|
||||
|
||||
|
||||
option_clauses([], _, _, _) --> [].
|
||||
option_clauses([H|T], Head, M, A) -->
|
||||
option_clause(H, Head, M),
|
||||
option_clauses(T, Head, M, A).
|
||||
|
||||
option_clause(Var, _, _) -->
|
||||
{ var(Var), !,
|
||||
throw(error(instantiation_error, _))
|
||||
}.
|
||||
option_clause(pass_to(PI0, Arg), Head, M) --> !,
|
||||
{ canonical_pi(PI0, PI),
|
||||
strip_module(M:PI, TM, Name/Arity),
|
||||
functor(THead, Name, Arity),
|
||||
Clause = ('$pred_option'(Head, pass_to(PI0, Arg), Opt, Seen) :-
|
||||
\+ memberchk(PI-Arg, Seen),
|
||||
predicate_options:pred_option(TM:THead, Opt, [PI-Arg|Seen]))
|
||||
},
|
||||
[ M:Clause ].
|
||||
option_clause(Option, Head, M) -->
|
||||
{ Option =.. [Name|ModeAndTypes], !,
|
||||
modes_and_types(ModeAndTypes, Args, Body),
|
||||
Opt =.. [Name|Args],
|
||||
Clause = ('$pred_option'(Head, Option, Opt, _) :- Body)
|
||||
},
|
||||
[ M:Clause ].
|
||||
option_clause(Option, _, _) -->
|
||||
{ throw(error(type_error(option_specifier, Option)))
|
||||
}.
|
||||
|
||||
modes_and_types([], [], true).
|
||||
modes_and_types([H|T], [A|AT], Body) :-
|
||||
mode_and_type(H, A, Body0),
|
||||
( T == []
|
||||
-> Body = Body0,
|
||||
AT = []
|
||||
; Body0 == true
|
||||
-> modes_and_types(T, AT, Body)
|
||||
; Body = (Body0,Body1),
|
||||
modes_and_types(T, AT, Body1)
|
||||
).
|
||||
|
||||
|
||||
mode_and_type(-Type, A, (predicate_option_mode(output, A), Body)) :- !,
|
||||
type_goal(Type, A, Body).
|
||||
mode_and_type(+Type, A, Body) :- !,
|
||||
type_goal(Type, A, Body).
|
||||
mode_and_type(Type, A, Body) :-
|
||||
type_goal(Type, A, Body).
|
||||
|
||||
type_goal(Type, A, predicate_option_type(Type, A)).
|
||||
|
||||
|
||||
%% canonical_pi(+PIIn, -PIout)
|
||||
|
||||
canonical_pi(M:Name//Arity, M:Name/PArity) :-
|
||||
integer(Arity), !,
|
||||
PArity is Arity+2.
|
||||
canonical_pi(Name//Arity, Name/PArity) :-
|
||||
integer(Arity), !,
|
||||
PArity is Arity+2.
|
||||
canonical_pi(PI, PI).
|
||||
|
||||
|
||||
/*******************************
|
||||
* EXPAND *
|
||||
*******************************/
|
||||
|
||||
%system:term_expansion((:- predicate_options(PI, Arg, Options)), Clauses) :-
|
||||
% expand_predicate_options(PI, Arg, Options, Clauses).
|
||||
675
swi/library/prolog_clause.pl
Normal file
675
swi/library/prolog_clause.pl
Normal file
@@ -0,0 +1,675 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2011, University of Amsterdam
|
||||
VU University 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 Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(prolog_clause,
|
||||
[ clause_info/4, % +ClauseRef, -File, -TermPos, -VarNames
|
||||
predicate_name/2, % +Head, -Name
|
||||
clause_name/2 % +ClauseRef, -Name
|
||||
]).
|
||||
:- use_module(library(lists), [append/3]).
|
||||
:- use_module(library(occurs), [sub_term/2]).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(listing)).
|
||||
:- use_module(library(prolog_source)).
|
||||
|
||||
|
||||
:- public % called from library(trace/clause)
|
||||
unify_term/2,
|
||||
make_varnames/5,
|
||||
do_make_varnames/3.
|
||||
|
||||
:- multifile
|
||||
make_varnames_hook/5.
|
||||
|
||||
/** <module> Get detailed source-information about a clause
|
||||
|
||||
This module started life as part of the GUI tracer. As it is generally
|
||||
useful for debugging purposes it has moved to the general Prolog
|
||||
library.
|
||||
|
||||
The tracer library library(trace/clause) adds caching and dealing with
|
||||
dynamic predicates using listing to XPCE objects to this. Note that
|
||||
clause_info/4 as below can be slow.
|
||||
*/
|
||||
|
||||
%% clause_info(+ClauseRef, -File, -TermPos, -VarNames)
|
||||
%
|
||||
% Fetches source information for the given clause. File is the
|
||||
% file from which the clause was loaded. TermPos describes the
|
||||
% source layout in a format compatible to the subterm_positions
|
||||
% option of read_term/2. VarNames provides access to the variable
|
||||
% allocation in a stack-frame. See make_varnames/5 for details.
|
||||
|
||||
clause_info(ClauseRef, File, TermPos, NameOffset) :-
|
||||
( debugging(clause_info)
|
||||
-> clause_name(ClauseRef, Name),
|
||||
debug(clause_info, 'clause_info(~w) (~w)... ',
|
||||
[ClauseRef, Name])
|
||||
; true
|
||||
),
|
||||
clause_property(ClauseRef, file(File)),
|
||||
'$clause'(Head, Body, ClauseRef, VarOffset),
|
||||
( Body == true
|
||||
-> DecompiledClause = Head
|
||||
; DecompiledClause = (Head :- Body)
|
||||
),
|
||||
File \== user, % loaded using ?- [user].
|
||||
clause_property(ClauseRef, line_count(LineNo)),
|
||||
( module_property(Module, file(File))
|
||||
-> true
|
||||
; strip_module(user:Head, Module, _)
|
||||
),
|
||||
debug(clause_info, 'from ~w:~d ... ', [File, LineNo]),
|
||||
read_term_at_line(File, LineNo, Module, Clause, TermPos0, VarNames),
|
||||
debug(clause_info, 'read ...', []),
|
||||
unify_clause(Clause, DecompiledClause, Module, TermPos0, TermPos),
|
||||
debug(clause_info, 'unified ...', []),
|
||||
make_varnames(Clause, DecompiledClause, VarOffset, VarNames, NameOffset),
|
||||
debug(clause_info, 'got names~n', []), !.
|
||||
|
||||
%% unify_term(+T1, +T2)
|
||||
%
|
||||
% Unify the two terms, where T2 is created by writing the term and
|
||||
% reading it back in, but be aware that rounding problems may
|
||||
% cause floating point numbers not to unify. Also, if the initial
|
||||
% term has a string object, it is written as "..." and read as a
|
||||
% code-list. We compensate for that.
|
||||
%
|
||||
% NOTE: Called directly from library(trace/clause) for the GUI
|
||||
% tracer.
|
||||
|
||||
unify_term(X, X) :- !.
|
||||
unify_term(X1, X2) :-
|
||||
compound(X1),
|
||||
compound(X2),
|
||||
functor(X1, F, Arity),
|
||||
functor(X2, F, Arity), !,
|
||||
unify_args(0, Arity, X1, X2).
|
||||
unify_term(X, Y) :-
|
||||
float(X), float(Y), !.
|
||||
unify_term(X, Y) :-
|
||||
string(X),
|
||||
is_list(Y),
|
||||
string_to_list(X, Y), !.
|
||||
unify_term(_, Y) :-
|
||||
Y == '...', !. % elipses left by max_depth
|
||||
unify_term(_:X, Y) :-
|
||||
unify_term(X, Y), !.
|
||||
unify_term(X, _:Y) :-
|
||||
unify_term(X, Y), !.
|
||||
unify_term(X, Y) :-
|
||||
format('[INTERNAL ERROR: Diff:~n'),
|
||||
portray_clause(X),
|
||||
format('~N*** <->~n'),
|
||||
portray_clause(Y),
|
||||
break.
|
||||
|
||||
unify_args(N, N, _, _) :- !.
|
||||
unify_args(I, Arity, T1, T2) :-
|
||||
A is I + 1,
|
||||
arg(A, T1, A1),
|
||||
arg(A, T2, A2),
|
||||
unify_term(A1, A2),
|
||||
unify_args(A, Arity, T1, T2).
|
||||
|
||||
|
||||
%% read_term_at_line(+File, +Line, +Module,
|
||||
%% -Clause, -TermPos, -VarNames) is semidet.
|
||||
%
|
||||
% Read a term from File at Line.
|
||||
|
||||
read_term_at_line(File, Line, Module, Clause, TermPos, VarNames) :-
|
||||
catch(open(File, read, In), _, fail),
|
||||
call_cleanup(
|
||||
read_source_term_at_location(
|
||||
In, Clause,
|
||||
[ line(Line),
|
||||
module(Module),
|
||||
subterm_positions(TermPos),
|
||||
variable_names(VarNames)
|
||||
]),
|
||||
close(In)).
|
||||
|
||||
|
||||
%% make_varnames(+ReadClause, +DecompiledClause,
|
||||
%% +Offsets, +Names, -Term) is det.
|
||||
%
|
||||
% Create a Term varnames(...) where each argument contains the name
|
||||
% of the variable at that offset. If the read Clause is a DCG rule,
|
||||
% name the two last arguments <DCG_list> and <DCG_tail>
|
||||
%
|
||||
% This predicate calles the multifile predicate
|
||||
% make_varnames_hook/5 with the same arguments to allow for user
|
||||
% extensions. Extending this predicate is needed if a compiler
|
||||
% adds additional arguments to the clause head that must be made
|
||||
% visible in the GUI tracer.
|
||||
%
|
||||
% @param Offsets List of Offset=Var
|
||||
% @param Names List of Name=Var
|
||||
|
||||
make_varnames(ReadClause, DecompiledClause, Offsets, Names, Term) :-
|
||||
make_varnames_hook(ReadClause, DecompiledClause, Offsets, Names, Term), !.
|
||||
make_varnames((Head --> _Body), _, Offsets, Names, Bindings) :- !,
|
||||
functor(Head, _, Arity),
|
||||
In is Arity,
|
||||
memberchk(In=IVar, Offsets),
|
||||
Names1 = ['<DCG_list>'=IVar|Names],
|
||||
Out is Arity + 1,
|
||||
memberchk(Out=OVar, Offsets),
|
||||
Names2 = ['<DCG_tail>'=OVar|Names1],
|
||||
make_varnames(xx, xx, Offsets, Names2, Bindings).
|
||||
make_varnames(_, _, Offsets, Names, Bindings) :-
|
||||
length(Offsets, L),
|
||||
functor(Bindings, varnames, L),
|
||||
do_make_varnames(Offsets, Names, Bindings).
|
||||
|
||||
do_make_varnames([], _, _).
|
||||
do_make_varnames([N=Var|TO], Names, Bindings) :-
|
||||
( find_varname(Var, Names, Name)
|
||||
-> true
|
||||
; Name = '_'
|
||||
),
|
||||
AN is N + 1,
|
||||
arg(AN, Bindings, Name),
|
||||
do_make_varnames(TO, Names, Bindings).
|
||||
|
||||
find_varname(Var, [Name = TheVar|_], Name) :-
|
||||
Var == TheVar, !.
|
||||
find_varname(Var, [_|T], Name) :-
|
||||
find_varname(Var, T, Name).
|
||||
|
||||
%% unify_clause(+Read, +Decompiled, +Module, +ReadTermPos,
|
||||
%% -RecompiledTermPos).
|
||||
%
|
||||
% What you read isn't always what goes into the database. The task
|
||||
% of this predicate is to establish the relation between the term
|
||||
% read from the file and the result from decompiling the clause.
|
||||
%
|
||||
% This predicate calls the multifile predicate unify_clause_hook/5
|
||||
% with the same arguments to support user extensions.
|
||||
%
|
||||
% @tbd This really must be more flexible, dealing with much
|
||||
% more complex source-translations, falling back to a
|
||||
% heuristic method locating as much as possible.
|
||||
|
||||
:- multifile
|
||||
unify_clause_hook/5.
|
||||
|
||||
unify_clause(Read, Read, _, TermPos, TermPos) :- !.
|
||||
% XPCE send-methods
|
||||
unify_clause(Read, Decompiled, Module, TermPoso, TermPos) :-
|
||||
unify_clause_hook(Read, Decompiled, Module, TermPoso, TermPos), !.
|
||||
unify_clause(:->(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !,
|
||||
pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos).
|
||||
% XPCE get-methods
|
||||
unify_clause(:<-(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !,
|
||||
pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos).
|
||||
% Unit test clauses
|
||||
unify_clause((TH :- Body),
|
||||
(_:'unit body'(_, _) :- !, Body), _,
|
||||
TP0, TP) :-
|
||||
( TH = test(_,_)
|
||||
; TH = test(_)
|
||||
), !,
|
||||
TP0 = term_position(F,T,FF,FT,[HP,BP]),
|
||||
TP = term_position(F,T,FF,FT,[HP,term_position(0,0,0,0,[FF-FT,BP])]).
|
||||
% module:head :- body
|
||||
unify_clause((Head :- Read),
|
||||
(Head :- _M:Compiled), Module, TermPos0, TermPos) :-
|
||||
unify_clause((Head :- Read), (Head :- Compiled), Module, TermPos0, TermPos1),
|
||||
TermPos1 = term_position(TA,TZ,FA,FZ,[PH,PB]),
|
||||
TermPos = term_position(TA,TZ,FA,FZ,
|
||||
[ PH,
|
||||
term_position(0,0,0,0,[0-0,PB])
|
||||
]).
|
||||
unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :-
|
||||
Read = (_ --> List, _),
|
||||
is_list(List),
|
||||
ci_expand(Read, Compiled2, Module),
|
||||
Compiled2 = (DH :- _),
|
||||
functor(DH, _, Arity),
|
||||
DArg is Arity - 1,
|
||||
arg(DArg, DH, List),
|
||||
nonvar(List),
|
||||
TermPos0 = term_position(F,T,FF,FT,[ HP,
|
||||
term_position(_,_,_,_,[_,BP])
|
||||
]), !,
|
||||
TermPos1 = term_position(F,T,FF,FT,[ HP, BP ]),
|
||||
match_module(Compiled2, Compiled1, TermPos1, TermPos).
|
||||
% general term-expansion
|
||||
unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :-
|
||||
ci_expand(Read, Compiled2, Module),
|
||||
match_module(Compiled2, Compiled1, TermPos0, TermPos).
|
||||
% I don't know ...
|
||||
unify_clause(_, _, _, _, _) :-
|
||||
debug(clause_info, 'Could not unify clause', []),
|
||||
fail.
|
||||
|
||||
unify_clause_head(H1, H2) :-
|
||||
strip_module(H1, _, H),
|
||||
strip_module(H2, _, H).
|
||||
|
||||
ci_expand(Read, Compiled, Module) :-
|
||||
catch(setup_call_cleanup('$set_source_module'(Old, Module),
|
||||
expand_term(Read, Compiled),
|
||||
'$set_source_module'(_, Old)),
|
||||
E,
|
||||
expand_failed(E, Read)).
|
||||
|
||||
match_module((H1 :- B1), (H2 :- B2), Pos0, Pos) :- !,
|
||||
unify_clause_head(H1, H2),
|
||||
unify_body(B1, B2, Pos0, Pos).
|
||||
match_module(H1, H2, Pos, Pos) :- % deal with facts
|
||||
unify_clause_head(H1, H2).
|
||||
|
||||
%% expand_failed(+Exception, +Term)
|
||||
%
|
||||
% When debugging, indicate that expansion of the term failed.
|
||||
|
||||
expand_failed(E, Read) :-
|
||||
debugging(clause_info),
|
||||
message_to_string(E, Msg),
|
||||
debug(clause_info, 'Term-expand ~p failed: ~w', [Read, Msg]),
|
||||
fail.
|
||||
|
||||
%% unify_body(+Read, +Decompiled, +Pos0, -Pos)
|
||||
%
|
||||
% Deal with translations implied by the compiler. For example,
|
||||
% compiling (a,b),c yields the same code as compiling a,b,c.
|
||||
%
|
||||
% Pos0 and Pos still include the term-position of the head.
|
||||
|
||||
unify_body(B, B, Pos, Pos) :-
|
||||
does_not_dcg_after_binding(B, Pos), !.
|
||||
unify_body(R, D,
|
||||
term_position(F,T,FF,FT,[HP,BP0]),
|
||||
term_position(F,T,FF,FT,[HP,BP])) :-
|
||||
ubody(R, D, BP0, BP).
|
||||
|
||||
%% does_not_dcg_after_binding(+ReadBody, +ReadPos) is semidet.
|
||||
%
|
||||
% True if ReadPos/ReadPos does not contain DCG delayed
|
||||
% unifications.
|
||||
%
|
||||
% @tbd We should pass that we are in a DCG; if we are not there
|
||||
% is no reason for this test.
|
||||
|
||||
does_not_dcg_after_binding(B, Pos) :-
|
||||
acyclic_term(B), % X = call(X)
|
||||
\+ sub_term(brace_term_position(_,_,_), Pos),
|
||||
\+ (sub_term((Cut,_=_), B), Cut == !), !.
|
||||
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
Some remarks.
|
||||
|
||||
a --> { x, y, z }.
|
||||
This is translated into "(x,y),z), X=Y" by the DCG translator, after
|
||||
which the compiler creates "a(X,Y) :- x, y, z, X=Y".
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
%% ubody(+Read, +Decompiled, +TermPosRead, -TermPosForDecompiled)
|
||||
%
|
||||
% @param Read Clause read _after_ expand_term/2
|
||||
% @param Decompiled Decompiled clause
|
||||
% @param TermPosRead Sub-term positions of source
|
||||
|
||||
ubody(B, B, P, P) :-
|
||||
does_not_dcg_after_binding(B, P), !.
|
||||
ubody(X, call(X), % X = call(X)
|
||||
From-To,
|
||||
term_position(From, To, From, To, [From-To])) :- !.
|
||||
ubody(B0, B,
|
||||
brace_term_position(F,T,A0),
|
||||
Pos) :-
|
||||
B0 = (_,_=_), !,
|
||||
T1 is T - 1,
|
||||
ubody(B0, B,
|
||||
term_position(F,T,
|
||||
F,T,
|
||||
[A0,T1-T]),
|
||||
Pos).
|
||||
ubody(B0, B,
|
||||
brace_term_position(F,T,A0),
|
||||
term_position(F,T,F,T,[A])) :- !,
|
||||
ubody(B0, B, A0, A).
|
||||
ubody(C0, C, P0, P) :-
|
||||
nonvar(C0), nonvar(C),
|
||||
C0 = (_,_), C = (_,_), !,
|
||||
conj(C0, P0, GL, PL),
|
||||
mkconj(C, P, GL, PL).
|
||||
ubody(X0, X,
|
||||
term_position(F,T,FF,TT,PA0),
|
||||
term_position(F,T,FF,TT,PA)) :-
|
||||
meta(X0), !,
|
||||
X0 =.. [_|A0],
|
||||
X =.. [_|A],
|
||||
ubody_list(A0, A, PA0, PA).
|
||||
% 5.7.X optimizations
|
||||
ubody(_=_, true, % singleton = Any
|
||||
term_position(F,T,_FF,_TT,_PA),
|
||||
F-T) :- !.
|
||||
ubody(_==_, fail, % singleton/firstvar == Any
|
||||
term_position(F,T,_FF,_TT,_PA),
|
||||
F-T) :- !.
|
||||
ubody(A1=B1, B2=A2, % Term = Var --> Var = Term
|
||||
term_position(F,T,FF,TT,[PA1,PA2]),
|
||||
term_position(F,T,FF,TT,[PA2,PA1])) :-
|
||||
(A1==B1) =@= (B2==A2), !,
|
||||
A1 = A2, B1=B2.
|
||||
ubody(A1==B1, B2==A2, % const == Var --> Var == const
|
||||
term_position(F,T,FF,TT,[PA1,PA2]),
|
||||
term_position(F,T,FF,TT,[PA2,PA1])) :-
|
||||
(A1==B1) =@= (B2==A2), !,
|
||||
A1 = A2, B1=B2.
|
||||
ubody(A is B - C, A is B + C2, Pos, Pos) :-
|
||||
integer(C),
|
||||
C2 =:= -C, !.
|
||||
|
||||
ubody_list([], [], [], []).
|
||||
ubody_list([G0|T0], [G|T], [PA0|PAT0], [PA|PAT]) :-
|
||||
ubody(G0, G, PA0, PA),
|
||||
ubody_list(T0, T, PAT0, PAT).
|
||||
|
||||
|
||||
conj(Goal, Pos, GoalList, PosList) :-
|
||||
conj(Goal, Pos, GoalList, [], PosList, []).
|
||||
|
||||
conj((A,B), term_position(_,_,_,_,[PA,PB]), GL, TG, PL, TP) :- !,
|
||||
conj(A, PA, GL, TGA, PL, TPA),
|
||||
conj(B, PB, TGA, TG, TPA, TP).
|
||||
conj((A,B), brace_term_position(_,T,PA), GL, TG, PL, TP) :-
|
||||
B = (_=_), !,
|
||||
conj(A, PA, GL, TGA, PL, TPA),
|
||||
T1 is T - 1,
|
||||
conj(B, T1-T, TGA, TG, TPA, TP).
|
||||
conj((!,(S=SR)), F-T, [!,S=SR|TG], TG, [F-T,F1-T1|TP], TP) :-
|
||||
F1 is F+1,
|
||||
T1 is T+1.
|
||||
conj(A, P, [A|TG], TG, [P|TP], TP).
|
||||
|
||||
|
||||
mkconj(Goal, Pos, GoalList, PosList) :-
|
||||
mkconj(Goal, Pos, GoalList, [], PosList, []).
|
||||
|
||||
mkconj(Conj, term_position(0,0,0,0,[PA,PB]), GL, TG, PL, TP) :-
|
||||
nonvar(Conj),
|
||||
Conj = (A,B), !,
|
||||
mkconj(A, PA, GL, TGA, PL, TPA),
|
||||
mkconj(B, PB, TGA, TG, TPA, TP).
|
||||
mkconj(A0, P0, [A|TG], TG, [P|TP], TP) :-
|
||||
ubody(A, A0, P, P0).
|
||||
|
||||
|
||||
/*******************************
|
||||
* PCE STUFF (SHOULD MOVE) *
|
||||
*******************************/
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
<method>(Receiver, ... Arg ...) :->
|
||||
Body
|
||||
|
||||
mapped to:
|
||||
|
||||
send_implementation(Id, <method>(...Arg...), Receiver)
|
||||
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
pce_method_clause(Head, Body, _:PlHead, PlBody, TermPos0, TermPos) :- !,
|
||||
pce_method_clause(Head, Body, PlBody, PlHead, TermPos0, TermPos).
|
||||
pce_method_clause(Head, Body,
|
||||
send_implementation(_Id, Msg, Receiver), PlBody,
|
||||
TermPos0, TermPos) :- !,
|
||||
debug(clause_info, 'send method ...', []),
|
||||
arg(1, Head, Receiver),
|
||||
functor(Head, _, Arity),
|
||||
pce_method_head_arguments(2, Arity, Head, Msg),
|
||||
debug(clause_info, 'head ...', []),
|
||||
pce_method_body(Body, PlBody, TermPos0, TermPos).
|
||||
pce_method_clause(Head, Body,
|
||||
get_implementation(_Id, Msg, Receiver, Result), PlBody,
|
||||
TermPos0, TermPos) :- !,
|
||||
debug(clause_info, 'get method ...', []),
|
||||
arg(1, Head, Receiver),
|
||||
debug(clause_info, 'receiver ...', []),
|
||||
functor(Head, _, Arity),
|
||||
arg(Arity, Head, PceResult),
|
||||
debug(clause_info, '~w?~n', [PceResult = Result]),
|
||||
pce_unify_head_arg(PceResult, Result),
|
||||
Ar is Arity - 1,
|
||||
pce_method_head_arguments(2, Ar, Head, Msg),
|
||||
debug(clause_info, 'head ...', []),
|
||||
pce_method_body(Body, PlBody, TermPos0, TermPos).
|
||||
|
||||
pce_method_head_arguments(N, Arity, Head, Msg) :-
|
||||
N =< Arity, !,
|
||||
arg(N, Head, PceArg),
|
||||
PLN is N - 1,
|
||||
arg(PLN, Msg, PlArg),
|
||||
pce_unify_head_arg(PceArg, PlArg),
|
||||
debug(clause_info, '~w~n', [PceArg = PlArg]),
|
||||
NextArg is N+1,
|
||||
pce_method_head_arguments(NextArg, Arity, Head, Msg).
|
||||
pce_method_head_arguments(_, _, _, _).
|
||||
|
||||
pce_unify_head_arg(V, A) :-
|
||||
var(V), !,
|
||||
V = A.
|
||||
pce_unify_head_arg(A:_=_, A) :- !.
|
||||
pce_unify_head_arg(A:_, A).
|
||||
|
||||
% pce_method_body(+SrcBody, +DbBody, +TermPos0, -TermPos
|
||||
%
|
||||
% Unify the body of an XPCE method. Goal-expansion makes this
|
||||
% rather tricky, especially as we cannot call XPCE's expansion
|
||||
% on an isolated method.
|
||||
%
|
||||
% TermPos0 is the term-position term of the whole clause!
|
||||
%
|
||||
% Further, please note that the body of the method-clauses reside
|
||||
% in another module than pce_principal, and therefore the body
|
||||
% starts with an I_CONTEXT call. This implies we need a
|
||||
% hypothetical term-position for the module-qualifier.
|
||||
|
||||
pce_method_body(A0, A, TermPos0, TermPos) :-
|
||||
TermPos0 = term_position(F, T, FF, FT,
|
||||
[ HeadPos,
|
||||
BodyPos0
|
||||
]),
|
||||
TermPos = term_position(F, T, FF, FT,
|
||||
[ HeadPos,
|
||||
term_position(0,0,0,0, [0-0,BodyPos])
|
||||
]),
|
||||
pce_method_body2(A0, A, BodyPos0, BodyPos).
|
||||
|
||||
|
||||
pce_method_body2(::(_,A0), A, TermPos0, TermPos) :- !,
|
||||
TermPos0 = term_position(_, _, _, _, [_Cmt,BodyPos0]),
|
||||
TermPos = BodyPos,
|
||||
expand_goal(A0, A, BodyPos0, BodyPos).
|
||||
pce_method_body2(A0, A, TermPos0, TermPos) :-
|
||||
A0 =.. [Func,B0,C0],
|
||||
control_op(Func), !,
|
||||
A =.. [Func,B,C],
|
||||
TermPos0 = term_position(F, T, FF, FT,
|
||||
[ BP0,
|
||||
CP0
|
||||
]),
|
||||
TermPos = term_position(F, T, FF, FT,
|
||||
[ BP,
|
||||
CP
|
||||
]),
|
||||
pce_method_body2(B0, B, BP0, BP),
|
||||
expand_goal(C0, C, CP0, CP).
|
||||
pce_method_body2(A0, A, TermPos0, TermPos) :-
|
||||
expand_goal(A0, A, TermPos0, TermPos).
|
||||
|
||||
control_op(',').
|
||||
control_op((;)).
|
||||
control_op((->)).
|
||||
control_op((*->)).
|
||||
|
||||
/*******************************
|
||||
* EXPAND_GOAL SUPPORT *
|
||||
*******************************/
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
With the introduction of expand_goal, it is increasingly hard to relate
|
||||
the clause from the database to the actual source. For one thing, we do
|
||||
not know the compilation module of the clause (unless we want to
|
||||
decompile it).
|
||||
|
||||
Goal expansion can translate goals into control-constructs, multiple
|
||||
clauses, or delete a subgoal.
|
||||
|
||||
To keep track of the source-locations, we have to redo the analysis of
|
||||
the clause as defined in init.pl
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
expand_goal(G, call(G), P, term_position(0,0,0,0,[P])) :-
|
||||
var(G), !.
|
||||
expand_goal(G, G, P, P) :-
|
||||
var(G), !.
|
||||
expand_goal(M0, M, P0, P) :-
|
||||
meta(M0), !,
|
||||
P0 = term_position(F,T,FF,FT,PL0),
|
||||
P = term_position(F,T,FF,FT,PL),
|
||||
functor(M0, Functor, Arity),
|
||||
functor(M, Functor, Arity),
|
||||
expand_meta_args(PL0, PL, 1, M0, M).
|
||||
expand_goal(A, B, P0, P) :-
|
||||
goal_expansion(A, B0, P0, P1), !,
|
||||
expand_goal(B0, B, P1, P).
|
||||
expand_goal(A, A, P, P).
|
||||
|
||||
expand_meta_args([], [], _, _, _).
|
||||
expand_meta_args([P0|T0], [P|T], I, M0, M) :-
|
||||
arg(I, M0, A0),
|
||||
arg(I, M, A),
|
||||
expand_goal(A0, A, P0, P),
|
||||
NI is I + 1,
|
||||
expand_meta_args(T0, T, NI, M0, M).
|
||||
|
||||
meta((_ , _)).
|
||||
meta((_ ; _)).
|
||||
meta((_ -> _)).
|
||||
meta((_ *-> _)).
|
||||
meta((\+ _)).
|
||||
meta((not(_))).
|
||||
meta((call(_))).
|
||||
meta((once(_))).
|
||||
meta((ignore(_))).
|
||||
meta((forall(_, _))).
|
||||
|
||||
goal_expansion(send(R, Msg), send_class(R, _, SuperMsg), P, P) :-
|
||||
compound(Msg),
|
||||
Msg =.. [send_super, Selector | Args], !,
|
||||
SuperMsg =.. [Selector|Args].
|
||||
goal_expansion(get(R, Msg, A), get_class(R, _, SuperMsg, A), P, P) :-
|
||||
compound(Msg),
|
||||
Msg =.. [get_super, Selector | Args], !,
|
||||
SuperMsg =.. [Selector|Args].
|
||||
goal_expansion(send_super(R, Msg), send_class(R, _, Msg), P, P).
|
||||
goal_expansion(get_super(R, Msg, V), get_class(R, _, Msg, V), P, P).
|
||||
goal_expansion(SendSuperN, send_class(R, _, Msg), P, P) :-
|
||||
compound(SendSuperN),
|
||||
SendSuperN =.. [send_super, R, Sel | Args],
|
||||
Msg =.. [Sel|Args].
|
||||
goal_expansion(SendN, send(R, Msg), P, P) :-
|
||||
compound(SendN),
|
||||
SendN =.. [send, R, Sel | Args],
|
||||
atom(Sel), Args \== [],
|
||||
Msg =.. [Sel|Args].
|
||||
goal_expansion(GetSuperN, get_class(R, _, Msg, Answer), P, P) :-
|
||||
compound(GetSuperN),
|
||||
GetSuperN =.. [get_super, R, Sel | AllArgs],
|
||||
append(Args, [Answer], AllArgs),
|
||||
Msg =.. [Sel|Args].
|
||||
goal_expansion(GetN, get(R, Msg, Answer), P, P) :-
|
||||
compound(GetN),
|
||||
GetN =.. [get, R, Sel | AllArgs],
|
||||
append(Args, [Answer], AllArgs),
|
||||
atom(Sel), Args \== [],
|
||||
Msg =.. [Sel|Args].
|
||||
goal_expansion(G0, G, P, P) :-
|
||||
user:goal_expansion(G0, G), % TBD: we need the module!
|
||||
G0 \== G. % \=@=?
|
||||
|
||||
|
||||
/*******************************
|
||||
* PRINTABLE NAMES *
|
||||
*******************************/
|
||||
|
||||
:- module_transparent
|
||||
predicate_name/2.
|
||||
:- multifile
|
||||
user:prolog_predicate_name/2,
|
||||
user:prolog_clause_name/2.
|
||||
|
||||
hidden_module(user).
|
||||
hidden_module(system).
|
||||
hidden_module(pce_principal). % should be config
|
||||
hidden_module(Module) :- % SWI-Prolog specific
|
||||
import_module(Module, system).
|
||||
|
||||
thaffix(1, st) :- !.
|
||||
thaffix(2, nd) :- !.
|
||||
thaffix(_, th).
|
||||
|
||||
%% predicate_name(:Head, -PredName:string) is det.
|
||||
%
|
||||
% Describe a predicate as [Module:]Name/Arity.
|
||||
|
||||
predicate_name(Predicate, PName) :-
|
||||
strip_module(Predicate, Module, Head),
|
||||
( user:prolog_predicate_name(Module:Head, PName)
|
||||
-> true
|
||||
; functor(Head, Name, Arity),
|
||||
( hidden_module(Module)
|
||||
-> format(string(PName), '~q/~d', [Name, Arity])
|
||||
; format(string(PName), '~q:~q/~d', [Module, Name, Arity])
|
||||
)
|
||||
).
|
||||
|
||||
%% clause_name(+Ref, -Name)
|
||||
%
|
||||
% Provide a suitable description of the indicated clause.
|
||||
|
||||
clause_name(Ref, Name) :-
|
||||
user:prolog_clause_name(Ref, Name), !.
|
||||
clause_name(Ref, Name) :-
|
||||
nth_clause(Head, N, Ref), !,
|
||||
predicate_name(Head, PredName),
|
||||
thaffix(N, Th),
|
||||
format(string(Name), '~d-~w clause of ~w', [N, Th, PredName]).
|
||||
clause_name(_, '<meta-call>').
|
||||
1508
swi/library/prolog_colour.pl
Normal file
1508
swi/library/prolog_colour.pl
Normal file
File diff suppressed because it is too large
Load Diff
238
swi/library/prolog_source.pl
Normal file
238
swi/library/prolog_source.pl
Normal file
@@ -0,0 +1,238 @@
|
||||
/* $Id: prolog_source.pl,v 1.1 2008-02-12 17:03:53 vsc Exp $
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2005, 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(prolog_source,
|
||||
[ prolog_read_source_term/4, % +Stream, -Term, -Expanded, +Options
|
||||
prolog_open_source/2, % +Source, -Stream
|
||||
prolog_close_source/1, % +Stream
|
||||
prolog_canonical_source/2 % +Spec, -Id
|
||||
]).
|
||||
:- use_module(operators).
|
||||
:- use_module(debug).
|
||||
|
||||
/** <module> Examine Prolog source-files
|
||||
|
||||
The modile prolog_source.pl provides predicates to open, close and read
|
||||
terms from Prolog source-files. This may seem easy, but there are a
|
||||
couple of problems that must be taken care of.
|
||||
|
||||
* Source files may start with #!, supporting PrologScript
|
||||
* Embeded operators declarations must be taken into account
|
||||
* Style-check options must be taken into account
|
||||
* Operators and style-check options may be implied by directives
|
||||
* On behalf of the development environment we also wish to
|
||||
parse PceEmacs buffers
|
||||
|
||||
This module concentrates these issues in a single library. Intended
|
||||
users of the library are:
|
||||
|
||||
$ prolog_xref.pl : The Prolog cross-referencer
|
||||
$ PceEmacs : Emacs syntax-colouring
|
||||
$ PlDoc : The documentation framework
|
||||
*/
|
||||
|
||||
:- thread_local
|
||||
open_source/2. % Stream, State
|
||||
|
||||
:- multifile
|
||||
requires_library/2,
|
||||
prolog:xref_source_identifier/2, % +Source, -Id
|
||||
prolog:xref_open_source/2. % +SourceId, -Stream
|
||||
|
||||
:- if(current_prolog_flag(dialect, yap)).
|
||||
% yap
|
||||
'$style_check'([Singleton,Discontiguous,Multiple], StyleF) :-
|
||||
(
|
||||
prolog_flag(single_var_warnings,on)
|
||||
->
|
||||
Singleton = singleton
|
||||
;
|
||||
Singleton = -singleton
|
||||
),
|
||||
(
|
||||
prolog_flag(discontiguous_warnings,on)
|
||||
->
|
||||
Discontiguous = discontiguous
|
||||
;
|
||||
Discontiguous = -discontiguous
|
||||
),
|
||||
(
|
||||
prolog_flag(redefine_warnings,on)
|
||||
->
|
||||
Multiple = multiple
|
||||
;
|
||||
Multiple = -multiple
|
||||
),
|
||||
style_check(StyleF).
|
||||
:- endif.
|
||||
|
||||
|
||||
/*******************************
|
||||
* READING *
|
||||
*******************************/
|
||||
|
||||
%% prolog_read_source_term(+In, -Term, -Expanded, +Options) is det.
|
||||
%
|
||||
% Read a term from a Prolog source-file. Options is a option list
|
||||
% as normally provided to read_term/3.
|
||||
%
|
||||
% @param Term Term read
|
||||
% @param Expanded Result of term-expansion on the term
|
||||
|
||||
prolog_read_source_term(In, Term, Expanded, Options) :-
|
||||
'$set_source_module'(SM, SM),
|
||||
read_term(In, Term,
|
||||
[ module(SM)
|
||||
| Options
|
||||
]),
|
||||
expand(Term, Expanded),
|
||||
update_state(Expanded).
|
||||
|
||||
expand(Var, Var) :-
|
||||
var(Var), !.
|
||||
expand(Term, _) :-
|
||||
requires_library(Term, Lib),
|
||||
ensure_loaded(user:Lib),
|
||||
fail.
|
||||
expand('$:-'(X), '$:-'(X)) :- !, % boot module
|
||||
style_check(+dollar).
|
||||
expand(Term, Expanded) :-
|
||||
expand_term(Term, Expanded).
|
||||
|
||||
%% requires_library(+Term, -Library)
|
||||
%
|
||||
% known expansion hooks. May be expanded as multifile predicate.
|
||||
|
||||
requires_library((:- emacs_begin_mode(_,_,_,_,_)), library(emacs_extend)).
|
||||
requires_library((:- draw_begin_shape(_,_,_,_)), library(pcedraw)).
|
||||
|
||||
%% update_state(+Expanded) is det.
|
||||
%
|
||||
% Update operators and style-check options from the expanded term.
|
||||
|
||||
update_state([]) :- !.
|
||||
update_state([H|T]) :- !,
|
||||
update_state(H),
|
||||
update_state(T).
|
||||
update_state((:- Directive)) :- !,
|
||||
update_directive(Directive).
|
||||
update_state((?- Directive)) :- !,
|
||||
update_directive(Directive).
|
||||
update_state(_).
|
||||
|
||||
update_directive(module(Module, Public)) :- !,
|
||||
'$set_source_module'(_, Module),
|
||||
public_operators(Public).
|
||||
update_directive(op(P,T,N)) :- !,
|
||||
'$set_source_module'(SM, SM),
|
||||
push_op(P,T,SM:N).
|
||||
update_directive(style_check(Style)) :-
|
||||
style_check(Style), !.
|
||||
update_directive(_).
|
||||
|
||||
public_operators([]).
|
||||
public_operators([H|T]) :- !,
|
||||
( H = op(_,_,_)
|
||||
-> update_directive(H)
|
||||
; true
|
||||
),
|
||||
public_operators(T).
|
||||
|
||||
|
||||
/*******************************
|
||||
* SOURCES *
|
||||
*******************************/
|
||||
|
||||
%% prolog_open_source(+CanonicalId:atomic, -Stream:stream) is det.
|
||||
%
|
||||
% Open source with given canonical id (see
|
||||
% prolog_canonical_source/2) and remove the #! line if any.
|
||||
% Streams opened using this predicate must be closed using
|
||||
% prolog_close_source/1. Typically using the skeleton below. Using
|
||||
% this skeleton, operator and style-check options are
|
||||
% automatically restored to the values before opening the source.
|
||||
%
|
||||
% ==
|
||||
% process_source(Src) :-
|
||||
% prolog_open_source(Src, In),
|
||||
% call_cleanup(process(Src), prolog_close_source(In)).
|
||||
% ==
|
||||
|
||||
prolog_open_source(Src, Fd) :-
|
||||
( prolog:xref_open_source(Src, Fd)
|
||||
-> true
|
||||
; open(Src, read, Fd)
|
||||
),
|
||||
( peek_char(Fd, #) % Deal with #! script
|
||||
-> skip(Fd, 10)
|
||||
; true
|
||||
),
|
||||
push_operators([]),
|
||||
'$set_source_module'(SM, SM),
|
||||
'$style_check'(Style, Style),
|
||||
asserta(open_source(Fd, state(Style, SM))).
|
||||
|
||||
|
||||
%% prolog_close_source(+In:stream) is det.
|
||||
%
|
||||
% Close a stream opened using prolog_open_source/2. Restores
|
||||
% operator and style options.
|
||||
|
||||
prolog_close_source(In) :-
|
||||
pop_operators,
|
||||
( retract(open_source(In, state(Style, SM)))
|
||||
-> '$style_check'(_, Style),
|
||||
'$set_source_module'(_, SM)
|
||||
; assertion(fail)
|
||||
),
|
||||
close(In).
|
||||
|
||||
|
||||
%% prolog_canonical_source(+SourceSpec:ground, -Id:atomic) is det.
|
||||
%
|
||||
% Given a user-specification of a source, generate a unique and
|
||||
% indexable identifier for it. For files we use the
|
||||
% prolog_canonical absolute filename.
|
||||
|
||||
prolog_canonical_source(Src, Id) :- % Call hook
|
||||
prolog:xref_source_identifier(Src, Id), !.
|
||||
prolog_canonical_source(User, user) :-
|
||||
User == user, !.
|
||||
prolog_canonical_source(Source, Src) :-
|
||||
absolute_file_name(Source,
|
||||
[ file_type(prolog),
|
||||
access(read),
|
||||
file_errors(fail)
|
||||
],
|
||||
Src), !.
|
||||
prolog_canonical_source(Source, Src) :-
|
||||
var(Source), !,
|
||||
Src = Source.
|
||||
1455
swi/library/prolog_xref.pl
Normal file
1455
swi/library/prolog_xref.pl
Normal file
File diff suppressed because it is too large
Load Diff
401
swi/library/quintus.pl
Normal file
401
swi/library/quintus.pl
Normal file
@@ -0,0 +1,401 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2008, 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 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.
|
||||
*/
|
||||
|
||||
:- module(quintus,
|
||||
[ % unix/1,
|
||||
% file_exists/1,
|
||||
|
||||
abs/2,
|
||||
sin/2,
|
||||
cos/2,
|
||||
tan/2,
|
||||
log/2,
|
||||
log10/2,
|
||||
pow/3,
|
||||
ceiling/2,
|
||||
floor/2,
|
||||
round/2,
|
||||
acos/2,
|
||||
asin/2,
|
||||
atan/2,
|
||||
atan2/3,
|
||||
sign/2,
|
||||
sqrt/2,
|
||||
|
||||
genarg/3,
|
||||
|
||||
(mode)/1,
|
||||
(public)/1,
|
||||
no_style_check/1,
|
||||
otherwise/0,
|
||||
simple/1,
|
||||
% statistics/2, % Please access as quintus:statistics/2
|
||||
prolog_flag/2,
|
||||
|
||||
date/1, % -date(Year, Month, Day)
|
||||
|
||||
current_stream/3, % ?File, ?Mode, ?Stream
|
||||
stream_position/3, % +Stream, -Old, +New
|
||||
skip_line/0,
|
||||
skip_line/1, % +Stream
|
||||
|
||||
compile/1, % +File(s)
|
||||
|
||||
atom_char/2,
|
||||
midstring/3, % ABC, B, AC
|
||||
midstring/4, % ABC, B, AC, LenA
|
||||
midstring/5, % ABC, B, AC, LenA, LenB
|
||||
midstring/6, % ABC, B, AC, LenA, LenB, LenC
|
||||
|
||||
raise_exception/1, % +Exception
|
||||
on_exception/3 % +Ball, :Goal, :Recover
|
||||
]).
|
||||
:- use_module(library(lists), [member/2]).
|
||||
|
||||
/** <module> Quintus compatibility
|
||||
|
||||
This module defines several predicates from the Quintus Prolog
|
||||
libraries. Note that our library structure is totally different. If this
|
||||
library were complete, Prolog code could be ported by removing the
|
||||
use_module/1 declarations, relying on the SWI-Prolog autoloader.
|
||||
|
||||
Bluffers guide to porting:
|
||||
|
||||
* Remove =|use_module(library(...))|=
|
||||
* Run =|?- list_undefined.|=
|
||||
* Fix problems
|
||||
|
||||
Of course, this library is incomplete ...
|
||||
*/
|
||||
|
||||
/********************************
|
||||
* SYSTEM INTERACTION *
|
||||
*********************************/
|
||||
|
||||
% %% unix(+Action)
|
||||
% % interface to Unix.
|
||||
|
||||
% unix(system(Command)) :-
|
||||
% shell(Command).
|
||||
% unix(shell(Command)) :-
|
||||
% shell(Command).
|
||||
% unix(shell) :-
|
||||
% shell.
|
||||
% unix(access(File, 0)) :-
|
||||
% access_file(File, read).
|
||||
% unix(cd) :-
|
||||
% expand_file_name(~, [Home]),
|
||||
% working_directory(_, Home).
|
||||
% unix(cd(Dir)) :-
|
||||
% working_directory(_, Dir).
|
||||
% unix(args(L)) :-
|
||||
% current_prolog_flag(argv, L).
|
||||
% unix(argv(L)) :-
|
||||
% current_prolog_flag(argv, S),
|
||||
% maplist(to_prolog, S, L).
|
||||
|
||||
% to_prolog(S, A) :-
|
||||
% name(S, L),
|
||||
% name(A, L).
|
||||
|
||||
|
||||
/********************************
|
||||
* META PREDICATES *
|
||||
*********************************/
|
||||
|
||||
%% otherwise
|
||||
%
|
||||
% For (A -> B ; otherwise -> C)
|
||||
|
||||
% otherwise.
|
||||
|
||||
|
||||
/********************************
|
||||
* ARITHMETIC *
|
||||
*********************************/
|
||||
|
||||
%% abs(+Number, -Absolute)
|
||||
% Unify `Absolute' with the absolute value of `Number'.
|
||||
|
||||
abs(Number, Absolute) :-
|
||||
Absolute is abs(Number).
|
||||
|
||||
%% sin(+Angle, -Sine) is det.
|
||||
%% cos(+Angle, -Cosine) is det.
|
||||
%% tan(+Angle, -Tangent) is det.
|
||||
%% log(+X, -NatLog) is det.
|
||||
%% log10(+X, -Log) is det.
|
||||
%
|
||||
% Math library predicates. SWI-Prolog (and ISO) support these as
|
||||
% functions under is/2, etc.
|
||||
|
||||
sin(A, V) :- V is sin(A).
|
||||
cos(A, V) :- V is cos(A).
|
||||
tan(A, V) :- V is tan(A).
|
||||
log(A, V) :- V is log(A).
|
||||
log10(X, V) :- V is log10(X).
|
||||
pow(X,Y,V) :- V is X**Y.
|
||||
ceiling(X, V) :- V is ceil(X).
|
||||
floor(X, V) :- V is floor(X).
|
||||
round(X, V) :- V is round(X).
|
||||
sqrt(X, V) :- V is sqrt(X).
|
||||
acos(X, V) :- V is acos(X).
|
||||
asin(X, V) :- V is asin(X).
|
||||
atan(X, V) :- V is atan(X).
|
||||
atan2(Y, X, V) :- V is atan(Y, X).
|
||||
sign(X, V) :- V is sign(X).
|
||||
|
||||
|
||||
/*******************************
|
||||
* TERM MANIPULATION *
|
||||
*******************************/
|
||||
|
||||
%% genarg(?Index, +Term, ?Arg) is nondet.
|
||||
%
|
||||
% Generalised version of ISO arg/3. SWI-Prolog's arg/3 is already
|
||||
% genarg/3.
|
||||
|
||||
genarg(N, T, A) :- % SWI-Prolog arg/3 is generic
|
||||
arg(N, T, A).
|
||||
|
||||
|
||||
/*******************************
|
||||
* FLAGS *
|
||||
*******************************/
|
||||
|
||||
%% prolog_flag(?Flag, ?Value) is nondet.
|
||||
%
|
||||
% Same as ISO current_prolog_flag/2. Maps =version=.
|
||||
%
|
||||
% @bug Should map relevant Quintus flag identifiers.
|
||||
|
||||
% prolog_flag(version, Version) :- !,
|
||||
% current_prolog_flag(version_data, swi(Major, Minor, Patch, _)),
|
||||
% current_prolog_flag(arch, Arch),
|
||||
% current_prolog_flag(compiled_at, Compiled),
|
||||
% atomic_list_concat(['SWI-Prolog ',
|
||||
% Major, '.', Minor, '.', Patch,
|
||||
% ' (', Arch, '): ', Compiled], Version).
|
||||
% prolog_flag(Flag, Value) :-
|
||||
% current_prolog_flag(Flag, Value).
|
||||
|
||||
|
||||
/*******************************
|
||||
* STATISTICS *
|
||||
*******************************/
|
||||
|
||||
% Here used to be a definition of Quintus statistics/2 in traditional
|
||||
% SWI-Prolog statistics/2. The current built-in emulates Quintus
|
||||
% almost completely.
|
||||
|
||||
|
||||
/*******************************
|
||||
* DATE/TIME *
|
||||
*******************************/
|
||||
|
||||
%% date(-Date) is det.
|
||||
%
|
||||
% Get current date as date(Y,M,D)
|
||||
|
||||
date(Date) :-
|
||||
get_time(T),
|
||||
stamp_date_time(T, DaTime, local),
|
||||
date_time_value(date, DaTime, Date).
|
||||
|
||||
|
||||
/********************************
|
||||
* STYLE CHECK *
|
||||
*********************************/
|
||||
|
||||
%% no_style_check(Style) is det.
|
||||
%
|
||||
% Same as SWI-Prolog =|style_check(-Style)|=. The Quintus option
|
||||
% =single_var= is mapped to =singleton=.
|
||||
%
|
||||
% @see style_check/1.
|
||||
|
||||
q_style_option(single_var, singleton) :- !.
|
||||
q_style_option(Option, Option).
|
||||
|
||||
% no_style_check(QOption) :-
|
||||
% q_style_option(QOption, SWIOption),
|
||||
% style_check(-SWIOption).
|
||||
|
||||
|
||||
/********************************
|
||||
* DIRECTIVES *
|
||||
*********************************/
|
||||
|
||||
% :- op(1150, fx, [(mode), (public)]).
|
||||
|
||||
% mode(_).
|
||||
% public(_).
|
||||
|
||||
|
||||
/*******************************
|
||||
* TYPES *
|
||||
*******************************/
|
||||
|
||||
%% simple(@Term) is semidet.
|
||||
%
|
||||
% Term is atomic or a variable.
|
||||
|
||||
% simple(X) :-
|
||||
% ( atomic(X)
|
||||
% -> true
|
||||
% ; var(X)
|
||||
% ).
|
||||
|
||||
|
||||
/*******************************
|
||||
* STREAMS *
|
||||
*******************************/
|
||||
|
||||
%% current_stream(?Object, ?Mode, ?Stream)
|
||||
%
|
||||
% SICStus/Quintus and backward compatible predicate. New code should
|
||||
% be using the ISO compatible stream_property/2.
|
||||
|
||||
% current_stream(Object, Mode, Stream) :-
|
||||
% stream_property(Stream, mode(FullMode)),
|
||||
% stream_mode(FullMode, Mode),
|
||||
% ( stream_property(Stream, file_name(Object0))
|
||||
% -> true
|
||||
% ; stream_property(Stream, file_no(Object0))
|
||||
% -> true
|
||||
% ; Object0 = []
|
||||
% ),
|
||||
% Object = Object0.
|
||||
|
||||
% stream_mode(read, read).
|
||||
% stream_mode(write, write).
|
||||
% stream_mode(append, write).
|
||||
% stream_mode(update, write).
|
||||
|
||||
% %% stream_position(+Stream, -Old, +New)
|
||||
|
||||
% stream_position(Stream, Old, New) :-
|
||||
% stream_property(Stream, position(Old)),
|
||||
% set_stream_position(Stream, New).
|
||||
|
||||
|
||||
%% skip_line is det.
|
||||
%% skip_line(Stream) is det.
|
||||
%
|
||||
% Skip the rest of the current line (on Stream). Same as
|
||||
% =|skip(0'\n)|=.
|
||||
|
||||
skip_line :-
|
||||
skip(10).
|
||||
skip_line(Stream) :-
|
||||
skip(Stream, 10).
|
||||
|
||||
|
||||
/*******************************
|
||||
* COMPILATION *
|
||||
*******************************/
|
||||
|
||||
%% compile(+Files) is det.
|
||||
%
|
||||
% Compile files. SWI-Prolog doesn't distinguish between
|
||||
% compilation and consult.
|
||||
%
|
||||
% @see load_files/2.
|
||||
|
||||
% :- meta_predicate
|
||||
% compile(:).
|
||||
|
||||
% compile(Files) :-
|
||||
% consult(Files).
|
||||
|
||||
/*******************************
|
||||
* ATOM-HANDLING *
|
||||
*******************************/
|
||||
|
||||
%% atom_char(+Char, -Code) is det.
|
||||
%% atom_char(-Char, +Code) is det.
|
||||
%
|
||||
% Same as ISO char_code/2.
|
||||
|
||||
atom_char(Char, Code) :-
|
||||
char_code(Char, Code).
|
||||
|
||||
%% midstring(?ABC, ?B, ?AC) is nondet.
|
||||
%% midstring(?ABC, ?B, ?AC, LenA) is nondet.
|
||||
%% midstring(?ABC, ?B, ?AC, LenA, LenB) is nondet.
|
||||
%% midstring(?ABC, ?B, ?AC, LenA, LenB, LenC) is nondet.
|
||||
%
|
||||
% Too difficult to explain. See the Quintus docs. As far as I
|
||||
% understand them the code below emulates this function just fine.
|
||||
|
||||
midstring(ABC, B, AC) :-
|
||||
midstring(ABC, B, AC, _, _, _).
|
||||
midstring(ABC, B, AC, LenA) :-
|
||||
midstring(ABC, B, AC, LenA, _, _).
|
||||
midstring(ABC, B, AC, LenA, LenB) :-
|
||||
midstring(ABC, B, AC, LenA, LenB, _).
|
||||
midstring(ABC, B, AC, LenA, LenB, LenC) :- % -ABC, +B, +AC
|
||||
var(ABC), !,
|
||||
atom_length(AC, LenAC),
|
||||
( nonvar(LenA) ; nonvar(LenC)
|
||||
-> plus(LenA, LenC, LenAC)
|
||||
; true
|
||||
),
|
||||
sub_atom(AC, 0, LenA, _, A),
|
||||
LenC is LenAC - LenA,
|
||||
sub_atom(AC, _, LenC, 0, C),
|
||||
atom_length(B, LenB),
|
||||
atomic_list_concat([A,B,C], ABC).
|
||||
midstring(ABC, B, AC, LenA, LenB, LenC) :-
|
||||
sub_atom(ABC, LenA, LenB, LenC, B),
|
||||
sub_atom(ABC, 0, LenA, _, A),
|
||||
sub_atom(ABC, _, LenC, 0, C),
|
||||
atom_concat(A, C, AC).
|
||||
|
||||
|
||||
/*******************************
|
||||
* EXCEPTIONS *
|
||||
*******************************/
|
||||
|
||||
%% raise_exception(+Term)
|
||||
%
|
||||
% Quintus compatible exception handling
|
||||
|
||||
% raise_exception(Term) :-
|
||||
% throw(Term).
|
||||
|
||||
%% on_exception(+Template, :Goal, :Recover)
|
||||
|
||||
:- meta_predicate
|
||||
on_exception(+, 0, 0).
|
||||
|
||||
% on_exception(Except, Goal, Recover) :-
|
||||
% catch(Goal, Except, Recover).
|
||||
242
swi/library/readutil.pl
Normal file
242
swi/library/readutil.pl
Normal file
@@ -0,0 +1,242 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, 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 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.
|
||||
*/
|
||||
|
||||
:- module(read_util,
|
||||
[ read_line_to_codes/2, % +Fd, -Codes (without trailing \n)
|
||||
read_line_to_codes/3, % +Fd, -Codes, ?Tail
|
||||
read_stream_to_codes/2, % +Fd, -Codes
|
||||
read_stream_to_codes/3, % +Fd, -Codes, ?Tail
|
||||
read_file_to_codes/3, % +File, -Codes, +Options
|
||||
read_file_to_terms/3 % +File, -Terms, +Options
|
||||
]).
|
||||
:- use_module(library(shlib)).
|
||||
:- use_module(library(lists), [select/3]).
|
||||
:- use_module(library(error)).
|
||||
|
||||
/** <module> Read utilities
|
||||
|
||||
This library provides some commonly used reading predicates. As these
|
||||
predicates have proven to be time-critical in some applications we moved
|
||||
them to C. For compatibility as well as to reduce system dependency, we
|
||||
link the foreign code at runtime and fallback to the Prolog
|
||||
implementation if the shared object cannot be found.
|
||||
*/
|
||||
|
||||
:- volatile
|
||||
read_line_to_codes/2,
|
||||
read_line_to_codes/3,
|
||||
read_stream_to_codes/2,
|
||||
read_stream_to_codes/3.
|
||||
|
||||
link_foreign :-
|
||||
catch(load_foreign_library(foreign(readutil)), _, fail), !.
|
||||
link_foreign :-
|
||||
assertz((read_line_to_codes(Stream, Line) :-
|
||||
pl_read_line_to_codes(Stream, Line))),
|
||||
assertz((read_line_to_codes(Stream, Line, Tail) :-
|
||||
pl_read_line_to_codes(Stream, Line, Tail))),
|
||||
assertz((read_stream_to_codes(Stream, Content) :-
|
||||
pl_read_stream_to_codes(Stream, Content))),
|
||||
assertz((read_stream_to_codes(Stream, Content, Tail) :-
|
||||
pl_read_stream_to_codes(Stream, Content, Tail))),
|
||||
compile_predicates([ read_line_to_codes/2,
|
||||
read_line_to_codes/3,
|
||||
read_stream_to_codes/2,
|
||||
read_stream_to_codes/3
|
||||
]).
|
||||
|
||||
:- initialization(link_foreign, now).
|
||||
|
||||
|
||||
/*******************************
|
||||
* LINES *
|
||||
*******************************/
|
||||
|
||||
%% read_line_to_codes(+In:stream, -Line:codes) is det.
|
||||
%
|
||||
% Read a line of input from In into a list of character codes.
|
||||
% Trailing newline and or return are deleted. Upon reaching
|
||||
% end-of-file Line is unified to the atom =end_of_file=.
|
||||
|
||||
pl_read_line_to_codes(Fd, Codes) :-
|
||||
get_code(Fd, C0),
|
||||
( C0 == -1
|
||||
-> Codes = end_of_file
|
||||
; read_1line_to_codes(C0, Fd, Codes0)
|
||||
),
|
||||
Codes = Codes0.
|
||||
|
||||
read_1line_to_codes(-1, _, []) :- !.
|
||||
read_1line_to_codes(10, _, []) :- !.
|
||||
read_1line_to_codes(13, Fd, L) :- !,
|
||||
get_code(Fd, C2),
|
||||
read_1line_to_codes(C2, Fd, L).
|
||||
read_1line_to_codes(C, Fd, [C|T]) :-
|
||||
get_code(Fd, C2),
|
||||
read_1line_to_codes(C2, Fd, T).
|
||||
|
||||
%% read_line_to_codes(+Fd, -Line, ?Tail) is det.
|
||||
%
|
||||
% Read a line of input as a difference list. This should be used
|
||||
% to read multiple lines efficiently. On reaching end-of-file,
|
||||
% Tail is bound to the empty list.
|
||||
|
||||
pl_read_line_to_codes(Fd, Codes, Tail) :-
|
||||
get_code(Fd, C0),
|
||||
read_line_to_codes(C0, Fd, Codes0, Tail),
|
||||
Codes = Codes0.
|
||||
|
||||
read_line_to_codes(-1, _, Tail, Tail) :- !,
|
||||
Tail = [].
|
||||
read_line_to_codes(10, _, [10|Tail], Tail) :- !.
|
||||
read_line_to_codes(C, Fd, [C|T], Tail) :-
|
||||
get_code(Fd, C2),
|
||||
read_line_to_codes(C2, Fd, T, Tail).
|
||||
|
||||
|
||||
/*******************************
|
||||
* STREAM (ENTIRE INPUT) *
|
||||
*******************************/
|
||||
|
||||
%% read_stream_to_codes(+Stream, -Codes) is det.
|
||||
%% read_stream_to_codes(+Stream, -Codes, ?Tail) is det.
|
||||
%
|
||||
% Read input from Stream to a list of character codes. The version
|
||||
% read_stream_to_codes/3 creates a difference-list.
|
||||
|
||||
pl_read_stream_to_codes(Fd, Codes) :-
|
||||
pl_read_stream_to_codes(Fd, Codes, []).
|
||||
pl_read_stream_to_codes(Fd, Codes, Tail) :-
|
||||
get_code(Fd, C0),
|
||||
read_stream_to_codes(C0, Fd, Codes0, Tail),
|
||||
Codes = Codes0.
|
||||
|
||||
read_stream_to_codes(-1, _, Tail, Tail) :- !.
|
||||
read_stream_to_codes(C, Fd, [C|T], Tail) :-
|
||||
get_code(Fd, C2),
|
||||
read_stream_to_codes(C2, Fd, T, Tail).
|
||||
|
||||
|
||||
%% read_stream_to_terms(+Stream, -Terms, ?Tail, +Options) is det.
|
||||
|
||||
read_stream_to_terms(Fd, Terms, Tail, Options) :-
|
||||
read_term(Fd, C0, Options),
|
||||
read_stream_to_terms(C0, Fd, Terms0, Tail, Options),
|
||||
Terms = Terms0.
|
||||
|
||||
read_stream_to_terms(end_of_file, _, Tail, Tail, _) :- !.
|
||||
read_stream_to_terms(C, Fd, [C|T], Tail, Options) :-
|
||||
read_term(Fd, C2, Options),
|
||||
read_stream_to_terms(C2, Fd, T, Tail, Options).
|
||||
|
||||
|
||||
/*******************************
|
||||
* FILE (ENTIRE INPUT) *
|
||||
*******************************/
|
||||
|
||||
%% read_file_to_codes(+Spec, -Codes, +Options) is det.
|
||||
%
|
||||
% Read the file Spec into a list of Codes. Options is split into
|
||||
% options for absolute_file_name/3 and open/4.
|
||||
|
||||
read_file_to_codes(Spec, Codes, Options) :-
|
||||
must_be(proper_list, Options),
|
||||
( select(tail(Tail), Options, Options1)
|
||||
-> true
|
||||
; Tail = [],
|
||||
Options1 = Options
|
||||
),
|
||||
split_options(Options1, file_option, FileOptions, OpenOptions),
|
||||
absolute_file_name(Spec,
|
||||
[ access(read)
|
||||
| FileOptions
|
||||
],
|
||||
Path),
|
||||
open(Path, read, Fd, OpenOptions),
|
||||
call_cleanup(read_stream_to_codes(Fd, Codes0, Tail),
|
||||
close(Fd)),
|
||||
Codes = Codes0.
|
||||
|
||||
|
||||
%% read_file_to_terms(+Spec, -Terms, +Options) is det.
|
||||
%
|
||||
% Read the file Spec into a list of terms. Options is split over
|
||||
% absolute_file_name/3, open/4 and read_term/3.
|
||||
|
||||
read_file_to_terms(Spec, Terms, Options) :-
|
||||
must_be(proper_list, Options),
|
||||
( select(tail(Tail), Options, Options1)
|
||||
-> true
|
||||
; Tail = [],
|
||||
Options1 = Options
|
||||
),
|
||||
split_options(Options1, file_option, FileOptions, Options2),
|
||||
split_options(Options2, read_option, ReadOptions, OpenOptions),
|
||||
absolute_file_name(Spec,
|
||||
[ access(read)
|
||||
| FileOptions
|
||||
],
|
||||
Path),
|
||||
open(Path, read, Fd, OpenOptions),
|
||||
call_cleanup(read_stream_to_terms(Fd, Terms0, Tail, ReadOptions),
|
||||
close(Fd)),
|
||||
Terms = Terms0.
|
||||
|
||||
split_options([], _, [], []).
|
||||
split_options([H|T], G, File, Open) :-
|
||||
( call(G, H)
|
||||
-> File = [H|FT],
|
||||
OT = Open
|
||||
; Open = [H|OT],
|
||||
FT = File
|
||||
),
|
||||
split_options(T, G, FT, OT).
|
||||
|
||||
|
||||
read_option(module(_)).
|
||||
read_option(syntax_errors(_)).
|
||||
read_option(character_escapes(_)).
|
||||
read_option(double_quotes(_)).
|
||||
read_option(backquoted_string(_)).
|
||||
|
||||
file_option(extensions(_)).
|
||||
file_option(file_type(_)).
|
||||
file_option(file_errors(_)).
|
||||
file_option(relative_to(_)).
|
||||
file_option(expand(_)).
|
||||
|
||||
/*******************************
|
||||
* XREF *
|
||||
*******************************/
|
||||
|
||||
:- multifile prolog:meta_goal/2.
|
||||
:- dynamic prolog:meta_goal/2.
|
||||
prolog:meta_goal(split_options(_,G,_,_), [G+1]).
|
||||
477
swi/library/record.pl
Normal file
477
swi/library/record.pl
Normal file
@@ -0,0 +1,477 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 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 Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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((record),
|
||||
[ (record)/1, % +Record
|
||||
current_record/2, % ?Name, ?Term
|
||||
current_record_predicate/2, % ?Record, :PI
|
||||
op(1150, fx, record)
|
||||
]).
|
||||
:- use_module(library(error)).
|
||||
|
||||
/** <module> Access compound arguments by name
|
||||
|
||||
This module creates a set of predicates to create a default instance,
|
||||
access and modify records represented as a compound term.
|
||||
|
||||
The full documentation is with record/1, which must be used as a
|
||||
_directive_. Here is a simple example declaration and some calls.
|
||||
|
||||
==
|
||||
:- record point(x:integer=0, y:integer=0).
|
||||
|
||||
default_point(Point),
|
||||
point_x(Point, X),
|
||||
set_x_of_point(10, Point, Point1),
|
||||
|
||||
make_point([y(20)], YPoint),
|
||||
==
|
||||
|
||||
@author Jan Wielemaker
|
||||
@author Richard O'Keefe
|
||||
*/
|
||||
|
||||
:- multifile
|
||||
error:has_type/2,
|
||||
prolog:generated_predicate/1.
|
||||
|
||||
error:has_type(record(M:Name), X) :-
|
||||
current_record(Name, M, _, X, IsX), !,
|
||||
call(M:IsX).
|
||||
|
||||
%% record(+RecordDef)
|
||||
%
|
||||
% Define access predicates for a compound-term. RecordDef is of
|
||||
% the form <constructor>(<argument>, ...), where each argument
|
||||
% is of the form:
|
||||
%
|
||||
% * <name>[:<type>][=<default>]
|
||||
%
|
||||
% Used a directive, =|:- record Constructor(Arg, ...)|= is expanded
|
||||
% info the following predicates:
|
||||
%
|
||||
% * <constructor>_<name>(Record, Value)
|
||||
% * <constructor>_data(?Name, ?Record, ?Value)
|
||||
% * default_<constructor>(-Record)
|
||||
% * is_<constructor>(@Term)
|
||||
% * make_<constructor>(+Fields, -Record)
|
||||
% * make_<constructor>(+Fields, -Record, -RestFields)
|
||||
% * set_<name>_of_<constructor>(+Value, +OldRecord, -New)
|
||||
% * set_<name>_of_<constructor>(+Value, !Record)
|
||||
% * nb_set_<name>_of_<constructor>(+Value, !Record)
|
||||
% * set_<constructor>_fields(+Fields, +Record0, -Record).
|
||||
% * set_<constructor>_fields(+Fields, +Record0, -Record, -RestFields).
|
||||
% * set_<constructor>_field(+Field, +Record0, -Record).
|
||||
% * user:current_record(:<constructor>)
|
||||
|
||||
record(Record) :-
|
||||
throw(error(context_error(nodirective, record(Record)), _)).
|
||||
|
||||
|
||||
%% compile_records(+RecordsDefs, -Clauses) is det.
|
||||
%
|
||||
% Compile a record specification into a list of clauses.
|
||||
|
||||
compile_records(Spec, Clauses) :-
|
||||
phrase(compile_records(Spec), Clauses).
|
||||
% maplist(portray_clause, Clauses).
|
||||
|
||||
compile_records(Var) -->
|
||||
{ var(Var), !,
|
||||
instantiation_error(Var)
|
||||
}.
|
||||
compile_records((A,B)) -->
|
||||
compile_record(A),
|
||||
compile_records(B).
|
||||
compile_records(A) -->
|
||||
compile_record(A).
|
||||
|
||||
%% compile_record(+Record)// is det.
|
||||
%
|
||||
% Create clauses for Record.
|
||||
|
||||
compile_record(RecordDef) -->
|
||||
{ RecordDef =.. [Constructor|Args],
|
||||
defaults(Args, Defs, TypedArgs),
|
||||
types(TypedArgs, Names, Types),
|
||||
atom_concat(default_, Constructor, DefName),
|
||||
atom_concat(Constructor, '_data', DataName),
|
||||
DefRecord =.. [Constructor|Defs],
|
||||
DefClause =.. [DefName,DefRecord],
|
||||
length(Names, Arity)
|
||||
},
|
||||
[ DefClause ],
|
||||
access_predicates(Names, 1, Arity, Constructor),
|
||||
data_predicate(Names, 1, Arity, Constructor, DataName),
|
||||
set_predicates(Names, 1, Arity, Types, Constructor),
|
||||
set_field_predicates(Names, 1, Arity, Types, Constructor),
|
||||
make_predicate(Constructor),
|
||||
is_predicate(Constructor, Types),
|
||||
current_clause(RecordDef).
|
||||
|
||||
:- meta_predicate
|
||||
current_record(?, :),
|
||||
current_record_predicate(?, :).
|
||||
:- multifile
|
||||
current_record/5. % Name, Module, Term, X, IsX
|
||||
|
||||
%% current_record(?Name, :Term)
|
||||
%
|
||||
% True if Name is the name of a record defined in the module
|
||||
% associated with Term and Term is the user-provided record
|
||||
% declaration.
|
||||
|
||||
current_record(Name, M:Term) :-
|
||||
current_record(Name, M, Term, _, _).
|
||||
|
||||
current_clause(RecordDef) -->
|
||||
{ prolog_load_context(module, M),
|
||||
functor(RecordDef, Name, _),
|
||||
atom_concat(is_, Name, IsName),
|
||||
IsX =.. [IsName, X]
|
||||
},
|
||||
[ (record):current_record(Name, M, RecordDef, X, IsX)
|
||||
].
|
||||
|
||||
|
||||
%% current_record_predicate(?Record, ?PI) is nondet.
|
||||
%
|
||||
% True if PI is the predicate indicator for an access predicate to
|
||||
% Record. This predicate is intended to support cross-referencer
|
||||
% tools.
|
||||
|
||||
current_record_predicate(Record, M:PI) :-
|
||||
( ground(PI)
|
||||
-> Det = true
|
||||
; true
|
||||
),
|
||||
current_record(Record, M:RecordDef),
|
||||
( general_record_pred(Record, M:PI)
|
||||
; RecordDef =.. [_|Args],
|
||||
defaults(Args, _Defs, TypedArgs),
|
||||
types(TypedArgs, Names, _Types),
|
||||
member(Field, Names),
|
||||
field_record_pred(Record, Field, M:PI)
|
||||
),
|
||||
( Det == true
|
||||
-> !
|
||||
; true
|
||||
).
|
||||
|
||||
general_record_pred(Record, _:Name/1) :-
|
||||
atom_concat(is_, Record, Name).
|
||||
general_record_pred(Record, _:Name/1) :-
|
||||
atom_concat(default_, Record, Name).
|
||||
general_record_pred(Record, _:Name/A) :-
|
||||
member(A, [2,3]),
|
||||
atom_concat(make_, Record, Name).
|
||||
general_record_pred(Record, _:Name/3) :-
|
||||
atom_concat(Record, '_data', Name).
|
||||
general_record_pred(Record, _:Name/A) :-
|
||||
member(A, [3,4]),
|
||||
atomic_list_concat([set_, Record, '_fields'], Name).
|
||||
general_record_pred(Record, _:Name/3) :-
|
||||
atomic_list_concat([set_, Record, '_field'], Name).
|
||||
|
||||
field_record_pred(Record, Field, _:Name/2) :-
|
||||
atomic_list_concat([Record, '_', Field], Name).
|
||||
field_record_pred(Record, Field, _:Name/A) :-
|
||||
member(A, [2,3]),
|
||||
atomic_list_concat([set_, Field, '_of_', Record], Name).
|
||||
field_record_pred(Record, Field, _:Name/2) :-
|
||||
atomic_list_concat([nb_set_, Field, '_of_', Record], Name).
|
||||
|
||||
prolog:generated_predicate(P) :-
|
||||
current_record_predicate(_, P).
|
||||
|
||||
%% make_predicate(+Constructor)// is det.
|
||||
%
|
||||
% Creates the make_<constructor>(+Fields, -Record) predicate. This
|
||||
% looks like this:
|
||||
%
|
||||
% ==
|
||||
% make_<constructor>(Fields, Record) :-
|
||||
% make_<constructor>(Fields, Record, [])
|
||||
%
|
||||
% make_<constructor>(Fields, Record, RestFields) :-
|
||||
% default_<constructor>(Record0),
|
||||
% set_<constructor>_fields(Fields, Record0, Record, RestFields).
|
||||
%
|
||||
% set_<constructor>_fields(Fields, Record0, Record) :-
|
||||
% set_<constructor>_fields(Fields, Record0, Record, []).
|
||||
%
|
||||
% set_<constructor>_fields([], Record, Record, []).
|
||||
% set_<constructor>_fields([H|T], Record0, Record, RestFields) :-
|
||||
% ( set_<constructor>_field(H, Record0, Record1)
|
||||
% -> set_<constructor>_fields(T, Record1, Record, RestFields)
|
||||
% ; RestFields = [H|RF],
|
||||
% set_<constructor>_fields(T, Record0, Record, RF)
|
||||
% ).
|
||||
%
|
||||
% set_<constructor>_field(<name1>(Value), Record0, Record).
|
||||
% ...
|
||||
% ==
|
||||
|
||||
make_predicate(Constructor) -->
|
||||
{ atomic_list_concat([make_, Constructor], MakePredName),
|
||||
atomic_list_concat([default_, Constructor], DefPredName),
|
||||
atomic_list_concat([set_, Constructor, '_fields'], SetFieldsName),
|
||||
atomic_list_concat([set_, Constructor, '_field'], SetFieldName),
|
||||
MakeHead3 =.. [MakePredName, Fields, Record],
|
||||
MakeHead4 =.. [MakePredName, Fields, Record, []],
|
||||
MakeClause3 = (MakeHead3 :- MakeHead4),
|
||||
MakeHead =.. [MakePredName, Fields, Record, RestFields],
|
||||
DefGoal =.. [DefPredName, Record0],
|
||||
SetGoal =.. [SetFieldsName, Fields, Record0, Record, RestFields],
|
||||
MakeClause = (MakeHead :- DefGoal, SetGoal),
|
||||
SetHead3 =.. [SetFieldsName, Fields, R0, R],
|
||||
SetHead4 =.. [SetFieldsName, Fields, R0, R, []],
|
||||
SetClause0 = (SetHead3 :- SetHead4),
|
||||
SetClause1 =.. [SetFieldsName, [], R, R, []],
|
||||
SetHead2 =.. [SetFieldsName, [H|T], R0, R, RF],
|
||||
SetGoal2a =.. [SetFieldName, H, R0, R1],
|
||||
SetGoal2b =.. [SetFieldsName, T, R1, R, RF],
|
||||
SetGoal2c =.. [SetFieldsName, T, R0, R, RF1],
|
||||
SetClause2 = (SetHead2 :- (SetGoal2a -> SetGoal2b ; RF=[H|RF1], SetGoal2c))
|
||||
},
|
||||
[ MakeClause3, MakeClause, SetClause0, SetClause1, SetClause2 ].
|
||||
|
||||
%% is_predicate(+Constructor, +Types)// is det.
|
||||
%
|
||||
% Create a clause that tests for a given record type.
|
||||
|
||||
is_predicate(Constructor, Types) -->
|
||||
{ type_checks(Types, Vars, Body0),
|
||||
clean_body(Body0, Body),
|
||||
Term =.. [Constructor|Vars],
|
||||
atom_concat(is_, Constructor, Name),
|
||||
Head1 =.. [Name,Var],
|
||||
Head2 =.. [Name,Term]
|
||||
},
|
||||
[ (Head1 :- var(Var), !, fail) ],
|
||||
( { Body == true }
|
||||
-> [ Head2 ]
|
||||
; [ (Head2 :- Body) ]
|
||||
).
|
||||
|
||||
type_checks([], [], true).
|
||||
type_checks([any|T], [_|Vars], Body) :-
|
||||
type_checks(T, Vars, Body).
|
||||
type_checks([Type|T], [V|Vars], (Goal, Body)) :-
|
||||
type_goal(Type, V, Goal),
|
||||
type_checks(T, Vars, Body).
|
||||
|
||||
%% type_goal(+Type, +Var, -BodyTerm) is det.
|
||||
%
|
||||
% Inline type checking calls.
|
||||
|
||||
type_goal(Type, Var, Body) :-
|
||||
defined_type(Type, Var, Body), !.
|
||||
type_goal(record(Record), Var, Body) :- !,
|
||||
atom_concat(is_, Record, Pred),
|
||||
Body =.. [Pred,Var].
|
||||
type_goal(Record, Var, Body) :-
|
||||
atom(Record), !,
|
||||
atom_concat(is_, Record, Pred),
|
||||
Body =.. [Pred,Var].
|
||||
type_goal(Type, _, _) :-
|
||||
domain_error(type, Type).
|
||||
|
||||
defined_type(Type, Var, error:Body) :-
|
||||
clause(error:has_type(Type, Var), Body).
|
||||
|
||||
|
||||
clean_body(M:(A0,B0), G) :- !,
|
||||
clean_body(M:A0, A),
|
||||
clean_body(M:B0, B),
|
||||
clean_body((A,B), G).
|
||||
clean_body((A0,true), A) :- !,
|
||||
clean_body(A0, A).
|
||||
clean_body((true,A0), A) :- !,
|
||||
clean_body(A0, A).
|
||||
clean_body((A0,B0), (A,B)) :-
|
||||
clean_body(A0, A),
|
||||
clean_body(B0, B).
|
||||
clean_body(_:A, A) :-
|
||||
predicate_property(A, built_in), !.
|
||||
clean_body(A, A).
|
||||
|
||||
|
||||
%% access_predicates(+Names, +Idx0, +Arity, +Constructor)// is det.
|
||||
%
|
||||
% Create the <constructor>_<name>(Record, Value) predicates.
|
||||
|
||||
access_predicates([], _, _, _) -->
|
||||
[].
|
||||
access_predicates([Name|NT], I, Arity, Constructor) -->
|
||||
{ atomic_list_concat([Constructor, '_', Name], PredName),
|
||||
functor(Record, Constructor, Arity),
|
||||
arg(I, Record, Value),
|
||||
Clause =.. [PredName, Record, Value],
|
||||
I2 is I + 1
|
||||
},
|
||||
[Clause],
|
||||
access_predicates(NT, I2, Arity, Constructor).
|
||||
|
||||
|
||||
%% data_predicate(+Names, +Idx0, +Arity, +Constructor, +DataName)// is det.
|
||||
%
|
||||
% Create the <constructor>_data(Name, Record, Value) predicate.
|
||||
|
||||
data_predicate([], _, _, _, _) -->
|
||||
[].
|
||||
data_predicate([Name|NT], I, Arity, Constructor, DataName) -->
|
||||
{ functor(Record, Constructor, Arity),
|
||||
arg(I, Record, Value),
|
||||
Clause =.. [DataName, Name, Record, Value],
|
||||
I2 is I + 1
|
||||
},
|
||||
[Clause],
|
||||
data_predicate(NT, I2, Arity, Constructor, DataName).
|
||||
|
||||
|
||||
%% set_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
|
||||
%
|
||||
% Create the clauses
|
||||
%
|
||||
% * set_<name>_of_<constructor>(Value, Old, New)
|
||||
% * set_<name>_of_<constructor>(Value, Record)
|
||||
|
||||
set_predicates([], _, _, _, _) -->
|
||||
[].
|
||||
set_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
|
||||
{ atomic_list_concat(['set_', Name, '_of_', Constructor], PredName),
|
||||
atomic_list_concat(['nb_set_', Name, '_of_', Constructor], NBPredName),
|
||||
length(Args, Arity),
|
||||
replace_nth(I, Args, Value, NewArgs),
|
||||
Old =.. [Constructor|Args],
|
||||
New =.. [Constructor|NewArgs],
|
||||
Head =.. [PredName, Value, Old, New],
|
||||
SetHead =.. [PredName, Value, Term],
|
||||
NBSetHead =.. [NBPredName, Value, Term],
|
||||
( Type == any
|
||||
-> Clause = Head,
|
||||
SetClause = (SetHead :- setarg(I, Term, Value)),
|
||||
NBSetClause = (NBSetHead :- nb_setarg(I, Term, Value))
|
||||
; type_check(Type, Value, MustBe),
|
||||
Clause = (Head :- MustBe),
|
||||
SetClause = (SetHead :- MustBe,
|
||||
setarg(I, Term, Value)),
|
||||
NBSetClause = (NBSetHead :- MustBe,
|
||||
nb_setarg(I, Term, Value))
|
||||
),
|
||||
I2 is I + 1
|
||||
},
|
||||
[ Clause, SetClause, NBSetClause ],
|
||||
set_predicates(NT, I2, Arity, TT, Constructor).
|
||||
|
||||
type_check(Type, Value, must_be(Type, Value)) :-
|
||||
defined_type(Type, Value, _), !.
|
||||
type_check(record(Spec), Value, must_be(record(M:Name), Value)) :- !,
|
||||
prolog_load_context(module, C),
|
||||
strip_module(C:Spec, M, Name).
|
||||
type_check(Atom, Value, Check) :-
|
||||
atom(Atom), !,
|
||||
type_check(record(Atom), Value, Check).
|
||||
|
||||
|
||||
%% set_field_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
|
||||
%
|
||||
% Create the clauses
|
||||
%
|
||||
% * set_<constructor>_field(<name>(Value), Old, New)
|
||||
|
||||
set_field_predicates([], _, _, _, _) -->
|
||||
[].
|
||||
set_field_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
|
||||
{ atomic_list_concat(['set_', Constructor, '_field'], FieldPredName),
|
||||
length(Args, Arity),
|
||||
replace_nth(I, Args, Value, NewArgs),
|
||||
Old =.. [Constructor|Args],
|
||||
New =.. [Constructor|NewArgs],
|
||||
NameTerm =.. [Name, Value],
|
||||
SetFieldHead =.. [FieldPredName, NameTerm, Old, New],
|
||||
( Type == any
|
||||
-> SetField = SetFieldHead
|
||||
; type_check(Type, Value, MustBe),
|
||||
SetField = (SetFieldHead :- MustBe)
|
||||
),
|
||||
I2 is I + 1
|
||||
},
|
||||
[ SetField ],
|
||||
set_field_predicates(NT, I2, Arity, TT, Constructor).
|
||||
|
||||
|
||||
%% replace_nth(+Index, +List, +Element, -NewList) is det.
|
||||
%
|
||||
% Replace the Nth (1-based) element of a list.
|
||||
|
||||
replace_nth(1, [_|T], V, [V|T]) :- !.
|
||||
replace_nth(I, [H|T0], V, [H|T]) :-
|
||||
I2 is I - 1,
|
||||
replace_nth(I2, T0, V, T).
|
||||
|
||||
|
||||
%% defaults(+ArgsSpecs, -Defaults, -Args)
|
||||
%
|
||||
% Strip the default specification from the argument specification.
|
||||
|
||||
defaults([], [], []).
|
||||
defaults([Arg=Default|T0], [Default|TD], [Arg|TA]) :- !,
|
||||
defaults(T0, TD, TA).
|
||||
defaults([Arg|T0], [_|TD], [Arg|TA]) :-
|
||||
defaults(T0, TD, TA).
|
||||
|
||||
|
||||
%% types(+ArgsSpecs, -Defaults, -Args)
|
||||
%
|
||||
% Strip the default specification from the argument specification.
|
||||
|
||||
types([], [], []).
|
||||
types([Name:Type|T0], [Name|TN], [Type|TT]) :- !,
|
||||
must_be(atom, Name),
|
||||
types(T0, TN, TT).
|
||||
types([Name|T0], [Name|TN], [any|TT]) :-
|
||||
must_be(atom, Name),
|
||||
types(T0, TN, TT).
|
||||
|
||||
|
||||
/*******************************
|
||||
* EXPANSION *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
system:term_expansion/2.
|
||||
:- dynamic
|
||||
system:term_expansion/2.
|
||||
|
||||
system:term_expansion((:- record(Record)), Clauses) :-
|
||||
compile_records(Record, Clauses).
|
||||
632
swi/library/settings.pl
Normal file
632
swi/library/settings.pl
Normal file
@@ -0,0 +1,632 @@
|
||||
/* $Id$
|
||||
|
||||
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(settings,
|
||||
[ setting/4, % :Name, +Type, +Default, +Comment
|
||||
setting/2, % :Name, ?Value
|
||||
set_setting/2, % :Name, +Value
|
||||
set_setting_default/2, % :Name, +Value
|
||||
restore_setting/1, % :Name
|
||||
load_settings/1, % +File
|
||||
load_settings/2, % +File, +Options
|
||||
save_settings/0,
|
||||
save_settings/1, % +File
|
||||
current_setting/1, % Module:Name
|
||||
setting_property/2, % ?Setting, ?Property
|
||||
list_settings/0,
|
||||
|
||||
convert_setting_text/3 % +Type, +Text, -Value
|
||||
]).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(broadcast)).
|
||||
:- use_module(library(debug)).
|
||||
:- use_module(library(option)).
|
||||
|
||||
/** <module> Setting management
|
||||
|
||||
This library allows management of configuration settings for Prolog
|
||||
applications. Applications define settings in one or multiple files
|
||||
using the directive setting/4 as illustrated below:
|
||||
|
||||
==
|
||||
:- use_module(library(setting)).
|
||||
|
||||
:- setting(version, atom, '1.0', 'Current version').
|
||||
:- setting(timeout, number, 20, 'Timeout in seconds').
|
||||
==
|
||||
|
||||
The directive is subject to term_expansion/2, which guarantees proper
|
||||
synchronisation of the database if source-files are reloaded. This
|
||||
implies it is *not* possible to call setting/4 as a predicate.
|
||||
|
||||
Settings are local to a module. This implies they are defined in a
|
||||
two-level namespace. Managing settings per module greatly simplifies
|
||||
assembling large applications from multiple modules that configuration
|
||||
through settings. This settings management library ensures proper
|
||||
access, loading and saving of settings.
|
||||
|
||||
@see library(config) distributed with XPCE provides an alternative
|
||||
aimed at graphical applications.
|
||||
@author Jan Wielemaker
|
||||
*/
|
||||
|
||||
:- dynamic
|
||||
st_value/3, % Name, Module, Value
|
||||
st_default/3, % Name, Module, Value
|
||||
local_file/1. % Path
|
||||
|
||||
:- multifile
|
||||
current_setting/6. % Name, Module, Type, Default, Comment, Source
|
||||
|
||||
:- meta_predicate
|
||||
setting(:, +, +, +),
|
||||
setting(:, ?),
|
||||
set_setting(:, +),
|
||||
set_setting_default(:, +),
|
||||
current_setting(:),
|
||||
restore_setting(:).
|
||||
|
||||
curr_setting(Name, Module, Type, Default, Comment) :-
|
||||
current_setting(Name, Module, Type, Default0, Comment, _Src),
|
||||
( st_default(Name, Module, Default1)
|
||||
-> Default = Default1
|
||||
; Default = Default0
|
||||
).
|
||||
|
||||
%% setting(Name, Type, Default, Comment) is det.
|
||||
%
|
||||
% Define a setting. Name denotes the name of the setting, Type its
|
||||
% type. Default is the value before it is modified. Default refer
|
||||
% to environment variables and use arithmetic expressions as
|
||||
% defined by eval_default/4.
|
||||
%
|
||||
% @param Name Name of the setting (an atom)
|
||||
% @param Type Type for setting. One of =any= or a type defined
|
||||
% by must_be/2.
|
||||
% @param Default Default value for the setting.
|
||||
% @param Comment Atom containing a (short) descriptive note.
|
||||
|
||||
|
||||
setting(Name, Type, Default, Comment) :-
|
||||
throw(error(context_error(nodirective,
|
||||
setting(Name, Type, Default, Comment)),
|
||||
_)).
|
||||
|
||||
:- multifile
|
||||
system:term_expansion/2.
|
||||
|
||||
system:term_expansion((:- setting(QName, Type, Default, Comment)),
|
||||
Expanded) :-
|
||||
prolog_load_context(module, M0),
|
||||
strip_module(M0:QName, Module, Name),
|
||||
must_be(atom, Name),
|
||||
to_atom(Comment, CommentAtom),
|
||||
eval_default(Default, Module, Type, Value),
|
||||
check_type(Type, Value),
|
||||
( current_setting(Name, Module, _, _, _, OldLoc)
|
||||
-> format(string(Message),
|
||||
'Already defined at: ~w', [OldLoc]),
|
||||
throw(error(permission_error(redefine, setting, Module:Name),
|
||||
context(Message, _)))
|
||||
; source_location(File, Line)
|
||||
-> Expanded = settings:current_setting(Name, Module, Type, Default,
|
||||
CommentAtom, File:Line)
|
||||
).
|
||||
|
||||
to_atom(Atom, Atom) :-
|
||||
atom(Atom), !.
|
||||
to_atom(String, Atom) :-
|
||||
format(atom(Atom), '~s', String).
|
||||
|
||||
%% setting(:Name, ?Value) is nondet.
|
||||
%
|
||||
% True if Name is a currently defined setting with Value.
|
||||
%
|
||||
% @error existence_error(setting, Name)
|
||||
|
||||
setting(QName, Value) :-
|
||||
strip_module(QName, Module, Name),
|
||||
( ground(Name)
|
||||
-> ( st_value(Name, Module, Value0)
|
||||
-> Value = Value0
|
||||
; curr_setting(Name, Module, Type, Default, _)
|
||||
-> eval_default(Default, Module, Type, Value)
|
||||
; existence_error(setting, Module:Name)
|
||||
)
|
||||
; current_setting(Name, Module, _, _, _, _),
|
||||
setting(Module:Name, Value)
|
||||
).
|
||||
|
||||
|
||||
:- dynamic
|
||||
setting_cache/3.
|
||||
:- volatile
|
||||
setting_cache/3.
|
||||
|
||||
%% clear_setting_cache is det.
|
||||
%
|
||||
% Clear the cache for evaluation of default values.
|
||||
|
||||
clear_setting_cache :-
|
||||
retractall(setting_cache(_,_,_)).
|
||||
|
||||
%% eval_default(+Default, +Module, +Type, -Value) is det.
|
||||
%
|
||||
% Convert the settings default value. The notation allows for some
|
||||
% `function-style' notations to make the library more generic:
|
||||
%
|
||||
% * env(Name)
|
||||
% Get value from the given environment variable. The value
|
||||
% is handed to convert_setting_text/3 to convert the
|
||||
% textual representation into a Prolog term. Raises an
|
||||
% existence_error of the variable is not defined.
|
||||
%
|
||||
% * env(Name, Default)
|
||||
% As env(Name), but uses the value Default if the variable
|
||||
% is not defined.
|
||||
%
|
||||
% * setting(Name)
|
||||
% Ask the value of another setting.
|
||||
%
|
||||
% * Expression
|
||||
% If Type is numeric, evaluate the expression. env(Var)
|
||||
% evaluates to the value of an environment variable.
|
||||
% If Type is =atom=, concatenate A+B+.... Elements of the
|
||||
% expression can be env(Name).
|
||||
|
||||
:- multifile
|
||||
eval_default/3. % +Default, +Type, -Value
|
||||
|
||||
eval_default(Default, _, Type, Value) :-
|
||||
eval_default(Default, Type, Val), !,
|
||||
Value = Val.
|
||||
eval_default(Default, _, _, Value) :-
|
||||
atomic(Default), !,
|
||||
Value = Default.
|
||||
eval_default(Default, _, Type, Value) :-
|
||||
setting_cache(Default, Type, Val), !,
|
||||
Value = Val.
|
||||
eval_default(env(Name), _, Type, Value) :- !,
|
||||
( getenv(Name, TextValue)
|
||||
-> convert_setting_text(Type, TextValue, Val),
|
||||
assert(setting_cache(env(Name), Type, Val)),
|
||||
Value = Val
|
||||
; existence_error(environment_variable, Name)
|
||||
).
|
||||
eval_default(env(Name, Default), _, Type, Value) :- !,
|
||||
( getenv(Name, TextValue)
|
||||
-> convert_setting_text(Type, TextValue, Val)
|
||||
; Value = Default
|
||||
),
|
||||
assert(setting_cache(env(Name), Type, Val)),
|
||||
Value = Val.
|
||||
eval_default(setting(Name), Module, Type, Value) :- !,
|
||||
strip_module(Module:Name, M, N),
|
||||
setting(M:N, Value),
|
||||
must_be(Type, Value).
|
||||
eval_default(Expr, _, Type, Value) :-
|
||||
numeric_type(Type, Basic), !,
|
||||
Val0 is Expr,
|
||||
( Basic == float
|
||||
-> Val is float(Val0)
|
||||
; Basic = integer
|
||||
-> Val is round(Val0)
|
||||
; Val = Val0
|
||||
),
|
||||
assert(setting_cache(Expr, Type, Val)),
|
||||
Value = Val.
|
||||
eval_default(A+B, Module, atom, Value) :- !,
|
||||
phrase(expr_to_list(A+B, Module), L),
|
||||
atomic_list_concat(L, Val),
|
||||
assert(setting_cache(A+B, atom, Val)),
|
||||
Value = Val.
|
||||
eval_default(List, Module, list(Type), Value) :- !,
|
||||
eval_list_default(List, Module, Type, Val),
|
||||
assert(setting_cache(List, list(Type), Val)),
|
||||
Value = Val.
|
||||
eval_default(Default, _, _, Default).
|
||||
|
||||
|
||||
%% eval_list_default(+List, +Module, +ElementType, -DefaultList)
|
||||
%
|
||||
% Evaluate the default for a list of values.
|
||||
|
||||
eval_list_default([], _, _, []).
|
||||
eval_list_default([H0|T0], Module, Type, [H|T]) :-
|
||||
eval_default(H0, Module, Type, H),
|
||||
eval_list_default(T0, Module, Type, T).
|
||||
|
||||
%% expr_to_list(+Expression, +Module)// is det.
|
||||
%
|
||||
% Process the components to create an atom. Atom concatenation is
|
||||
% expressed as A+B. Components may refer to envrionment variables.
|
||||
|
||||
expr_to_list(A+B, Module) --> !,
|
||||
expr_to_list(A, Module),
|
||||
expr_to_list(B, Module).
|
||||
expr_to_list(env(Name), _) --> !,
|
||||
( { getenv(Name, Text) }
|
||||
-> [Text]
|
||||
; { existence_error(environment_variable, Name) }
|
||||
).
|
||||
expr_to_list(env(Name, Default), _) --> !,
|
||||
( { getenv(Name, Text) }
|
||||
-> [Text]
|
||||
; [Default]
|
||||
).
|
||||
expr_to_list(setting(Name), Module) --> !,
|
||||
{ strip_module(Module:Name, M, N),
|
||||
setting(M:N, Value)
|
||||
},
|
||||
[ Value ].
|
||||
expr_to_list(A, _) -->
|
||||
[A].
|
||||
|
||||
:- if((\+ current_prolog_flag(version_data,yap(_,_,_,_)))).
|
||||
|
||||
%% env(+Name:atom, -Value:number) is det.
|
||||
%% env(+Name:atom, +Default:number, -Value:number) is det
|
||||
%
|
||||
% Evaluate environment variables on behalf of arithmetic
|
||||
% expressions.
|
||||
|
||||
:- arithmetic_function(env/1).
|
||||
:- arithmetic_function(env/2).
|
||||
|
||||
env(Name, Value) :-
|
||||
( getenv(Name, Text)
|
||||
-> convert_setting_text(number, Text, Value)
|
||||
; existence_error(environment_variable, Name)
|
||||
).
|
||||
env(Name, Default, Value) :-
|
||||
( getenv(Name, Text)
|
||||
-> convert_setting_text(number, Text, Value)
|
||||
; Value = Default
|
||||
).
|
||||
|
||||
:- endif.
|
||||
|
||||
%% numeric_type(+Type, -BaseType)
|
||||
%
|
||||
% True if Type is a numeric type and BaseType is the associated
|
||||
% basic Prolog type. BaseType is one of =integer=, =float= or
|
||||
% =number=.
|
||||
|
||||
numeric_type(integer, integer).
|
||||
numeric_type(nonneg, integer).
|
||||
numeric_type(float, float).
|
||||
numeric_type(between(L,_), Type) :-
|
||||
( integer(L) -> Type = integer ; Type = float ).
|
||||
|
||||
|
||||
%% set_setting(:Name, +Value) is det.
|
||||
%
|
||||
% Change a setting. Performs existence and type-checking for the
|
||||
% setting. If the effective value of the setting is changed it
|
||||
% broadcasts the event below.
|
||||
%
|
||||
% settings(changed(Module:Name, Old, New))
|
||||
%
|
||||
% @error existence_error(setting, Name)
|
||||
% @error type_error(Type, Value)
|
||||
|
||||
set_setting(QName, Value) :-
|
||||
strip_module(QName, Module, Name),
|
||||
must_be(atom, Name),
|
||||
( curr_setting(Name, Module, Type, Default0, _Comment),
|
||||
eval_default(Default0, Module, Type, Default)
|
||||
-> ( Value == Default
|
||||
-> retract_setting(Module:Name)
|
||||
; st_value(Name, Module, Value)
|
||||
-> true
|
||||
; check_type(Type, Value)
|
||||
-> setting(Module:Name, Old),
|
||||
retract_setting(Module:Name),
|
||||
assert_setting(Module:Name, Value),
|
||||
broadcast(settings(changed(Module:Name, Old, Value))),
|
||||
clear_setting_cache % might influence dependent settings.
|
||||
)
|
||||
; existence_error(setting, Name)
|
||||
).
|
||||
|
||||
retract_setting(Module:Name) :-
|
||||
retractall(st_value(Name, Module, _)).
|
||||
|
||||
assert_setting(Module:Name, Value) :-
|
||||
assert(st_value(Name, Module, Value)).
|
||||
|
||||
%% restore_setting(:Name) is det.
|
||||
%
|
||||
% Restore the value of setting Name to its default. Broadcast a
|
||||
% change like set_setting/2 if the current value is not the
|
||||
% default.
|
||||
|
||||
restore_setting(QName) :-
|
||||
strip_module(QName, Module, Name),
|
||||
must_be(atom, Name),
|
||||
( st_value(Name, Module, Old)
|
||||
-> retract_setting(Module:Name),
|
||||
setting(Module:Name, Value),
|
||||
( Old \== Value
|
||||
-> broadcast(settings(changed(Module:Name, Old, Value)))
|
||||
; true
|
||||
)
|
||||
; true
|
||||
).
|
||||
|
||||
%% set_setting_default(:Name, +Default) is det.
|
||||
%
|
||||
% Change the default for a setting. The effect is the same as
|
||||
% set_setting/2, but the new value is considered the default when
|
||||
% saving and restoring a setting. It is intended to change
|
||||
% application defaults in a particular context.
|
||||
|
||||
set_setting_default(QName, Default) :-
|
||||
strip_module(QName, Module, Name),
|
||||
must_be(atom, Name),
|
||||
( current_setting(Name, Module, Type, Default0, _Comment, _Src)
|
||||
-> retractall(settings:st_default(Name, Module, _)),
|
||||
retract_setting(Module:Name),
|
||||
( Default == Default0
|
||||
-> true
|
||||
; assert(settings:st_default(Name, Module, Default))
|
||||
),
|
||||
eval_default(Default, Module, Type, Value),
|
||||
set_setting(Module:Name, Value)
|
||||
; existence_error(setting, Module:Name)
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* TYPES *
|
||||
*******************************/
|
||||
|
||||
%% check_type(+Type, +Term)
|
||||
%
|
||||
% Type checking for settings. Currently simply forwarded to
|
||||
% must_be/2.
|
||||
|
||||
check_type(Type, Term) :-
|
||||
must_be(Type, Term).
|
||||
|
||||
|
||||
/*******************************
|
||||
* FILE *
|
||||
*******************************/
|
||||
|
||||
%% load_settings(File) is det.
|
||||
%% load_settings(File, +Options) is det.
|
||||
%
|
||||
% Load local settings from File. Succeeds if File does not exist,
|
||||
% setting the default save-file to File. Options are:
|
||||
%
|
||||
% * undefined(+Action)
|
||||
% Define how to handle settings that are not defined. When
|
||||
% =error=, an error is printed and the setting is ignored.
|
||||
% when =load=, the setting is loaded anyway, waiting for a
|
||||
% definition.
|
||||
|
||||
load_settings(File) :-
|
||||
load_settings(File, []).
|
||||
|
||||
load_settings(File, Options) :-
|
||||
absolute_file_name(File, Path,
|
||||
[ access(read),
|
||||
file_errors(fail)
|
||||
]), !,
|
||||
assert(local_file(Path)),
|
||||
open(Path, read, In, [encoding(utf8)]),
|
||||
read_setting(In, T0),
|
||||
call_cleanup(load_settings(T0, In, Options), close(In)),
|
||||
clear_setting_cache.
|
||||
load_settings(File, _) :-
|
||||
absolute_file_name(File, Path,
|
||||
[ access(write),
|
||||
file_errors(fail)
|
||||
]), !,
|
||||
assert(local_file(Path)).
|
||||
load_settings(_, _).
|
||||
|
||||
load_settings(end_of_file, _, _) :- !.
|
||||
load_settings(Setting, In, Options) :-
|
||||
catch(store_setting(Setting, Options), E,
|
||||
print_message(warning, E)),
|
||||
read_setting(In, Next),
|
||||
load_settings(Next, In, Options).
|
||||
|
||||
read_setting(In, Term) :-
|
||||
read_term(In, Term,
|
||||
[ errors(dec10)
|
||||
]).
|
||||
|
||||
%% store_setting(Term, +Options)
|
||||
%
|
||||
% Store setting loaded from file in the Prolog database.
|
||||
|
||||
store_setting(setting(Module:Name, Value), _) :-
|
||||
curr_setting(Name, Module, Type, Default0, _Commentm), !,
|
||||
eval_default(Default0, Module, Type, Default),
|
||||
( Value == Default
|
||||
-> true
|
||||
; check_type(Type, Value)
|
||||
-> retractall(st_value(Name, Module, _)),
|
||||
assert(st_value(Name, Module, Value)),
|
||||
broadcast(settings(changed(Module:Name, Default, Value)))
|
||||
).
|
||||
store_setting(setting(Module:Name, Value), Options) :- !,
|
||||
( option(undefined(load), Options, load)
|
||||
-> retractall(st_value(Name, Module, _)),
|
||||
assert(st_value(Name, Module, Value))
|
||||
; existence_error(setting, Module:Name)
|
||||
).
|
||||
store_setting(Term, _) :-
|
||||
type_error(setting, Term).
|
||||
|
||||
%% save_settings is det.
|
||||
%% save_settings(+File) is det.
|
||||
%
|
||||
% Save modified settings to File.
|
||||
|
||||
save_settings :-
|
||||
local_file(File), !,
|
||||
save_settings(File).
|
||||
|
||||
save_settings(File) :-
|
||||
absolute_file_name(File, Path,
|
||||
[ access(write)
|
||||
]), !,
|
||||
open(Path, write, Out,
|
||||
[ encoding(utf8),
|
||||
bom(true)
|
||||
]),
|
||||
write_setting_header(Out),
|
||||
forall(current_setting(Name, Module, _, _, _, _),
|
||||
save_setting(Out, Module:Name)),
|
||||
close(Out).
|
||||
|
||||
|
||||
write_setting_header(Out) :-
|
||||
get_time(Now),
|
||||
format_time(string(Date), '%+', Now),
|
||||
format(Out, '/* Saved settings~n', []),
|
||||
format(Out, ' Date: ~w~n', [Date]),
|
||||
format(Out, '*/~n~n', []).
|
||||
|
||||
save_setting(Out, Module:Name) :-
|
||||
curr_setting(Name, Module, Type, Default, Comment),
|
||||
( st_value(Name, Module, Value),
|
||||
\+ ( eval_default(Default, Module, Type, DefValue),
|
||||
debug(setting, '~w <-> ~w~n', [DefValue, Value]),
|
||||
DefValue =@= Value
|
||||
)
|
||||
-> format(Out, '~n% ~w~n', [Comment]),
|
||||
format(Out, 'setting(~q:~q, ~q).~n', [Module, Name, Value])
|
||||
; true
|
||||
).
|
||||
|
||||
%% current_setting(?Setting) is nondet.
|
||||
%
|
||||
% True if Setting is a currently defined setting
|
||||
|
||||
current_setting(Setting) :-
|
||||
ground(Setting), !,
|
||||
strip_module(Setting, Module, Name),
|
||||
current_setting(Name, Module, _, _, _, _).
|
||||
current_setting(Module:Name) :-
|
||||
current_setting(Name, Module, _, _, _, _).
|
||||
|
||||
%% setting_property(+Setting, +Property) is det.
|
||||
%% setting_property(?Setting, ?Property) is nondet.
|
||||
%
|
||||
% Query currently defined settings. Property is one of
|
||||
%
|
||||
% * comment(-Atom)
|
||||
% * type(-Type)
|
||||
% Type of the setting.
|
||||
% * default(-Default)
|
||||
% Default value. If this is an expression, it is
|
||||
% evaluated.
|
||||
|
||||
setting_property(Setting, Property) :-
|
||||
ground(Setting), !,
|
||||
Setting = Module:Name,
|
||||
curr_setting(Name, Module, Type, Default, Comment), !,
|
||||
setting_property(Property, Module, Type, Default, Comment).
|
||||
setting_property(Setting, Property) :-
|
||||
Setting = Module:Name,
|
||||
curr_setting(Name, Module, Type, Default, Comment),
|
||||
setting_property(Property, Module, Type, Default, Comment).
|
||||
|
||||
setting_property(type(Type), _, Type, _, _).
|
||||
setting_property(default(Default), M, Type, Default0, _) :-
|
||||
eval_default(Default0, M, Type, Default).
|
||||
setting_property(comment(Comment), _, _, _, Comment).
|
||||
|
||||
%% list_settings
|
||||
%
|
||||
% List settings to =current_output=.
|
||||
|
||||
list_settings :-
|
||||
format('~`=t~72|~n'),
|
||||
format('~w~t~20| ~w~w~t~40| ~w~n', ['Name', 'Value (*=modified)', '', 'Comment']),
|
||||
format('~`=t~72|~n'),
|
||||
forall(current_setting(Module:Setting),
|
||||
list_setting(Module:Setting)).
|
||||
|
||||
list_setting(Module:Name) :-
|
||||
curr_setting(Name, Module, Type, Default0, Comment),
|
||||
eval_default(Default0, Module, Type, Default),
|
||||
setting(Module:Name, Value),
|
||||
( Value \== Default
|
||||
-> Modified = (*)
|
||||
; Modified = ''
|
||||
),
|
||||
format('~w~t~20| ~q~w~t~40| ~w~n', [Module:Name, Value, Modified, Comment]).
|
||||
|
||||
|
||||
/*******************************
|
||||
* TYPES *
|
||||
*******************************/
|
||||
|
||||
%% convert_setting_text(+Type, +Text, -Value)
|
||||
%
|
||||
% Converts from textual form to Prolog Value. Used to convert
|
||||
% values obtained from the environment. Public to provide support
|
||||
% in user-interfaces to this library.
|
||||
%
|
||||
% @error type_error(Type, Value)
|
||||
|
||||
:- multifile
|
||||
convert_text/3. % +Type, +Text, -Value
|
||||
|
||||
convert_setting_text(Type, Text, Value) :-
|
||||
convert_text(Type, Text, Value), !.
|
||||
convert_setting_text(atom, Value, Value) :- !,
|
||||
must_be(atom, Value).
|
||||
convert_setting_text(boolean, Value, Value) :- !,
|
||||
must_be(boolean, Value).
|
||||
convert_setting_text(integer, Atom, Number) :- !,
|
||||
term_to_atom(Term, Atom),
|
||||
Number is round(Term).
|
||||
convert_setting_text(float, Atom, Number) :- !,
|
||||
term_to_atom(Term, Atom),
|
||||
Number is float(Term).
|
||||
convert_setting_text(between(L,U), Atom, Number) :- !,
|
||||
( integer(L)
|
||||
-> convert_setting_text(integer, Atom, Number)
|
||||
; convert_setting_text(float, Atom, Number)
|
||||
),
|
||||
must_be(between(L,U), Number).
|
||||
convert_setting_text(Type, Atom, Term) :-
|
||||
term_to_atom(Term, Atom),
|
||||
must_be(Type, Term).
|
||||
|
||||
|
||||
409
swi/library/shlib.pl
Normal file
409
swi/library/shlib.pl
Normal file
@@ -0,0 +1,409 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2009, 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 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.
|
||||
*/
|
||||
|
||||
:- module(shlib,
|
||||
[ load_foreign_library/1, % :LibFile
|
||||
load_foreign_library/2, % :LibFile, +InstallFunc
|
||||
unload_foreign_library/1, % +LibFile
|
||||
unload_foreign_library/2, % +LibFile, +UninstallFunc
|
||||
current_foreign_library/2, % ?LibFile, ?Public
|
||||
reload_foreign_libraries/0,
|
||||
% Directives
|
||||
use_foreign_library/1, % :LibFile
|
||||
use_foreign_library/2 % :LibFile, +InstallFunc
|
||||
]).
|
||||
:- use_module(library(lists), [reverse/2]).
|
||||
:- set_prolog_flag(generate_debug_info, false).
|
||||
|
||||
/** <module> Utility library for loading foreign objects (DLLs, shared objects)
|
||||
|
||||
This section discusses the functionality of the (autoload)
|
||||
library(shlib), providing an interface to manage shared libraries. We
|
||||
describe the procedure for using a foreign resource (DLL in Windows and
|
||||
shared object in Unix) called =mylib=.
|
||||
|
||||
First, one must assemble the resource and make it compatible to
|
||||
SWI-Prolog. The details for this vary between platforms. The plld(1)
|
||||
utility can be used to deal with this in a portable manner. The typical
|
||||
commandline is:
|
||||
|
||||
==
|
||||
plld -o mylib file.{c,o,cc,C} ...
|
||||
==
|
||||
|
||||
Make sure that one of the files provides a global function
|
||||
=|install_mylib()|= that initialises the module using calls to
|
||||
PL_register_foreign(). Here is a simple example file mylib.c, which
|
||||
creates a Windows MessageBox:
|
||||
|
||||
==
|
||||
#include <windows.h>
|
||||
#include <SWI-Prolog.h>
|
||||
|
||||
static foreign_t
|
||||
pl_say_hello(term_t to)
|
||||
{ char *a;
|
||||
|
||||
if ( PL_get_atom_chars(to, &a) )
|
||||
{ MessageBox(NULL, a, "DLL test", MB_OK|MB_TASKMODAL);
|
||||
|
||||
PL_succeed;
|
||||
}
|
||||
|
||||
PL_fail;
|
||||
}
|
||||
|
||||
install_t
|
||||
install_mylib()
|
||||
{ PL_register_foreign("say_hello", 1, pl_say_hello, 0);
|
||||
}
|
||||
==
|
||||
|
||||
Now write a file mylib.pl:
|
||||
|
||||
==
|
||||
:- module(mylib, [ say_hello/1 ]).
|
||||
:- use_foreign_library(foreign(mylib)).
|
||||
==
|
||||
|
||||
The file mylib.pl can be loaded as a normal Prolog file and provides the
|
||||
predicate defined in C.
|
||||
*/
|
||||
|
||||
:- meta_predicate
|
||||
load_foreign_library(:),
|
||||
load_foreign_library(:, +),
|
||||
use_foreign_library(:),
|
||||
use_foreign_library(:, +).
|
||||
|
||||
:- dynamic
|
||||
loading/1, % Lib
|
||||
error/2, % File, Error
|
||||
foreign_predicate/2, % Lib, Pred
|
||||
current_library/5. % Lib, Entry, Path, Module, Handle
|
||||
|
||||
:- volatile % Do not store in state
|
||||
loading/1,
|
||||
error/2,
|
||||
foreign_predicate/2,
|
||||
current_library/5.
|
||||
|
||||
:- ( current_prolog_flag(open_shared_object, true)
|
||||
-> true
|
||||
; print_message(warning, shlib(not_supported)) % error?
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* DISPATCHING *
|
||||
*******************************/
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
Windows: If libpl.dll is compiled for debugging, prefer loading <lib>D.dll
|
||||
to allow for debugging.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
find_library(Spec, Lib) :-
|
||||
current_prolog_flag(windows, true),
|
||||
false,
|
||||
current_prolog_flag(kernel_compile_mode, debug),
|
||||
libd_spec(Spec, SpecD),
|
||||
catch(find_library2(SpecD, Lib), _, fail).
|
||||
find_library(Spec, Lib) :-
|
||||
find_library2(Spec, Lib).
|
||||
|
||||
find_library2(Spec, Lib) :-
|
||||
absolute_file_name(Spec,
|
||||
[ file_type(executable),
|
||||
access(read),
|
||||
file_errors(fail)
|
||||
], Lib), !.
|
||||
find_library2(Spec, Spec) :-
|
||||
atom(Spec), !. % use machines finding schema
|
||||
find_library2(foreign(Spec), Spec) :-
|
||||
atom(Spec), !. % use machines finding schema
|
||||
find_library2(Spec, _) :-
|
||||
throw(error(existence_error(source_sink, Spec), _)).
|
||||
|
||||
libd_spec(Name, NameD) :-
|
||||
atomic(Name),
|
||||
file_name_extension(Base, Ext, Name),
|
||||
atom_concat(Base, 'D', BaseD),
|
||||
file_name_extension(BaseD, Ext, NameD).
|
||||
libd_spec(Spec, SpecD) :-
|
||||
compound(Spec),
|
||||
Spec =.. [Alias,Name],
|
||||
libd_spec(Name, NameD),
|
||||
SpecD =.. [Alias,NameD].
|
||||
libd_spec(Spec, Spec). % delay errors
|
||||
|
||||
base(Path, Base) :-
|
||||
atomic(Path), !,
|
||||
file_base_name(Path, File),
|
||||
file_name_extension(Base, _Ext, File).
|
||||
base(Path, Base) :-
|
||||
Path =.. [_,Arg],
|
||||
base(Arg, Base).
|
||||
|
||||
entry(_, Function, Function) :-
|
||||
Function \= default(_), !.
|
||||
entry(Spec, default(FuncBase), Function) :-
|
||||
base(Spec, Base),
|
||||
atomic_list_concat([FuncBase, Base], '_', Function).
|
||||
entry(_, default(Function), Function).
|
||||
|
||||
/*******************************
|
||||
* (UN)LOADING *
|
||||
*******************************/
|
||||
|
||||
%% load_foreign_library(:FileSpec) is det.
|
||||
%% load_foreign_library(:FileSpec, +Entry:atom) is det.
|
||||
%
|
||||
% Load a _|shared object|_ or _DLL_. After loading the Entry
|
||||
% function is called without arguments. The default entry function
|
||||
% is composed from =install_=, followed by the file base-name.
|
||||
% E.g., the load-call below calls the function
|
||||
% =|install_mylib()|=. If the platform prefixes extern functions
|
||||
% with =_=, this prefix is added before calling.
|
||||
%
|
||||
% ==
|
||||
% ...
|
||||
% load_foreign_library(foreign(mylib)),
|
||||
% ...
|
||||
% ==
|
||||
%
|
||||
% @param FileSpec is a specification for absolute_file_name/3. If searching
|
||||
% the file fails, the plain name is passed to the OS to try the default
|
||||
% method of the OS for locating foreign objects. The default definition
|
||||
% of file_search_path/2 searches <prolog home>/lib/<arch> on Unix and
|
||||
% <prolog home>/bin on Windows.
|
||||
%
|
||||
% @see use_foreign_library/1,2 are intended for use in directives.
|
||||
|
||||
load_foreign_library(Library) :-
|
||||
load_foreign_library(Library, default(install)).
|
||||
|
||||
load_foreign_library(Module:LibFile, Entry) :-
|
||||
with_mutex('$foreign',
|
||||
load_foreign_library(LibFile, Module, Entry)).
|
||||
|
||||
load_foreign_library(LibFile, _Module, _) :-
|
||||
current_library(LibFile, _, _, _, _), !.
|
||||
load_foreign_library(LibFile, Module, DefEntry) :-
|
||||
retractall(error(_, _)),
|
||||
find_library(LibFile, Path),
|
||||
asserta(loading(LibFile)),
|
||||
catch(Module:open_shared_object(Path, Handle), E, true),
|
||||
( nonvar(E)
|
||||
-> assert(error(Path, E)),
|
||||
fail
|
||||
; true
|
||||
), !,
|
||||
( ( entry(LibFile, DefEntry, Entry),
|
||||
Module:call_shared_object_function(Handle, Entry)
|
||||
-> true
|
||||
; DefEntry == default(install)
|
||||
)
|
||||
-> retractall(loading(LibFile)),
|
||||
assert_shlib(LibFile, Entry, Path, Module, Handle)
|
||||
; retractall(loading(LibFile)),
|
||||
close_shared_object(Handle),
|
||||
print_message(error, shlib(LibFile, call_entry(DefEntry))),
|
||||
fail
|
||||
).
|
||||
load_foreign_library(LibFile, _, _) :-
|
||||
retractall(loading(LibFile)),
|
||||
( error(_Path, E)
|
||||
-> retractall(error(_, _)),
|
||||
throw(E)
|
||||
; throw(error(existence_error(foreign_library, LibFile), _))
|
||||
).
|
||||
|
||||
%% use_foreign_library(+FileSpec) is det.
|
||||
%% use_foreign_library(+FileSpec, +Entry:atom) is det.
|
||||
%
|
||||
% Load and install a foreign library as load_foreign_library/1,2
|
||||
% and register the installation using initialization/2 with the
|
||||
% option =now=. This is similar to using:
|
||||
%
|
||||
% ==
|
||||
% :- initialization(load_foreign_library(foreign(mylib))).
|
||||
% ==
|
||||
%
|
||||
% but using the initialization/1 wrapper causes the library to be
|
||||
% loaded _after_ loading of the file in which it appears is
|
||||
% completed, while use_foreign_library/1 loads the library
|
||||
% _immediately_. I.e. the difference is only relevant if the
|
||||
% remainder of the file uses functionality of the C-library.
|
||||
|
||||
use_foreign_library(FileSpec) :-
|
||||
initialization(load_foreign_library(FileSpec), now).
|
||||
|
||||
use_foreign_library(FileSpec, Entry) :-
|
||||
initialization(load_foreign_library(FileSpec, Entry), now).
|
||||
|
||||
%% unload_foreign_library(+FileSpec) is det.
|
||||
%% unload_foreign_library(+FileSpec, +Exit:atom) is det.
|
||||
%
|
||||
% Unload a _|shared object|_ or _DLL_. After calling the Exit
|
||||
% function, the shared object is removed from the process. The
|
||||
% default exit function is composed from =uninstall_=, followed by
|
||||
% the file base-name.
|
||||
|
||||
unload_foreign_library(LibFile) :-
|
||||
unload_foreign_library(LibFile, default(uninstall)).
|
||||
|
||||
unload_foreign_library(LibFile, DefUninstall) :-
|
||||
with_mutex('$foreign', do_unload(LibFile, DefUninstall)).
|
||||
|
||||
do_unload(LibFile, DefUninstall) :-
|
||||
current_library(LibFile, _, _, Module, Handle),
|
||||
retractall(current_library(LibFile, _, _, _, _)),
|
||||
( entry(LibFile, DefUninstall, Uninstall),
|
||||
Module:call_shared_object_function(Handle, Uninstall)
|
||||
-> true
|
||||
; true
|
||||
),
|
||||
abolish_foreign(LibFile),
|
||||
close_shared_object(Handle).
|
||||
|
||||
abolish_foreign(LibFile) :-
|
||||
( retract(foreign_predicate(LibFile, Module:Head)),
|
||||
functor(Head, Name, Arity),
|
||||
abolish(Module:Name, Arity),
|
||||
fail
|
||||
; true
|
||||
).
|
||||
|
||||
system:'$foreign_registered'(M, H) :-
|
||||
( loading(Lib)
|
||||
-> true
|
||||
; Lib = '<spontaneous>'
|
||||
),
|
||||
assert(foreign_predicate(Lib, M:H)).
|
||||
|
||||
assert_shlib(File, Entry, Path, Module, Handle) :-
|
||||
retractall(current_library(File, _, _, _, _)),
|
||||
asserta(current_library(File, Entry, Path, Module, Handle)).
|
||||
|
||||
|
||||
/*******************************
|
||||
* ADMINISTRATION *
|
||||
*******************************/
|
||||
|
||||
%% current_foreign_library(?File, ?Public)
|
||||
%
|
||||
% Query currently loaded shared libraries.
|
||||
|
||||
current_foreign_library(File, Public) :-
|
||||
current_library(File, _Entry, _Path, _Module, _Handle),
|
||||
findall(Pred, foreign_predicate(File, Pred), Public).
|
||||
|
||||
|
||||
/*******************************
|
||||
* RELOAD *
|
||||
*******************************/
|
||||
|
||||
%% reload_foreign_libraries
|
||||
%
|
||||
% Reload all foreign libraries loaded (after restore of a state
|
||||
% created using qsave_program/2.
|
||||
|
||||
reload_foreign_libraries :-
|
||||
findall(lib(File, Entry, Module),
|
||||
( retract(current_library(File, Entry, _, Module, _)),
|
||||
File \== -
|
||||
),
|
||||
Libs),
|
||||
reverse(Libs, Reversed),
|
||||
reload_libraries(Reversed).
|
||||
|
||||
reload_libraries([]).
|
||||
reload_libraries([lib(File, Entry, Module)|T]) :-
|
||||
( load_foreign_library(File, Module, Entry)
|
||||
-> true
|
||||
; print_message(error, shlib(File, load_failed))
|
||||
),
|
||||
reload_libraries(T).
|
||||
|
||||
|
||||
/*******************************
|
||||
* CLEANUP (WINDOWS ...) *
|
||||
*******************************/
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
Called from Halt() in pl-os.c (if it is defined), *after* all at_halt/1
|
||||
hooks have been executed, and after dieIO(), closing and flushing all
|
||||
files has been called.
|
||||
|
||||
On Unix, this is not very useful, and can only lead to conflicts.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
unload_all_foreign_libraries :-
|
||||
current_prolog_flag(unix, true), !.
|
||||
unload_all_foreign_libraries :-
|
||||
forall(current_library(File, _, _, _, _),
|
||||
unload_foreign(File)).
|
||||
|
||||
%% unload_foreign(+File)
|
||||
%
|
||||
% Unload the given foreign file and all `spontaneous' foreign
|
||||
% predicates created afterwards. Handling these spontaneous
|
||||
% predicates is a bit hard, as we do not know who created them and
|
||||
% on which library they depend.
|
||||
|
||||
unload_foreign(File) :-
|
||||
unload_foreign_library(File),
|
||||
( clause(foreign_predicate(Lib, M:H), true, Ref),
|
||||
( Lib == '<spontaneous>'
|
||||
-> functor(H, Name, Arity),
|
||||
abolish(M:Name, Arity),
|
||||
erase(Ref),
|
||||
fail
|
||||
; !
|
||||
)
|
||||
-> true
|
||||
; true
|
||||
).
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(shlib(LibFile, call_entry(DefEntry))) -->
|
||||
[ '~w: Failed to call entry-point ~w'-[LibFile, DefEntry] ].
|
||||
prolog:message(shlib(LibFile, load_failed)) -->
|
||||
[ '~w: Failed to load file'-[LibFile] ].
|
||||
prolog:message(shlib(not_supported)) -->
|
||||
[ 'Emulator does not support foreign libraries' ].
|
||||
418
swi/library/thread_pool.pl
Normal file
418
swi/library/thread_pool.pl
Normal file
@@ -0,0 +1,418 @@
|
||||
/* Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 2008, 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(thread_pool,
|
||||
[ thread_pool_create/3, % +Pool, +Size, +Options
|
||||
thread_pool_destroy/1, % +Pool
|
||||
thread_create_in_pool/4, % +Pool, :Goal, -Id, +Options
|
||||
|
||||
current_thread_pool/1, % ?Pool
|
||||
thread_pool_property/2 % ?Pool, ?Property
|
||||
]).
|
||||
:- use_module(library(error)).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(option)).
|
||||
:- use_module(library(rbtrees)).
|
||||
:- use_module(library(debug)).
|
||||
|
||||
|
||||
/** <module> Resource bounded thread management
|
||||
|
||||
The module library(thread_pool) manages threads in pools. A pool defines
|
||||
properties of its member threads and the maximum number of threads that
|
||||
can coexist in the pool. The call thread_create_in_pool/4 allocates a
|
||||
thread in the pool, just like thread_create/3. If the pool is fully
|
||||
allocated it can be asked to wait or raise an error.
|
||||
|
||||
The library has been designed to deal with server application that
|
||||
recieve a variety of requests, such as HTTP servers. Simply starting a
|
||||
thread for each request is a bit too simple minded for such servers:
|
||||
|
||||
* Creating many CPU intensive threads often leads to a slow-down
|
||||
rather than a speedup.
|
||||
* Creating many memory intensive threads may exhaust resources
|
||||
* Tasks that require little CPU and memory but take long waiting
|
||||
for external resources can run many threads.
|
||||
|
||||
Using this library, one can define a pool for each set of tasks with
|
||||
comparable characteristics and create threads in this pool. Unlike the
|
||||
worker-pool model, threads are not started immediately. Depending on the
|
||||
design, both approaches can be attractive.
|
||||
|
||||
The library is implemented by means of a manager thread with the fixed
|
||||
thread id =|__thread_pool_manager|=. All state is maintained in this
|
||||
manager thread, which receives and processes requests to create and
|
||||
destroy pools, create threads in a pool and handle messages from
|
||||
terminated threads. Thread pools are _not_ saved in a saved state and
|
||||
must therefore be recreated using the initialization/1 directive or
|
||||
otherwise during startup of the application.
|
||||
|
||||
@see http_handler/3 and http_spawn/2.
|
||||
*/
|
||||
|
||||
:- meta_predicate
|
||||
thread_create_in_pool(+, 0, -, +).
|
||||
|
||||
|
||||
%% thread_pool_create(+Pool, +Size, +Options) is det.
|
||||
%
|
||||
% Create a pool of threads. A pool of threads is a declaration for
|
||||
% creating threads with shared properties (stack sizes) and a
|
||||
% limited number of threads. Threads are created using
|
||||
% thread_create_in_pool/4. If all threads in the pool are in use,
|
||||
% the behaviour depends on the =wait= option of
|
||||
% thread_create_in_pool/4 and the =backlog= option described
|
||||
% below. Options are passed to thread_create/3, except for
|
||||
%
|
||||
% * backlog(+MaxBackLog)
|
||||
% Maximum number of requests that can be suspended. Default
|
||||
% is =infinite=. Otherwise it must be a non-negative integer.
|
||||
% Using backlog(0) will never delay thread creation for this
|
||||
% pool.
|
||||
%
|
||||
% The pooling mechanism does _not_ interact with the =detached=
|
||||
% state of a thread. Threads can be created both =detached= and
|
||||
% normal and must be joined using thread_join/2 if they are not
|
||||
% detached.
|
||||
%
|
||||
% @bug The thread creation option =at_exit= is reserved for
|
||||
% internal use by this library.
|
||||
|
||||
thread_pool_create(Name, Size, Options) :-
|
||||
pool_manager(Manager),
|
||||
thread_self(Me),
|
||||
thread_send_message(Manager, create_pool(Name, Size, Options, Me)),
|
||||
wait_reply.
|
||||
|
||||
%% thread_pool_destroy(+Name) is det.
|
||||
%
|
||||
% Destroy the thread pool named Name.
|
||||
%
|
||||
% @error existence_error(thread_pool, Name).
|
||||
|
||||
thread_pool_destroy(Name) :-
|
||||
pool_manager(Manager),
|
||||
thread_self(Me),
|
||||
thread_send_message(Manager, destroy_pool(Name, Me)),
|
||||
wait_reply.
|
||||
|
||||
|
||||
%% current_thread_pool(?Name) is nondet.
|
||||
%
|
||||
% True if Name refers to a defined thread pool.
|
||||
|
||||
current_thread_pool(Name) :-
|
||||
pool_manager(Manager),
|
||||
thread_self(Me),
|
||||
thread_send_message(Manager, current_pools(Me)),
|
||||
wait_reply(Pools),
|
||||
( atom(Name)
|
||||
-> memberchk(Name, Pools)
|
||||
; member(Name, Pools)
|
||||
).
|
||||
|
||||
%% thread_pool_property(?Name, ?Property) is nondet.
|
||||
%
|
||||
% True if Property is a property of thread pool Name. Defined
|
||||
% properties are:
|
||||
%
|
||||
% * options(Options)
|
||||
% Thread creation options for this pool
|
||||
% * free(Size)
|
||||
% Number of free slots on this pool
|
||||
% * size(Size)
|
||||
% Total number of slots on this pool
|
||||
% * members(ListOfIDs)
|
||||
% ListOfIDs is the list or threads running in this pool
|
||||
% * running(Running)
|
||||
% Number of running threads in this pool
|
||||
% * backlog(Size)
|
||||
% Number of delayed thread creations on this pool
|
||||
|
||||
thread_pool_property(Name, Property) :-
|
||||
current_thread_pool(Name),
|
||||
pool_manager(Manager),
|
||||
thread_self(Me),
|
||||
thread_send_message(Manager, pool_properties(Me, Name, Property)),
|
||||
wait_reply(Props),
|
||||
( nonvar(Property)
|
||||
-> memberchk(Property, Props)
|
||||
; member(Property, Props)
|
||||
).
|
||||
|
||||
|
||||
%% thread_create_in_pool(+Pool, :Goal, -Id, +Options) is det.
|
||||
%
|
||||
% Create a thread in Pool. Options overrule default thread
|
||||
% creation options associated to the pool. In addition, the
|
||||
% following option is defined:
|
||||
%
|
||||
% * wait(+Boolean)
|
||||
% If =true= (default) and the pool is full, wait until a
|
||||
% member of the pool completes. If =false=, throw a
|
||||
% resource_error.
|
||||
%
|
||||
% @error resource_error(threads_in_pool(Pool)) is raised if wait
|
||||
% is =false= or the backlog limit has been reached.
|
||||
% @error existence_error(thread_pool, Pool) if Pool does not
|
||||
% exist.
|
||||
|
||||
thread_create_in_pool(Pool, Goal, Id, Options) :-
|
||||
select_option(wait(Wait), Options, ThreadOptions, true),
|
||||
pool_manager(Manager),
|
||||
thread_self(Me),
|
||||
thread_send_message(Manager,
|
||||
create(Pool, Goal, Me, Wait, ThreadOptions)),
|
||||
wait_reply(Id).
|
||||
|
||||
|
||||
/*******************************
|
||||
* START MANAGER *
|
||||
*******************************/
|
||||
|
||||
%% pool_manager(-ThreadID) is det.
|
||||
%
|
||||
% ThreadID is the thread (alias) identifier of the manager. Starts
|
||||
% the manager if it is not running.
|
||||
|
||||
pool_manager(TID) :-
|
||||
TID = '__thread_pool_manager',
|
||||
( thread_running(TID)
|
||||
-> true
|
||||
; with_mutex('__thread_pool', create_pool_manager(TID))
|
||||
).
|
||||
|
||||
thread_running(Thread) :-
|
||||
catch(thread_property(Thread, status(Status)),
|
||||
E, true),
|
||||
( var(E)
|
||||
-> ( Status == running
|
||||
-> true
|
||||
; thread_join(Thread, _),
|
||||
print_message(warning, thread_pool(manager_died(Status))),
|
||||
fail
|
||||
)
|
||||
; E = error(existence_error(thread, Thread), _)
|
||||
-> fail
|
||||
; throw(E)
|
||||
).
|
||||
|
||||
create_pool_manager(Thread) :-
|
||||
thread_running(Thread), !.
|
||||
create_pool_manager(Thread) :-
|
||||
rb_new(State0),
|
||||
thread_create(manage_thread_pool(State0), _,
|
||||
[ alias(Thread)
|
||||
]).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MANAGER LOGIC *
|
||||
*******************************/
|
||||
|
||||
%% manage_thread_pool(+State)
|
||||
|
||||
manage_thread_pool(State0) :-
|
||||
thread_get_message(Message),
|
||||
( update_thread_pool(Message, State0, State)
|
||||
-> debug(thread_pool(state), 'Message ~p --> ~p', [Message, State]),
|
||||
manage_thread_pool(State)
|
||||
; format(user_error, 'Update failed: ~p~n', [Message])
|
||||
).
|
||||
|
||||
|
||||
update_thread_pool(create_pool(Name, Size, Options, For), State0, State) :- !,
|
||||
( rb_insert_new(State0,
|
||||
Name, tpool(Options, Size, Size, WP, WP, []),
|
||||
State)
|
||||
-> thread_send_message(For, thread_pool(true))
|
||||
; reply_error(For, permission_error(create, thread_pool, Name)),
|
||||
State = State0
|
||||
).
|
||||
update_thread_pool(destroy_pool(Name, For), State0, State) :- !,
|
||||
( rb_delete(State0, Name, State)
|
||||
-> thread_send_message(For, thread_pool(true))
|
||||
; reply_error(For, existence_error(thread_pool, Name)),
|
||||
State = State0
|
||||
).
|
||||
update_thread_pool(current_pools(For), State, State) :- !,
|
||||
rb_keys(State, Keys),
|
||||
debug(thread_pool(current), 'Reply to ~w: ~p', [For, Keys]),
|
||||
reply(For, Keys).
|
||||
update_thread_pool(pool_properties(For, Name, P), State, State) :- !,
|
||||
( rb_lookup(Name, Pool, State)
|
||||
-> findall(P, pool_property(P, Pool), List),
|
||||
reply(For, List)
|
||||
; reply_error(For, existence_error(thread_pool, Name))
|
||||
).
|
||||
update_thread_pool(Message, State0, State) :-
|
||||
arg(1, Message, Name),
|
||||
( rb_lookup(Name, Pool0, State0)
|
||||
-> update_pool(Message, Pool0, Pool),
|
||||
rb_update(State0, Name, Pool, State)
|
||||
; State = State0,
|
||||
( Message = create(Name, _, For, _, _)
|
||||
-> reply_error(For, existence_error(thread_pool, Name))
|
||||
; true
|
||||
)
|
||||
).
|
||||
|
||||
pool_property(options(Options),
|
||||
tpool(Options, _Free, _Size, _WP, _WPT, _Members)).
|
||||
pool_property(backlog(Size),
|
||||
tpool(_, _Free, _Size, WP, WPT, _Members)) :-
|
||||
diff_list_length(WP, WPT, Size).
|
||||
pool_property(free(Free),
|
||||
tpool(_, Free, _Size, _, _, _)).
|
||||
pool_property(size(Size),
|
||||
tpool(_, _Free, Size, _, _, _)).
|
||||
pool_property(running(Count),
|
||||
tpool(_, Free, Size, _, _, _)) :-
|
||||
Count is Size - Free.
|
||||
pool_property(members(IDList),
|
||||
tpool(_, _, _, _, _, IDList)).
|
||||
|
||||
diff_list_length(List, Tail, Size) :-
|
||||
'$skip_list'(Length, List, Rest),
|
||||
( Rest == Tail
|
||||
-> Size = Length
|
||||
; type_error(difference_list, List/Tail)
|
||||
).
|
||||
|
||||
|
||||
%% update_pool(+Message, +Pool0, -Pool) is det.
|
||||
%
|
||||
% Deal with create requests and completion messages on a given
|
||||
% pool. There are two messages:
|
||||
%
|
||||
% * create(PoolName, Goal, ForThread, Wait, Options)
|
||||
% Create a new thread on behalve of ForThread. There are
|
||||
% two cases:
|
||||
% * Free slots: create the thread
|
||||
% * No free slots: error or add to waiting
|
||||
% * exitted(PoolName, Thread)
|
||||
% A thread completed. If there is a request waiting,
|
||||
% create a new one.
|
||||
|
||||
update_pool(create(Name, Goal, For, _, MyOptions),
|
||||
tpool(Options, Free0, Size, WP, WPT, Members0),
|
||||
tpool(Options, Free, Size, WP, WPT, Members)) :-
|
||||
succ(Free, Free0), !,
|
||||
thread_self(Me),
|
||||
merge_options(MyOptions, Options, ThreadOptions),
|
||||
( option(at_exit(_), ThreadOptions)
|
||||
-> reply_error(For, permission_error(specify, option, at_axit)),
|
||||
Members = Members0
|
||||
; Exit = thread_send_message(Me, exitted(Name, Id)),
|
||||
catch(thread_create(Goal, Id,
|
||||
[ at_exit(Exit)
|
||||
| ThreadOptions
|
||||
]),
|
||||
E, true),
|
||||
( var(E)
|
||||
-> Members = [Id|Members0],
|
||||
reply(For, Id)
|
||||
; reply_error(For, E),
|
||||
Members = Members0
|
||||
)
|
||||
).
|
||||
update_pool(Create,
|
||||
tpool(Options, 0, Size, WP, WPT0, Members),
|
||||
tpool(Options, 0, Size, WP, WPT, Members)) :-
|
||||
Create = create(Name, _Goal, For, Wait, _Options), !,
|
||||
option(backlog(BackLog), Options, infinite),
|
||||
( can_delay(Wait, BackLog, WP, WPT0)
|
||||
-> WPT0 = [Create|WPT],
|
||||
debug(thread_pool, 'Delaying ~p', [Create])
|
||||
; WPT = WPT0,
|
||||
reply_error(For, resource_error(threads_in_pool(Name)))
|
||||
).
|
||||
update_pool(exitted(_Name, Id),
|
||||
tpool(Options, Free0, Size, WP0, WPT, Members0),
|
||||
Pool) :-
|
||||
succ(Free0, Free),
|
||||
delete(Members0, Id, Members1),
|
||||
Pool1 = tpool(Options, Free, Size, WP, WPT, Members1),
|
||||
( WP0 == WPT
|
||||
-> WP = WP0,
|
||||
Pool = Pool1
|
||||
; WP0 = [Waiting|WP],
|
||||
debug(thread_pool, 'Start delayed ~p', [Waiting]),
|
||||
update_pool(Waiting, Pool1, Pool)
|
||||
).
|
||||
|
||||
|
||||
can_delay(true, infinite, _, _) :- !.
|
||||
can_delay(true, BackLog, WP, WPT) :-
|
||||
diff_list_length(WP, WPT, Size),
|
||||
BackLog > Size.
|
||||
|
||||
|
||||
/*******************************
|
||||
* UTIL *
|
||||
*******************************/
|
||||
|
||||
reply(To, Term) :-
|
||||
thread_send_message(To, thread_pool(true(Term))).
|
||||
|
||||
reply_error(To, Error) :-
|
||||
thread_send_message(To, thread_pool(error(Error, _))).
|
||||
|
||||
wait_reply :-
|
||||
thread_get_message(thread_pool(Result)),
|
||||
( Result == true
|
||||
-> true
|
||||
; Result == fail
|
||||
-> fail
|
||||
; throw(Result)
|
||||
).
|
||||
|
||||
wait_reply(Value) :-
|
||||
thread_get_message(thread_pool(Reply)),
|
||||
( Reply = true(Value0)
|
||||
-> Value = Value0
|
||||
; Reply == fail
|
||||
-> fail
|
||||
; throw(Reply)
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
% Print messages
|
||||
|
||||
prolog:message(thread_pool(Message)) -->
|
||||
message(Message).
|
||||
|
||||
prolog:message(manager_died(Status)) -->
|
||||
[ 'Thread-pool: manager died on status ~p; restarting'-[Status] ].
|
||||
1048
swi/library/url.pl
Normal file
1048
swi/library/url.pl
Normal file
File diff suppressed because it is too large
Load Diff
134
swi/library/utf8.pl
Normal file
134
swi/library/utf8.pl
Normal file
@@ -0,0 +1,134 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: wielemak@science.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2005, 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(utf8,
|
||||
[ utf8_codes//1 % ?String
|
||||
]).
|
||||
|
||||
%% utf8_codes(?Codes)// is det.
|
||||
%
|
||||
% DCG translating between a Unicode code-list and its UTF-8
|
||||
% encoded byte-string. The DCG works two ways. Encoding a
|
||||
% code-list to a UTF-8 byte string is achieved using
|
||||
%
|
||||
% phrase(utf8_codes(Codes), UTF8)
|
||||
%
|
||||
% The algorithm is a close copy of the C-algorithm used
|
||||
% internally and defined in src/pl-utf8.c
|
||||
%
|
||||
% NOTE: in many cases you can avoid this library and leave
|
||||
% encoding and decoding to I/O streams. If only part of the data
|
||||
% is to be encoded the encoding of a stream can be switched
|
||||
% temporary using set_stream(Stream, encoding(utf8))
|
||||
|
||||
utf8_codes([H|T]) -->
|
||||
utf8_code(H), !,
|
||||
utf8_codes(T).
|
||||
utf8_codes([]) -->
|
||||
[].
|
||||
|
||||
utf8_code(C) -->
|
||||
[C0],
|
||||
{ nonvar(C0) }, !, % decoding version
|
||||
( {C0 < 0x80}
|
||||
-> {C = C0}
|
||||
; {C0/\0xe0 =:= 0xc0}
|
||||
-> utf8_cont(C1, 0),
|
||||
{C is (C0/\0x1f)<<6\/C1}
|
||||
; {C0/\0xf0 =:= 0xe0}
|
||||
-> utf8_cont(C1, 6),
|
||||
utf8_cont(C2, 0),
|
||||
{C is ((C0/\0xf)<<12)\/C1\/C2}
|
||||
; {C0/\0xf8 =:= 0xf0}
|
||||
-> utf8_cont(C1, 12),
|
||||
utf8_cont(C2, 6),
|
||||
utf8_cont(C3, 0),
|
||||
{C is ((C0/\0x7)<<18)\/C1\/C2\/C3}
|
||||
; {C0/\0xfc =:= 0xf8}
|
||||
-> utf8_cont(C1, 18),
|
||||
utf8_cont(C2, 12),
|
||||
utf8_cont(C3, 6),
|
||||
utf8_cont(C4, 0),
|
||||
{C is ((C0/\0x3)<<24)\/C1\/C2\/C3\/C4}
|
||||
; {C0/\0xfe =:= 0xfc}
|
||||
-> utf8_cont(C1, 24),
|
||||
utf8_cont(C2, 18),
|
||||
utf8_cont(C3, 12),
|
||||
utf8_cont(C4, 6),
|
||||
utf8_cont(C5, 0),
|
||||
{C is ((C0/\0x1)<<30)\/C1\/C2\/C3\/C4\/C5}
|
||||
).
|
||||
utf8_code(C) -->
|
||||
{ nonvar(C) }, !, % encoding version
|
||||
( { C < 0x80 }
|
||||
-> [C]
|
||||
; { C < 0x800 }
|
||||
-> { C0 is 0xc0\/((C>>6)/\0x1f),
|
||||
C1 is 0x80\/(C/\0x3f)
|
||||
},
|
||||
[C0,C1]
|
||||
; { C < 0x10000 }
|
||||
-> { C0 is 0xe0\/((C>>12)/\0x0f),
|
||||
C1 is 0x80\/((C>>6)/\0x3f),
|
||||
C2 is 0x80\/(C/\0x3f)
|
||||
},
|
||||
[C0,C1,C2]
|
||||
; { C < 0x200000 }
|
||||
-> { C0 is 0xf0\/((C>>18)/\0x07),
|
||||
C1 is 0x80\/((C>>12)/\0x3f),
|
||||
C2 is 0x80\/((C>>6)/\0x3f),
|
||||
C3 is 0x80\/(C/\0x3f)
|
||||
},
|
||||
[C0,C1,C2,C3]
|
||||
; { C < 0x4000000 }
|
||||
-> { C0 is 0xf8\/((C>>24)/\0x03),
|
||||
C1 is 0x80\/((C>>18)/\0x3f),
|
||||
C2 is 0x80\/((C>>12)/\0x3f),
|
||||
C3 is 0x80\/((C>>6)/\0x3f),
|
||||
C4 is 0x80\/(C/\0x3f)
|
||||
},
|
||||
[C0,C1,C2,C3,C4]
|
||||
; { C < 0x80000000 }
|
||||
-> { C0 is 0xfc\/((C>>30)/\0x01),
|
||||
C1 is 0x80\/((C>>24)/\0x3f),
|
||||
C2 is 0x80\/((C>>18)/\0x3f),
|
||||
C3 is 0x80\/((C>>12)/\0x3f),
|
||||
C4 is 0x80\/((C>>6)/\0x3f),
|
||||
C5 is 0x80\/(C/\0x3f)
|
||||
},
|
||||
[C0,C1,C2,C3,C4,C5]
|
||||
).
|
||||
|
||||
utf8_cont(Val, Shift) -->
|
||||
[C],
|
||||
{ C/\0xc0 =:= 0x80,
|
||||
Val is (C/\0x3f)<<Shift
|
||||
}.
|
||||
252
swi/library/win_menu.pl
Executable file
252
swi/library/win_menu.pl
Executable file
@@ -0,0 +1,252 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: jan@swi.psy.uva.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2002, 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 Lesser General Public
|
||||
License along with this library; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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(win_menu,
|
||||
[ init_win_menus/0
|
||||
]).
|
||||
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(www_browser)).
|
||||
|
||||
:- set_prolog_flag(generate_debug_info, false).
|
||||
:- op(200, fy, @).
|
||||
:- op(990, xfx, :=).
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
This library sets up the menu of PLWIN.EXE. It is called from the system
|
||||
initialisation file plwin.rc, predicate gui_setup_/0.
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
|
||||
menu('&File',
|
||||
[ '&Consult ...' = win_menu:action(user:compile(+file(open,
|
||||
'Load file into Prolog'))),
|
||||
% '&Edit ...' = win_menu:action(user:edit(+file(open,
|
||||
% 'Edit existing file'))),
|
||||
% '&New ...' = win_menu:action(edit_new(+file(save,
|
||||
% 'Create new Prolog source'))),
|
||||
--,
|
||||
'&Reload modified files' = user:make,
|
||||
% --,
|
||||
% '&Navigator ...' = prolog_ide(open_navigator),
|
||||
--
|
||||
],
|
||||
[ before_item('&Exit')
|
||||
]).
|
||||
/*
|
||||
menu('&Settings',
|
||||
[ --,
|
||||
'&User init file ...' = prolog_edit_preferences(prolog)
|
||||
% '&GUI preferences ...' = prolog_edit_preferences(xpce)
|
||||
],
|
||||
[]).
|
||||
menu('&Debug',
|
||||
[ %'&Trace' = trace,
|
||||
%'&Debug mode' = debug,
|
||||
%'&No debug mode' = nodebug,
|
||||
'&Edit spy points ...' = user:prolog_ide(open_debug_status),
|
||||
'&Edit exceptions ...' = user:prolog_ide(open_exceptions(@on)),
|
||||
'&Threads monitor ...' = user:prolog_ide(thread_monitor),
|
||||
'Debug &messages ...' = user:prolog_ide(debug_monitor),
|
||||
'Cross &referencer ...'= user:prolog_ide(xref),
|
||||
--,
|
||||
'&Graphical debugger' = user:guitracer
|
||||
],
|
||||
[ before_menu(-)
|
||||
]).
|
||||
*/
|
||||
menu('&Help',
|
||||
[ '&About ...' = about,
|
||||
'&Help ...' = help,
|
||||
'YAP &Manual (on www) ...' = win_menu:www_open(yap_man),
|
||||
--,
|
||||
'YAP &WWW home (on www) ...' = win_menu:www_open(yap),
|
||||
'YAP &GIT (on www) ...' = win_menu:www_open(yap_git),
|
||||
% 'YAP Mailing &List (on www) ...' = win_menu:www_open(swipl_mail),
|
||||
'YAP &Download (on www) ...' = win_menu:www_open(yap_download),
|
||||
--,
|
||||
% '&XPCE (GUI) Manual ...' = manpce,
|
||||
% --,
|
||||
'Submit &Bug report (on www) ...' = win_menu:www_open(yap_bugs)
|
||||
],
|
||||
[ before_menu(-)
|
||||
]).
|
||||
|
||||
|
||||
init_win_menus :-
|
||||
( menu(Menu, Items, Options),
|
||||
( memberchk(before_item(Before), Options)
|
||||
-> true
|
||||
; Before = (-)
|
||||
),
|
||||
( memberchk(before_menu(BM), Options)
|
||||
-> system:win_insert_menu(Menu, BM)
|
||||
; true
|
||||
),
|
||||
( member(Item, Items),
|
||||
( Item = (Label = Action)
|
||||
-> true
|
||||
; Item == --
|
||||
-> Label = --
|
||||
),
|
||||
win_insert_menu_item(Menu, Label, Before, Action),
|
||||
fail
|
||||
; true
|
||||
),
|
||||
fail
|
||||
; insert_associated_file
|
||||
).
|
||||
|
||||
insert_associated_file :-
|
||||
current_prolog_flag(associated_file, File),
|
||||
file_base_name(File, Base),
|
||||
atom_concat('Edit &', Base, Label),
|
||||
win_insert_menu_item('&File', Label, '&New ...', edit(file(File))).
|
||||
insert_associated_file.
|
||||
|
||||
|
||||
:- initialization
|
||||
( win_has_menu
|
||||
-> init_win_menus
|
||||
; true
|
||||
).
|
||||
|
||||
/*******************************
|
||||
* ACTIONS *
|
||||
*******************************/
|
||||
|
||||
edit_new(File) :-
|
||||
call(edit(file(File))). % avoid autoloading
|
||||
|
||||
www_open(Id) :-
|
||||
Spec =.. [Id, '.'],
|
||||
call(expand_url_path(Spec, URL)),
|
||||
print_message(informational, opening_url(URL)),
|
||||
call(www_open_url(URL)), % avoid autoloading
|
||||
print_message(informational, opened_url(URL)).
|
||||
|
||||
html_open(Spec) :-
|
||||
absolute_file_name(Spec, [access(read)], Path),
|
||||
call(win_shell(open, Path)).
|
||||
|
||||
about :-
|
||||
print_message(informational, about).
|
||||
|
||||
|
||||
/*******************************
|
||||
* HANDLE CALLBACK *
|
||||
*******************************/
|
||||
|
||||
action(Action) :-
|
||||
strip_module(Action, Module, Plain),
|
||||
Plain =.. [Name|Args],
|
||||
gather_args(Args, Values),
|
||||
Goal =.. [Name|Values],
|
||||
Module:Goal.
|
||||
|
||||
gather_args([], []).
|
||||
gather_args([+H0|T0], [H|T]) :- !,
|
||||
gather_arg(H0, H),
|
||||
gather_args(T0, T).
|
||||
gather_args([H|T0], [H|T]) :-
|
||||
gather_args(T0, T).
|
||||
|
||||
gather_arg(file(Mode, Title), File) :-
|
||||
findall(tuple('Prolog Source', Pattern),
|
||||
prolog_file_pattern(Pattern),
|
||||
Tuples),
|
||||
append(Tuples, [tuple('All files', '*.*')], AllTuples),
|
||||
Filter =.. [chain|AllTuples],
|
||||
current_prolog_flag(hwnd, HWND),
|
||||
working_directory(CWD, CWD),
|
||||
% filter(AllTuples, Filter),
|
||||
win_open_file_name(HWND, CWD, File).
|
||||
%% call(get(@display, win_file_name, % avoid autoloading
|
||||
%% Mode, Filter, Title,
|
||||
%% directory := CWD,
|
||||
%% owner := HWND,
|
||||
%% File)).
|
||||
|
||||
prolog_file_pattern(Pattern) :-
|
||||
user:prolog_file_type(Ext, prolog),
|
||||
atom_concat('*.', Ext, Pattern).
|
||||
|
||||
|
||||
|
||||
|
||||
/*******************************
|
||||
* APPLICATION *
|
||||
*******************************/
|
||||
|
||||
%% init_win_app
|
||||
%
|
||||
% If Prolog is started using --win_app, try to change directory
|
||||
% to <My Documents>\Prolog.
|
||||
|
||||
init_win_app :-
|
||||
current_prolog_flag(associated_file, _), !.
|
||||
init_win_app :-
|
||||
current_prolog_flag(argv, Argv),
|
||||
append(Pre, ['--win_app'|_Post], Argv),
|
||||
\+ member(--, Pre), !,
|
||||
catch(my_prolog, E, print_message(warning, E)).
|
||||
init_win_app.
|
||||
|
||||
my_prolog :-
|
||||
win_folder(personal, MyDocs),
|
||||
atom_concat(MyDocs, '/Prolog', PrologDir),
|
||||
( ensure_dir(PrologDir)
|
||||
-> working_directory(_, PrologDir)
|
||||
; working_directory(_, MyDocs)
|
||||
).
|
||||
|
||||
|
||||
ensure_dir(Dir) :-
|
||||
exists_directory(Dir), !.
|
||||
ensure_dir(Dir) :-
|
||||
catch(make_directory(Dir), E, (print_message(warning, E), fail)).
|
||||
|
||||
|
||||
:- initialization
|
||||
init_win_app.
|
||||
|
||||
|
||||
/*******************************
|
||||
* MESSAGES *
|
||||
*******************************/
|
||||
|
||||
:- multifile
|
||||
prolog:message/3.
|
||||
|
||||
prolog:message(opening_url(Url)) -->
|
||||
[ 'Opening ~w ... '-[Url], flush ].
|
||||
prolog:message(opened_url(_Url)) -->
|
||||
[ at_same_line, 'ok' ].
|
||||
225
swi/library/www_browser.pl
Executable file
225
swi/library/www_browser.pl
Executable file
@@ -0,0 +1,225 @@
|
||||
/* $Id$
|
||||
|
||||
Part of SWI-Prolog
|
||||
|
||||
Author: Jan Wielemaker
|
||||
E-mail: J.Wielemaker@cs.vu.nl
|
||||
WWW: http://www.swi-prolog.org
|
||||
Copyright (C): 1985-2011, University of Amsterdam
|
||||
VU University 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 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.
|
||||
*/
|
||||
|
||||
:- module(www_browser,
|
||||
[ www_open_url/1, % +UrlOrSpec
|
||||
expand_url_path/2 % +Spec, -URL
|
||||
]).
|
||||
:- use_module(library(lists)).
|
||||
:- use_module(library(readutil)).
|
||||
|
||||
:- multifile
|
||||
known_browser/2.
|
||||
|
||||
%% www_open_url(+Url)
|
||||
%
|
||||
% Open URL in running version of the users' browser or start a new
|
||||
% browser. This predicate tries the following steps:
|
||||
%
|
||||
% 1. If a prolog flag (see set_prolog_flag/2) =browser= is set
|
||||
% or the environment =BROWSER= and this is the name of a known
|
||||
% executable, use this. This uses www_open_url/2.
|
||||
%
|
||||
% 2. On Windows, use win_shell(open, URL)
|
||||
%
|
||||
% 3. Find a generic `open' comment. Candidates are =open=,
|
||||
% =|gnome-open|=, =kfmclient=.
|
||||
%
|
||||
% 4. Try to find a known browser.
|
||||
%
|
||||
% @tbd Figure out the right tool in step 3 as it is not
|
||||
% uncommon that multiple are installed.
|
||||
|
||||
www_open_url(Spec) :- % user configured
|
||||
( current_prolog_flag(browser, Browser)
|
||||
; getenv('BROWSER', Browser)
|
||||
),
|
||||
has_command(Browser), !,
|
||||
expand_url_path(Spec, URL),
|
||||
www_open_url(Browser, URL).
|
||||
:- if(current_predicate(win_shell/2)).
|
||||
www_open_url(Spec) :- % Windows shell
|
||||
expand_url_path(Spec, URL),
|
||||
win_shell(open, URL).
|
||||
:- endif.
|
||||
www_open_url(Spec) :- % Unix `open document'
|
||||
open_command(Open),
|
||||
has_command(Open), !,
|
||||
expand_url_path(Spec, URL),
|
||||
format(string(Cmd), '~w "~w"', [Open, URL]),
|
||||
shell(Cmd).
|
||||
www_open_url(Spec) :- % KDE client
|
||||
has_command(kfmclient), !,
|
||||
expand_url_path(Spec, URL),
|
||||
format(string(Cmd), 'kfmclient openURL "~w"', [URL]),
|
||||
shell(Cmd).
|
||||
www_open_url(Spec) :- % something we know
|
||||
known_browser(Browser, _),
|
||||
has_command(Browser), !,
|
||||
expand_url_path(Spec, URL),
|
||||
www_open_url(Browser, URL).
|
||||
|
||||
open_command('gnome-open').
|
||||
open_command(open).
|
||||
|
||||
%% www_open_url(+Browser, +URL) is det.
|
||||
%
|
||||
% Open a page using a browser. Preferably we use an existing
|
||||
% browser to to the job. Currently only supports browsers with a
|
||||
% netscape compatible remote interface.
|
||||
%
|
||||
% @see http://www.mozilla.org/unix/remote.html
|
||||
|
||||
www_open_url(Browser, URL) :-
|
||||
compatible(Browser, netscape),
|
||||
netscape_remote(Browser, 'ping()', []), !,
|
||||
netscape_remote(Browser, 'openURL(~w,new-window)', [URL]).
|
||||
www_open_url(Browser, URL) :-
|
||||
format(string(Cmd), '"~w" "~w" &', [Browser, URL]),
|
||||
shell(Cmd).
|
||||
|
||||
%% netscape_remote(+Browser, +Format, +Args) is semidet.
|
||||
%
|
||||
% Execute netscape remote command using =|-remote|=. Create the
|
||||
% remote command using format/3 from Format and Args.
|
||||
%
|
||||
% @bug At least firefox gives always 0 exit code on -remote,
|
||||
% so we must check the error message. Grrrr.
|
||||
|
||||
netscape_remote(Browser, Fmt, Args) :-
|
||||
format(string(RCmd), Fmt, Args),
|
||||
format(string(Cmd), '"~w" -remote "~w" 2>&1', [Browser, RCmd]),
|
||||
open(pipe(Cmd), read, In),
|
||||
call_cleanup(read_stream_to_codes(In, Codes),
|
||||
close(In)),
|
||||
( append("Error:", _, Codes)
|
||||
-> !, fail
|
||||
; true
|
||||
).
|
||||
|
||||
|
||||
compatible(Browser, With) :-
|
||||
file_base_name(Browser, Base),
|
||||
known_browser(Base, With).
|
||||
|
||||
%% known_browser(+FileBaseName, -Compatible)
|
||||
%
|
||||
% True if browser FileBaseName has a remote protocol compatible to
|
||||
% Compatible.
|
||||
|
||||
known_browser(firefox, netscape).
|
||||
known_browser(mozilla, netscape).
|
||||
known_browser(netscape, netscape).
|
||||
known_browser(konqueror, -).
|
||||
known_browser(opera, -).
|
||||
|
||||
|
||||
%% has_command(+Command)
|
||||
%
|
||||
% Succeeds if Command is in $PATH. Works for Unix systems. For
|
||||
% Windows we have to test for executable extensions.
|
||||
|
||||
:- dynamic
|
||||
command_cache/2.
|
||||
:- volatile
|
||||
command_cache/2.
|
||||
|
||||
has_command(Command) :-
|
||||
command_cache(Command, Path), !,
|
||||
Path \== (-).
|
||||
has_command(Command) :-
|
||||
( getenv('PATH', Path),
|
||||
( current_prolog_flag(windows, true)
|
||||
-> Sep = (;)
|
||||
; Sep = (:)
|
||||
),
|
||||
atomic_list_concat(Parts, Sep, Path),
|
||||
member(Part, Parts),
|
||||
prolog_to_os_filename(PlPart, Part),
|
||||
atomic_list_concat([PlPart, Command], /, Exe),
|
||||
access_file(Exe, execute)
|
||||
-> assert(command_cache(Command, Exe))
|
||||
; assert(command_cache(Command, -)),
|
||||
fail
|
||||
).
|
||||
|
||||
|
||||
/*******************************
|
||||
* NET PATHS *
|
||||
*******************************/
|
||||
|
||||
%% url_path(+Alias, -Expansion) is nondet.
|
||||
%
|
||||
% Define URL path aliases. This multifile predicate is defined in
|
||||
% module =user=. Expansion is either a URL, or a term Alias(Sub).
|
||||
|
||||
:- multifile
|
||||
user:url_path/2.
|
||||
|
||||
user:url_path(swipl, 'http://www.swi-prolog.org').
|
||||
|
||||
user:url_path(swipl_faq, swipl('FAQ')).
|
||||
user:url_path(swipl_man, swipl('pldoc/index.html')).
|
||||
user:url_path(swipl_mail, swipl('Mailinglist.html')).
|
||||
user:url_path(swipl_download, swipl('Download.html')).
|
||||
user:url_path(swipl_bugs, swipl('bugzilla')).
|
||||
user:url_path(swipl_quick, swipl('man/quickstart.html')).
|
||||
|
||||
user:url_path(yap, 'http://www.dcc.fc.up.pt/~vsc/Yap').
|
||||
|
||||
user:url_path(yap_download, 'http://www.dcc.fc.up.pt/~vsc/Yap/downloads.html').
|
||||
user:url_path(yap_man, yap('documentation.html')).
|
||||
user:url_path(yap_bugs, 'http://sourceforge.net/tracker/?group_id=24437&atid=381483').
|
||||
user:url_path(yap_git, 'http://yap.git.sourceforge.net/git/gitweb-index.cgi').
|
||||
|
||||
|
||||
|
||||
%% expand_url_path(+Spec, -URL)
|
||||
%
|
||||
% Expand URL specifications similar to absolute_file_name/3. The
|
||||
% predicate url_path/2 plays the role of file_search_path/2.
|
||||
|
||||
expand_url_path(URL, URL) :-
|
||||
atomic(URL), !. % Allow atom and string
|
||||
expand_url_path(Spec, URL) :-
|
||||
Spec =.. [Path, Local],
|
||||
( user:url_path(Path, Spec2)
|
||||
-> expand_url_path(Spec2, URL0),
|
||||
( Local == '.'
|
||||
-> URL = URL0
|
||||
; sub_atom(Local, 0, _, _, #)
|
||||
-> atom_concat(URL0, Local, URL)
|
||||
; atomic_list_concat([URL0, Local], /, URL)
|
||||
)
|
||||
; throw(error(existence_error(url_path, Path), expand_url_path/2))
|
||||
).
|
||||
|
||||
Reference in New Issue
Block a user