ADDED: Support SSU DCG rules as Head[, Guard] ==> DCGBody.

boot/dcg.pl

@@ -3,7 +3,7 @@
     Author:        Jan Wielemaker
     E-mail:        [email protected]
     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,16 +70,41 @@
 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),
     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, (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),

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),

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)) -->

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},

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}

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}
 

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"

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),	/* | */