diff --git a/boot/dcg.pl b/boot/dcg.pl index 3ff2cff551..9a638210f1 100644 --- a/boot/dcg.pl +++ b/boot/dcg.pl @@ -3,7 +3,7 @@ Author: Jan Wielemaker E-mail: J.Wielemaker@vu.nl WWW: http://www.swi-prolog.org - Copyright (c) 2009-2023, University of Amsterdam + Copyright (c) 2009-2024, University of Amsterdam VU University Amsterdam SWI-Prolog Solutions b.v. All rights reserved. @@ -70,8 +70,24 @@ dcg_translate_rule(Rule, Clause) :- dcg_translate_rule(Rule, _, Clause, _). -dcg_translate_rule(((LP,MNT)-->RP), Pos0, (H:-B0,B1), Pos) :- - !, +dcg_translate_rule((LP,MNT-->RP), Pos0, Clause, Pos) => + Clause = (H:-B0,B1), + f2_pos(Pos0, PosH0, PosRP0, Pos, PosH, PosRP), + f2_pos(PosH0, PosLP0, PosMNT0, PosH, PosLP, PosMNT), + '$current_source_module'(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_translate_rule((LP-->RP), Pos0, Clause, Pos) => + Clause = (H:-B), + f2_pos(Pos0, PosLP0, PosRP0, Pos, PosLP, PosRP), + dcg_extend(LP, PosLP0, S0, S, H, PosLP), + '$current_source_module'(M), + Qualify = q(M,M,_), + dcg_body(RP, PosRP0, Qualify, S0, S, B, PosRP). +dcg_translate_rule((LP,MNT==>RP), Pos0, Clause, Pos), is_list(MNT) => + Clause = (H=>B0,B1), f2_pos(Pos0, PosH0, PosRP0, Pos, PosH, PosRP), f2_pos(PosH0, PosLP0, PosMNT0, PosH, PosLP, PosMNT), '$current_source_module'(M), @@ -79,7 +95,16 @@ 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_translate_rule((LP-->RP), Pos0, (H:-B), Pos) :- +dcg_translate_rule((LP,Grd==>RP), Pos0, Clause, Pos) => + Clause = (H,Grd=>B), + f2_pos(Pos0, PosH0, PosRP0, Pos, PosH, PosRP), + f2_pos(PosH0, PosLP0, PosGrd, PosH, PosLP, PosGrd), + dcg_extend(LP, PosLP0, S0, S, H, PosLP), + '$current_source_module'(M), + Qualify = q(M,M,_), + dcg_body(RP, PosRP0, Qualify, S0, S, B, PosRP). +dcg_translate_rule((LP==>RP), Pos0, Clause, Pos) => + Clause = (H=>B), f2_pos(Pos0, PosLP0, PosRP0, Pos, PosLP, PosRP), dcg_extend(LP, PosLP0, S0, S, H, PosLP), '$current_source_module'(M), diff --git a/boot/expand.pl b/boot/expand.pl index 1eec11a5bd..078b4c3207 100644 --- a/boot/expand.pl +++ b/boot/expand.pl @@ -192,8 +192,9 @@ ; call_term_expansion(T, Term0, Pos0, Term, Pos) ). -expand_term_2((Head --> Body), Pos0, Expanded, Pos) :- - dcg_translate_rule((Head --> Body), Pos0, Expanded0, Pos1), +expand_term_2(DCGRule, Pos0, Expanded, Pos) :- + is_dcg(DCGRule), + dcg_translate_rule(DCGRule, Pos0, Expanded0, Pos1), !, expand_bodies(Expanded0, Pos1, Expanded1, Pos), non_terminal_decl(Expanded1, Expanded). @@ -203,6 +204,10 @@ expand_bodies(Term0, Pos0, Term, Pos). expand_term_2(Term, Pos, Term, Pos). +is_dcg(_-->_) => true. +is_dcg(_==>_) => true. +is_dcg(_) => fail. + non_terminal_decl(Clause, Decl) :- \+ current_prolog_flag(xref, true), clause_head(Clause, Head), diff --git a/library/prolog_colour.pl b/library/prolog_colour.pl index fc2c7f2fde..26f4607210 100644 --- a/library/prolog_colour.pl +++ b/library/prolog_colour.pl @@ -674,6 +674,26 @@ colour_item(neck(-->), TB, FF-FT), colourise_extended_head(Head, 2, TB, HP), colourise_dcg(Body, Head, TB, BP). +colourise_term(((Head,RHC) ==> Body), TB, + term_position(F,T,FF,FT, + [ term_position(_,_,_,_,[HP,RHCP]), + BP + ])) :- + !, + extend(Head, 2, HeadEx), + colour_item(grammar_rule, TB, F-T), + colour_item(rule_condition, TB, RHCP), + colourise_body(RHC, HeadEx, TB, RHCP), + colour_item(neck(==>), TB, FF-FT), + colourise_extended_head(Head, 2, TB, HP), + colourise_dcg(Body, Head, TB, BP). +colourise_term((Head ==> Body), TB, % TBD: expansion! + term_position(F,T,FF,FT,[HP,BP])) :- + !, + colour_item(grammar_rule, TB, F-T), + colour_item(neck(==>), TB, FF-FT), + colourise_extended_head(Head, 2, TB, HP), + colourise_dcg(Body, Head, TB, BP). colourise_term(:->(Head, Body), TB, term_position(F,T,FF,FT,[HP,BP])) :- !, @@ -3209,6 +3229,8 @@ [ 'Rule' ]. syntax_message(neck(-->)) --> [ 'Grammar rule' ]. +syntax_message(neck(==>)) --> + [ 'SSU Grammar rule' ]. syntax_message(macro(String)) --> [ 'Macro indicator (expands to ~s)'-[String] ]. syntax_message(flag_name(Name)) --> diff --git a/man/builtin.doc b/man/builtin.doc index 9088b2e2c3..0c21805ff0 100644 --- a/man/builtin.doc +++ b/man/builtin.doc @@ -8111,7 +8111,7 @@ and modules. \begin{center} \begin{tabular}{|r|D{f}{f}{-1}|p{4in}|} \hline -1200 & xfx & \op{-->}, \op{:-}, \op{=>} \\ +1200 & xfx & \op{-->}, \op{:-}, \op{=>}, \op{==>} \\ 1200 & fx & \op{:-}, \op{?-} \\ 1150 & fx & \op{dynamic}, \op{discontiguous}, \op{initialization}, \op{meta_predicate}, diff --git a/man/ssu.doc b/man/ssu.doc index dce7124d92..404ba16d54 100644 --- a/man/ssu.doc +++ b/man/ssu.doc @@ -290,6 +290,20 @@ a term \exam{Head :- Body} and for a single sided unification rule it is a term \exam{Head {=>} Body}. \end{description} +\subsection{Single sided unification for Definite Clause Grammars} +\label{sec:ssu-dcg} + +Single sided unification is attractive for \jargon{generative DCG +rules}, i.e., DCG rules that are used to \jargon{serialize} some term. +In that context they avoid unwanted matching on variables and provide +better error messages in case not all possible terms are described by +the grammar. Single sided unification has no practical use for parsing +because the arguments are typically \jargon{output} arguments. + +If the head of an SSU DCG rules is a term \verb$Head, Extra$, +\arg{Extra} is interpreted as a \jargon{push back list} if it is a list +and as an SSU \jargon{guard} otherwise. The guard is \emph{not} subject +to DCG expansion, i.e., it is interpreted as if enclosed by \verb${}$. \subsection{SSU: Future considerations} \label{sec:ssu-future} diff --git a/man/summary.doc b/man/summary.doc index a8c3809e10..2f325fabff 100644 --- a/man/summary.doc +++ b/man/summary.doc @@ -987,6 +987,7 @@ suggest predicates from a keyword. \opsummary{1200}{fx}{:-}{Introduces a directive} \opsummary{1200}{fx}{?-}{Introduces a directive} \opsummary{1200}{xfx}{-->}{DCGrammar: rewrite} +\opsummary{1200}{xfx}{==>}{DCGrammar: rewrite} \opsummary{1200}{xfx}{:-}{head \Sneck{} body. separator} \end{summarylist} diff --git a/src/ATOMS b/src/ATOMS index 231ecdc849..b647ced44f 100644 --- a/src/ATOMS +++ b/src/ATOMS @@ -787,6 +787,7 @@ A sqrt "sqrt" A ssu "ssu" A ssu_commit "=>" A ssu_choice "?=>" +A ssu_dcg "==>" A stack "stack" A stack_limit "stack_limit" A stack_overflow "stack_overflow" diff --git a/src/pl-op.c b/src/pl-op.c index a3bce706fa..4231cfd96c 100644 --- a/src/pl-op.c +++ b/src/pl-op.c @@ -682,6 +682,7 @@ static const opdef operators[] = { OP(ATOM_prove, OP_FX, 1200), /* :- */ OP(ATOM_prove, OP_XFX, 1200), OP(ATOM_ssu_commit, OP_XFX, 1200), /* => */ + OP(ATOM_ssu_dcg, OP_XFX, 1200), /* ==> */ //OP(ATOM_ssu_choice, OP_XFX, 1200), /* ?=> */ OP(ATOM_semicolon, OP_XFY, 1100), /* ; */ OP(ATOM_bar, OP_XFY, 1105), /* | */