/* Part of SWI-Prolog Author: Jan Wielemaker E-mail: J.Wielemaker@vu.nl WWW: http://www.swi-prolog.org Copyright (C): 1985-2013, 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 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('$dcg', [ dcg_translate_rule/2, % +Rule, -Clause dcg_translate_rule/4, % +Rule, ?Pos0, -Clause, -Pos phrase/2, phrase/3 ]). /******************************** * GRAMMAR RULES * *********************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - The DCG compiler. The original code was copied from C-Prolog and written by Fernando Pereira, EDCAAD, Edinburgh, 1984. Since then many people have modified and extended this code. It's a nice mess now and it should be redone from scratch. I won't be doing this before I get a complete spec explaining all an implementor needs to know about DCG. I'm a too basic user of this facility myself (though I learned some tricks from people reporting bugs :-) The original version contained '$t_tidy'/2 to convert ((a,b), c) to (a,(b,c)), but as the SWI-Prolog compiler doesn't really care (the resulting code is simply the same), I've removed that. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ dcg_translate_rule(Rule, Clause) :- dcg_translate_rule(Rule, _, Clause, _). dcg_translate_rule(((LP,MNT)-->RP), Pos0, (H:-B), Pos) :- !, f2_pos(Pos0, PosH0, PosRP0, Pos, PosH, PosRP), f2_pos(PosH0, PosLP0, PosMNT0, PosH, PosLP, PosMNT), '$set_source_module'(M, M), Qualify = q(M,M,_), dcg_extend(LP, PosLP0, S0, SR, H, PosLP), dcg_body(RP, PosRP0, Qualify, S0, S1, B0, PosRP), dcg_body(MNT, PosMNT0, Qualify, SR, S1, B1, PosMNT), dcg_optimise((B0,B1),B2,S0), dcg_optimise(B2,B,SR). dcg_translate_rule((LP-->RP), Pos0, (H:-B), Pos) :- f2_pos(Pos0, PosLP0, PosRP0, Pos, PosLP, PosRP), dcg_extend(LP, PosLP0, S0, S, H, PosLP), '$set_source_module'(M, M), Qualify = q(M,M,_), dcg_body(RP, PosRP0, Qualify, S0, S, B0, PosRP), dcg_optimise(B0,B,S0). %% dcg_optimise(+BodyIn, -Body, +S0) is det. % % Performs the following translations: % % - a(H,T) :- H = [a,b|T], b(T), ... into % a([a,b|T0]) :- b(T0, T). % - a(H,T) :- H = [a,b|T] into % a([a,b|T0]) % % @arg S0 is the initial input list of the rule. dcg_optimise((S00=X,B), B, S0) :- S00 == S0, !, S0 = X. dcg_optimise(S00=X, B, S0) :- S00 == S0, !, S0 = X, B = true. dcg_optimise(B, B, _). %% dcg_body(:DCG, ?Pos0, +Qualify, ?List, ?Tail, -Goal, -Pos) is det. % % Translate DCG body term. dcg_body(Var, P0, Q, S, SR, phrase(QVar, S, SR), P) :- var(Var), !, qualify(Q, Var, P0, QVar, P). dcg_body(M:X, Pos0, q(_,C,_), S, SR, Ct, Pos) :- !, f2_pos(Pos0, _, XP0, _, _, _), dcg_body(X, XP0, q(M,C,Pos0), S, SR, Ct, Pos). dcg_body([], P0, _, S, SR, S=SR, P) :- !, % Terminals dcg_terminal_pos(P0, P). dcg_body(List, P0, _, S, SR, C, P) :- ( List = [_|_] -> !, ( is_list(List) -> '$append'(List, SR, OL), % open the list C = (S = OL) ; '$skip_list'(_, List, Tail), var(Tail) -> C = '$append'(List, SR, S) % TBD: Can be optimized ; '$type_error'(list_or_partial_list, List) ) ; string(List) % double_quotes = string -> !, string_codes(List, Codes), '$append'(Codes, SR, OL), C = (S = OL) ), dcg_terminal_pos(P0, P). dcg_body(!, P0, _, S, SR, (!, SR = S), P) :- !, dcg_cut_pos(P0, P). dcg_body({}, P, _, S, S, true, P) :- !. dcg_body({T}, P0, Q, S, SR, (QT, SR = S), P) :- !, dcg_bt_pos(P0, P1), qualify(Q, T, P1, QT, P). dcg_body((T,R), P0, Q, S, SR, (Tt, Rt), P) :- !, f2_pos(P0, PA0, PB0, P, PA, PB), dcg_body(T, PA0, Q, S, SR1, Tt, PA), dcg_body(R, PB0, Q, SR1, SR, Rt, PB). dcg_body((T;R), P0, Q, S, SR, (Tt;Rt), P) :- !, f2_pos(P0, PA0, PB0, P, PA, PB), dcg_body(T, PA0, Q, S, S1, T1, PA), or_delay_bind(S, SR, S1, T1, Tt), dcg_body(R, PB0, Q, S, S2, R1, PB), or_delay_bind(S, SR, S2, R1, Rt). dcg_body((T|R), P0, Q, S, SR, (Tt;Rt), P) :- !, f2_pos(P0, PA0, PB0, P, PA, PB), dcg_body(T, PA0, Q, S, S1, T1, PA), or_delay_bind(S, SR, S1, T1, Tt), dcg_body(R, PB0, Q, S, S2, R1, PB), or_delay_bind(S, SR, S2, R1, Rt). dcg_body((C->T), P0, Q, S, SR, (Ct->Tt), P) :- !, f2_pos(P0, PA0, PB0, P, PA, PB), dcg_body(C, PA0, Q, S, SR1, Ct, PA), dcg_body(T, PB0, Q, SR1, SR, Tt, PB). dcg_body((C*->T), P0, Q, S, SR, (Ct*->Tt), P) :- !, f2_pos(P0, PA0, PB0, P, PA, PB), dcg_body(C, PA0, Q, S, SR1, Ct, PA), dcg_body(T, PB0, Q, SR1, SR, Tt, PB). dcg_body((\+ C), P0, Q, S, SR, (\+ Ct, SR = S), P) :- !, f1_pos(P0, PA0, P, PA), dcg_body(C, PA0, Q, S, _, Ct, PA). dcg_body(T, P0, Q, S, SR, QTt, P) :- dcg_extend(T, P0, S, SR, Tt, P1), qualify(Q, Tt, P1, QTt, P). or_delay_bind(S, SR, S1, T, (T, SR=S)) :- S1 == S, !. or_delay_bind(_S, SR, SR, T, T). %% qualify(+QualifyInfo, +Goal, +Pos0, -QGoal, -Pos) is det. % % @arg QualifyInfo is a term q(Module,Context,Pos), where Module % is the module in which Goal must be called and Context is the % current source module. qualify(q(M,C,_), X0, Pos0, X, Pos) :- M == C, !, X = X0, Pos = Pos0. qualify(q(M,_,MP), X, Pos0, M:X, Pos) :- dcg_qualify_pos(Pos0, MP, Pos). %% dcg_extend(+Head, +Extra1, +Extra2, -NewHead) % % Extend Head with two more arguments (on behalf DCG compilation). % The solution below is one option. Using =.. and append is the % alternative. In the current version (5.3.2), the =.. is actually % slightly faster, but it creates less garbage. :- dynamic dcg_extend_cache/4. :- volatile dcg_extend_cache/4. dcg_no_extend([]). dcg_no_extend([_|_]). dcg_no_extend({_}). dcg_no_extend({}). dcg_no_extend(!). dcg_no_extend((\+_)). dcg_no_extend((_,_)). dcg_no_extend((_;_)). dcg_no_extend((_|_)). dcg_no_extend((_->_)). dcg_no_extend((_*->_)). dcg_no_extend((_-->_)). %% dcg_extend(:Rule, ?Pos0, ?List, ?Tail, -Head, -Pos) is det. % % Extend a non-terminal with the DCG difference list List\Tail. % The position term is extended as well to reflect the layout of % the created term. The additional variables are located at the % end of the Rule. dcg_extend(V, _, _, _, _, _) :- var(V), !, throw(error(instantiation_error,_)). dcg_extend(M:OldT, Pos0, A1, A2, M:NewT, Pos) :- !, f2_pos(Pos0, MPos, P0, Pos, MPos, P), dcg_extend(OldT, P0, A1, A2, NewT, P). dcg_extend(OldT, P0, A1, A2, NewT, P) :- dcg_extend_cache(OldT, A1, A2, NewT), !, extend_pos(P0, P). dcg_extend(OldT, P0, A1, A2, NewT, P) :- ( callable(OldT) -> true ; throw(error(type_error(callable,OldT),_)) ), ( dcg_no_extend(OldT) -> throw(error(permission_error(define,dcg_nonterminal,OldT),_)) ; true ), functor(OldT, Name, Arity), functor(CopT, Name, Arity), NewArity is Arity+2, functor(NewT, Name, NewArity), copy_args(1, Arity, CopT, NewT), A1Pos is Arity+1, A2Pos is Arity+2, arg(A1Pos, NewT, A1C), arg(A2Pos, NewT, A2C), assert(dcg_extend_cache(CopT, A1C, A2C, NewT)), OldT = CopT, A1C = A1, A2C = A2, extend_pos(P0, P). copy_args(I, Arity, Old, New) :- I =< Arity, !, arg(I, Old, A), arg(I, New, A), I2 is I + 1, copy_args(I2, Arity, Old, New). copy_args(_, _, _, _). /******************************* * POSITION LOGIC * *******************************/ extend_pos(Var, Var) :- var(Var), !. extend_pos(term_position(F,T,FF,FT,Args0), term_position(F,T,FF,FT,Args)) :- !, '$append'(Args0, [T-T,T-T], Args). extend_pos(F-T, term_position(F,T,F,T,[T-T,T-T])) :- !. extend_pos(Pos, Pos) :- print_message(warning, term_position(Pos)). f2_pos(Pos0, A0, B0, Pos, A, B) :- '$expand':f2_pos(Pos0, A0, B0, Pos, A, B). f1_pos(Pos0, A0, Pos, A) :- '$expand':f1_pos(Pos0, A0, Pos, A). %% dcg_bt_pos(?BraceTermPos, -Pos) is det. % % Position transformation for mapping of {G} to (G, S=SR). dcg_bt_pos(Var, Var) :- var(Var), !. dcg_bt_pos(brace_term_position(F,T,P0), term_position(F,T,F,F, [ P0, term_position(T,T,T,T,_) ])) :- !. dcg_bt_pos(Pos, _) :- expected_layout(brace_term, Pos). dcg_cut_pos(Var, Var) :- var(Var), !. dcg_cut_pos(F-T, term_position(F,T,F,T, [ F-T, term_position(T,T,T,T,_) ])). dcg_cut_pos(Pos, _) :- expected_layout(atomic, Pos). %% dcg_terminal_pos(+ListPos, -TermPos) dcg_terminal_pos(Pos, _) :- var(Pos), !. dcg_terminal_pos(list_position(F,T,_Elms,_Tail), term_position(F,T,_,_,_)). dcg_terminal_pos(F-T, term_position(F,T,_,_,_)). dcg_terminal_pos(Pos, _) :- expected_layout(terminal, Pos). %% dcg_qualify_pos(?TermPos0, ?ModuleCreatingPos, -TermPos) dcg_qualify_pos(Var, _, _) :- var(Var), !. dcg_qualify_pos(Pos, term_position(F,T,FF,FT,[MP,_]), term_position(F,T,FF,FT,[MP,Pos])) :- !. dcg_qualify_pos(_, Pos, _) :- expected_layout(f2, Pos). expected_layout(Expected, Found) :- '$expand':expected_layout(Expected, Found). /******************************* * PHRASE INTERFACE * *******************************/ %% phrase(:RuleSet, ?List). %% phrase(:RuleSet, ?List, ?Rest). % % Interface to DCGs :- meta_predicate phrase(//, ?), phrase(//, ?, ?). :- noprofile((phrase/2, phrase/3)). phrase(RuleSet, Input) :- phrase(RuleSet, Input, []). phrase(RuleSet, Input, Rest) :- ( strip_module(RuleSet, M, Plain), nonvar(Plain), dcg_special(Plain) -> dcg_body(Plain, _, q(M,M,_), S0, S, Body, _), Input = S0, Rest = S, call(M:Body) ; call(RuleSet, Input, Rest) ). dcg_special(S) :- string(S). dcg_special((_,_)). dcg_special((_;_)). dcg_special((_|_)). dcg_special((_->_)). dcg_special(!). dcg_special({_}). dcg_special([]). dcg_special([_|_]). dcg_special(\+_).