This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/library/expand_macros.yap
2009-04-26 10:56:19 -05:00

491 lines
15 KiB
Prolog

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% preprocessing for meta-calls
%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- use_module(library(lists), [append/3]).
:- use_module(library(charsio), [format_to_chars/3, read_from_chars/2]).
:- use_module(library(error), [must_be/2]).
:- use_module(library(occurs), [sub_term/2]).
:- multifile user:goal_expansion/3.
user:goal_expansion(checklist(Meta, List), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(checklist, 2, Proto, GoalName),
append(MetaVars, [List], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[]], Base),
append_args(HeadPrefix, [[In|Ins]], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(maplist(Meta, List), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(maplist, 2, Proto, GoalName),
append(MetaVars, [List], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[]], Base),
append_args(HeadPrefix, [[In|Ins]], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(maplist(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(maplist, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], [Out|Outs]], RecursionHead),
append_args(Pred, [In, Out], Apply),
append_args(HeadPrefix, [Ins, Outs], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(maplist(Meta, L1, L2, L3), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(maplist, 4, Proto, GoalName),
append(MetaVars, [L1, L2, L3], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], [], []], Base),
append_args(HeadPrefix, [[A1|A1s], [A2|A2s], [A3|A3s]], RecursionHead),
append_args(Pred, [A1, A2, A3], Apply),
append_args(HeadPrefix, [A1s, A2s, A3s], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(maplist(Meta, L1, L2, L3, L4), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(maplist, 5, Proto, GoalName),
append(MetaVars, [L1, L2, L3, L4], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], [], [], []], Base),
append_args(HeadPrefix, [[A1|A1s], [A2|A2s], [A3|A3s], [A4|A4s]], RecursionHead),
append_args(Pred, [A1, A2, A3, A4], Apply),
append_args(HeadPrefix, [A1s, A2s, A3s, A4s], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(selectlist(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(selectlist, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins, NOuts], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs = [In|NOuts]; Outs = NOuts),
RecursiveCall)
], Module).
% same as selectlist
user:goal_expansion(include(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(include, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins, NOuts], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs = [In|NOuts]; Outs = NOuts),
RecursiveCall)
], Module).
user:goal_expansion(exclude(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(exclude, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins, NOuts], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs = [In|NOuts]; Outs = NOuts),
RecursiveCall)
], Module).
user:goal_expansion(partition(Meta, ListIn, List1, List2), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(partition, 4, Proto, GoalName),
append(MetaVars, [ListIn, List1, List2], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], [], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs1, Outs2], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Ins, NOuts1, NOuts2], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs1 = [In|NOuts1], Outs2 = NOuts2; Outs1 = NOuts1, Outs2 = [In|NOuts2]),
RecursiveCall)
], Module).
user:goal_expansion(partition(Meta, ListIn, List1, List2, List3), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(partition2, 5, Proto, GoalName),
append(MetaVars, [ListIn, List1, List2, List3], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], [], [], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs1, Outs2, Outs3], RecursionHead),
append_args(Pred, [In,Diff], Apply),
append_args(HeadPrefix, [Ins, NOuts1, NOuts2, NOuts3], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
Apply,
(Diff == (<) ->
Outs1 = [In|NOuts1],
Outs2 = NOuts2,
Outs3 = NOuts3
;
Diff == (=) ->
Outs1 = NOuts1,
Outs2 = [In|NOuts2],
Outs3 = NOuts3
;
Diff == (>) ->
Outs1 = NOuts1,
Outs2 = NOuts2,
Outs3 = [In|NOuts3]
;
error:must_be(oneof([<,=,>]), Diff)
),
RecursiveCall)
], Module).
user:goal_expansion(convlist(Meta, ListIn, ListOut), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(convlist, 3, Proto, GoalName),
append(MetaVars, [ListIn, ListOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], Outs], RecursionHead),
append_args(Pred, [In, Out], Apply),
append_args(HeadPrefix, [Ins, NOuts], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
(Apply -> Outs = [Out|NOuts]; Outs = NOuts),
RecursiveCall)
], Module).
user:goal_expansion(sumlist(Meta, List, AccIn, AccOut), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(sumlist, 4, Proto, GoalName),
append(MetaVars, [List, AccIn, AccOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], Acc, Acc], Base),
append_args(HeadPrefix, [[In|Ins], Acc1, Acc2], RecursionHead),
append_args(Pred, [In, Acc1, Acc3], Apply),
append_args(HeadPrefix, [Ins, Acc3, Acc2], RecursiveCall),
compile_aux([
Base,
(RecursionHead :- Apply, RecursiveCall)
], Module).
user:goal_expansion(mapargs(Meta, In, Out), _Module, NewGoal) :-
goal_expansion_allowed,
( var(Out)
->
NewGoal = (
In =.. [F|InArgs],
maplist(Meta, InArgs, OutArgs),
Out =.. [F|OutArgs]
)
;
NewGoal = (
Out =.. [F|OutArgs],
maplist(Meta, InArgs, OutArgs),
In =.. [F|InArgs]
)
).
user:goal_expansion(sumargs(Meta, Term, AccIn, AccOut), _Module, Goal) :-
goal_expansion_allowed,
Goal = (
Term =.. [_|TermArgs],
sumlist(Meta, TermArgs, AccIn, AccOut)
).
user:goal_expansion(mapnodes(Meta, InTerm, OutTerm), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(mapnodes, 3, Proto, GoalName),
append(MetaVars, [[InTerm], [OutTerm]], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], []], Base),
append_args(HeadPrefix, [[In|Ins], [Out|Outs]], RecursionHead),
append_args(Pred, [In, Temp], Apply),
append_args(HeadPrefix, [InArgs, OutArgs], SubRecursiveCall),
append_args(HeadPrefix, [Ins, Outs], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
Apply,
(compound(Temp)
->
Temp =.. [F|InArgs],
SubRecursiveCall,
Out =.. [F|OutArgs]
;
Out = Temp
),
RecursiveCall)
], Module).
user:goal_expansion(checknodes(Meta, Term), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(checknodes, 2, Proto, GoalName),
append(MetaVars, [[Term]], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[]], Base),
append_args(HeadPrefix, [[In|Ins]], RecursionHead),
append_args(Pred, [In], Apply),
append_args(HeadPrefix, [Args], SubRecursiveCall),
append_args(HeadPrefix, [Ins], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
Apply,
(compound(In)
->
In =.. [_|Args],SubRecursiveCall
;
true
),
RecursiveCall)
], Module).
user:goal_expansion(sumnodes(Meta, Term, AccIn, AccOut), Mod, Goal) :-
goal_expansion_allowed,
callable(Meta),
!,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Mod, Module),
% the new goal
pred_name(sumnodes, 4, Proto, GoalName),
append(MetaVars, [[Term], AccIn, AccOut], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
append_args(HeadPrefix, [[], Acc, Acc], Base),
append_args(HeadPrefix, [[In|Ins], Acc1, Acc2], RecursionHead),
append_args(Pred, [In, Acc1, Acc3], Apply),
append_args(HeadPrefix, [Args, Acc3, Acc4], SubRecursiveCall),
append_args(HeadPrefix, [Ins, Acc4, Acc2], RecursiveCall),
compile_aux([
Base,
(RecursionHead :-
Apply,
(compound(In)
->
In =.. [_|Args],SubRecursiveCall
;
Acc3 = Acc4
),
RecursiveCall)
], Module).
:- unhide('$translate_rule').
% stolen from SWI-Prolog
user:goal_expansion(phrase(NT,Xs), Mod, NTXsNil) :-
user:goal_expansion(phrase(NT,Xs,[]), Mod, NTXsNil).
user:goal_expansion(phrase(NT,Xs0,Xs), _Mod, NewGoal) :-
goal_expansion_allowed,
Goal = phrase(NT,Xs0,Xs),
nonvar(NT),
catch('$translate_rule'((pseudo_nt --> NT), Rule),
error(Pat,ImplDep),
( \+ harmless_dcgexception(Pat),
throw(error(Pat,ImplDep))
)),
Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0),
Goal \== NewGoal0,
% apply translation only if we are safe
\+ contains_illegal_dcgnt(NT), !,
( var(Xsc), Xsc \== Xs0c
-> Xs = Xsc, NewGoal1 = NewGoal0
; NewGoal1 = (NewGoal0, Xsc = Xs)
),
( var(Xs0c)
-> Xs0 = Xs0c,
NewGoal = NewGoal1
; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal
).
:- hide('$translate_rule').
%%%%%%%%%%%%%%%%%%%%
% utilities
%%%%%%%%%%%%%%%%%%%%
compile_aux([Clause|Clauses], Module) :-
% compile the predicat declaration if needed
( Clause = (Head :- _)
; Clause = Head ),
!,
functor(Head, F, N),
( current_predicate(Module:F/N)
->
true
;
% format("*** Creating auxiliary predicate ~q~n", [F/N]),
% checklist(portray_clause, [Clause|Clauses]),
compile_term([Clause|Clauses], Module)
).
compile_term([], _).
compile_term([Clause|Clauses], Module) :-
assert_static(Module:Clause),
compile_term(Clauses, Module).
append_args(Term, Args, NewTerm) :-
Term =.. [Meta|OldArgs],
append(OldArgs, Args, GoalArgs),
NewTerm =.. [Meta|GoalArgs].
aux_preds(Module:Meta, MetaVars, Pred, PredVars, Proto, _, OModule) :- !,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Module, OModule).
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Module, Module) :-
Meta =.. [F|Args],
aux_args(Args, MetaVars, PredArgs, PredVars, ProtoArgs),
Pred =.. [F|PredArgs],
Proto =.. [F|ProtoArgs].
aux_args([], [], [], [], []).
aux_args([Arg|Args], MVars, [Arg|PArgs], PVars, [Arg|ProtoArgs]) :-
ground(Arg), !,
aux_args(Args, MVars, PArgs, PVars, ProtoArgs).
aux_args([Arg|Args], [Arg|MVars], [PVar|PArgs], [PVar|PVars], ['_'|ProtoArgs]) :-
aux_args(Args, MVars, PArgs, PVars, ProtoArgs).
pred_name(Macro, Arity, Proto, Name) :-
format_to_chars('\'~a(~d,~w)\'.',[Macro, Arity, Proto], Chars),
read_from_chars(Chars, Name).
harmless_dcgexception(instantiation_error). % ex: phrase(([1],x:X,[3]),L)
harmless_dcgexception(type_error(callable,_)). % ex: phrase(27,L)
%% contains_illegal_dcgnt(+Term) is semidet.
%
% True if Term contains a non-terminal we cannot deal with using
% goal-expansion. The test is too general approximation, but safe.
contains_illegal_dcgnt(NT) :-
sub_term(I, NT),
nonvar(I),
( I = ! ; I = phrase(_,_,_) ), !.
% write(contains_illegal_nt(NT)), % JW: we do not want to write
% nl.
goal_expansion_allowed :-
\+ current_prolog_flag(xref, true).