:- style_check(-singleton). % added djd

% Copyright (C) Goedel Group, University of Bristol, June 1992.
% Title and ownership of all Goedel software originating from the Goedel
% Group at the University of Bristol remains with the Goedel Group.
%
% The Goedel language was designed by P.M. Hill and J.W. Lloyd, and the
% language was implemented by A. Bowers and J. Wang. The design and
% implementation of the language was partly supported by the ESPRIT Basic
% Research Action 3012 (Compulog), a SERC Grant GR/F/26256, and the
% University of Bristol.
%
% This software is available ONLY for research and educational purposes.
% In particular, it may not be used for any commercial purpose whatsoever.
% The software is free and is provided "as is", without warranty of any kind.
% Users of the software are free to modify and experiment with it for
% research and educational purposes. However, users may not distribute
% the software (modified or not) to third parties without the express
% permission of the Goedel Group. The normal method of obtaining this
% software is by ftp from ftp.cs.kuleuven.ac.be.
%
% Any enquiries about this copyright notice or the use of this software
% should be directed to J.W. Lloyd at jwl@compsci.bristol.ac.uk.


/*
File:		tokeniser.pl
Subject:	tokenising Goedel programs.
Author:		Jiwei Wang
Date:		6 Sept. 1991

Agree to the Goedel Report, Sept, 1991.

This tokenizer may be used to scan the source file only once or several times.
For efficiency reason, the tokenizer does not test tokens for their semantics.
This includes:
	1. omitting test of label in commit as non-zero digit;

The good thing about new Goedel language definition is that tokenizing can be
done with one look-ahead char.
*/



:- module(tokenizer).   % converted djd
/*------------------------------------------------------------------------------
 * Note: the line number for the first item is always not right.
 * But it doesn't matter.
 */

:- discontiguous token/6. % added djd

get_one_module(Stream, Module):-
   get_one_module_aux(Stream, Module, 1, []).

get_one_module_aux(Stream, Module, StartLine, LeftChars) :-
   get_one_item(Stream, Item, StartLine, EndLine, LeftChars, AheadChars),
   ( Item = end_of_file
     -> Module = []
     ;  StartLine2 is StartLine + 1,
	Module = [item(Item, StartLine2, EndLine)|Module2],
        get_one_module_aux(Stream, Module2, EndLine, AheadChars)
   ).


/*------------------------------------------------------------------------------
 * get_one_item(+Stream, -Item, +Start, -End, Left, Ahead)
 *
 * get_one_item_aux(+Stream, -Item, +Start, -End, Left, Ahead)
 *
 *	Item:	item(list(token), start-line-No, end-line-No).
 *		or end_of_file
 *	Start:  the starting line number of the item
 *	End:	the ending line number of the item
 *	Left:	a list of one (or none) char left from the previous token
 *	Ahead:	a list of one (or none) char left for the next token
 *
 * usage: get_one_item(+Stream, -Item, +Start, -End, [], _)
 *
 * get_one_item is determinate and alway succeeds.
 */

get_one_item(Stream, Item, Start, End, Left, Ahead) :-
   get_one_token(Stream, Token, Start, Ln, Left, Temp),
   ( Token == end_of_file
     -> Item = end_of_file,
	Ahead = Temp,
	End = Ln
     ;  ( Token == terminator
          -> format(user_error, '~nWarning: empty item in line ~d.~n', [Ln]),
	     % empty items are thrown away
	     get_one_item(Stream, Item, Ln, End, Temp, Ahead)
          ;  get_one_item_aux(Stream, Item2, Ln, End, Temp, Ahead, EndOfFile),
	     ( var(EndOfFile)
	       -> Item = [Token|Item2]
	       ;  Item = end_of_file		% unfinished item discarded
	     )
        )
   ).


get_one_item_aux(Stream, Item, Start, End, Left, Ahead, EndOfFile):-
   get_one_token(Stream, Token, Start, Ln, Left, Temp),
   ( Token == terminator
     -> Item = [],
	End = Ln,
	Ahead = Temp
     ;  ( Token == end_of_file
          -> format(user_error, '~nError: unexpected end_of_file, the last clause discarded.~n', []),
	     EndOfFile = yes,
	     Item = [],
	     End = Ln,
	     Ahead = Temp
          ;  Item = [Token|Item2],
	     get_one_item_aux(Stream, Item2, Ln, End, Temp, Ahead, EndOfFile)
	)
   ).


/*------------------------------------------------------------------------------
 */

get_one_token(Stream, Token, Start, End, Left, Ahead):-
   ( Left = [0'., A]	% a case in handling decimals
     -> Token = terminator,
	Ahead =  [A],
	End = Start
     ;  ( Left = []
	  -> get0(Stream, C)
	  ;  Left = [C]
	),
	token(C, Stream, Token, Start, End, Ahead)
   ).


/*------------------------------------------------------------------------------
 */

token(-1, _, end_of_file, Ln, Ln, []):- !.

% Comments
token(0'%, Stream, Token, Start, End, Ahead) :- !,
   comment(Stream, EndOfFile),
   ( nonvar(EndOfFile)
     -> Token = end_of_file,
	End = Start
     ;  Ln is Start + 1,
	get_one_token(Stream, Token, Ln, End, [], Ahead)
   ).

/*------------------------------------------------------------------------------
 */

comment(Stream, EndOfFile):-
   get0(Stream, C),
   ( C = 10
     -> true
     ;  ( C = -1
	  -> EndOfFile = yes
	  ;  comment(Stream, EndOfFile)
	)
   ).

/*------------------------------------------------------------------------------
 */


% Layout-char

token(32, Stream, Token, Start, End, Ahead) :- !,
   get_one_token(Stream, Token, Start, End, [], Ahead).

token(9, Stream, Token, Start, End, Ahead) :- !,
   get_one_token(Stream, Token, Start, End, [], Ahead).

token(10, Stream, Token, Start, End, Ahead) :- !,
   Ln is Start + 1,
   get_one_token(Stream, Token, Ln, End, [], Ahead).


% String with error recovery

token(0'", Stream, string(String), Start, End, Ahead) :- !,
   string_chars(Cs, Stream, Start, Start, End, Ahead),
   name(String, Cs).

/*------------------------------------------------------------------------------
 * One " terminates string, two " escapes this, anything else just adds
 * characters to the string
 */

string_chars(Cs, Stream, Very_first, Start, End, Ahead) :-
   get0(Stream, C),
   string_chars_aux(C, Cs, Stream, Very_first, Start, End, Ahead).

string_chars_aux(0'", [], _, _, Start, Start, []) :- !.

string_chars_aux(0'\\, Cs, Stream, Very_first, Start, End, Ahead) :- !, % added \ djd
   get0(Stream, C),
   ( C = -1
     -> format(user_error, '~nError: incomplete string in lines: ~d-~d.~n',
			     [Very_first, Start]),
	Cs = [], End = Start, Ahead = [-1]
     ;  ( C = 0'n		% \n
          -> Cs = [10|Cs2]
	  ;  ( C = 0't		% \t
	       -> Cs = [9|Cs2]
	       ;  ( C = 0'b	% \b
	            -> Cs = [8|Cs2]
		    ;  Cs = [C|Cs2]
		  )
	     )
	),
        string_chars(Cs2, Stream, Very_first, Start, End, Ahead)
   ).

string_chars_aux(-1, [], _, Very_first, Start, Start, [-1]) :- !,
   format(user_error, '~nError: incomplete string in lines: ~d-~d.~n',
			[Very_first, Start]).  % error recovery

string_chars_aux(10, [10|Cs], Stream, Very_first, Start, End, Ahead) :- !,
   Ln is Start + 1,
   string_chars(Cs, Stream, Very_first, Ln, End, Ahead).

string_chars_aux(C, [C|Cs], Stream, Very_first, Start, End, Ahead) :-
   string_chars(Cs, Stream, Very_first, Start, End, Ahead).

/*------------------------------------------------------------------------------
 */

% left curly
token(0'{, _, '{', Ln, Ln, []) :- !.

% right curly (Label)
token(0'}, Stream, '}'(N), Ln, Ln, Ahead) :- !,
   commit_label(N, Stream, Ahead).

commit_label(N, Stream, Ahead) :-
   get0(Stream, C),
   ( C == 0'_
     -> number_chars(Cs, Stream, Ahead),
	name(N, Cs)
     ;  N = 1000000000, Ahead = [C]
   ).


% left round
token(0'(, _, '(', Ln, Ln, []) :- !.

% right round
token(0'), _, ')', Ln, Ln, []) :- !.

% left square
token(0'[, _, '[', Ln, Ln, []) :- !.

% right square
token(0'], _, ']', Ln, Ln, []) :- !.


% Comma
token(0',, _, ',', Ln, Ln, []) :- !.


% Underscore, the name is "_littlename"
token(0'_, Stream, '_'(N), Ln, Ln, Ahead) :- !,
   get0(Stream, C),
   ( little_letter(C)
     -> name_chars(Cs, Stream, Ahead),
        name(N, [0'_, C|Cs])
     ;  N = '_',
	Ahead = [C]
   ).

% SemiColon
token(0';, _, ';', Ln, Ln, []) :- !.

% Terminator
token(0'., _, terminator, Ln, Ln, []) :- !.


% Big-name
token(C, Stream, big_name(N), Ln, Ln, Ahead) :-
   0'A =< C, C =< 0'Z,
   !,
   name_chars(Cs, Stream, Ahead),
   name(N, [C|Cs]).

% Little-name
token(C, Stream, little_name(N), Ln, Ln, Ahead) :-
   0'a =< C, C =< 0'z,
   !,
   name_chars(Cs, Stream, Ahead),
   name(N, [C|Cs]).

/*------------------------------------------------------------------------------
 */

% name_chars is written in this clumsy form in order to remove choice points
% hence improve efficiency
name_chars(Cs, Stream, Ahead) :-
   get0(Stream, C),
   ( ( little_letter(C);
       number_char(C);
       big_letter(C);
       C = 0'_
     )
     -> Cs = [C|Cs2],
	name_chars(Cs2, Stream, Ahead)
     ;  Cs = [],
	Ahead = [C]
   ).

% member(C,"ABCDEFGHIJKLMNOPQRSTUVWXYZ")
big_letter(C) :-
   0'A =< C, C =< 0'Z.

% member(C,"abcdefghijklmnopqrstuvwxyz")
little_letter(C) :-
   0'a =< C, C =< 0'z.

% member(C,"0123456789")
number_char(C) :-
   0'0 =< C, C =< 0'9.

/*------------------------------------------------------------------------------
 */

% Graphic-name

token(C, Stream, graphic_name(N), Ln, Ln, Ahead) :-
   graphic_char(C),
   !,
   graphic_chars(Cs, Stream, Ahead),
   name(N, [C|Cs]).

/*------------------------------------------------------------------------------
 */

graphic_char(0'+).
graphic_char(0'-).
graphic_char(0'*).
graphic_char(0'/).
graphic_char(0'\\).  % added \ djd
graphic_char(0'^).
graphic_char(0'#).
graphic_char(0'<).
graphic_char(0'>).
graphic_char(0'=).
graphic_char(0'~).
graphic_char(0'&).
graphic_char(0'?).
graphic_char(0'`).
graphic_char(0'@).
graphic_char(0'!).
graphic_char(0'$).
graphic_char(0':).
graphic_char(0'|).
graphic_char(0'').


graphic_chars(Cs, Stream, Ahead) :-
   get0(Stream, C),
   ( graphic_char(C)
     -> Cs = [C|Cs2],
	graphic_chars(Cs2, Stream, Ahead)
     ;  Cs = [],
	Ahead = [C]
   ).

/*------------------------------------------------------------------------------
 * Representation of numbers:
 *	Number:		number(integer) where the integer >= 0.
 *	Float:		float(float)
 */

% Number & Float
token(C, Stream, Token, Ln, Ln, Ahead) :-
   0'0 =< C, C =< 0'9,
   !,
   number_chars(Cs1, Stream, Ahead1),
   ( Ahead1 = [0'.]
     -> get0(Stream, C0),
	( number_char(C0)	% make sure it's not P(a) <- a = 3.
	  -> number_chars(Cs2, Stream, Ahead2),
	     ( Ahead2 = [0'E]
	       -> get0(Stream, C2),
		  ( signed_number(C2)
		    -> number_chars(Cs3, Stream, Ahead),
		       append(Cs2, [0'E, C2|Cs3], Cs4),
		       append(Cs1, [0'., C0|Cs4], Cs5),
		       name(Int2, [C|Cs5]),
		       Token = float(Int2)
		    ;  format(user_error, '~nError: wrong format in the float number in line ~d.~n', [Ln]),
		            % here is the error recovery job
		       append(Cs1, [0'., C0|Cs2], Cs7),
		       name(Int4, [C|Cs7]),
		       Token = float(Int4),
		       Ahead = [C2]
		  )
	       ;  append(Cs1, [0'., C0|Cs2], Cs6),
		  name(Int3, [C|Cs6]),
		  Token = float(Int3),
		  Ahead = Ahead2
	     )
	  ;  name(Int1, [C|Cs1]),
	     Token = number(Int1),
	     Ahead = [0'., C0]
	)
     ;  name(Int1, [C|Cs1]),
	Token = number(Int1),
	Ahead = Ahead1
   ).


signed_number(0'+) :- !.
signed_number(0'-) :- !.
signed_number(C) :-
   0'0 =< C, C =< 0'9.


number_chars(Cs, Stream, Ahead) :-
   get0(Stream, C),
   ( number_char(C)
     -> Cs = [C|Cs2],
        number_chars(Cs2, Stream, Ahead)
     ;  Cs = [],
	Ahead = [C]
   ).

/*------------------------------------------------------------------------------
 */

% Cope with illegal characters
token(C, Stream, Token, Start, End, Ahead) :-
   format(user_error, '~nError: illegal character with ASCII code "~w" in line ~d.~n',
		[C, Start]),
   get_one_token(Stream, Token, Start, End, [], Ahead).
:- style_check(-singleton). % added djd

% Copyright (C) Goedel Group, University of Bristol, June 1992.
% Title and ownership of all Goedel software originating from the Goedel
% Group at the University of Bristol remains with the Goedel Group.
%
% The Goedel language was designed by P.M. Hill and J.W. Lloyd, and the
% language was implemented by A. Bowers and J. Wang. The design and
% implementation of the language was partly supported by the ESPRIT Basic
% Research Action 3012 (Compulog), a SERC Grant GR/F/26256, and the
% University of Bristol.
%
% This software is available ONLY for research and educational purposes.
% In particular, it may not be used for any commercial purpose whatsoever.
% The software is free and is provided "as is", without warranty of any kind.
% Users of the software are free to modify and experiment with it for
% research and educational purposes. However, users may not distribute
% the software (modified or not) to third parties without the express
% permission of the Goedel Group. The normal method of obtaining this
% software is by ftp from ftp.cs.kuleuven.ac.be.
%
% Any enquiries about this copyright notice or the use of this software
% should be directed to J.W. Lloyd at jwl@compsci.bristol.ac.uk.


/*
File:		tokeniser2.pl
Subject:	tokenising Goedel programs.
Author:		Jiwei Wang
Date:		19 Jan. 1992

This version of tokenizer assumes that module is read in a list.

This tokenizer does not return line number and returns items in a list of
lists.

The good thing about new Goedel language definition is that tokenizing can be
done with one look-ahead char.
*/

%% '$$module'('@(#)tokenizer2.pl 1.12 last updated 93/11/24 17:34:36 by jiwei').
:- module(tokenizer2).   % converted djd

:- discontiguous token_2nd/4. %% added djd

/*------------------------------------------------------------------------------
 */

/* Comment out for to avoid redefine get_one_module

get_one_module(Stream, Module):-
   stream2chars(Stream, Chars),
   get_one_module_aux(Chars, Module).

get_one_module_aux([], []) :-  !.
get_one_module_aux(Chars, Module) :-
   get_one_item_2nd(Chars, Remains, Item),
   ( Item = end_of_file
     -> Module = []
     ;  Module = [Item|Module2],
	get_one_module_aux(Remains, Module2)
   ).


stream2chars(Str,Cs):-
   get0(Str, C),
   stream2chars_aux(Str, C, Cs).

stream2chars_aux(Str, C, Cs):-
   ( C = -1
     -> Cs = []
     ;  Cs = [C|Cs1],
	get0(Str, C1),
	stream2chars_aux(Str, C1, Cs1)
   ).

 */

/*------------------------------------------------------------------------------
 * get_one_item_2nd(+Chars, -Remains, -Item)
 *
 * get_one_item_2nd_aux(+Chars, -Remains, -Item)
 *
 *   Item:   list(token_2nd).
 *	     or end_of_file
 *
 * usage: get_one_item_2nd(+Chars, -Remains, -Item)
 *
 * get_one_item_2nd is determinate and alway succeeds.
 */

get_one_item_2nd(Chars, Remains, Item) :-
   get_one_token_2nd(Chars, Remains2, Token),
   ( Token == terminator
     -> format(user_error, '~nWarning: there is an empty item.~n', []),
        get_one_item_2nd(Remains2, Remains, Item)
     ;  ( Token == end_of_file
          -> Item = end_of_file,
	     Remains = Remains2
          ;  Item = [Token|Item2],
	     get_one_item_2nd_aux(Remains2, Remains, Item2)
        )
   ).


get_one_item_2nd_aux(Chars, Remains, Item):-
   get_one_token_2nd(Chars, Remains2, Token),
   ( Token == terminator
     -> Item = [],
	Remains = Remains2
     ;  ( Token == end_of_file
          -> format(user_error, '~nError: unexpected end_of_input.~n', []),
	     Item = [],
	     Remains = Remains2
          ;  Item = [Token|Item2],
	     get_one_item_2nd_aux(Remains2, Remains, Item2)
	)
   ).

/*------------------------------------------------------------------------------
 */

get_one_token_2nd([], [], end_of_file).
get_one_token_2nd([Char|Chars], Remains, Token):-
   token_2nd(Char, Chars, Remains, Token).


/*------------------------------------------------------------------------------
 */

% Comments
token_2nd(0'%, Chars, Remains, Token) :- !,
   comment_2nd(Chars, Remains2),
   get_one_token_2nd(Remains2, Remains, Token).

/*------------------------------------------------------------------------------
 */

comment_2nd([], []).
comment_2nd([Char|Chars], Remains):-
   ( Char = 10
     -> Remains = Chars
     ;  comment_2nd(Chars, Remains)
   ).

/*------------------------------------------------------------------------------
 */

% Layout-char
token_2nd(32, Chars, Remains, Token) :- !,
   get_one_token_2nd(Chars, Remains, Token).
token_2nd(9, Chars, Remains, Token) :- !,
   get_one_token_2nd(Chars, Remains, Token).
token_2nd(10, Chars, Remains, Token) :- !,
   get_one_token_2nd(Chars, Remains, Token).

% String with error recovery
token_2nd(0'", Chars, Remains, string(String)) :- !,
   string_chars_2nd(Chars, Remains, SChars),
   name(String, SChars).

/*------------------------------------------------------------------------------
 * One " terminates string, two " escapes this, anything else just adds
 * characters to the string
 */

string_chars_2nd([], [], []) :-
   format(user_error, '~nError: incomplete string.~n', []).
		% does error recovery
string_chars_2nd([C|Chars], Remains, SChars) :-
   ( C = 0'"
     -> SChars = [],
	Remains = Chars
     ;  ( C = 0'\
	  -> ( Chars = [C2|Remains2]
	       -> ( C2 = 0'n               % \n
		    -> SChars = [10|SChars2]
		    ;  ( C2 = 0't          % \t
			 -> SChars = [9|SChars2]
	                 ;  ( C2 = 0'b     % \b
		              -> SChars = [8|SChars2]
                              ;  SChars = [C2|SChars2]
                            )
                       )
                  ),
		  string_chars_2nd(Remains2, Remains, SChars2)
	       ;  format(user_error, '~nError: incomplete string.~n', [])
	     )
          ;  SChars = [C|SChars2],
             string_chars_2nd(Chars, Remains, SChars2)
        )
   ).

/*------------------------------------------------------------------------------
 */

% left curly
token_2nd(0'{, Chars, Chars, '{') :- !.

% right curly (Label)
token_2nd(0'}, Chars, Remains, '}'(N)) :- !,
   commit_label_2nd(Chars, Remains, N).

commit_label_2nd([], [], 1000000000).
	% in fact this is an error
commit_label_2nd([C|Chars], Remains, N) :-
   ( C == 0'_
     -> number_chars_2nd(Chars, Remains, Cs),
	name(N, Cs)
     ;  N = 1000000000,
	Remains = [C|Chars]
   ).


% left round
token_2nd(0'(, Chars, Chars, '(') :- !.

% right round
token_2nd(0'), Chars, Chars, ')') :- !.

% left square
token_2nd(0'[, Chars, Chars, '[') :- !.

% right square
token_2nd(0'], Chars, Chars, ']') :- !.

% Comma
token_2nd(0',, Chars, Chars, ',') :- !.

% Underscore, the name is "_littlename"
token_2nd(0'_, Chars, Remains, '_'(N)) :- !,
   ( Chars = [C|Chars2], little_letter(C)
     -> name_chars_2nd(Chars2, Remains, Cs),
        name(N, [0'_, C|Cs])
     ;  N = '_',
	Remains = Chars
   ).


% SemiColon
token_2nd(0';, Chars, Chars, ';') :- !.

% Terminator
token_2nd(0'., Chars, Chars, terminator) :- !.


% Big-name
token_2nd(C, Chars, Remains, big_name(N)) :-
   0'A =< C, C =< 0'Z,
   !,
   name_chars_2nd(Chars, Remains, Cs),
   name(N, [C|Cs]).

% Little-name
token_2nd(C, Chars, Remains, little_name(N)) :-
   0'a =< C, C =< 0'z,
   !,
   name_chars_2nd(Chars, Remains, Cs),
   name(N, [C|Cs]).

/*------------------------------------------------------------------------------
 */

% name_chars_2nd is written in this clumsy form in order to remove choice points
% hence improve efficiency
name_chars_2nd([], [], []).
	% an error case
name_chars_2nd([C|Chars], Remains, Cs) :-
   ( ( little_letter(C);
       number_char(C);
       big_letter(C);
       C = 0'_
     )
     -> Cs = [C|Cs2],
	name_chars_2nd(Chars, Remains, Cs2)
     ;  Cs = [],
	Remains = [C|Chars]
   ).

/*------------------------------------------------------------------------------
 */

% Graphic-name

token_2nd(C, Chars, Remains, graphic_name(N)) :-
   graphic_char(C),
   !,
   graphic_chars_2nd(Chars, Remains, Cs),
   name(N, [C|Cs]).


graphic_chars_2nd([], [], []).
	% a case for error
graphic_chars_2nd([C|Chars], Remains, Cs) :-
   ( graphic_char(C)
     -> Cs = [C|Cs2],
	graphic_chars_2nd(Chars, Remains, Cs2)
     ;  Cs = [],
	Remains =[C|Chars]
   ).

/*------------------------------------------------------------------------------
 * Representation of numbers:
 *   Number:      number(integer) where the integer >= 0.
 *   Float:      float(float)
 */

% Number & Float
token_2nd(C, Chars, Remains, Token) :-
   0'0 =< C, C =< 0'9,
   !,
   number_chars_2nd(Chars, Remains1, Cs1),
   ( Remains1 = [0'.|Remains2]
     -> ( Remains2 = [C0|Remains3],
          number_char(C0)   % make sure it's not P(a) <- a = 3.
          -> number_chars_2nd(Remains3, Remains4, Cs2),
             ( Remains4 = [0'E|Remains5]
               -> ( Remains5 = [C2|Remains6],
                    signed_number(C2)
                    -> number_chars_2nd(Remains6, Remains, Cs3),
                       append(Cs2, [0'E, C2|Cs3], Cs4),
                       append(Cs1, [0'., C0|Cs4], Cs5),
                       name(Int2, [C|Cs5]),
                       Token = float(Int2)
                    ;  format(user_error, '~nError: wrong format in the float number.~n', []),
				% here is the error recovery job
                       append(Cs1, [0'., C0|Cs2], Cs7),
                       name(Int4, [C|Cs7]),
                       Token = float(Int4),
		       Remains = Remains5
                  )
               ;  append(Cs1, [0'., C0|Cs2], Cs6),
                  name(Int3, [C|Cs6]),
                  Token = float(Int3),
		  Remains = Remains4
             )
          ;  name(Int1, [C|Cs1]),
             Token = number(Int1),
             Remains = [0'.|Remains2]
        )
     ;  name(Int1, [C|Cs1]),
        Token = number(Int1),
        Remains = Remains1
   ).


number_chars_2nd([], [], []).
number_chars_2nd([C|Chars], Remains, Cs) :-
   ( number_char(C)
     -> Cs = [C|Cs2],
	number_chars_2nd(Chars, Remains, Cs2)
     ;  Cs = [],
	Remains = [C|Chars]
   ).

/*------------------------------------------------------------------------------
 */

% Cope with illegal characters
token_2nd(C, Chars, Remains, Token) :-
   format(user_error, '~nError: illegal character with ASCII code "~q".~n',
		[C]),
   get_one_token_2nd(Chars, Remains, Token).

:- style_check(-singleton). % added djd

% Copyright (C) Goedel Group, University of Bristol, June 1992.
% Title and ownership of all Goedel software originating from the Goedel
% Group at the University of Bristol remains with the Goedel Group.
%
% The Goedel language was designed by P.M. Hill and J.W. Lloyd, and the
% language was implemented by A. Bowers and J. Wang. The design and
% implementation of the language was partly supported by the ESPRIT Basic
% Research Action 3012 (Compulog), a SERC Grant GR/F/26256, and the
% University of Bristol.
%
% This software is available ONLY for research and educational purposes.
% In particular, it may not be used for any commercial purpose whatsoever.
% The software is free and is provided "as is", without warranty of any kind.
% Users of the software are free to modify and experiment with it for
% research and educational purposes. However, users may not distribute
% the software (modified or not) to third parties without the express
% permission of the Goedel Group. The normal method of obtaining this
% software is by ftp from ftp.cs.kuleuven.ac.be.
%
% Any enquiries about this copyright notice or the use of this software
% should be directed to J.W. Lloyd at jwl@compsci.bristol.ac.uk.


/*
File:		term.pl
Subject:	parsing terms
Author:		Jiwei Wang
Date:		25 October 1991
		15 November 1991, the first fully working version of the
		ambiguous parser
Comments:	the new design of the parser which copes with all kinds of
		ambiguity.

================================================================================
*/

%%'$$module'('@(#)term.pl 1.42 last updated 93/12/14 11:58:33 by jiwei').
:- module(term).   % converted djd

:- discontiguous term_aux/6. % added djd
:- discontiguous term_prime_aux/6. % added djd

/*------------------------------------------------------------------------------
  The parsing method follows the general idea of recursive descent parsing
  method. Firstly the sequence of term is decided by recursive procedures.
  Then, the order of operators is sorted out by their precedence and
  associativity. Multiple parse trees are output from the parser.


  The original grammars for term can be rewritten as:

	T -> c | f1 T | f2 T | T f3 | T f4 | T f5 T | T f6 T | T f7 T

  where c stands for terms in Term(infinite), fi stands for a function.

  The transformed grammars (with left recursion removed) are as follows:

	T  -> c T' | f1 T T' | f2 T T'
	T' -> f3 T'| f4 T'   | f5 T T' | f6 T T' | f7 T T' | e

  where e is the empty string.
  In fact sequence T T' is just T.  Replace T T' by T, we have the grammar:

	T  -> c T' | f1 T | f2 T
	T' -> f3 T'| f4 T'| f5 T | f6 T | f7 T | e

  The parsing strategy is first to get the sequence of tokens in the term
  right, and then sort out the order of operators by their precedences.

  Sorting out the order of operators.
	T and T' carry the indicator of its immediate-left operator (can be
	'null') and a stack whose elements contain a parse tree and the
	indicator of the major function in the parse tree. Therefore in T and T'
	Let (IndLeft), (IndOp) and (IndRight)
	be the indicators of the left, the current and the right operators
	respectively. Let the current operator be Op and the parsetree on the
	top of the stack be TreeRight.
	Let the specifier for Term(8) be 'null'.

	We define three relations between two indicators, namely bigger_than,
	less_than and ambiguous.  Indicators (IndLeft and IndRight) have
	two components, namely specifier (Spec) and precedence (Prec).


	bigger_than(IndLeft, IndRight) <-
		PrecLeft > PrecRight \/
		( PrecLeft = PrecRight &
		  ( ( SpecLeft = 'YFX' & SpecRight = 'YFX' ) \/
		    ( SpecLeft = 'YFX' & SpecRight = 'YF' ) \/
		    ( SpecLeft = 'XFX' & SpecRight = 'YFX' ) \/
		    ( SpecLeft = 'XFX' & SpecRight = 'YF' ) \/
		    ( SpecLeft = 'FX' & SpecRight = 'YFX' ) \/
		    ( SpecLeft = 'FX' & SpecRight = 'YF' ) \/
		    ( SpecLeft = 'XF' & SpecRight = 'YFX' ) \/
		    ( SpecLeft = 'XF' & SpecRight = 'YF' ) \/
		    ( SpecLeft = 'YF' & SpecRight = 'YFX' ) \/
		    ( SpecLeft = 'YF' & SpecRight = 'YF' )
		  )
		).

	less_than(IndLeft, IndRight) <-
		PrecLeft < PrecRight \/
		( PrecLeft = PrecRight &
		  ( ( SpecLeft = 'XFY' & SpecRight = 'XFX') \/
	            ( SpecLeft = 'XFY' & SpecRight = 'XFY') \/
	            ( SpecLeft = 'XFY' & SpecRight = 'XF') \/
	            ( SpecLeft = 'FY' & SpecRight = 'XFX') \/
	            ( SpecLeft = 'FY' & SpecRight = 'XFY') \/
	            ( SpecLeft = 'FY' & SpecRight = 'XF') \/
	            ( SpecLeft = 'XFY' & SpecRight = 'FX') \/
	            ( SpecLeft = 'XFY' & SpecRight = 'FY') \/
	            ( SpecLeft = 'FY' & SpecRight = 'FX') \/
	            ( SpecLeft = 'FY' & SpecRight = 'FY')
		  )
		).

	ambiguous(IndLeft, IndRight) <-
		PrecLeft = PrecRight &
		( ( SpecLeft = 'XFY' & SpecRight = 'YFX') \/
	          ( SpecLeft = 'XFY' & SpecRight = 'YF') \/
	          ( SpecLeft = 'FY' & SpecRight = 'YFX') \/
	          ( SpecLeft = 'FY' & SpecRight = 'YF')
		).

	In the parse tree of an expression, adjacent operators not satisfying
	one of bigger_than, less_than or ambiguous cause syntax errors.
	There are 25 combinations of this kind.

	The following operations are considered with the condition that the
	stack is always kept in normal form.  A stack is in normal form if
	there is no expression (Op) in the stack satisfying the condition:
		less_than(IndUp, IndOp) &
		( bigger_than(IndOp, IndDown) \/ ambiguous(IndOp, IndDown) ) &
		less_than(IndUp, IndDown).
	This is maintained by contracting the stack, in which Op should
	be filled into the hole of the expression at its right.

	There are two stack operations, namely push and pop. pop fails if the
	stack is empty.

	1. When Op is a term(8): (it happens in T -> c T' )

	If empty(Stack)
	   push(stack('null', _, term(Op, [])).
	else
	   pop(stack(IndRight, HoleRight, TreeRight)),
	   if null(IndRight)
	      error		% no two constants can be put together
	   else if null(IndLeft) \/ less_than(IndLeft, IndRight) \/
			ambiguous(IndLeft, IndRight)
			% ambiguity is dealt later.
		   HoleRight = term(Op, []).
		   push(stack(IndRight, HoleRight, TreeRight)),
	   else if bigger_than(IndLeft, IndRight)
		   push(stack(IndRight, HoleRight, TreeRight)),
		   push(stack('null', _, term(Op, [])).
	   otherwise
		   error.


	2. When Op is unary prefix: (it happens in T -> f1 T | f2 T )

	If empty(Stack)
	   error	% expecting a term
	else
	   if null(IndLeft) \/ less_than(IndLeft, IndOp)
	      pop(stack(IndRight, HoleRight, TreeRight)),
	      if null(IndRight) \/ less_than(IndOp, IndRight)
		 contract(IndLeft, stack(IndOp, term(Op, [TreeRight]), Stack)
	      else if ambiguous(IndOp, IndRight)
		      pull apart TreeRight, create two parse trees
	      else
		 error	% including bigger_than(IndLeft, IndOp)
	   else
	      error % This includes the case of bigger_than(IndLeft, IndOp),
	            % because it is only possible when SpecRight = 'FX'/'FY'.
		    % There is no ambiguous case for this one.


	3. When Op is unary postfix: (it happens in T' -> f1 T' | f2 T' )

	If empty(Stack)
	   push(stack(IndOp, Hole, term(Op, [Hole])),
	else
	   if null(IndRight)
	      error		% PrecRight can not be 'null'
	   else if bigger_than(IndOp, IndRight)
	           if null(IndLeft) \/ less_than(IndLeft, IndOp)
		      contract(IndLeft, stack(IndOp, term(Op, [Hole]), Stack)
		   else if bigger_than(IndLeft, IndOp) \/
				ambiguous(IndLeft, IndOp)
		           push(stack(IndOp, Hole, term(Op, [Hole])),
		   otherwise
			   error
	   else
	      error % This includes the case of less_than(IndOp, IndRight),
		    % There is no ambiguous case


	4. When Op is binary infix: (it happens in T' -> f5 T | f6 T | f7 T)

	If empty(Stack)
	   error
	else
	   pop(stack(IndRight, HoleRight, TreeRight)),
	   if null(IndRight) \/ less_than(IndOp, IndRight)
	      contract(IndLeft, stack(IndOp, Hole, term(Op, [TreeRight]), Stack)
	   else if ambiguous(IndOp, IndRight)
		   pull apart TreeRight and create two parse trees
	   else
	      error	% it's impossible that big_than(IndOp, IndRight) holds


	5. When Op is e: (it happens in T' -> e)
	  create empty stack, and record Remains.
 */

/*------------------------------------------------------------------------------
 * All predicates in this file should be assume to be always succeed (unless
 * stated) and leave no choice points behind.
 *----------------------------------------------------------------------------*/

/*------------------------------------------------------------------------------
 * term(+Tokens, -Return, +Language).
 * term(+Tokens, -Return, +SpecLeft, +PrecLeft, +Language):-
 *	Token:		one look ahead token
 *	Tokens:		tokens to be parsed
 *	Language:	language of the module
 *	Return:		the returned parse result.  It is a list of:
 *				Stack/Remains or error(A,B)/Remains
 *	  Stack:	a list of:
 *			stack(Spec, Prec, Hole, ParseTree)
 *			where Spec and Prec is the indicator of the major
 *			operator in the parse tree, Hole is an unfilled position
 *			in ParseTree.
 *	  Remains:	tokens left unparsed
 *	  ParseTree:	a structure of the form:
 *			term(Name_of_MajorFunctor, ListOfArgus)
 *			referring to the ground representation
 *	  Indicator:	Indicator of the major function in the term, consisting
 *			Spec and Prec. Spec can be a specifier and 'null'.
 *	SpecLeft:	specifier of the immediately left operator, can be
 *			'null' when there is no operator at the left.
 *	PrecLeft:	precedence of the immediately left operator, can be
 *			a positive integer or uninstantiated, indicating
 *			not applicable.
 */

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * term/3
 */

% term([], [], _).  comment out to remove choice point, not certain about effect

term(Tokens, Return, Language):-
	term(Tokens, Return, null, _, Language).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * term/6
 */

% this is the case for Stack=[] and Remains=[]
term([], [[]/[]], _, _, _).

term([Token|Tokens], Return, SpecLeft, PrecLeft, Language):-
   ( check_term_token(Token, SymbolList, Language)
     -> term_aux(SymbolList, Tokens, Return2, SpecLeft, PrecLeft, Language),
	( Return2 = []
	  -> length(Tokens, Position),
	     Return = [error('misuse of infix/postfix functions', [])/Position]
	  ;  Return = Return2
	)
     ;  length(Tokens, Position),
	Return = [error('undeclared or illegal symbol in term: "~w"', [Token])/Position]
   ).

/*------------------------------------------------------------------------------
 * term_aux(+Decl, +Tokens, -Return, +SpecLeft, +PrecLeft, +Language)
 *	for the format of Decl, see interface file.
 */

% The following two term_aux predicates cope with overloading.
term_aux([], _, [], _, _, _).

term_aux([Decl|SymbolList], Tokens, Return, SpecLeft, PrecLeft, Language):-
   term_aux(Decl, Tokens, Return2, SpecLeft, PrecLeft, Language),
   term_aux(SymbolList, Tokens, Return3, SpecLeft, PrecLeft, Language),
   append(Return3, Return2, Return).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

% This clause is for grammar T -> f1 T | f2 T
term_aux(prefix_function(Functor, Indicator), Tokens, Return, SpecLeft,
		PrecLeft, Language) :-
   Indicator =.. [SpecOp, PrecOp],
   term(Tokens, Return2, SpecOp, PrecOp, Language),
   term_aux_prefix(Return2, Return, Tokens, SpecLeft, PrecLeft,
			Functor, SpecOp, PrecOp).

term_aux_prefix([], [], _, _, _, _, _, _).
term_aux_prefix([Stack/Remains|Return], NewReturn, Tokens, SpecLeft, PrecLeft,
		Functor, SpecOp, PrecOp):-
   ( Stack = error(_, _)
     -> NewReturn = [Stack/Remains|NewReturn2]
     ;  ( pop(stack(SpecRight, PrecRight, HoleRight, TreeRight), Stack, Stack2),
          nonvar(HoleRight)
          -> ( ( null(SpecLeft, PrecLeft);
                 less_than(SpecLeft, PrecLeft, SpecOp, PrecOp)
               )
	       -> ( ( null(SpecRight, PrecRight);
	              less_than(SpecOp, PrecOp, SpecRight, PrecRight)
	            )
	            -> contract(Stack2, SpecLeft, PrecLeft,
			        stack(SpecOp, PrecOp, no_hole,
				'MetaDefs.Term.F2'(Functor, [TreeRight])),
			        Stacks),
		       stack_to_return(Stacks, Tokens, Remains, NewReturn,
					NewReturn2)
	            ;  ( ambiguous(SpecOp, PrecOp, SpecRight, PrecRight)
		         -> % assume PrecOp < PrecRight
			    copy_term(Stack2, NewStack2),
			    contract(Stack2, SpecLeft, PrecLeft,
				     stack(SpecOp, PrecOp, no_hole,
				      'MetaDefs.Term.F2'(Functor, [TreeRight])),
				     Stacks2),
			    stack_to_return(Stacks2, Tokens, Remains,
						NewReturn3, NewReturn2),
			    % assume PrecOp > PrecRight
			    TreeRight = 'MetaDefs.Term.F2'(FuncRight,
								[Argu|Argus]),
			    contract(NewStack2, SpecLeft, PrecLeft,
				     stack(SpecRight, PrecRight, no_hole,
				      'MetaDefs.Term.F2'(FuncRight,
				         ['MetaDefs.Term.F2'(Functor, [Argu])
					  |Argus])),
				     Stacks3),
			    stack_to_return(Stacks3, Tokens, Remains, NewReturn,
						NewReturn3)
			 ;  TreeRight = 'MetaDefs.Term.F2'(FuncRight, _),
			    length(Tokens, Position),
			    NewReturn = [ error('wrong precedence or associativity between operators: "~w" and "~w"', [Functor, FuncRight])/Position
					 | NewReturn2]
		       )
	          )
	       ;  length(Tokens, Position),
		  NewReturn = [ error('misuse of operator "~w" (wrong precedence or associativity)', [Functor])/Position
			       | NewReturn2]
	     )
          ;  length(Tokens, Position),
	     NewReturn = [ error('misuse of prefix function "~w"', [Functor])/Position| NewReturn2]
        )
   ),
   term_aux_prefix(Return, NewReturn2, Tokens, SpecLeft, PrecLeft,
			Functor, SpecOp, PrecOp).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * error handling in terms of function_no_ind, list, (Term):
 *	if there is an valid parsing for this term, the errors encountered
 *	inside the term is discarded, otherwise they are returned.
 */

% The following procedures correspond to the grammar: T -> c T'

% function without indicator
% function_no_ind should take a list of function declarations. This is for
% identify function with their arities.
term_aux(function_no_ind(Functors), Tokens, Return, SpecLeft, PrecLeft,
		Language) :-
   ( Tokens = [ '(' |Tokens2]
     -> term_seq(Tokens2, Remains2, Term_seqs, Language, ErrorReturn),
		% there can be only one remains
	( Term_seqs = []
	  -> Return = ErrorReturn
	  ; ( Remains2 = [')'|Remains3]
	      -> Term_seqs = [H|_],
		 length(H, Arity),
	         create_functions(Functors, Term_seqs, Arity, Terms, []),
		 ( Terms = []
		   -> Functors = ['MetaDefs.Name.F4'(_, GF, _, _)|_],
		      length(Remains3, Position),
		      Return = [error('undefined function "~w/~d"', [F, Arity])/Position],
		      gstring2string(GF, F)
		   ;  term_infinite(Remains3, Return, Terms, SpecLeft, PrecLeft,
				Language)
		 )
	      ;  length(Remains2, Position),
		 Return = [error('missing ")"', [])/Position]
	    )
	)
     ;  length(Tokens, Position),
	Return = [error('missing "("', [])/Position]
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * Giving a list of normal function declarations and a list of term_seqs,
 * this returns the parse trees of the function. Arity of the function is
 * checked.
 */

create_functions([], _, _, Terms, Terms).
create_functions(['MetaDefs.Name.F4'(Module, Symbol, 'MetaDefs.Function.C0',
			ArityD)|Functors], Term_seqs, Arity, Terms, Terms2) :-
	( ArityD == Arity
	  -> create_functions_aux(Term_seqs, 'MetaDefs.Name.F4'(Module,
			Symbol, 'MetaDefs.Function.C0', ArityD), Terms, Terms3)
	  ;  Terms = Terms3
	),
	create_functions(Functors, Term_seqs, Arity, Terms3, Terms2).


create_functions_aux([], _, Terms, Terms).
create_functions_aux([Term_seq|Term_seqs], Functor,
		['MetaDefs.Term.F2'(Functor, Term_seq)|Terms], Terms2) :-
	create_functions_aux(Term_seqs, Functor, Terms, Terms2).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

% list
term_aux(list, Tokens, Return, SpecLeft, PrecLeft, Language) :-
   ( lookup_constructor('"List', 1, '"Lists', Language)
     -> list(Tokens, Remains, ListTerms, Language, ErrorReturn),
	( ListTerms = []
	  -> Return = ErrorReturn
	  ;  term_infinite(Remains, Return, ListTerms, SpecLeft, PrecLeft,
				Language)
	)
     ;  length(Tokens, Position),
        Return = [error('system module "Lists" not imported', [])/Position]
  ).

% set
term_aux(set, Tokens, Return, SpecLeft, PrecLeft, Language) :-
   ( lookup_constructor('"Set', 1, '"Sets', Language)
     -> set(Tokens, Remains, SetTerms, Language, ErrorReturn),
	( SetTerms = []
	  -> Return = ErrorReturn
	  ;  term_infinite(Remains, Return, SetTerms, SpecLeft, PrecLeft,
				Language)
	)
     ;  length(Tokens, Position),
        Return = [error('system module "Sets" not imported', [])/Position]
  ).

% (Term)
term_aux(bracket, Tokens, Return, SpecLeft, PrecLeft, Language) :-
	term(Tokens, Return2, null, _, Language),
	( select_return(Return2, [')'], Terms, Remains2, ErrorReturn)
	  -> ( Terms = []	% indicating the term cannot be parsed
	       -> ( select_return(Return2, null, Terms4, Remains4, _)
		    -> true
		    ;  write('Internal error No 1.'), nl, abort
		  ),
		  ( Terms4 = []
		    -> Return = ErrorReturn
		    ;  length(Remains4, Position),
		       Return = [error('")" expected', [])/Position|ErrorReturn]
		  )
	       ;  ( Remains2 = [')'|Remains3]
		    -> term_infinite(Remains3, Return, Terms, SpecLeft,
					PrecLeft, Language)
		    ;  length(Remains2, Position),
		       Return = [error('missing ")"', [])/Position]
		  )
	     )
	  ;  write('Internal error No 2.'), nl, abort
				% this should never happen
	).


% constant
term_aux(constant(ConstantTerms), Tokens, Return, SpecLeft, PrecLeft,
		Language) :-
	term_infinite(Tokens, Return, ConstantTerms, SpecLeft, PrecLeft,
			Language).


% variable, number, float and string
term_aux(simple_object(Object), Tokens, Return, SpecLeft, PrecLeft, Language) :-
	term_infinite(Tokens, Return, [Object], SpecLeft, PrecLeft, Language).


% infix/postfix functions and predicates are missed out in T
term_aux(infix_function(_, _), Tokens,
		[error('unexpected infix function', [])/Position], _, _, _) :-
	length(Tokens, Position).
term_aux(postfix_function(_, _), Tokens,
		[error('unexpected postfix function', [])/Position], _, _, _) :-
	length(Tokens, Position).
term_aux(predicate(_), Tokens,
		[error('unexpected predicate', [])/Position], _, _, _) :-
	length(Tokens, Position).


/*------------------------------------------------------------------------------
 * term_infinite:
 *	LeftTerms is a list of terms of Term(8) on the immediate left side.
 */

term_infinite(Tokens, Return, LeftTerms, SpecLeft, PrecLeft, Language) :-
   term_prime(Tokens, Return2, SpecLeft, PrecLeft, Language),
   term_infinite_aux(Return2, Return, Tokens, LeftTerms, SpecLeft, PrecLeft).


term_infinite_aux([], [], _, _, _, _).
term_infinite_aux([Stack/Remains|Return], NewReturn, Tokens, LeftTerms,
			SpecLeft, PrecLeft) :-
   ( Stack = error(_, _)
     -> NewReturn = [Stack/Remains|NewReturn2]
     ;  ( pop(stack(SpecRight, PrecRight, _, TreeRight), Stack, _)
          -> ( null(SpecRight, PrecRight)
               -> length(Tokens, Position),
		  NewReturn = [error('operator expected', [])/Position|NewReturn2]
	       ;  ( ( null(SpecLeft, PrecLeft);
	              less_than(SpecLeft, PrecLeft, SpecRight, PrecRight);
		      ambiguous(SpecLeft, PrecLeft, SpecRight, PrecRight)
	            )
	            -> fill_holes(LeftTerms, Stack, NewStacks),
		       stack_to_return(NewStacks, Tokens, Remains, NewReturn,
					NewReturn2)
	            ;  ( bigger_than(SpecLeft, PrecLeft, SpecRight, PrecRight)
		         -> push_in_constants(LeftTerms, Stack, NewStacks2),
		            stack_to_return(NewStacks2, Tokens, Remains,
						NewReturn, NewReturn2)
		         ;  TreeRight = 'MetaDefs.Term.F2'(FuncRight, _),
			    length(Tokens, Position),
		            NewReturn = [error('misuse of operator "~w" (wrong precedence or associativity)', [FuncRight])/Position
					 |NewReturn2]
		       )
	         )
	     )
          ;  push_in_constants(LeftTerms, Stack, NewStacks3),
	     stack_to_return(NewStacks3, Tokens, Remains, NewReturn, NewReturn2)
			% equivalent to a push
        )
   ),
   term_infinite_aux(Return, NewReturn2, Tokens, LeftTerms, SpecLeft, PrecLeft).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

% This fills the HoleRight with one of LeftTerms.
fill_holes([LeftTerm], Stack, [Stack]) :-
	!,
	pop(stack(_, _, LeftTerm, _), Stack, _).
		% HoleRight is filled with LeftTerm straight away
fill_holes([LeftTerm|LeftTerms], Stack, [Stack2|NewStacks]):-
	copy_term(Stack, Stack2),
	pop(stack(_, _, LeftTerm, _), Stack2, _),
	fill_holes(LeftTerms, Stack, NewStacks).

% This pushs in a term of Term(8) into the stack.
push_in_constants([LeftTerm], Stack, [Stack2]) :-
	!,
	push(stack(null, _, no_hole, LeftTerm), Stack, Stack2).
push_in_constants([LeftTerm|LeftTerms], Stack, [Stack2|NewStacks]) :-
	copy_term(Stack, Stack3),
	push(stack(null, _, no_hole, LeftTerm), Stack3, Stack2),
	push_in_constants(LeftTerms, Stack, NewStacks).


/*------------------------------------------------------------------------------
 * check_term_token(+Token, -SymbolList, +Language)
 * It succeeds when Token is a valid in terms, and fails if Token is not
 * valid in Term.
 *	SymbolList is a list of elements in the form:
 *		Attribute/decl(Functor, Indicator),
 *		or null (not applicable)
 *	when Attribute is function_no_ind (or constant), the declaration part
 *	is a list of declarations, all function_no_ind (or constants) specified
 *	with that symbol.
 */

% This bit can be optimised by throwing away lists
check_term_token(little_name(Var), simple_object(VarRep), _) :-
   var_conversion(Var, 0, VarRep).

check_term_token('_'(Var), simple_object('MetaDefs.Var.F2'(GVar, Label)), _) :-
   string2Gstring(Var, GVar),
   underscore_label(Label).

check_term_token(string(String),
		simple_object('MetaDefs.Str.F1'(GString)), Language) :-
   lookup_base('"String', '"Strings', Language),
   string2Gstring(String, GString).

check_term_token(float(Float), simple_object('MetaDefs.Flo.F1'(Float)),
		Language) :-
   lookup_base('"Float', '"Floats', Language).

check_term_token(number(N), simple_object('MetaDefs.Num.F1'(N)), Language):-
   lookup_base('"Integer', '"Integers', Language).

check_term_token('[', list, _).
check_term_token('{', set, _).
check_term_token('(', bracket, _).
check_term_token(big_name(Name), SymbolList, Language) :-
   lookup_function_dict(big_name(Name), SymbolList, Language).
	% decide whether it's a constant, function_no_ind, prefix_function,
	%	infix_function, and postfix_function.
	%	Symbols of other kinds should not be included in SymbolList.
check_term_token(graphic_name(Name), SymbolList, Language) :-
   lookup_function_dict(graphic_name(Name), SymbolList, Language).


%------------------------------------------------------------------------------

var_conversion(Var, Label, VarRep) :-
   ( Var = 'v'
     -> VarRep = 'MetaDefs.Var.F1'(Label)
     ;  VarRep = 'MetaDefs.Var.F2'(GVar, Label),
	string2Gstring(Var, GVar)
   ).

/*------------------------------------------------------------------------------
 * This procedure assumes that every term in a term_seq should end at the same
 * place.  Can this be verified?
 * Error returns are removed from the sequence of terms.  If there is no valid
 * parse tree, term_seq is returned as an empty list.
 */

term_seq(Tokens, Remains, Term_seqs, Language, ErrorReturn) :-
   term_seq_aux(Tokens, Remains, Amb_term_seqs, Language, ErrorReturn2),
   cartesian_product(Amb_term_seqs, Term_seqs),
   ( Term_seqs = [],
     ErrorReturn2 = []
     -> length(Remains, Position),
	ErrorReturn = [error('"," or ")" expected', [])/Position]
     ;  ErrorReturn = ErrorReturn2
   ).


term_seq_aux(Tokens, Remains, Terms_seq, Language, ErrorReturn) :-
	term(Tokens, Return, null, _, Language),
	( select_return(Return, [',', ')'], Terms, Remains2, ErrorReturn2)
	  -> ( Terms = []	% indicating the term cannot be parsed
	       -> Terms_seq = [],
		  Remains = Remains2,
	          ( select_return(Return, null, Terms4, Remains4, _)
		    -> true
		    ;  write('Internal error No 3.'), nl, abort
		  ),
		  ( Terms4 = []
		    -> ErrorReturn = ErrorReturn2
		    ;  length(Remains4, Position),
		       ErrorReturn =
		        [error('")" or "," expected', [])/Position|ErrorReturn2]
		  )
	       ;  ( Remains2 = [')'|_]
		    -> Remains = Remains2,
		       ErrorReturn = [],
	               Terms_seq = [Terms]
		    ;  ( Remains2 = [','|Remains3]
			 -> term_seq_aux(Remains3, Remains, Terms_seq2,
						Language, ErrorReturn),
		            ( Terms_seq2 = []
			      -> Terms_seq = []
			      ;  Terms_seq = [Terms|Terms_seq2]
		            )
			 ;  Terms_seq = [],
			    length(Remains2, Position),
			    ErrorReturn = [error('incomplete term sequence or illegal symbol in term sequence', [])/Position]
		       )
		  )
	     )
	  ;  write('Internal error No 4.'), nl, abort
				% this should never happen
	).



/*------------------------------------------------------------------------------
 */

% This separates error returns and proper returns.  Returns not ended with
% a certain Token (e.g. ',') is also removed.
% NewRemains can be left uninstantiated when Terms is []

select_return([], _, [], _, []).
select_return([Stack/Remains|Rest], Terminators, Terms, NewRemains,
			ErrorReturn) :-
   ( Stack = error(_, _)
     -> ErrorReturn = [Stack/Remains|ErrorReturn2],
	Terms = Terms2
     ;  ErrorReturn = ErrorReturn2,
	select_valid_term(Terminators, Stack, Terms, Terms2,
		NewRemains, Remains)	% this should not fail, if it does so
					% it's an internal error.
   ),
   select_return(Rest, Terminators, Terms2, NewRemains, ErrorReturn2).

%------------------------------------------------------------------------------

select_valid_term(Terminators, Stack, Terms, Terms2, NewRemains,
	Remains) :-
   ( Stack = [stack(_, _, Hole, Term)], nonvar(Hole)
     -> select_valid_term_aux(Terminators, Term, Terms, Terms2,
		NewRemains, Remains)
     ;  Terms = Terms2             % ignore the error
   ).

% the case of accept all cases
select_valid_term_aux(null, Term, [Term|Terms], Terms, Remains, Remains).
% the case of accept only end_of_atom condition
select_valid_term_aux(end_of_atom, Term, Terms2, Terms, NewRemains, Remains) :-
   ( end_of_atom(Remains)
     -> Terms2 = [Term|Terms],
        NewRemains = Remains
     ;  Terms2 = Terms
   ).
% the same as null, but should not have been used
select_valid_term_aux([], Term, [Term|Terms], Terms, Remains, Remains).
% the case with a list of terminators
select_valid_term_aux([H|T], Term, Terms2, Terms, NewRemains, Remains) :-
   ( Remains = [Token|_]
     -> ( member_check(Token, [H|T])
	  -> Terms2 = [Term|Terms],	% when it ends at designated terminator
	     NewRemains = Remains	% accept it.
	  ;  Terms2 = Terms
	)
     ;  Terms2 = [Term|Terms],		% when it's the end of item, accept it.
	NewRemains = Remains
   ).

/*------------------------------------------------------------------------------
 * list(+Tokens, -Remains, +ListTerms, +Language, -ErrorReturn) :-
 *	ListTerms is a list of parse trees for the list term.
 *	ErrorReturn contains all the errors encountered in parsing the list.
 */

list(Tokens, Remains, ListTerms, Language, ErrorReturn) :-
	( Tokens = [ ']'|Remains]
	  -> ListTerms = ['MetaDefs.CTerm.F1'('MetaDefs.Name.F4'('"Lists',
				'"Nil', 'MetaDefs.Constant.C0', 0))]
	  ;  list_expr(Tokens, Remains2, ListTerms2, Language, ErrorReturn2),
	     ( ListTerms2 = []
	       -> ListTerms = [],
		  ErrorReturn = ErrorReturn2
	       ;  ( Remains2 = [']'|Remains3]
	            -> ListTerms = ListTerms2,
		       Remains = Remains3
	            ;  ListTerms = [],
		       length(Remains2, Position),
		       ErrorReturn = [error('missing "]"', [])/Position]
		  )
	     )
	).


list_expr(Tokens, Remains, ListTerms, Language, ErrorReturn) :-
   term(Tokens, Return, null, _, Language),
   ( select_return(Return, [graphic_name('|'), ',', ']' ], Terms, Remains2,
			ErrorReturn2)
     -> ( Terms = []	% indicating the term cannot be parsed
	  -> ( select_return(Return, null, Terms4, Remains4, _)
	       -> true
	       ;  write('Internal error No. 5'), nl, abort
	     ),
	     ( Terms4 = []
	       -> ErrorReturn = ErrorReturn2
	       ;  length(Remains4, Position),
		  ErrorReturn = [error('"|", "," or "]" expected', [])/Position|
				 ErrorReturn2]
	     ),
	     ListTerms = []
	  ;  ( Remains2 = [Token|Remains3]
	       -> ( list_expr_aux(Token, Remains3, Remains, Terms, ListTerms,
					ErrorReturn, Language)
		    -> true
		    ;  ListTerms = [],
		       length(Remains2, Position),
		       ErrorReturn = [error('illegal symbol in list: "~w"',
					[Token])/Position]
		  )
	       ;  ListTerms = [],
		  length(Remains2, Position),
		  ErrorReturn = [error('incomplete list', [])/Position]
	     )
         )
      ;  write('Internal error No 6.'), nl, abort
			% this should never happen
   ).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * list_expr_aux(+Token, +Tokens, -Remains, -Terms, -TailTerms, -ErrorReturn,
 *			+Language)
 *	Token identifies the three cases in a list structure.
 *	Terms is a list of heads.
 *	TailTerms is a list of tails.
 */

list_expr_aux(',', Remains2, Remains, Terms, TailTerms, ErrorReturn, Language):-
   list_expr(Remains2, Remains3, TailTerms2, Language, ErrorReturn2),
   ( TailTerms2 = []
     -> TailTerms = [],
	ErrorReturn = ErrorReturn2
     ;  ErrorReturn = [],
	Remains = Remains3,
	create_lists(Terms, TailTerms2, TailTerms, [])
   ).

list_expr_aux(']', Remains2, [']'|Remains2], Terms, TailTerms, [], _):-
   create_lists(Terms, ['MetaDefs.CTerm.F1'('MetaDefs.Name.F4'('"Lists',
			'"Nil', 'MetaDefs.Constant.C0', 0))], TailTerms, []).

list_expr_aux(graphic_name('|'), Remains2, Remains, Terms, TailTerms,
		ErrorReturn, Language):-
   ( Remains2 = [Token|Remains3]
     -> ( (  Token = little_name(V), Label = 0
	   ; Token = '_'(V), underscore_label(Label)
	  )
	  -> ErrorReturn = [],
	     Remains = Remains3,
	     var_conversion(V, Label, VarRep),
	     create_lists(Terms, [VarRep], TailTerms, [])
	  ;  ( Token = '['
	       -> list(Remains3, Remains4, TailTerms2, Language, ErrorReturn2),
		  ( TailTerms2 = []
		    -> TailTerms = [],
		       ErrorReturn = ErrorReturn2
		    ;  ErrorReturn = [],
		       Remains = Remains4,
		       create_lists(Terms, TailTerms2, TailTerms, [])
		  )
	       ;  length(Remains2, Position),
		  ErrorReturn = [error('illegal symbol in list: "~w"', [Token])/Position],
		  TailTerms = []
	     )
        )
     ;  TailTerms = [],
	length(Remains3, Position),
	ErrorReturn = [error('incomplete list', [])/Position]
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * Given a list of Terms and a list of TailTerms, create_lists create ambiguous
 * parse trees for the list.
 */

create_lists([], _, ListTerms, ListTerms).
create_lists([Term|Terms], TailTerms, ListTerms, ListTerms2) :-
	create_lists_aux(TailTerms, Term, ListTerms, ListTerms3),
	create_lists(Terms, TailTerms, ListTerms3, ListTerms2).


create_lists_aux([], _, ListTerms, ListTerms).
create_lists_aux([TailTerm|TailTerms], Term,
			['MetaDefs.Term.F2'('MetaDefs.Name.F4'('"Lists',
			     '"Cons', 'MetaDefs.Function.C0', 2),
			[Term, TailTerm])|ListTerms],
			ListTerms2) :-
	create_lists_aux(TailTerms, Term, ListTerms, ListTerms2).


/*------------------------------------------------------------------------------
 * set(+Tokens, -Remains, +SetTerms, +Language, -ErrorReturn) :-
 *	SetTerms is a set of parse trees for the set term.
 *	ErrorReturn contains all the errors encountered in parsing the set.
 */

set(Tokens, Remains, SetTerms, Language, ErrorReturn) :-
   ( Tokens = [ '}'(1000000000)|Remains]
     -> SetTerms = ['MetaDefs.CTerm.F1'('MetaDefs.Name.F4'('"Sets',
				'"Null', 'MetaDefs.Constant.C0', 0))]
     ;  set_expr(Tokens, Remains2, SetTerms2, Language, ErrorReturn2),
	( SetTerms2 = []
	  -> SetTerms = [],
	     ErrorReturn = ErrorReturn2
	  ;  ( Remains2 = ['}'(1000000000)|Remains3]
	       -> SetTerms = SetTerms2,
		  Remains = Remains3
	       ;  SetTerms = [],
		  length(Remains2, Position),
		  ErrorReturn = [error('missing "}"', [])/Position]
	     )
	)
   ).

%------------------------------------------------------------------------------

set_expr(Tokens, Remains, SetTerms, Language, ErrorReturn) :-
   term(Tokens, Return, null, _, Language),
   ( select_return(Return, [graphic_name('|'), graphic_name(':'), ',',
			'}'(1000000000)], Terms, Remains2, ErrorReturn2)
     -> ( Terms = []	% indicating the term cannot be parsed
	  -> ( select_return(Return, null, Terms4, Remains4, _)
	       -> true
	       ;  write('Internal error No 7.'), nl, abort
	     ),
	     ( Terms4 = []
	       -> ErrorReturn = ErrorReturn2
	       ;  length(Remains4, Position),
		  ErrorReturn =
			[error('"|", ":", "," or "}" expected', [])/Position|
			 ErrorReturn2]
	     ),
	     SetTerms = []
	  ;  ( Remains2 = [Token|Remains3]
	       -> ( set_expr_aux(Token, Remains3, Remains, Terms, SetTerms,
					ErrorReturn, Language)
		    -> true
		    ;  SetTerms = [],
		       length(Remains2, Position),
		       ( Token = '}'(_)
			 -> ErrorReturn = [error('illegal symbol in set: "~w"',
						['}'])/Position]
		         ;  ErrorReturn = [error('illegal symbol in set: "~w"',
					[Token])/Position]
		       )
		  )
	       ;  SetTerms = [],
		  length(Remains2, Position),
		  ErrorReturn = [error('incomplete set', [])/Position]
	     )
         )
      ;  write('Internal error No 8.'), nl, abort
			% this should never happen
   ).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * set_expr_aux(+Token, +Tokens, -Remains, -Terms, -TailTerms, -ErrorReturn,
 *			+Language)
 *	Token identifies the three cases in a set structure.
 *	Terms is a set of heads.
 *	TailTerms is a set of tails.
 */


set_expr_aux(',', Tokens, Remains, Terms, TailTerms, ErrorReturn, Language):-
   set_expr(Tokens, Remains3, TailTerms2, Language, ErrorReturn2),
   ( TailTerms2 = []
     -> TailTerms = [],
	ErrorReturn = ErrorReturn2
     ;  ErrorReturn = [],
	Remains = Remains3,
	create_sets(Terms, TailTerms2, TailTerms, [])
   ).

set_expr_aux('}'(1000000000), Tokens, ['}'(1000000000)|Tokens], Terms,
	TailTerms, [], _):-
   create_sets(Terms, ['MetaDefs.CTerm.F1'('MetaDefs.Name.F4'('"Sets', '"Null',
	'MetaDefs.Constant.C0', 0))], TailTerms, []).

set_expr_aux(graphic_name(':'), Tokens, Remains, Terms, TailTerms,
		ErrorReturn, Language):-  !,	% note the cut
   formula(Tokens, Return, Language),
   ( select_return(Return, null, Formulae, Remains, ErrorReturn2)
     -> ( Formulae = []
          -> TailTerms = [],
	     ErrorReturn = ErrorReturn2
          ;  Terms = [Term|_],
	     Formulae = [Formula|_],
	     collect_variables(Term, [], TVars),
	     collect_variables(Formula, [], FVars),
	     ( subset(TVars, FVars)
	       -> ErrorReturn = [],
	          create_intensional_set([Terms, Formulae], TailTerms)
	       ;  TailTerms = [],
	          set_minus(TVars, FVars, Rest),
		  strip_variables(Rest, Rest2),
	          length(Tokens, Position),
	          ErrorReturn = [error('bound variables "~w" in the intensional set do not occur in the formula', [Rest2])/Position]
	     )
       )
     ; write('Internal error No 9.'), nl, abort
   ).

set_expr_aux(graphic_name('|'), Tokens, Remains, Terms, TailTerms,
		ErrorReturn, Language):-
   ( Tokens = [Token|Remains3]
     -> ( (  Token = little_name(V), Label = 0
	   ; Token = '_'(V), underscore_label(Label)
	  )
	  -> var_conversion(V, Label, VarRep),
	     ErrorReturn = [],
	     Remains = Remains3,
	     create_sets(Terms, [VarRep], TailTerms, [])
%	     create_sets(Terms,
%		     ['MetaDefs.CTerm.F1'('MetaDefs.Name.F4'('"Sets', '"Null',
%			 'MetaDefs.Constant.C0', 0))], SetTerms, []),
%	     cartesian_product([SetTerms, [VarRep]], TermSeq),
%	     create_functions(
%		['MetaDefs.Name.F4'('"Sets', '"+', 'MetaDefs.Function.C0', 2)],
%		TermSeq, 2, TailTerms, [])
%  the organisation here should be done in the compiler.
	  ;  ( Token = '{'
	       -> set(Remains3, Remains4, TailTerms2, Language, ErrorReturn2),
		  ( TailTerms2 = []
		    -> TailTerms = [],
		       ErrorReturn = ErrorReturn2
		    ;  ErrorReturn = [],
		       Remains = Remains4,
		       create_sets(Terms, TailTerms2, TailTerms, [])
		  )
	       ;  length(Tokens, Position),
		  ( Token = '}'(_)
		    -> ErrorReturn = [error('illegal symbol in set: "~w"',
						['}'])/Position]
		    ;  ErrorReturn = [error('illegal symbol in set: "~w"',
					[Token])/Position]
		  ),
		  TailTerms = []
	     )
        )
     ;  TailTerms = [],
	length(Remains3, Position),
	ErrorReturn = [error('incomplete set', [])/Position]
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * Given a set of Terms and a set of TailTerms, create_sets create ambiguous
 * parse trees for the set.
 */

create_sets([], _, SetTerms, SetTerms).
create_sets([Term|Terms], TailTerms, SetTerms, SetTerms2) :-
	create_sets_aux(TailTerms, Term, SetTerms, SetTerms3),
	create_sets(Terms, TailTerms, SetTerms3, SetTerms2).


create_sets_aux([], _, SetTerms, SetTerms).
create_sets_aux([TailTerm|TailTerms], Term,
			['MetaDefs.Term.F2'('MetaDefs.Name.F4'('"Sets',
			     '"Inc', 'MetaDefs.Function.C0', 2),
			[Term, TailTerm])|SetTerms],
			SetTerms2) :-
	create_sets_aux(TailTerms, Term, SetTerms, SetTerms2).

%------------------------------------------------------------------------------

create_intensional_set(Terms, NewTerms) :-
   cartesian_product(Terms, Terms2),
   create_intensional_set_aux(Terms2, NewTerms).

create_intensional_set_aux([], []).
create_intensional_set_aux([[Term1, Term2]|TermSeqs],
	['MetaDefs.SuchThat.F2'(Term1, Term2)|NewTerms]) :-
   create_intensional_set_aux(TermSeqs, NewTerms).

/*------------------------------------------------------------------------------
 * term_prime(+Tokens, -Return, +SpecLeft, +PrecLeft, +Language).
 *	parameters are defined the same as term/6
 * term_prime recognises the termination of a term which are:
 *	empty, ')', ']', '}', ';', ',', '|'  predicate, connective,
 */

% partly corresponding to the grammar T' -> e
term_prime([], [[]/[]], _, _, _).

% corresponding to the grammar T' -> f3 T'| f4 T'| f5 T | f6 T | f7 T | e
term_prime([Token|Tokens], Return, SpecLeft, PrecLeft, Language):-
   ( end_of_term(Token)
     -> Return = [ []/[Token|Tokens] ]
     ;  ( check_term_token(Token, SymbolList, Language)
	  -> term_prime_aux(SymbolList, Tokens, Return2, SpecLeft,
				PrecLeft, Language),
	     ( Return2 = []
	       -> length(Tokens, Position),
		  Return = [ error('operator expected', [])/Position]
	       ;  Return = Return2
	     )
	  ;  length(Tokens, Position),
	     Return = [error('undeclared or illegal symbol in term: "~w"', [Token])/Position]
	)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

% Predicate is also a sign of end-of-term, delt in term_prime_aux
end_of_term(',') :- !.
end_of_term(';') :- !.
end_of_term(':') :- !.
end_of_term(']') :- !.
end_of_term(graphic_name(Name)) :- !,
   end_of_term(Name).
end_of_term(Token) :-
   end_of_atom(Token).

/*------------------------------------------------------------------------------
 */

% The following two predicate of term_prime_aux copes with overloading
term_prime_aux([], _, [], _, _, _).

term_prime_aux([Decl|SymbolList], Tokens, Return, SpecLeft, PrecLeft,
		Language) :-
	term_prime_aux(Decl, Tokens, Return2, SpecLeft, PrecLeft, Language),
	term_prime_aux(SymbolList, Tokens, Return3, SpecLeft, PrecLeft,
			Language),
	append(Return3, Return2, Return).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

% corresponding to the grammar T' -> f3 T'| f4 T'
term_prime_aux(postfix_function(Functor, Indicator), Tokens, Return, SpecLeft,
		PrecLeft, Language):-
   Indicator =.. [SpecOp, PrecOp],
   term_prime(Tokens, Return2, SpecOp, PrecOp, Language),
   term_prime_postfix(Return2, Return, Tokens, SpecLeft, PrecLeft, Functor,
			    SpecOp, PrecOp).

term_prime_postfix([], [], _, _, _, _, _, _).
term_prime_postfix([Stack/Remains|Return], NewReturn, Tokens, SpecLeft,
	PrecLeft, Functor, SpecOp, PrecOp):-
   ( Stack = error(_, _)
     -> NewReturn = [Stack/Remains|NewReturn2]
     ; ( pop(stack(SpecRight, PrecRight, _, TreeRight), Stack, _)
         -> ( null(SpecRight, PrecRight)
	      -> length(Tokens, Position),
		 NewReturn = [ error('error with unknown reason', [])/Position
			      | NewReturn2]
	      ;  ( bigger_than(SpecOp, PrecOp, SpecRight, PrecRight)
	           -> ( ( null(SpecLeft, PrecLeft);
	                  less_than(SpecLeft, PrecLeft, SpecOp, PrecOp)
		        )
		        -> contract(Stack, SpecLeft, PrecLeft,
			            stack(SpecOp, PrecOp, Hole,
					'MetaDefs.Term.F2'(Functor, [Hole])),
			            Stacks),
		           stack_to_return(Stacks, Tokens, Remains, NewReturn,
					NewReturn2)
	                ;  ( ( bigger_than(SpecLeft, PrecLeft, SpecOp, PrecOp);
			       ambiguous(SpecLeft, PrecLeft, SpecOp, PrecOp)
			     )
			     -> NewReturn = [Stack2/Remains|NewReturn2],
				push(stack(SpecOp, PrecOp, Hole,
					'MetaDefs.Term.F2'(Functor, [Hole])),
					Stack, Stack2)
			     ;  length(Tokens, Position),
				NewReturn = [ error('misuse of operator "~w" (wrong precedence or associativity', [Functor])/Position
					     | NewReturn2]
		           )
		      )
	           ;  TreeRight = 'MetaDefs.Term.F2'(FuncRight, _),
		      length(Tokens, Position),
		      NewReturn = [ error('wrong precedence or associativity between operators "~w" and "~w"', [Functor, FuncRight])/Position
				   | NewReturn2]
	         )
	    )
         ;  NewReturn = [ [stack(SpecOp, PrecOp, Hole,
			   'MetaDefs.Term.F2'(Functor, [Hole]))]/Remains
			 | NewReturn2 ]
       )
   ),
   term_prime_postfix(Return, NewReturn2, Tokens, SpecLeft, PrecLeft,
			Functor, SpecOp, PrecOp).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

% corresponding to the grammar T' -> f5 T | f6 T | f7 T
term_prime_aux(infix_function(Functor, Indicator), Tokens, Return, SpecLeft,
		PrecLeft, Language):-
   Indicator =.. [SpecOp, PrecOp],
   term(Tokens, Return2, SpecOp, PrecOp, Language),
   term_prime_infix(Return2, Return, Tokens, SpecLeft, PrecLeft,
		       Functor, SpecOp, PrecOp).


term_prime_infix([], [], _, _, _, _, _, _).
term_prime_infix([Stack/Remains|Return], NewReturn, Tokens, SpecLeft, PrecLeft,
		Functor, SpecOp, PrecOp):-
   ( Stack = error(_, _)
     -> NewReturn = [Stack/Remains|NewReturn2]
     ; ( pop(stack(SpecRight, PrecRight, HoleRight, TreeRight), Stack, Stack2),
         nonvar(HoleRight)
         -> ( ( null(SpecRight, PrecRight);
	        less_than(SpecOp, PrecOp, SpecRight, PrecRight)
	      )
	      -> contract(Stack2, SpecLeft, PrecLeft,
			    stack(SpecOp, PrecOp, Hole,
				'MetaDefs.Term.F2'(Functor, [Hole, TreeRight])),
		          Stacks),
		 stack_to_return(Stacks, Tokens, Remains, NewReturn, NewReturn2)
	      ;  ( ambiguous(SpecOp, PrecOp, SpecRight, PrecRight)
	           -> % assume PrecOp < PrecRight
		      copy_term(Stack2, NewStack2),
		      contract(Stack2, SpecLeft, PrecLeft,
		               stack(SpecOp, PrecOp, Hole,
			        'MetaDefs.Term.F2'(Functor, [Hole, TreeRight])),
			       Stacks2),
		      stack_to_return(Stacks2, Tokens, Remains, NewReturn3,
					NewReturn2),
		      % assume PrecOp > PrecRight
		      TreeRight = 'MetaDefs.Term.F2'(FuncRight, [Argu|Argus]),
		      contract(NewStack2, SpecLeft, PrecLeft,
			       stack(SpecRight, PrecRight, Hole2,
				'MetaDefs.Term.F2'(FuncRight,
				['MetaDefs.Term.F2'(Functor, [Hole2, Argu])
				  |Argus])),
			       Stacks3),
		      stack_to_return(Stacks3, Tokens, Remains, NewReturn,
					NewReturn3)
	           ;  TreeRight = 'MetaDefs.Term.F2'(FuncRight, _),
		      length(Tokens, Position),
		      NewReturn = [ error('wrong precedence or associativity between operators "~w" and "~w"', [Functor, FuncRight])/Position
				   | NewReturn2]
	         )
	    )
         ;  length(Tokens, Position),
	    NewReturn = [ error('misuse of infix function "~w"', [Functor])/Position
			 |NewReturn2]
       )
   ),
   term_prime_infix(Return, NewReturn2, Tokens, SpecLeft, PrecLeft,
			Functor, SpecOp, PrecOp).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

% variable, list, string, number, constant, float, and prefix functions
% are missed out in T', because they are not legal in T'.
term_prime_aux(prefix_function(_, _), Tokens,
		[error('unexpected prefix function', [])/Position], _, _, _):-
   length(Tokens, Position).
term_prime_aux(function_no_ind(_), Tokens,
		[error('unexpected function of no indicator', [])/Position],
		_, _, _):-
   length(Tokens, Position).
term_prime_aux(constant(_), Tokens,
		[error('unexpected constant', [])/Position], _, _, _):-
   length(Tokens, Position).
term_prime_aux(simple_object(_), Tokens,
		[error('unexpected variable/string/integer/float', [])
		      /Position], _, _, _):-
   length(Tokens, Position).
term_prime_aux(list, Tokens,
		[error('unexpected list', [])/Position], _, _, _):-
   length(Tokens, Position).
term_prime_aux(set, Tokens,
		[error('unexpected set', [])/Position], _, _, _):-
   length(Tokens, Position).
term_prime_aux(bracket, Tokens,
		[error('unexpected "("', [])/Position], _, _, _):-
   length(Tokens, Position).
% predicate as a terminator for terms
term_prime_aux(predicate(Token), Tokens, [ []/[Token|Tokens] ], _, _, _).


/*------------------------------------------------------------------------------
 * Operator relations
 * bigger_than, less_than and ambiguous fails if one of the indicator
 * is not defined.
 */


% null(Specifier, Precedence)
null(null, _).


bigger_than(_, PrecLeft, _, PrecRight):-
	( var(PrecLeft);
	  var(PrecRight)
	), !, fail.
bigger_than(_, PrecLeft, _, PrecRight):- PrecLeft > PrecRight, !.
bigger_than('Syntax.YFX.F1', Prec, 'Syntax.YFX.F1', Prec):- !.
bigger_than('Syntax.YFX.F1', Prec, 'Syntax.YF.F1', Prec):- !.
bigger_than('Syntax.XFX.F1', Prec, 'Syntax.YFX.F1', Prec):- !.
bigger_than('Syntax.XFX.F1', Prec, 'Syntax.YF.F1', Prec):- !.
bigger_than('Syntax.FX.F1', Prec, 'Syntax.YFX.F1', Prec):- !.
bigger_than('Syntax.FX.F1', Prec, 'Syntax.YF.F1', Prec):- !.
bigger_than('Syntax.XF.F1', Prec, 'Syntax.YFX.F1', Prec):- !.
bigger_than('Syntax.XF.F1', Prec, 'Syntax.YF.F1', Prec):- !.
bigger_than('Syntax.YF.F1', Prec, 'Syntax.YFX.F1', Prec):- !.
bigger_than('Syntax.YF.F1', Prec, 'Syntax.YF.F1', Prec).


less_than(_, PrecLeft, _, PrecRight):-
	( var(PrecLeft);
	  var(PrecRight)
	), !, fail.
less_than(_, PrecLeft, _, PrecRight):-		PrecLeft < PrecRight, !.
less_than('Syntax.XFY.F1', Prec, 'Syntax.XFX.F1', Prec):- !.
less_than('Syntax.XFY.F1', Prec, 'Syntax.XFY.F1', Prec):- !.
less_than('Syntax.XFY.F1', Prec, 'Syntax.XF.F1', Prec):- !.
less_than('Syntax.FY.F1', Prec, 'Syntax.XFX.F1', Prec):- !.
less_than('Syntax.FY.F1', Prec, 'Syntax.XFY.F1', Prec):- !.
less_than('Syntax.FY.F1', Prec, 'Syntax.XF.F1', Prec):- !.
less_than('Syntax.XFY.F1', Prec, 'Syntax.FX.F1', Prec):- !.
less_than('Syntax.XFY.F1', Prec, 'Syntax.FY.F1', Prec):- !.
less_than('Syntax.FY.F1', Prec, 'Syntax.FX.F1', Prec):- !.
less_than('Syntax.FY.F1', Prec, 'Syntax.FY.F1', Prec).


ambiguous('Syntax.XFY.F1', Prec, 'Syntax.YFX.F1', Prec):- !.
ambiguous('Syntax.XFY.F1', Prec, 'Syntax.YF.F1', Prec):- !.
ambiguous('Syntax.FY.F1', Prec, 'Syntax.YFX.F1', Prec):- !.
ambiguous('Syntax.FY.F1', Prec, 'Syntax.YF.F1', Prec).


/*------------------------------------------------------------------------------
 * Stack operations
 */

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * push(+Element, +Stack, -NewStack)
 */

push(Element, Stack, [Element|Stack]).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * pop(-Element, +Stack, -NewStack)
 * it fails if the stack is empty.
 */

pop(Element, [Element|Stack], Stack).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

stack_to_return([], _, _, NewReturn, NewReturn).
stack_to_return([Stack|Stacks], Tokens, Remains, NewReturn, NewReturn2) :-
	( Stack = error(A, B)
	  -> length(Tokens, Position),
	     NewReturn = [error(A, B)/Position|NewReturn3]
	  ;  NewReturn = [Stack/Remains|NewReturn3]
	),
	stack_to_return(Stacks, Tokens, Remains, NewReturn3, NewReturn2).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * contract(+Stack, +SpecLeft, +PrecLeft, +Element, -NewStack)
 * this predicate contracts the stack into normal form, as defined in the
 * algorithm
 * It assumes that the IndOp (in Element) can not be 'null'
 */

contract([], _, _, Element, [[Element]]).
contract([stack(SpecRight, PrecRight, HoleRight, TreeRight)|Stack2],
		SpecLeft, PrecLeft,
		stack(SpecOp, PrecOp, HoleOp, TreeOp), NewStacks):-
   ( ( null(SpecLeft, PrecLeft);
       less_than(SpecLeft, PrecLeft, SpecOp, PrecOp)
     ),
     ( bigger_than(SpecOp, PrecOp, SpecRight, PrecRight);
       ambiguous(SpecOp, PrecOp, SpecRight, PrecRight)
     )
     -> ( ( null(SpecLeft, PrecLeft);
	    less_than(SpecLeft, PrecLeft, SpecRight, PrecRight)
	  )
	  -> HoleRight = TreeOp,
			% not sure if I need to test the HoleRight or not
	     contract(Stack2, SpecLeft, PrecLeft,
		   stack(SpecRight, PrecRight, HoleOp, TreeRight), NewStacks)
	  ;  ( bigger_than(SpecLeft, PrecLeft, SpecRight, PrecRight)
	       -> NewStacks = [[stack(SpecOp, PrecOp, HoleOp, TreeOp),
				stack(SpecRight, PrecRight, HoleRight,TreeRight)
			       | Stack2]
			      ]
	       ;  ( ambiguous(SpecLeft, PrecLeft, SpecRight, PrecRight)
		    -> % the ambiguous case, create two parse trees
		       copy_term(quintet(HoleRight, TreeRight, HoleOp,
					TreeOp, Stack2),
				 quintet(NewHoleRight, NewTreeRight,
					NewHoleOp, NewTreeOp, NewStack2)),
			    % create a parse tree where PrecLeft < PrecRight
		       HoleRight = TreeOp,
			    % not sure if I need to test the HoleRight or not
			    % I thin  there is no need, because terms are
			    % formed only when there is enough information
			    % about the precedence.
		       NewStacks = [ [stack(SpecOp, PrecOp,NewHoleOp,NewTreeOp),
				      stack(SpecRight, PrecRight, NewHoleRight,
						NewTreeRight)
				      | NewStack2
				     ]
				    | NewStacks2],
		       contract(Stack2, SpecLeft, PrecLeft,
				stack(SpecRight, PrecRight, HoleOp, TreeRight),
				NewStacks2)
		    ; NewStacks = [ error('misuse of operators/connectives (wrong precedence or associativity)', []) ]
		      % old fragment
		      % arg(1, TreeRight, FuncRight),
		      % NewStacks = [ error('misuse of operator "~w" (wrong precedence or associativity)', [FuncRight]) ]
		      % this is a strange error message
		  )
	     )
        )
     ;  NewStacks = [ [stack(SpecOp, PrecOp, HoleOp, TreeOp),
		       stack(SpecRight, PrecRight, HoleRight, TreeRight)
		       | Stack2]
		    ]
   ).

:- style_check(-singleton). % added djd

% Copyright (C) Goedel Group, University of Bristol, June 1992.
% Title and ownership of all Goedel software originating from the Goedel
% Group at the University of Bristol remains with the Goedel Group.
%
% The Goedel language was designed by P.M. Hill and J.W. Lloyd, and the
% language was implemented by A. Bowers and J. Wang. The design and
% implementation of the language was partly supported by the ESPRIT Basic
% Research Action 3012 (Compulog), a SERC Grant GR/F/26256, and the
% University of Bristol.
%
% This software is available ONLY for research and educational purposes.
% In particular, it may not be used for any commercial purpose whatsoever.
% The software is free and is provided "as is", without warranty of any kind.
% Users of the software are free to modify and experiment with it for
% research and educational purposes. However, users may not distribute
% the software (modified or not) to third parties without the express
% permission of the Goedel Group. The normal method of obtaining this
% software is by ftp from ftp.cs.kuleuven.ac.be.
%
% Any enquiries about this copyright notice or the use of this software
% should be directed to J.W. Lloyd at jwl@compsci.bristol.ac.uk.


/*
File:		formula.pl
Subject:	handling formula
Author:		Jiwei Wang
Date:		18 November 1991, starting the ambiguous parser.

================================================================================
*/

%% '$$module'('@(#)formula.pl 1.34 last updated 93/05/23 18:24:43 by jiwei').

:- module(formula).  % converted djd

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * Again we use the recursive descent parsing method.
 *
 * The original grammars for formula are transformed by unfolding and assigning
 * precedences to connectives as:

  Formula(8) ->   Proposition
		| PredicateNoInd(n) ( TermSeq(n) )
		| PredicateInd(1,Pz) Term
		| Term PredicateInd(1,zP)
		| Term PredicateInd(2,zPz) Term
		| Term Less Variable Less Term
		| Term Greater Variable Greater Term
		| Term = Term
		| Term ~= Term
		| ~ Formula(8)
		| SOME [ VariableSeq ] Formula(8)
		| ALL [ VariableSeq ] Formula(8)
		| ( Formula(f1) )
		| Conditional

  Formula(f) ->   Formula(f2) & Formula(f3)
		| Formula(f2) \/ Formula(f3)
		| Formula(f2) <- Formula(f3)
		| Formula(f2) -> Formula(f3)
		| Formula(f2) <-> Formula(f3)
  Precedence:
		&   : xFy(100);
		\/  : xFy(90);
		->  : xFy(80);
		<-  : xFy(80);
		<-> : xFx(80);

  Less ->	 < | =<

  Greater ->	 > | >=


 * These grammars can then be rewritten as:
 *
 *	F -> a | F c1 F | F c2 F | F c3 F | F c4 F| F c5 F
 *
 * where a stands for formulas in Formula(8), ci is a connective.
 *
 * The transformed grammars (with left recursion removed) are as follows:
 *
 *	F  -> a F'
 *	F' -> c1 F F'| c2 F F' | c3 F F' | c4 F F' | c5 F F' | e
 *
 * where e is the empty string.
 * Replace F F' by F (because they are equivalent), we have
 *
 *	F  -> a F'
 *	F' -> c1 F | c2 F | c3 F | c4 F | c5 F | e
 *
 *
 *	The parser for formulae is very close to that for terms, except that
 * there is no ambiguous connectives.
 */


/*------------------------------------------------------------------------------
 * All predicates in this file should be assume to be always succeed (unless
 * stated) and leave no choice points behind.
 *----------------------------------------------------------------------------*/

/*------------------------------------------------------------------------------
 * formula(+Tokens, -Return, +Language).
 * formula(+Tokens, -Return, +SpecLeft, +PrecLeft, +Language):-
 *	Token:		one look ahead token
 *	Tokens:		tokens to be parsed
 *	Language:	language of the module
 *	Return:		the returned parse result.  It is a list of:
 *				Stack/Remains or error(A,B)/Remains
 *	  Remains:	tokens left unparsed
 *	  Stack:	a list of:
 *			stack(Spec, Prec, Hole, ParseTree)
 *			where Spec and Prec is the indicator of the major
 *			operator in the parse tree, Hole is an unfilled position
 *			in ParseTree.
 *	  ParseTree:	a structure of the form:
 *			see ground representation
 *	  Indicator:	Indicator of the major connective in the formula,
 *			consisting Spec and Prec. Spec can be a specifier and
 *			'null'.
 *
 *	SpecLeft:	specifier of the immediately left operator, can be
 *			'null' when there is no operator at the left.
 *	PrecLeft:	precedence of the immediately left operator, can be
 *			a positive integer or uninstantiated, indicating
 *			not applicable.
 */

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * formula/3
 */

formula(Tokens, Return, Language):-
	formula(Tokens, Return, null, _, Language).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * formula(+Tokens, -Return, +SpecLeft, +PrecLeft, +Language):-
 */

formula([], [], _, _, _).

formula([Token|Tokens], Return, SpecLeft, PrecLeft, Language):-
   ( check_formula_token(Token, SymbolList, Language)
     -> formula_aux(SymbolList, Tokens, Return2, SpecLeft, PrecLeft, Language),
        ( Return2 = []
	  -> length(Tokens, Position),
	     Return = [error('formula expected', [])/Position]
	  ;  Return = Return2
	)
     ;  length(Tokens, Position),
	Return = [error('undeclared or illegal symbol: "~w"', [Token])/Position]
   ).

/*------------------------------------------------------------------------------
 * formula_aux(+SymbolList, +Tokens, -Return, +SpecLeft, +PrecLeft, +Language)
 *	for predicate of no indicator and proposition, Decl is a list
 *
 * error handling in formulas of predicate_no_ind, (Formula):
 *	if there is an valid parsing for this formula, the errors encountered
 *	inside the formula is discarded, otherwise they are returned.
 *
 * Just to speed things up, a list of symbol and an element is not
 * distinguished in formula_aux
 */


formula_aux([], _, [], _, _, _).

formula_aux([Decl|SymbolList], Tokens, Return, SpecLeft, PrecLeft, Language) :-
   formula_aux(Decl, Tokens, Return2, SpecLeft, PrecLeft, Language),
   formula_aux(SymbolList, Tokens, Return3, SpecLeft, PrecLeft, Language),
   append(Return3, Return2, Return).

%- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

formula_aux(proposition(LeftAtoms), Tokens, Return, SpecLeft, PrecLeft,
		Language) :-
   formula_infinite(Tokens, Return, LeftAtoms, SpecLeft, PrecLeft, Language).

formula_aux(term(Token), Tokens, Return, SpecLeft, PrecLeft, Language) :-
   atom(term(Token), Tokens, Remains, LeftAtoms, ErrorReturn, Language),
   ( LeftAtoms = []
     -> Return = ErrorReturn
     ;  formula_infinite(Remains, Return, LeftAtoms, SpecLeft, PrecLeft,
			Language)
   ).

formula_aux(predicate_no_ind(Decls), Tokens, Return, SpecLeft, PrecLeft,
		Language) :-
   atom(predicate_no_ind(Decls), Tokens, Remains, LeftAtoms, ErrorReturn,
		Language),
   ( LeftAtoms = []
     -> Return = ErrorReturn
     ;  formula_infinite(Remains, Return, LeftAtoms, SpecLeft, PrecLeft,
			Language)
   ).

formula_aux(prefix_predicate(Decls), Tokens, Return, SpecLeft, PrecLeft,
		Language) :-
   atom(prefix_predicate(Decls), Tokens, Remains, LeftAtoms, ErrorReturn,
			Language),
   ( LeftAtoms = []
     -> Return = ErrorReturn
     ;  formula_infinite(Remains, Return, LeftAtoms, SpecLeft, PrecLeft,
			Language)
   ).

% This bracket can be a bracket for either a term or a formula
formula_aux(bracket(Token), Tokens, Return, SpecLeft, PrecLeft, Language) :-
   atom(bracket(Token), Tokens, Remains, LeftAtoms, ErrorReturn, Language),
   ( LeftAtoms = []
     -> Return = ErrorReturn
     ;  formula_infinite(Remains, Return, LeftAtoms, SpecLeft, PrecLeft,
			Language)
   ).

% Formula(0) and Formula(1) are taken as Atoms.
% This is only for the convenience reasons.
formula_aux('~', Tokens, Return, SpecLeft, PrecLeft, Language) :-
   atom('~', Tokens, Remains, LeftAtoms, ErrorReturn, Language),
   ( LeftAtoms = []
     -> Return = ErrorReturn
     ;  formula_infinite(Remains, Return, LeftAtoms, SpecLeft, PrecLeft,
			Language)
   ).

formula_aux('SOME', Tokens, Return, SpecLeft, PrecLeft, Language) :-
   atom('SOME', Tokens, Remains, LeftAtoms, ErrorReturn, Language),
   ( LeftAtoms = []
     -> Return = ErrorReturn
     ;  formula_infinite(Remains, Return, LeftAtoms, SpecLeft, PrecLeft,
			Language)
   ).

formula_aux('ALL', Tokens, Return, SpecLeft, PrecLeft, Language) :-
   atom('ALL', Tokens, Remains, LeftAtoms, ErrorReturn, Language),
   ( LeftAtoms = []
     -> Return = ErrorReturn
     ;  formula_infinite(Remains, Return, LeftAtoms, SpecLeft, PrecLeft,
			Language)
   ).

formula_aux('IF', Tokens, Return, SpecLeft, PrecLeft, Language) :-
   conditional(Tokens, Remains, LeftAtoms, ErrorReturn, Language),
   ( LeftAtoms = []
     -> Return = ErrorReturn
     ;  formula_infinite(Remains, Return, LeftAtoms, SpecLeft, PrecLeft,
			Language)
   ).

% symbols missed out in F
formula_aux(infix_predicate(_), Tokens,
		[error('unexpected infix predicate', [])/Position], _, _, _) :-
   length(Tokens, Position).
formula_aux(postfix_predicate(_), Tokens,
		[error('unexpected postfix predicate', [])/Position], _, _, _):-
   length(Tokens, Position).
formula_aux(end_of_formula(_), _, [], _, _, _).
formula_aux(connective(_, _), Tokens,
		[error('unexpected connective', [])/Position], _, _, _):-
   length(Tokens, Position).

/*------------------------------------------------------------------------------
 * variable_seq sucks in the left and right square brackets
 *	VarList = [] is the error signal.
 */

variable_seq([], [], [], [error('left square bracket expected', [])/0]).
variable_seq([Token|Tokens], Remains, VarList, ErrorReturn) :-
	( Token = '['
	  -> variable_seq_aux(Tokens, Remains2, VarList2, ErrorReturn2),
	     ( ErrorReturn2 = []
	       -> ( Remains2 = [ ']'|Remains ]
	            -> VarList = VarList2,
		       ErrorReturn = ErrorReturn2
	            ;  VarList = [],
		       length(Remains2, Position),
		       ErrorReturn = [error('missing "]"', [])/Position]
	          )
	       ;  VarList = [],
		  ErrorReturn = ErrorReturn2
	     )
	  ;  VarList = [],
	     length(Tokens, Position),
	     ErrorReturn = [error('missing "["', [])/Position]
	).


% ErrorReturn = [] is the correct signal.
% make sure this won't fail
variable_seq_aux([], [], [], [error('incomplete variable sequence', [])/0]).
variable_seq_aux([Token|Tokens], Remains, VarList, ErrorReturn) :-
   ( ( Token = little_name(Var), Label = 0;
       Token = '_'(Var), underscore_label(Label)
     )
     -> var_conversion(Var, Label, VarRep),
        VarList = [VarRep|VarList2],
	variable_seq_aux(Tokens, Remains, VarList2, ErrorReturn)
     ;  ( Token = ','
	  -> variable_seq_aux(Tokens, Remains, VarList, ErrorReturn)
	  ;  ( Token = ']'
	       -> VarList = [],
		  Remains = [ ']'|Tokens],
		  ErrorReturn = []
	       ;  length(Tokens, Position),
		  ErrorReturn = [error('nonvariable symbol in variable sequence', [])/Position]
	     )
	)
   ).

/*------------------------------------------------------------------------------
 * formula_infinite:
 *	LeftAtoms is a list of formulas of Term(8) on the immediate left side.
 */

formula_infinite(Tokens, Return, LeftAtoms, SpecLeft, PrecLeft, Language) :-
   formula_prime(Tokens, Return2, SpecLeft, PrecLeft, Language),
   formula_infinite_aux(Return2, Return, Tokens, LeftAtoms, SpecLeft, PrecLeft).


formula_infinite_aux([], [], _, _, _, _).
formula_infinite_aux([Stack/Remains|Return], NewReturn, Tokens, LeftAtoms,
			SpecLeft, PrecLeft) :-
   ( Stack = error(_, _)
     -> NewReturn = [Stack/Remains|NewReturn2]
     ;  ( pop(stack(SpecRight, PrecRight, _, _), Stack, _)
          -> ( null(SpecRight, PrecRight)
               -> length(Tokens, Position),
		  NewReturn = [error('connective expected', [])/Position|NewReturn2]
	       ;  ( ( null(SpecLeft, PrecLeft);
	              less_than(SpecLeft, PrecLeft, SpecRight, PrecRight)
	            )
	            -> fill_holes(LeftAtoms, Stack, NewStacks),
		       stack_to_return(NewStacks, Tokens, Remains, NewReturn,
					NewReturn2)
	            ;  ( bigger_than(SpecLeft, PrecLeft, SpecRight, PrecRight)
		         -> push_in_constants(LeftAtoms, Stack, NewStacks2),
		            stack_to_return(NewStacks2, Tokens, Remains,
						NewReturn, NewReturn2)
		         ;  length(Tokens, Position),
			    NewReturn = [error('misuse of connectives', [])/Position
					 |NewReturn2]
		       )
	         )
	     )
          ;  push_in_constants(LeftAtoms, Stack, NewStacks3),
	     stack_to_return(NewStacks3, Tokens, Remains, NewReturn, NewReturn2)
			% equivalent to a push
        )
   ),
   formula_infinite_aux(Return, NewReturn2, Tokens, LeftAtoms, SpecLeft,
		PrecLeft).


/*------------------------------------------------------------------------------
 * formula_prime(+Tokens, -Return, +SpecLeft, +PrecLeft, +Language).
 *	parameters are defined the same as formula/6
 */

% partly corresponding to the grammar F' -> e
formula_prime([], [[]/[]], _, _, _).

% corresponding to the grammar F' -> f1 F | f2 F | f3 F | f4 F | f5 F | e
formula_prime([Token|Tokens], Return, SpecLeft, PrecLeft, Language):-
   ( end_of_formula([Token|Tokens], Language)
     -> Return = [[]/[Token|Tokens]]
     ;  ( connective(Token, SymbolList)
	  -> formula_prime_aux(SymbolList, Tokens, Return, SpecLeft, PrecLeft,
			Language)
	  ;  length(Tokens, Position),
	     Return = [error('connective expected', [])/Position]
	)
   ).

end_of_formula([Token|Tokens], Language) :-
   ( end_of_formula_aux(Token)
     -> true
     ;  Token = graphic_name('&'),	% the start of a CFormula
	start_of_cformula(Tokens, Language)
   ).

end_of_formula_aux(')').
end_of_formula_aux('}'(_)).
end_of_formula_aux(graphic_name('|')).
end_of_formula_aux(big_name(Name)) :-
   end_of_formula_aux(Name).

end_of_formula_aux('THEN').
end_of_formula_aux('ELSE').
end_of_formula_aux('UNTIL').


start_of_cformula([Token|Tokens], Language) :-
   ( Token = '{'
     -> term_aux(set, Tokens, Return, null, _, Language),
	( select_return(Return, null, Terms, _, _)
	  -> Terms = []
	  ;  write('Internal error No. 10'), nl, abort
	)
		% a test that it's not set.
     ;  Token = '(',
	start_of_cformula(Tokens, Language)
   ).


connective(graphic_name(Name), SymbolList) :-  connective(Name, SymbolList).
connective('&', connective('MetaDefs.&''.F2', 'Syntax.XFY.F1'(150))).
connective('\\/', connective('MetaDefs.\\/''.F2', 'Syntax.XFY.F1'(140))). % added 2 \ djd
connective('->', connective('MetaDefs.->''.F2', 'Syntax.XFY.F1'(120))).
connective('<-', connective('MetaDefs.<-''.F2', 'Syntax.XFY.F1'(120))).
connective('<->', connective('MetaDefs.<->''.F2', 'Syntax.XFX.F1'(120))).

/*------------------------------------------------------------------------------
 */

% corresponding to the grammar F' -> f5 F | f6 F | f7 F
formula_prime_aux(connective(Connective, Indicator), Tokens, Return, SpecLeft,
		PrecLeft, Language):-
   Indicator =.. [SpecOp, PrecOp],
   formula(Tokens, Return2, SpecOp, PrecOp, Language),
   formula_prime_connective(Return2, Return, Tokens, SpecLeft, PrecLeft,
			Connective, SpecOp, PrecOp).


formula_prime_connective([], [], _, _, _, _, _, _).
formula_prime_connective([Stack/Remains|Return], NewReturn, Tokens, SpecLeft,
	PrecLeft, Connective, SpecOp, PrecOp):-
   ( Stack = error(_, _)
     -> NewReturn = [Stack/Remains|NewReturn2]
     ; ( pop(stack(SpecRight, PrecRight, HoleRight, TreeRight), Stack, Stack2),
         nonvar(HoleRight)
         -> ( ( null(SpecRight, PrecRight);
	        less_than(SpecOp, PrecOp, SpecRight, PrecRight)
	      )
	      -> Formula =.. [Connective, Hole, TreeRight],
	         contract(Stack2, SpecLeft, PrecLeft,
			  stack(SpecOp, PrecOp, Hole, Formula), Stacks),
		 stack_to_return(Stacks, Tokens, Remains, NewReturn, NewReturn2)
	      ;  length(Tokens, Position),
		 NewReturn = [error('misuse of connective "~w"', [Connective])/Position | NewReturn2]
	    )
         ;  length(Tokens, Position),
	    NewReturn = [error('misuse of connective "~w"', [Connective])/Position
			 |NewReturn2]
       )
   ),
   formula_prime_connective(Return, NewReturn2, Tokens, SpecLeft, PrecLeft,
			Connective, SpecOp, PrecOp).

/*------------------------------------------------------------------------------
 * check_formula_token(+Token, -SymbolList, +Language)
 * decides whether it's a term token, a reserved word, a proposition,
 * a prefix_predicate, an infix_predicate, or a postfix_predicate.
 * Symbols of other kinds (base and constructor names) should not be included
 * in SymbolList.
 * It succeeds when Token is a valid in formulae (bases and constructors are
 * not regarded as valid token in formulae), and fails when Token is not
 * declared.
 *	SymbolList is a list of elements in the form:
 *		Attribute/Token
 *		or when Attribute denoting connective, it is of the form
 *			Attribute/decl(Connective, Indicator))
 *		or null (not applicable)
 *	when Attribute is predicate_no_ind (or constant), the declaration part
 *	is a list of declarations, all predicate_no_ind (or constants) specified
 *	with that symbol.
 */

check_formula_token(little_name(A), term(little_name(A)), _).
check_formula_token('_'(A), term('_'(A)), _).
check_formula_token(string(A), term(string(A)), _).
check_formula_token(float(A), term(float(A)), _).
check_formula_token(number(A), term(number(A)), _).
check_formula_token('[', term('['), _).
check_formula_token('{', term('{'), _).
check_formula_token('(', bracket('('), _).
check_formula_token(')', end_of_formula(')'), _).
check_formula_token('}'(N), end_of_formula('}'(N)), _).

check_formula_token(big_name(Name), SymbolList, Language) :-
   ( lookup_reserved_word(Name, SymbolList)
     -> true
     ;  lookup_predicate_dict(big_name(Name), SymbolList, Language)
   ).

check_formula_token(graphic_name(Name), SymbolList, Language) :-
   ( lookup_reserved_word(Name, SymbolList)
     -> true
     ;  lookup_predicate_dict(graphic_name(Name), SymbolList, Language)
   ).

lookup_reserved_word('ALL', 'ALL').
lookup_reserved_word('SOME', 'SOME').
lookup_reserved_word('~', '~').
lookup_reserved_word('IF', 'IF').

/* This is now provided by the builtin language

lookup_reserved_word('True', proposition(
	['MetaDefs.PAtom.F1'('MetaDefs.Name.F4'('"', '"True',
			'MetaDefs.Proposition.C0', 0))])).
lookup_reserved_word('False', proposition(
	['MetaDefs.PAtom.F1'('MetaDefs.Name.F4'('"', '"False',
			'MetaDefs.Proposition.C0', 0))])).
*/

lookup_reserved_word('&',
	connective('MetaDefs.&''.F2', 'Syntax.YFX.F1'(150))).
lookup_reserved_word('\\/',   % added \ djd
	connective('MetaDefs.\\/''.F2', 'Syntax.YFX.F1'(140))).  % added \ djd
lookup_reserved_word('->',
	connective('MetaDefs.->''.F2', 'Syntax.XFY.F1'(120))).
lookup_reserved_word('<-',
	connective('MetaDefs.<-''.F2', 'Syntax.XFY.F1'(120))).
lookup_reserved_word('<->',
	connective('MetaDefs.<->''.F2', 'Syntax.XFX.F1'(120))).

lookup_reserved_word('THEN', end_of_formula(big_name('THEN'))).
lookup_reserved_word('ELSE', end_of_formula(big_name('ELSE'))).
lookup_reserved_word('UNTIL', end_of_formula(big_name('UNTIL'))).
lookup_reserved_word('|', end_of_formula(graphic_name('|'))).

/*------------------------------------------------------------------------------
 * atom(+Tokens, -Remains, -Formulae, -ErrorReturn, +Language):-
 *	Formulae = [] is the signal indicating errors
 *	ErrorReturn should always be instantiated.
 */

atom([], [], [], [], _).
atom([Token|Tokens], Remains, Formulae, ErrorReturn, Language):-
   ( check_formula_token(Token, SymbolList, Language)
     -> atom(SymbolList, Tokens, Remains, Formulae, ErrorReturn, Language)
     ;  Formulae = [],
	length(Tokens, Position),
	ErrorReturn = [error('undeclared or illegal symbol: "~w"',
				[Token])/Position]
   ).

/*------------------------------------------------------------------------------
 * atom(+SymbolList, +Tokens, -Remains, -LeftAtoms, -ErrorReturn,
 *		+Language)
 *	LeftAtoms = [] is the signal indicating errors
 *	ErrorReturn should always be instantiated.
 *
 * Be very careful !!  The following procedure takes more than just Atoms.
 * For efficiency reason, (Formula), ~ Formula, SOME Var_seq Formula, and
 * ALL Var_seq Formula are all taken as an atom.
 * If only a headatom is wanted, use headatom/5.
 */

atom([], _, _, [], [], _).

atom([Decl|SymbolList], Tokens, Remains, Atoms, ErrorReturn, Language) :-
	atom(Decl, Tokens, Remains2, Atoms2, ErrorReturn2, Language),
	atom(SymbolList, Tokens, Remains, Atoms3, ErrorReturn3, Language),
	( var(Remains2)
	  -> Atoms = Atoms3,
	     append(ErrorReturn3, ErrorReturn2, ErrorReturn)
	  ;  ( end_of_atom(Remains2)
	       -> ( Remains = Remains2
	            -> true
	            ;  write('Internal error No 11.'), nl, abort
		  ),
		  append(Atoms3, Atoms2, Atoms),
		  append(ErrorReturn3, ErrorReturn2, ErrorReturn)
	       ;  Atoms = Atoms3,	% remove inproper atoms
		  append(ErrorReturn3, ErrorReturn2, ErrorReturn)
	     )
	).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */


atom(term(Token), Tokens, Remains, LeftAtoms, ErrorReturn, Language) :-
   term([Token|Tokens], TermReturn, Language),
   process_term_return(TermReturn, Remains, LeftAtoms2, [], ErrorReturn,
				Language),
   quantify_underscore(LeftAtoms2, LeftAtoms).

atom(proposition(LeftAtoms), Tokens, Tokens, LeftAtoms, [], _).

atom(predicate_no_ind(Decls), Tokens, Remains, LeftAtoms, ErrorReturn,
		Language) :-
   ( Tokens = ['('|Remains2]
     -> term_seq(Remains2, Remains3, Term_seqs, Language, ErrorReturn2),
	( Term_seqs = []
	  -> LeftAtoms = [],
	     ErrorReturn = ErrorReturn2
	  ;  ( Remains3 = [')'|Remains]
	       -> Term_seqs = [Term_seq|_],
		  length(Term_seq, Arity),
		  create_predicates(Decls, Term_seqs, Arity, LeftAtoms2, []),
		  ( LeftAtoms2 = []
		    -> LeftAtoms = [],
		       Decls = ['MetaDefs.Name.F4'(_, GPred, _, _)|_],
		       gstring2string(GPred, Pred),
		       length(Remains3, Position2),
		       Position is Position2 - 1,
		       ErrorReturn = [error('predicate "~w/~d" undeclared',
					[Pred, Arity])/Position]
		    ;  ErrorReturn = [],
		       quantify_underscore(LeftAtoms2, LeftAtoms)
		  )
	       ;  LeftAtoms = [],
		  length(Remains3, Position),
		  ErrorReturn = [error('missing ")"', [])/Position]
	     )
	)
     ;  LeftAtoms = [],
	length(Tokens, Position),
	ErrorReturn = [error('misuse of predicate, "(" expected', [])/Position]
   ).


atom(prefix_predicate(Predicate), Tokens, Remains, LeftAtoms, ErrorReturn,
		Language):-
   term(Tokens, TermReturn, Language),
   ( select_return(TermReturn, end_of_atom, Terms, Remains, ErrorReturn2)
     -> ( Terms = []
	  -> LeftAtoms = [],
	     ErrorReturn = ErrorReturn2
	  ;  list2listOflist(Terms, TermLists),
	     create_formula('MetaDefs.Atom.F2', [ [Predicate], TermLists],
			LeftAtoms2),
	     ErrorReturn = [],
	     quantify_underscore(LeftAtoms2, LeftAtoms)

	)
     ;  write('Internal error No 12.'), nl, abort
   ).

% For brackets, we first parse it as an atom, if we succeed, we won't parse
% it as a (Formula)
atom(bracket(_), Tokens, Remains, LeftAtoms, ErrorReturn, Language):-
	atom(term('('), Tokens, Remains2, LeftAtoms2, ErrorReturn2, Language),
	( LeftAtoms2 = []
	  -> formula(Tokens, Return, Language),
	     ( select_return(Return, [')'], Formulas, Remains3, ErrorReturn3)
	       -> ( Formulas = []
	            -> LeftAtoms = [],
		       ( select_return(Return, null, Formulas2, Remains5, _)
			 -> true
			 ;  write('Internal error No 13.'), nl, abort
		       ),
		       ( Formulas2 = []
		         -> append(ErrorReturn2, ErrorReturn3, ErrorReturn)
		         ;  length(Remains5, Position),
			    append(ErrorReturn2,
			      [error('")" expected', [])/Position|ErrorReturn3],
			      ErrorReturn)
		       )
	            ;  ( Remains3 = [')'|Remains4]
		         -> LeftAtoms = Formulas,
		            Remains = Remains4,
			    ErrorReturn = []
		         ;  LeftAtoms = [],
			    length(Remains3, Position),
		            ErrorReturn = [error('missing ")"', [])/Position]
		       )
                  )
	       ;  write('Internal error No 14.'), nl, abort
	     )
	  ;  Remains = Remains2,
	     ErrorReturn = [],
	     LeftAtoms = LeftAtoms2
	     % the old version quantify_underscore(LeftAtoms2, LeftAtoms)

	).


atom('~', Tokens, Remains, LeftAtoms, ErrorReturn, Language) :-
	atom(Tokens, Remains, Formulae, ErrorReturn, Language),
	( Formulae = []
	  -> LeftAtoms = []
	  ;  create_formula('MetaDefs.~''.F1', [Formulae], LeftAtoms)
	).


atom('SOME', Tokens, Remains, LeftAtoms, ErrorReturn, Language) :-
	variable_seq(Tokens, Remains2, VarList, ErrorReturn2),
	( VarList = []
	  -> LeftAtoms = [],
	     ErrorReturn = ErrorReturn2
	  ;  atom(Remains2, Remains, Formulae, ErrorReturn3, Language),
	     ( Formulae = []
	       -> LeftAtoms = [],
		  ErrorReturn = ErrorReturn3
	       ;  ErrorReturn = [],
		  create_formula('MetaDefs.Some.F2', [[VarList], Formulae],
				LeftAtoms)
	     )
	).


atom('ALL', Tokens, Remains, LeftAtoms, ErrorReturn, Language) :-
	variable_seq(Tokens, Remains2, VarList, ErrorReturn2),
	( VarList = []
	  -> LeftAtoms = [],
	     ErrorReturn = ErrorReturn2
	  ;  atom(Remains2, Remains, Formulae, ErrorReturn3, Language),
	     ( Formulae = []
	       -> LeftAtoms = [],
		  ErrorReturn = ErrorReturn3
	       ;  ErrorReturn = [],
		  create_formula('MetaDefs.All.F2', [[VarList], Formulae],
				LeftAtoms)
	     )
	).


% The following should not be the start of an atom
atom('IF', Tokens, Tokens, [],
		[error('unexpected conditional', [])/Position], _) :-
	length(Tokens, Position).
atom(infix_predicate(_), Tokens, Tokens, [],
		[error('unexpected infix predicate', [])/Position], _) :-
	length(Tokens, Position).
atom(postfix_predicate(_), Tokens, Tokens, [],
		[error('unexpected postfix predicate', [])/Position], _) :-
	length(Tokens, Position).
atom(connective(_, _), Tokens, Tokens, [],
		[error('unexpected connective', [])/Position], _) :-
	length(Tokens, Position).
atom(end_of_formula(Token), Tokens, [Token|Tokens], [], [], _).

/*------------------------------------------------------------------------------
 */

conditional(Tokens, Remains, Formulae, ErrorReturn, Language) :-
   conditional_aux(Tokens, Remains2, Formulae2, ErrorReturn2, Language),
   ( Formulae2 = []
     -> ErrorReturn = ErrorReturn2,
	Formulae = []
     ;  ( end_of_conditional(Remains2, Language)
	  -> Formulae = Formulae2,
	     Remains = Remains2,
	     ErrorReturn = []
	  ;  ( Remains2 = [graphic_name('&')|Remains3]
	       -> formula(Remains3, Return3, Language),
		  ( select_return(Return3, null, Formulae4, Remains,
				ErrorReturn4)
		    -> ( Formulae4 = []
		         -> ErrorReturn = ErrorReturn4,
		            Formulae = []
		         ;  ErrorReturn = [],
		            create_formula('MetaDefs.&''.F2',
					    [Formulae2, Formulae4], Formulae)
		       )
		    ;  write('Internal error No 15.'), nl, abort
		  )
	       ;  Formulae = [],
		  length(Remains2, Position),
		  Remains2 = [Symb|_],
		  ErrorReturn = [error('illegal symbol: "~w"', [Symb])/Position]
	     )
	)
   ).


conditional_aux(Tokens, Remains, Formulae, ErrorReturn, Language) :-
   ( Tokens = [big_name('SOME')|Tokens2]
     -> variable_seq(Tokens2, Remains2, VarList, ErrorReturn2),
	( VarList = []
	  -> Formulae = [],
	     ErrorReturn = ErrorReturn2
          ;  conditional_rest(Remains2, Remains, VarList, Formulae, ErrorReturn,
				Language)
	)
     ;  conditional_rest(Tokens, Remains, [], Formulae, ErrorReturn, Language)
   ).

%------------------------------------------------------------------------------

end_of_conditional([], _).
end_of_conditional([Token|Tokens], Language) :-
   ( end_of_conditional_aux(Token)
     -> true
     ;  Token = graphic_name('&'),      % the start of a Commit
	Tokens = ['{'|Tokens2],
	term_aux(set, Tokens2, Return, null, _, Language),
	( select_return(Return, null, Terms, _, _)
	  -> Terms = []
	  ;  write('Internal error No 16.'), nl, abort
	)
		% a test that it's not set
   ).

end_of_conditional_aux(')').
end_of_conditional_aux('}'(_)).
end_of_conditional_aux(graphic_name(N)) :-
   end_of_conditional_aux(N).
end_of_conditional_aux('|').
end_of_conditional_aux('\\/').   % added \ djd
end_of_conditional_aux('<-').
end_of_conditional_aux('->').
end_of_conditional_aux('<->').
end_of_conditional_aux(big_name(N)) :-
   end_of_conditional_aux(N).
end_of_conditional_aux('ELSE').
end_of_conditional_aux('THEN').

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

conditional_rest(Tokens, Remains, VarList, Formulae, ErrorReturn, Language) :-
   formula(Tokens, CondReturn, Language),
   ( select_return(CondReturn, [big_name('THEN')], Conds, Remains2,
		ErrorReturn2)
     -> true
      ;  write('Internal error No 17.'), nl, abort
   ),
   ( Conds = []
     -> Formulae = [],
        ( ErrorReturn2 = []
	  -> length(Tokens, Position),
	     ErrorReturn = [error('invalid formula or "THEN" missing', [])/Position]
	  ;  ErrorReturn = ErrorReturn2
	)
     ;  ( Remains2 = [big_name('THEN')|Remains3]
          -> then_part(Remains3, Remains4, Thens, ErrorReturn4, Language),
	     ( Thens = []
	       -> Formulae = [],
		  ( ErrorReturn4 = []
		    -> length(Remains3, Position),
		       ErrorReturn = [error('formula expected', [])/Position]
		    ;  ErrorReturn = ErrorReturn4
		  )
	       ;  ( Remains4 = [big_name('ELSE')|Remains5]
		    -> else_part(Remains5, Remains, Elses, ErrorReturn5,
					Language),
		       ( Elses = [],
			 ErrorReturn5 = []
			 -> Formulae = [],
			    length(Remains5, Position),
			    ErrorReturn = [error('formula expected', [])/Position]
			 ;  ( Elses = []
			      -> Formulae = [],
			         ErrorReturn = ErrorReturn5
			      ;  ErrorReturn = [],
			         ( VarList = []
			           -> create_formula('MetaDefs.ITE.F3',
					[Conds, Thens, Elses], Formulae)
			           ;  create_formula('MetaDefs.ISTE.F4',
					[[VarList], Conds, Thens, Elses],
					Formulae)
				 )
			    )
		       )
		    ;  Remains = Remains4,
		       ErrorReturn = [],
		       ( VarList = []
			 -> create_formula('MetaDefs.IT.F2',
				      [Conds, Thens], Formulae)
			 ;  create_formula('MetaDefs.IST.F3',
				      [[VarList], Conds, Thens], Formulae)
		       )
		  )
	     )
	  ;  Formulae =[],
	     length(Remains2, Position),
	     ErrorReturn = [error('"THEN" expected', [])/Position]
       )
   ).

%------------------------------------------------------------------------------
% ElsePart ->   Atom | IF A THEN B | IF A THEN B ELSE C | Atom & ElsePart

else_part([big_name('IF')|Tokens], Remains, Formulae, ErrorReturn, Language) :-
   !,
   conditional(Tokens, Remains, Formulae, ErrorReturn, Language).

% it must be a Formula by now.
else_part(Tokens, Remains, Formulae, ErrorReturn, Language) :-
   atom(Tokens, Remains2, Formulae2, ErrorReturn2, Language),
   ( Formulae2 = []
     -> ErrorReturn = ErrorReturn2,
	Formulae = []
     ;  ( end_of_conditional(Remains2, Language)
	  -> Formulae = Formulae2,
	     ErrorReturn = [],
	     Remains = Remains2
	  ;  ( Remains2 = [graphic_name('&')|Remains3]
	       -> else_part(Remains3, Remains, Formulae3, ErrorReturn3,
				Language),
		  ( Formulae3 = []
		    -> ErrorReturn = ErrorReturn3,
		       Formulae = []
		    ;  ErrorReturn = [],
		       create_formula('MetaDefs.&''.F2', [Formulae2, Formulae3],
					Formulae)
		  )
	       ;  Formulae = [],
	          length(Remains2, Position),
		  Remains2 = [Symb|_],
		  ErrorReturn = [error('illegal symbol in conditional: "~w"', [Symb])/Position]
	     )
	)
   ).

%------------------------------------------------------------------------------
% ThenPart ->   Atom | IF A THEN B | Atom & ThenPart

then_part([big_name('IF')|Tokens], Remains, Formulae, ErrorReturn, Language) :-
   !,
   ( Tokens = [big_name('SOME')|Tokens2]
     -> variable_seq(Tokens2, Remains2, VarList, ErrorReturn2),
	( VarList = []
	  -> Formulae = [],
	     ErrorReturn = ErrorReturn2
          ;  then_part_aux(Remains2, Remains, VarList, Formulae, ErrorReturn,
				Language)
	)
     ;  then_part_aux(Tokens, Remains, [], Formulae, ErrorReturn, Language)
   ).

% it must be a Formula by now.
then_part(Tokens, Remains, Formulae, ErrorReturn, Language) :-
   atom(Tokens, Remains2, Formulae2, ErrorReturn2, Language),
   ( Formulae2 = []
     -> ErrorReturn = ErrorReturn2,
	Formulae = []
     ;  ( end_of_conditional(Remains2, Language)
	  -> Formulae = Formulae2,
	     ErrorReturn = [],
	     Remains = Remains2
	  ;  ( Remains2 = [graphic_name('&')|Remains3]
	       -> then_part(Remains3, Remains, Formulae3, ErrorReturn3,Language),
		  ( Formulae3 = []
		    -> ErrorReturn = ErrorReturn3,
		       Formulae = []
		    ;  ErrorReturn = [],
		       create_formula('MetaDefs.&''.F2', [Formulae2, Formulae3],
					Formulae)
		  )
	       ;  Formulae = [],
	          length(Remains2, Position),
		  Remains2 = [Symb|_],
		  ErrorReturn = [error('illegal symbol in conditional: "~w"', [Symb])/Position]
	     )
	)
   ).

%------------------------------------------------------------------------------

then_part_aux(Tokens, Remains, VarList, Formulae, ErrorReturn, Language) :-
   formula(Tokens, CondReturn, Language),
   ( select_return(CondReturn, [big_name('THEN')], Conds, Remains2,
		ErrorReturn2)
     -> true
     ;  write('Internal error No 18.'), nl, abort
   ),
   ( Conds = []
     -> Formulae = [],
        ( ErrorReturn2 = []
	  -> length(Tokens, Position),
	     ErrorReturn = [error('not formula or "THEN" missing', [])/Position]
	  ;  ErrorReturn = ErrorReturn2
	)
     ;  ( Remains2 = [big_name('THEN')|Remains3]
          -> then_part(Remains3, Remains4, Thens, ErrorReturn4, Language),
	     ( Thens = []
	       -> Formulae = [],
		  ( ErrorReturn4 = []
		    -> length(Remains3, Position),
		       ErrorReturn = [error('formula expected', [])/Position]
		    ;  ErrorReturn = ErrorReturn4
		  )
	       ;  Remains = Remains4,
		  ErrorReturn = [],
		  ( VarList = []
		    -> create_formula('MetaDefs.IT.F2', [Conds, Thens], Formulae)
		    ;  create_formula('MetaDefs.IST.F3',
				      [[VarList], Conds, Thens], Formulae)
		  )
	     )
	  ;  Formulae =[],
	     length(Remains2, Position),
	     ErrorReturn = [error('"THEN" expected', [])/Position]
       )
   ).

/*------------------------------------------------------------------------------
 * create_predicates(+Predicates, +Term_seqs, +Term_seq_Arity, -Atoms, +Atoms2)
 * Giving a list of normal predicate declarations and a list of formula_seqs,
 * this returns the parse trees of the predicate. Arity of the predicate is
 * checked.
 */

create_predicates([], _, _, Atoms, Atoms).
create_predicates(['MetaDefs.Name.F4'(Module, Predicate, Cat, Arity)|Decls],
		Term_seqs, Term_seq_Arity, Atoms, Atoms2) :-
	( Arity = Term_seq_Arity
	  -> create_predicates_aux(Term_seqs,
			      'MetaDefs.Name.F4'(Module, Predicate, Cat, Arity),
			      Atoms, Atoms3)
	  ;  Atoms = Atoms3
	),
	create_predicates(Decls, Term_seqs, Term_seq_Arity, Atoms3, Atoms2).


create_predicates_aux([], _, Atoms, Atoms).
create_predicates_aux([Term_seq|Term_seqs], Predicate,
		['MetaDefs.Atom.F2'(Predicate, Term_seq)|Atoms], Atoms2) :-
	create_predicates_aux(Term_seqs, Predicate, Atoms, Atoms2).


/*------------------------------------------------------------------------------
 * process_term_return(+TermReturn, -NewRemains, -LeftAtoms, +LeftAtoms2,
 *		-ErrorReturn, +Language)
 *	LeftAtoms = [] is the signal indicating errors
 *	ErrorReturn should always be instantiated.
 */

process_term_return([], _, LeftAtoms, LeftAtoms, [], _).
process_term_return([Stack/Remains|TermReturn], NewRemains, LeftAtoms,
			LeftAtoms2, ErrorReturn, Language) :-
	( Stack = error(_, _)
	  -> ErrorReturn = [Stack/Remains|ErrorReturn2],
	     LeftAtoms = LeftAtoms3
	  ;  ( Stack = [stack(_, _, Hole, Term)],
	       nonvar(Hole)
	       -> ( Remains = [Token|Remains3],
		    change_symbol(Token, Symbol)
		    -> atom_middleway(Symbol, Remains3, NewRemains, Term,
				LeftAtoms, LeftAtoms3, ErrorReturn3, Language),
		       append(ErrorReturn3, ErrorReturn2, ErrorReturn)
		    ;  length(Remains, Position),
		       ErrorReturn = [error('predicate expected', [])/Position|ErrorReturn2],
		       LeftAtoms = LeftAtoms3
		  )
	       ;  length(Remains, Position),
		  ErrorReturn = [error('term expected', [])/Position|ErrorReturn2],
		  LeftAtoms = LeftAtoms3
	     )
	),
	process_term_return(TermReturn, NewRemains, LeftAtoms3, LeftAtoms2,
			ErrorReturn2, Language).

%- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
% this is to enable the use of indexing

change_symbol(A, B) :-
   ( A = graphic_name(S),
     change_symbol_aux(S, B);
     B = A
   ).

change_symbol_aux('=', '=').
change_symbol_aux('~=', '~=').
change_symbol_aux('=<', '=<').
change_symbol_aux('<', '<').

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

create_formula(Predicates, Terms, Formulae) :-
	cartesian_product(Terms, Arguments),
	create_formula_aux(Arguments, Predicates, Formulae, []).


create_formula_aux([], _, Formulae, Formulae).
create_formula_aux([Argus|Arguments], Predicate, [Formula|Formulae],
		Formulae2) :-
	Formula =.. [Predicate|Argus],
	create_formula_aux(Arguments, Predicate, Formulae, Formulae2).


/*------------------------------------------------------------------------------
 * atom_middleway(+Symbol, +Tokens, -NewRemains, +LeftTerm, -Atoms, +Atoms2,
 *		-ErrorReturn, +Language)
 *	Atoms = [] is the signal indicating errors
 *	ErrorReturn should always be instantiated.
 */

atom_middleway(Symbol, Tokens, NewRemains, LeftTerm, Atoms, Atoms2, ErrorReturn,
			Language) :-
	atom_aux(Symbol, Tokens, NewRemains, Predicates, RightTerms,
			ErrorReturn, Language),
	( Predicates = []
	  -> Atoms = Atoms2
	  ;  ( Predicates = Predicates2/adjust(A, B)
	       -> adjust_interval(A, B, LeftTerm, LeftTerm2, RightTerms,
			RightTerms2)
	       ;  Predicates2 = Predicates,
		  LeftTerm = LeftTerm2,
		  RightTerms = RightTerms2
	     ),
	     cartesian_product([[LeftTerm2]|RightTerms2], Term_seqs),
	     create_predicates(Predicates2, Term_seqs, _, Atoms, Atoms2)
	),
	( var(NewRemains)
	  -> NewRemains = Remains
	  ;  ( NewRemains = Remains
	       -> true
	       ;  write('Internal error No 19.'), nl, abort
	     )
	).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * atom_aux(+Symbol, +Tokens, -NewRemains, -Predicates, -RightTerms,
 *		-ErrorReturn, +Language)
 *	Predicates = [] is the signal indicating errors
 *	RightTerms is a list of lists.
 *	ErrorReturn should always be instantiated.
 */

atom_aux('~=', Tokens, NewRemains, Predicates, [RightTerms], ErrorReturn,
		Language) :-
   !,
   term(Tokens, Return, Language),
   ( select_return(Return, end_of_atom, RightTerms, NewRemains, ErrorReturn2)
     -> ( RightTerms = []
	  -> Predicates = [],
	     ( ErrorReturn2 = []
	       -> length(Tokens, Position),
		  ErrorReturn = [error('term expected', [])/Position]
	       ;  ErrorReturn = ErrorReturn2
	     )
	  ;  ErrorReturn = ErrorReturn2,
	     Predicates = ['MetaDefs.Name.F4'('"', '"~=',
					'MetaDefs.Predicate.C0', 2)]
	)
     ;  write('Internal error No 20.'), nl, abort
   ).


atom_aux('=', Tokens, NewRemains, Predicates, [RightTerms], ErrorReturn,
		Language) :-
   !,
   term(Tokens, Return, Language),
   ( select_return(Return, end_of_atom, RightTerms, NewRemains, ErrorReturn2)
     -> ( RightTerms = []
	  -> Predicates = [],
	     ( ErrorReturn2 = []
	       -> length(Tokens, Position),
		  ErrorReturn = [error('term expected', [])/Position]
	       ;  ErrorReturn = ErrorReturn2
	     )
	  ;  ErrorReturn = [],
	     Predicates = ['MetaDefs.Name.F4'('"', '"=',
					'MetaDefs.Predicate.C0', 2)]
	)
     ;  write('Internal error No 21.'), nl, abort
   ).


atom_aux('<', Tokens, NewRemains, Predicates, RightTerms, ErrorReturn,
		Language) :-
   !,
   term(Tokens, Return, Language),
   ( select_return(Return, [graphic_name('<'), graphic_name('=<')], MidTerms,
		Remains, _ErrorReturn3)
     -> true
     ;  write('Internal error No 22.'), nl, abort
   ),
   ( ( MidTerms = [];
       \+ inequation(Remains, _, _)	% make sure it's not an interval
     )
     -> ( select_return(Return, end_of_atom, RightTerms2, NewRemains,
				ErrorReturn2)
          -> true
          ;  write('Internal error No 42.'), nl, abort
        ),
        ( RightTerms2 = []
	  -> Predicates = [],
	     length(Tokens, Position),
	     ErrorReturn = [error('term expected',[])/Position|ErrorReturn2]
	  ;  RightTerms = [RightTerms2],
	     ( lookup_predicate_dict(graphic_name('<'), SymbolList, Language)
	       -> ErrorReturn = [],
		  select_binary_infix(SymbolList, Predicates)
	       ;  Predicates = [],
		  length(Tokens, Position),
		  ErrorReturn = [error('undeclared symbol: "<"',[])/Position]
	     )
	)
     ;  inequation(Remains, Remains2, Operator),
	term(Remains2, Return2, Language),
        ( select_return(Return2, end_of_atom, RightTerms2, NewRemains,
				ErrorReturn2)
          -> true
          ;  write('Internal error No 43.'), nl, abort
        ),
	( RightTerms2 = []
	  -> Predicates = [],
	     length(Remains2, Position),
	     ErrorReturn = [error('term expected',[])/Position|ErrorReturn2]
	  ;  RightTerms = [MidTerms, RightTerms2],
	     ( lookup_base('"Integer', '"Integers', Language)
	       -> Predicates = ['MetaDefs.Name.F4'('"Integers',
				'"Interval', 'MetaDefs.Predicate.C0', 3)]/
				adjust('<', Operator),
				% note the special structure of Predicates
		  ErrorReturn = []
	       ;  length(Tokens, Position),
		  ErrorReturn = [error('system module "Intergers" not imported', [])/Position]
	     )
	)
   ).


atom_aux('=<', Tokens, NewRemains, Predicates, RightTerms, ErrorReturn,
		Language) :-
   !,
   term(Tokens, Return, Language),
   ( select_return(Return, [graphic_name('<'), graphic_name('=<')], MidTerms,
		Remains, _ErrorReturn3)
     -> true
     ;  write('Internal error No 23.'), nl, abort
   ),
   ( ( MidTerms = [];
       \+ inequation(Remains, _, _)   % make sure it's not an interval
     )
     -> ( select_return(Return, end_of_atom, RightTerms2, NewRemains,
				ErrorReturn2)
          -> true
          ;  write('Internal error No 44.'), nl, abort
        ),
        ( RightTerms2 = []
	  -> Predicates = [],
	     length(Tokens, Position),
	     ErrorReturn = [error('term expected',[])/Position|ErrorReturn2]
	  ;  RightTerms = [RightTerms2],
	     ( lookup_predicate_dict(graphic_name('=<'), SymbolList, Language)
	       -> ErrorReturn = [],
		  select_binary_infix(SymbolList, Predicates)
	       ;  Predicates = [],
		  length(Tokens, Position),
		  ErrorReturn = [error('undeclared symbol: "=<"',[])/Position]
	     )
	)
     ;  inequation(Remains, Remains2, Operator),
	term(Remains2, Return2, Language),
        ( select_return(Return2, end_of_atom, RightTerms2, NewRemains,
				ErrorReturn2)
          -> true
          ;  write('Internal error No 45.'), nl, abort
        ),
	( RightTerms2 = []
	  -> Predicates = [],
	     length(Remains2, Position),
	     ErrorReturn = [error('term expected',[])/Position|ErrorReturn2]
	  ;  RightTerms = [MidTerms, RightTerms2],
	     ( lookup_base('"Integer', '"Integers', Language)
	       -> Predicates = ['MetaDefs.Name.F4'('"Integers',
				'"Interval', 'MetaDefs.Predicate.C0', 3)]/
				adjust('=<', Operator),
				% note the special structure of Predicates
		  ErrorReturn = []
	       ;  length(Tokens, Position),
		  ErrorReturn = [error('system module "Intergers" not imported', [])/Position]
	     )
	)
   ).


atom_aux(Symbol, Tokens, NewRemains, Predicates, RightTerms, ErrorReturn,
		Language) :-
   ( lookup_predicate_dict(Symbol, SymbolList, Language)
     -> ( ( Tokens = [Token|_],
	    end_of_atom(Token);
	    Tokens = []
	  )
	  -> NewRemains = Tokens,
	     select_predicate_operator(SymbolList, postfix_predicate,
						Predicates),
	     RightTerms = [],
	     ( Predicates = []
	       -> length(Tokens, Position),
		  ErrorReturn = [error('misuse of postfix predicate operator "~w"', [Symbol])/Position]
	       ;  ErrorReturn = []
	     )
	  ;  term(Tokens, Return, Language),
	     ( select_return(Return, end_of_atom, RightTerms2, NewRemains,
			ErrorReturn2)
	       -> ( RightTerms2 = []
	            -> ErrorReturn = ErrorReturn2,
		       RightTerms = [],
		       Predicates = []
		    ;  select_predicate_operator(SymbolList,
						infix_predicate, Predicates),
		       ( Predicates = []
			 -> RightTerms = [],
			    length(Tokens, Position),
			    ErrorReturn = [error('misuse of infix predicate operator "~w"', [Symbol])/Position]
			 ;  RightTerms = [RightTerms2],
			    ErrorReturn = []
		       )
		  )
	       ;  write('Internal error No 24.'), nl, abort
	     )
	 )
      ;  RightTerms = [],
	 length(Tokens, Position),
	 ErrorReturn = [error('infix or postfix predicate operator expected', [])/Position]
   ).


end_of_atom([]).
end_of_atom([Token|_]) :-
   end_of_atom(Token).

end_of_atom(')').
end_of_atom('}'(_)).

end_of_atom(graphic_name(Name)) :-
   end_of_atom(Name).
end_of_atom(big_name(Name)) :-
   end_of_atom(Name).

end_of_atom('&').
end_of_atom('->').
end_of_atom('\\/').   % added \ djd
end_of_atom('<-').
end_of_atom('<->').
end_of_atom('|').
end_of_atom('THEN').
end_of_atom('ELSE').
end_of_atom('UNTIL').

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * this assume infix, postfix, and prefix predicates are all in the dictionary
 * format of Attribute/decl(Predicate-name, null).
 */

select_predicate_operator([], _, []).
select_predicate_operator([Decl|SymbolList], Switch, Predicates):-
	( Decl =.. [Switch, Predicate]
	  -> Predicates = [Predicate|Predicates2]
	  ;  Predicates = Predicates2
	),
	select_predicate_operator(SymbolList, Switch, Predicates2).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * select_binary_infix picks out binary infix predicates
 */

select_binary_infix([], []).
select_binary_infix([infix_predicate(Name)|SymbolList], [Name|Predicates]) :-
	!,
	select_binary_infix(SymbolList, Predicates).
select_binary_infix([_|SymbolList], Predicates) :-
	select_binary_infix(SymbolList, Predicates).

%------------------------------------------------------------------------------

inequation([graphic_name('<')|Remains], Remains, '<') :- !.
inequation([graphic_name('=<')|Remains], Remains, '=<').


/*------------------------------------------------------------------------------
 * adjust_interval adds +1 to intervals when the relation operator is <.
 */

adjust_interval('<', SecondOp, LeftTerm,
		'MetaDefs.Term.F2'('MetaDefs.Name.F4'('"Integers', '"+',
			'MetaDefs.Function.C0', 2),
			[LeftTerm, 'MetaDefs.Int.F1'(1)]),
		RightTerms, RightTerms2) :-
   adjust_interval2(SecondOp, RightTerms, RightTerms2).

adjust_interval('=<', SecondOp, LeftTerm, LeftTerm, RightTerms, RightTerms2) :-
   adjust_interval2(SecondOp, RightTerms, RightTerms2).


adjust_interval2('<', [Var, RightTerms], [Var, RightTerms2]) :-
   adjust_interval2_aux(RightTerms, RightTerms2).

adjust_interval2('=<', RightTerms, RightTerms).


adjust_interval2_aux([], []).
adjust_interval2_aux([T|RightTerms],
		['MetaDefs.Term.F2'('MetaDefs.Name.F4'('"Integers', '"-',
			'MetaDefs.Function.C0', 2), [T, 'MetaDefs.Int.F1'(1)])
		 |RightTerms2]) :-
   adjust_interval2_aux(RightTerms, RightTerms2).

/*------------------------------------------------------------------------------
 */

quantify_underscore([], []).
quantify_underscore([Formula|Formulae], [NewFormula|NewFormulae]):-
	process_underscore(Formula, NewFormula),
	quantify_underscore(Formulae, NewFormulae).


process_underscore('MetaDefs.Empty.C0', 'MetaDefs.Empty.C0').
process_underscore('MetaDefs.PAtom.F1'(B), 'MetaDefs.PAtom.F1'(B)).
process_underscore('MetaDefs.Atom.F2'(Name, Terms), NewFormula) :-
	collect_underscores(Terms, Underscores, []),
	( Underscores = []
	  -> NewFormula = 'MetaDefs.Atom.F2'(Name, Terms)
	  ;  NewFormula = 'MetaDefs.Some.F2'(Underscores,
				'MetaDefs.Atom.F2'(Name, Terms))
	).

% 'MetaDefs.Var.F1'(Label) is definitely not an underscore
collect_underscores('MetaDefs.Var.F2'(GVar, Label),
		['MetaDefs.Var.F2'(GVar, Label)|Underscores], Underscores) :-
	name(GVar, [0'",0'_|_]), !.
collect_underscores([H|T], Underscores, Underscores2) :-
	!,
	collect_underscores(H, Underscores, Underscores3),
	collect_underscores(T, Underscores3, Underscores2).

collect_underscores('MetaDefs.Term.F2'(_, Terms), Underscores, Underscores2) :-
	!,
	collect_underscores(Terms, Underscores, Underscores2).

collect_underscores(_, Underscores, Underscores).

:- style_check(-singleton). % added djd

% Copyright (C) Goedel Group, University of Bristol, June 1992.
% Title and ownership of all Goedel software originating from the Goedel
% Group at the University of Bristol remains with the Goedel Group.
%
% The Goedel language was designed by P.M. Hill and J.W. Lloyd, and the
% language was implemented by A. Bowers and J. Wang. The design and
% implementation of the language was partly supported by the ESPRIT Basic
% Research Action 3012 (Compulog), a SERC Grant GR/F/26256, and the
% University of Bristol.
%
% This software is available ONLY for research and educational purposes.
% In particular, it may not be used for any commercial purpose whatsoever.
% The software is free and is provided "as is", without warranty of any kind.
% Users of the software are free to modify and experiment with it for
% research and educational purposes. However, users may not distribute
% the software (modified or not) to third parties without the express
% permission of the Goedel Group. The normal method of obtaining this
% software is by ftp from ftp.cs.kuleuven.ac.be.
%
% Any enquiries about this copyright notice or the use of this software
% should be directed to J.W. Lloyd at jwl@compsci.bristol.ac.uk.


/* File:	statement.pl
Subject:	parse the statements, including CFormula and NonCFormula
Author:		Jiwei Wang
Date:		3 December 1991

		Changed to new grammar for IF-THEN-ELSE, at 5 June 1992.

================================================================================
*/

%% '$$module'('@(#)statement.pl 1.39 last updated 93/11/24 17:32:03 by jiwei').

:- module(statement).   %% converted djd

:- dynamic underscore_counter/1.

/*------------------------------------------------------------------------------
 * statement(+Item, +ModuleName, -Formulae, -ErrorReturn, +Language)
 *	Formulae = [] is the error signal,
 *	ErrorReturn is not always instantiated
 *	ModuleName is of GString type
 */

statement(item(Tokens, _, _), ModuleName, Formulae, ErrorReturn, Language):-
   underscore_init,	% initialising underscore label counter.
   headatom(Tokens, Remains2, ModuleName, HeadAtoms, ErrorReturn2, Language),
   ( HeadAtoms = []
     -> ErrorReturn = ErrorReturn2,
	Formulae = []
     ;  ( Remains2 = []
	  -> create_formula('MetaDefs.<-''.F2',
				[HeadAtoms, ['MetaDefs.Empty.C0']], Formulae)
	  ;  ( Remains2 = [graphic_name('<-')|Remains3]
	       -> body(Remains3, CFormulae, ErrorReturn3, Language),
		  ( CFormulae = []
		    -> ErrorReturn = ErrorReturn3,
		       Formulae = []
		    ;  ErrorReturn = [],
		       create_formula('MetaDefs.<-''.F2',
					[HeadAtoms, CFormulae], Formulae)
		  )
	       ;  length(Remains2, Position),
		  ErrorReturn = [error('"<-" expected in statement',[])/Position],
		  Formulae = []
	     )
	)
   ).

%------------------------------------------------------------------------------

underscore_counter(1).

underscore_init :-
   retractall(underscore_counter(_)),
   assert(underscore_counter(1)).

underscore_label(Label) :-
   retract(underscore_counter(Label)),
   Label2 is Label + 1,
   assert(underscore_counter(Label2)).

/*------------------------------------------------------------------------------
 * headatom(+Tokens, -Remains, +ModuleName, -Formulae, -ErrorReturn, +Language)
 *	Formulae = [] indicates error
 *	ModuleName is of GString type
 */

headatom(Tokens, Remains, ModuleName, Formulae, ErrorReturn, Language):-
   atom(Tokens, Remains, Formulae2, ErrorReturn2, Language),
   select_headatom(Formulae2, Formulae, ModuleName),
   ( Formulae2 = [],
     Formulae = []
     -> ( ErrorReturn2 = []
	  -> length(Tokens, Position),
	     ErrorReturn = [error('illegal headatom', [])/Position]
	  ;  ErrorReturn = ErrorReturn2
	)
     ;  ( Formulae2 \== [],
	  Formulae = []
	  -> length(Remains, Position),
	     ErrorReturn = [error('illegal headatom (possibly attempting to define a predicate not declared in this module)', [])/Position]
	  ;  ErrorReturn = ErrorReturn2
	)
   ).

% still select_headatom does not filter out (Atom).  Hope this is tolerable.
select_headatom([], [], _).
select_headatom([Atom|Formulae], NewFormulae, ModuleName) :-
   ( ( Atom = 'MetaDefs.PAtom.F1'('MetaDefs.Name.F4'(ModuleName, _, _, _));
       Atom = 'MetaDefs.Atom.F2'('MetaDefs.Name.F4'(ModuleName, _,_,_), _)
     )
     -> NewFormulae = [Atom|NewFormulae2]
     ;  ( Atom = 'MetaDefs.Some.F2'([Variable|_], 'MetaDefs.Atom.F2'(
				'MetaDefs.Name.F4'(ModuleName,S,C,A), Terms)),
	  Variable = 'MetaDefs.Var.F2'(GVar, _),
	  name(GVar, [0'", 0'_|_])
	  -> NewFormulae = ['MetaDefs.Atom.F2'(
				'MetaDefs.Name.F4'(ModuleName, S, C, A), Terms)
			    | NewFormulae2]
			% remove quantifiers for underscores
          ;  NewFormulae = NewFormulae2
	)
   ),
   select_headatom(Formulae, NewFormulae2, ModuleName).

/*------------------------------------------------------------------------------
 The grammar for Body has to be treated differently from that in the Goedel
 Report.  In the parser, this part of grammar is treated as follows:

	CFormula(0) ->   <'{'> CFormula(f) <'}'[Label]>
		       | Formula(f)

	CFormula(2) -> CFormula(f) & CFormula(f1)
			f =< 1 and f =< 2
 */

/*------------------------------------------------------------------------------
 * body(+Tokens, -Formulae, -ErrorReturn, +Language)
 *	Formulae can be [], indicating a unit clause.
 *	ErrorReturn \= [] indicates errors.
 *	CFormulae are those in the scope of a bar_commit.
 * bar-commit takes 0 as the commit label which is not allowed in other
 * user defined commits.
 * one-solution (1000000000) is not completed yet.
 */

body([], [], [error('empty statement body', [])/0], _).

body([Token|Tokens], Formulae, ErrorReturn, Language) :-
   ( Token = graphic_name('|')
     -> cformula(Tokens, Remains2, Formulae2, ErrorReturn2, Language),
        ( Formulae2 = [],
	  ErrorReturn2 = []
	  -> ( Remains2 == []
	       -> ErrorReturn = [],
		  Formulae = ['MetaDefs.Commit.F2'(0, 'MetaDefs.PAtom.F1'(
					'MetaDefs.Name.F4'('"', '"True',
					'MetaDefs.Proposition.C0', 0)))]
	       ;  Formulae = [],
		  length(Remains2, Position),
		  Remains2 = [Symb|_],
		  ErrorReturn = [error('illegal symbol: "~w"', [Symb])/Position]
	     )
	  ;  ( Formulae2 = []
	       -> Formulae = [],
	          ErrorReturn = ErrorReturn2
	       ;  ( Remains2 == []
		    -> ErrorReturn = [],
		       create_formula('MetaDefs.&''.F2',
				      [ ['MetaDefs.Commit.F2'(0,
					  'MetaDefs.PAtom.F1'(
					    'MetaDefs.Name.F4'('"', '"True',
					      'MetaDefs.Proposition.C0', 0)))],
				      Formulae2 ], Formulae)
	            ;  Formulae = [],
		       length(Remains2, Position),
		       Remains2 = [Symb|_],
		       ErrorReturn = [error('illegal symbol: "~w"', [Symb])/Position]
		  )
	     )
	)
     ;  cformula([Token|Tokens], Remains3, Formulae3, ErrorReturn3, Language),
	( Formulae3 = []
	  -> Formulae = [],
	     ( ErrorReturn3 = []
	       -> length([Token|Tokens], Position),
		  ErrorReturn = [error('formula expected', [])/Position]
	       ;  ErrorReturn = ErrorReturn3
	     )
	 ;  ( Remains3 = []
	      -> Formulae = Formulae3,
		 ErrorReturn = []
	      ;	 ( Remains3 = [graphic_name('|')|Remains4]
	           -> cformula(Remains4, Remains5, Formulae4, ErrorReturn4,
					Language),
		      ( Formulae4 = [],
		        ErrorReturn4 = []
		        -> ( Remains5 == []	% Remains5 can be var, don't use =
			     -> ErrorReturn = [],
			        create_formula('MetaDefs.Commit.F2',
						[[0], Formulae3], Formulae)
		             ;  Formulae = [],
			        length(Remains4, Position),
			        ErrorReturn = [error('formula expected',[])/Position]
		           )
		        ;  ( Formulae4 = []
			     -> Formulae = [],
			        ErrorReturn = ErrorReturn4
			     ;  ( Remains5 = []
			          -> create_formula('MetaDefs.Commit.F2',
						[[0], Formulae3], Formulae5),
				     create_formula('MetaDefs.&''.F2',
					      [Formulae5, Formulae4], Formulae)
			          ;  Formulae = [],
				     length(Remains5, Position),
				     Remains5 = [Symb|_],
			             ErrorReturn = [error('illegal symbol: "~w"',
							[Symb])/Position]
			        )
		           )
		      )
	           ;  Formulae = [],
		      length(Remains3, Position),
		      Remains3 = [Symb|_],
		      ErrorReturn = [error('illegal symbol: "~w"', [Symb])/Position]
		 )
	    )
        )
   ).


/*------------------------------------------------------------------------------
 * cformula(+Tokens, -Remains, -Formulae, -ErrorReturn, +Language)
 *	Formulae can be []
 *	Remains should always be instantiated
 *	ErrorReturn \= []  as the error signal.
 */

% This should be the only place with empty CFormula
cformula([], [], [], [], _).

cformula([Token|Tokens], Remains, Formulae, ErrorReturn, Language) :-
   cformula_aux(Token, Tokens, Remains2, Formulae2, ErrorReturn2, Language),
   ( Formulae2 = []
     -> ErrorReturn = ErrorReturn2,
	Formulae = []
     ;  ( end_of_cformula(Remains2)
	  -> Formulae = Formulae2,
	     Remains = Remains2,
	     ErrorReturn = []
	  ;  ( Remains2 = [graphic_name('&')|Remains3]
	       -> cformula(Remains3, Remains, Formulae4, ErrorReturn4,
					Language),
		  ( Formulae4 = []
		    -> ErrorReturn = ErrorReturn4,
		       Formulae = []
		    ;  ErrorReturn = [],
		       create_formula('MetaDefs.&''.F2',
					    [Formulae2, Formulae4], Formulae)
		  )
	       ;  Formulae = [],
		  length(Remains2, Position),
		  Remains2 = [Symb|_],
		  ErrorReturn = [error('illegal symbol: "~w"', [Symb])/Position]
	     )
	)
   ).


end_of_cformula([]).
end_of_cformula([')'|_]) :- !.
end_of_cformula(['}'(_)|_]) :- !.
end_of_cformula([graphic_name('|')|_]).

/*------------------------------------------------------------------------------
 * cformula_aux(+Token, +Tokens, -Remains, -Formulae, -ErrorReturn, +Language)
 *	Formulae = [] is the error signal.
 * The algorithm for CFormula is first to parse a list of tokens as special
 * formula i.e. conditionals, commits.  If this fails, we parse it as Formula
 */

cformula_aux('{', Tokens, Remains, Formulae, ErrorReturn, Language) :-
   !,
   cformula(Tokens, Remains2, Formulae2, ErrorReturn2, Language),
   ( Formulae2 =[]
     -> term_aux(set, Tokens, Return, null, _, Language),
	( select_return(Return, null, SetTerms, _, ErrorReturn3)
	  -> true
	  ;  write('Internal error No 25.'), nl, abort
        ),
	( SetTerms = []
	  -> Formulae = [],
	     ( ErrorReturn2 = [], ErrorReturn3 = []
	       -> length(Tokens, Position),
	          ErrorReturn = [error('formula expected', [])/Position]
	       ;  append(ErrorReturn2, ErrorReturn3, ErrorReturn)
	     )
	  ;  formula(['{'|Tokens], Return2, Language),
	     ( select_return(Return2, null, Formulae, Remains, ErrorReturn)
	       -> true
	       ;  write('Internal error No 26.'), nl, abort
	     )
	)
     ;  ( Remains2 = ['}'(Label)|Remains]
	  -> ErrorReturn = [],
	     create_formula('MetaDefs.Commit.F2', [[Label], Formulae2],
					Formulae)
	  ;  Formulae = [],
	     length(Remains2, Position),
	     ErrorReturn = [error('missing "}"', [])/Position]
	)
   ).

cformula_aux(Token, Tokens, Remains, Formulae, ErrorReturn, Language) :-
   formula([Token|Tokens], Return, Language),
   ( select_return(Return, null, Formulae, Remains, ErrorReturn)
     -> true
     ;  write('Internal error No 27.'), nl, abort
   ).


/*------------------------------------------------------------------------------
 * lookup_predicate_dict(+Token, -SymbolList, +Language)
 * This fails if Token is not declared in Language
 */

lookup_predicate_dict(Token, SymbolList, Language):-
   ( Token = big_name(Name);
     Token = graphic_name(Name)
   ),
   string2Gstring(Name, GName),
   'ParserPrograms.ParserSymbols.P3'(GName, Language, Candidates), !,
			% the cut here is essential
   candidates2predicates(Candidates, SymbolList2, IsTerm),
   collect_predicate_no_ind(SymbolList2, SymbolList3),
   collect_proposition(SymbolList3, SymbolList4),
   ( var(IsTerm)
     -> SymbolList = SymbolList4,
	SymbolList \== []
     ;  SymbolList = [term(Token)|SymbolList4]
				% Name may not be big_name but doesn't matter
   ).


candidates2predicates([], [], _).
candidates2predicates([Candidate|Candidates], SymbolList, IsTerm) :-
   ( Candidate = 'ParserPrograms.FCandidate.F2'(_, _)
     -> IsTerm = yes,
        SymbolList = SymbolList2
     ;  Candidate = 'ParserPrograms.PCandidate.F2'(Name, Ind),
        candidates2predicates_aux(Ind, Name, Symbol),
        SymbolList = [Symbol|SymbolList2]
   ),
   candidates2predicates(Candidates, SymbolList2, IsTerm).


candidates2predicates_aux('Syntax.NoPredInd.C0',
				'MetaDefs.Name.F4'(M, S, C, A), Symbol) :-
   ( A = 0
     -> Symbol = proposition('MetaDefs.PAtom.F1'('MetaDefs.Name.F4'(M, S, C, A)))
     ;  Symbol = predicate_no_ind('MetaDefs.Name.F4'(M, S, C, A))
		% note this is not confirmed with the interface
   ).
candidates2predicates_aux('Syntax.ZPZ.C0', Name, infix_predicate(Name)).
candidates2predicates_aux('Syntax.ZP.C0', Name, postfix_predicate(Name)).
candidates2predicates_aux('Syntax.PZ.C0', Name, prefix_predicate(Name)).

%------------------------------------------------------------------------------

collect_predicate_no_ind(SymbolList, SymbolList2):-
   collect_predicate_no_ind(SymbolList, SymbolList3, Names),
   ( Names = []
     -> SymbolList2 = SymbolList3
     ;  SymbolList2 = [predicate_no_ind(Names)|SymbolList3]
   ).

collect_predicate_no_ind([], [], []).
collect_predicate_no_ind([Symbol|SymbolList], SymbolList2, Names) :-
   ( Symbol = predicate_no_ind(Name)
     -> SymbolList2 = SymbolList3,
	Names = [Name|Names2]
     ;  SymbolList2 = [Symbol|SymbolList3],
        Names = Names2
   ),
   collect_predicate_no_ind(SymbolList, SymbolList3, Names2).

%------------------------------------------------------------------------------

collect_proposition(SymbolList, SymbolList2):-
   collect_proposition(SymbolList, SymbolList3, Names),
   ( Names = []
     -> SymbolList2 = SymbolList3
     ;  SymbolList2 = [proposition(Names)|SymbolList3]
   ).

collect_proposition([], [], []).
collect_proposition([Symbol|SymbolList], SymbolList2, Names) :-
   ( Symbol = proposition(Name)
     -> SymbolList2 = SymbolList3,
	Names = [Name|Names2]
     ;  SymbolList2 = [Symbol|SymbolList3],
        Names = Names2
   ),
   collect_proposition(SymbolList, SymbolList3, Names2).

/*------------------------------------------------------------------------------
 * lookup_function_dict(+Token, -SymbolList, +Language)
 * This fails if Token is not declared in Language
 */

lookup_function_dict(Token, SymbolList, Language):-
   ( Token = big_name(Name);
     Token = graphic_name(Name)
   ),
   string2Gstring(Name, GName),
   'ParserPrograms.ParserSymbols.P3'(GName, Language, Candidates), !,
   candidates2functions(Candidates, SymbolList2, IsPredicate),
   collect_function_no_ind(SymbolList2, SymbolList3),
   collect_constant(SymbolList3, SymbolList4),
   ( var(IsPredicate)
     -> SymbolList = SymbolList4,
	SymbolList \== []
     ;  SymbolList = [predicate(Token)|SymbolList4]
				% Name may not be big_name but doesn't matter
   ).

/* comment out as = and ~= are provided in SymbolTable
	( ( Name = '='; Name = '~=')
	  -> SymbolList = [predicate(graphic_name(Name))|SymbolList5]
	  ;  SymbolList = SymbolList5,
	     SymbolList \== []
	).
*/


candidates2functions([], [], _).
candidates2functions([Candidate|Candidates], SymbolList, IsPredicate) :-
   ( Candidate = 'ParserPrograms.PCandidate.F2'(_, _)
     -> IsPredicate = yes,
	SymbolList = SymbolList2
     ;  Candidate = 'ParserPrograms.FCandidate.F2'(Name, Ind),
	candidates2functions_aux(Ind, Name, Symbol),
        SymbolList = [Symbol|SymbolList2]
   ),
   candidates2functions(Candidates, SymbolList2, IsPredicate).


candidates2functions_aux('Syntax.NoFunctInd.C0',
				'MetaDefs.Name.F4'(M, S, C, A), Symbol) :-
   ( A = 0
     -> Symbol = constant('MetaDefs.CTerm.F1'('MetaDefs.Name.F4'(M, S, C, A)))
     ;  Symbol = function_no_ind('MetaDefs.Name.F4'(M, S, C, A))
		% the interface format is done in collect_function_no_ind
   ).
candidates2functions_aux('Syntax.XFX.F1'(Prec), Name,
			infix_function(Name, 'Syntax.XFX.F1'(Prec))).
candidates2functions_aux('Syntax.XFY.F1'(Prec), Name,
			infix_function(Name, 'Syntax.XFY.F1'(Prec))).
candidates2functions_aux('Syntax.YFX.F1'(Prec), Name,
			infix_function(Name, 'Syntax.YFX.F1'(Prec))).
candidates2functions_aux('Syntax.XF.F1'(Prec), Name,
			postfix_function(Name, 'Syntax.XF.F1'(Prec))).
candidates2functions_aux('Syntax.YF.F1'(Prec), Name,
			postfix_function(Name, 'Syntax.YF.F1'(Prec))).
candidates2functions_aux('Syntax.FX.F1'(Prec), Name,
			prefix_function(Name, 'Syntax.FX.F1'(Prec))).
candidates2functions_aux('Syntax.FY.F1'(Prec), Name,
			prefix_function(Name, 'Syntax.FY.F1'(Prec))).

%------------------------------------------------------------------------------

collect_function_no_ind(SymbolList, SymbolList2):-
   collect_function_no_ind(SymbolList, SymbolList3, Names),
   ( Names = []
     -> SymbolList2 = SymbolList3
     ;  SymbolList2 = [function_no_ind(Names)|SymbolList3]
   ).

collect_function_no_ind([], [], []).
collect_function_no_ind([Symbol|SymbolList], SymbolList2, Names) :-
   ( Symbol = function_no_ind(Name)
     -> SymbolList2 = SymbolList3,
	Names = [Name|Names2]
     ;  SymbolList2 = [Symbol|SymbolList3],
        Names = Names2
   ),
   collect_function_no_ind(SymbolList, SymbolList3, Names2).

%------------------------------------------------------------------------------

collect_constant(SymbolList, SymbolList2):-
	collect_constant(SymbolList, SymbolList3, Names),
	( Names = []
	  -> SymbolList2 = SymbolList3
	  ;  SymbolList2 = [constant(Names)|SymbolList3]
	).

collect_constant([], [], []).
collect_constant([Symbol|SymbolList], SymbolList2, Names) :-
   ( Symbol = constant(Name)
     -> SymbolList2 = SymbolList3,
	Names = [Name|Names2]
     ;  SymbolList2 = [Symbol|SymbolList3],
        Names = Names2
   ),
   collect_constant(SymbolList, SymbolList3, Names2).

/*------------------------------------------------------------------------------
 * lookup_base(+BaseName, +ModuleName, +SymbolTable)
 *	this fails if such base of such module is not declared.
 */

lookup_base(BaseName, ModuleName, SymbolTable) :-
   'ParserPrograms.ParserTypeSymbols.P3'(BaseName, SymbolTable, Names), !,
   member('MetaDefs.Name.F4'(ModuleName, BaseName, 'MetaDefs.Base.C0', 0),
				   Names), !.

/*------------------------------------------------------------------------------
 * lookup_constructor(+ConstrName, +Arity, +ModuleName, +SymbolTable)
 *	this fails if such constructor of such module is not declared.
 */

lookup_constructor(ConstrName, Arity, ModuleName, SymbolTable) :-
   'ParserPrograms.ParserTypeSymbols.P3'(ConstrName, SymbolTable, Names), !,
   member('MetaDefs.Name.F4'(ModuleName, ConstrName,
			'MetaDefs.Constructor.C0', Arity), Names), !.

:- style_check(-singleton). % added djd

% Copyright (C) Goedel Group, University of Bristol, June 1992.
% Title and ownership of all Goedel software originating from the Goedel
% Group at the University of Bristol remains with the Goedel Group.
%
% The Goedel language was designed by P.M. Hill and J.W. Lloyd, and the
% language was implemented by A. Bowers and J. Wang. The design and
% implementation of the language was partly supported by the ESPRIT Basic
% Research Action 3012 (Compulog), a SERC Grant GR/F/26256, and the
% University of Bristol.
%
% This software is available ONLY for research and educational purposes.
% In particular, it may not be used for any commercial purpose whatsoever.
% The software is free and is provided "as is", without warranty of any kind.
% Users of the software are free to modify and experiment with it for
% research and educational purposes. However, users may not distribute
% the software (modified or not) to third parties without the express
% permission of the Goedel Group. The normal method of obtaining this
% software is by ftp from ftp.cs.kuleuven.ac.be.
%
% Any enquiries about this copyright notice or the use of this software
% should be directed to J.W. Lloyd at jwl@compsci.bristol.ac.uk.


/*
File:		parser.pl
Subject:	the top level of the Goedel parser
Author:		Jiwei Wang
Date:		11 September 1991

The whole parser consists of files:
	tokenizer.pl:	the tokenizer.
	parser.pl:	the top-level of the parser.
	statement.pl:	parsing statements.
	formula.pl:	parsing formula.
	term.pl:	parsing terms.
	Programs.pl:	the system module Program and the type-checker.

================================================================================
*/

%% '$$module'('@(#)parser.pl 1.68 last updated 94/04/18 22:22:18 by jiwei').

:- module(parser).  %% converted djd

:- discontiguous language_decl1/8. %% added djd
:- discontiguous language_decl2/8. %% added djd

% for gfreeze
:- op(500, yfx, and).
:- op(400, yfx, or).

/*------------------------------------------------------------------------------
 * parse_program(+ModuleName, +Switch, -Program)
 * This is the top level entry point of the parser.  It takes a main-module
 * name and returns the program in ground representation.
 * Switch to indicate whether doing compile or make
 */

parse_program(ModuleName, Switch, Program):-
   module_as_items(ModuleName, ExpTokens, LocTokens),
   string2Gstring(ModuleName, GModuleName),
   identify_module_kind(ExpTokens, ModuleKind),
   identify_module_part(ExpTokens, ModulePartExp, ModulePartLoc),
   'ParserPrograms.QuickNewProgram.P3'(GModuleName, ModuleKind, EmptyProg),
   parse_module_decl(GModuleName, Switch, ExpTokens, ExpTokens2, LocTokens,
		LocTokens2, [ModuleName], _LoadedModule, EmptyProg, Prog2),
   'ParserPrograms.ExportSymbolTable.P3'(Prog2, GModuleName, ExpLang),
   parse_language1(ExpTokens2, ExpTokens3, GModuleName, 'ProgDefs.Exported.C0',
			ExpLang, ExpLang2),
   parse_language2(ExpTokens3, ExpTokens4, GModuleName, 'ProgDefs.Exported.C0',
			ExpLang2, ExpLang3),
   'ParserPrograms.UpdateProgramLanguage.P4'(Prog2, GModuleName, ExpLang3, Prog3),
   parse_delays_aux(ExpTokens4, ExpTokens5, GModuleName, ModulePartExp,
	                ExpLang3, Prog3, Prog4, export),
   'ParserPrograms.LocalSymbolTable.P3'(Prog4, GModuleName, LocLang),
   parse_language1(LocTokens2, LocTokens3, GModuleName, 'ProgDefs.Hidden.C0',
			LocLang, LocLang2),
   parse_language2(LocTokens3, LocTokens4, GModuleName, 'ProgDefs.Hidden.C0',
			LocLang2, LocLang3),
   'ParserPrograms.UpdateProgramLanguage.P4'(Prog4, GModuleName, LocLang3, Prog5),
   parse_delays_aux(LocTokens4, LocTokens5, GModuleName, ModulePartLoc,
	                LocLang3, Prog5, Prog6, local),
   parse_statements(GModuleName, ExpTokens5, LocTokens5, LocLang3,
			Prog6, Program).


/*------------------------------------------------------------------------------
 */

parse_module(ModuleName, Switch, Loaded, NewLoaded, OldProg, NewProg):-
   string2Gstring(ModuleName, GModuleName),
   ( ( member(ModuleName, Loaded); system_module_name(GModuleName) )
     -> NewProg = OldProg,
	NewLoaded = Loaded	% skip if the module is already parsed
     ;  ( Switch = compile, lang_file_ok(ModuleName)
	  -> sappend(ModuleName, '.lng', LangFile),
	     open(LangFile, read, Stream),
	     my_format(user_output, 'Loading the language of module "~a" ...~n', [ModuleName]),
	     read(Stream, version(_, ordinary)),
	     read(Stream, ModuleDef),
	     read(Stream, ModuleDescriptor),
	     close(Stream),
	     'ParserPrograms.QuickInsertModuleDef.P4'(OldProg, GModuleName,
				ModuleDef, Prog2),
	     'SharedPrograms.ProgramLanguage.P2'(Prog2, Lang),
	     'ParserPrograms.QuickInsertModuleDescriptor.P4'(Lang, GModuleName,
				ModuleDescriptor, Language),
	     'ParserPrograms.ReplaceProgramLanguage.P3'(Prog2, Language, Prog3),
	     ModuleDef = 'ProgDefs.ModDef.F4'(_, ImpExp, ImpLoc, Lifts),
	     append(ImpLoc, ImpExp, ImportedMods1),
	     append(Lifts, ImportedMods1, ImportedMods),
	     gstringlist2stringlist(ImportedMods, ImportedMods2),
	     make_modules(ImportedMods, Prog3, Prog4),
	     parse_module_aux(ImportedMods2, Switch, [ModuleName|Loaded],
				NewLoaded, Prog4, NewProg)
	  ;  module_as_items(ModuleName, ExpTokens, LocTokens),
	     identify_module_part(ExpTokens, ModulePartExp, ModulePartLoc),
             parse_module_decl(GModuleName, Switch, ExpTokens, ExpTokens2,
			LocTokens, LocTokens2, [ModuleName|Loaded], NewLoaded,
			OldProg, Prog2),
             'ParserPrograms.ExportSymbolTable.P3'(Prog2, GModuleName, ExpLang),
	     parse_language1(ExpTokens2, ExpTokens3, GModuleName,
	                'ProgDefs.Exported.C0',	ExpLang, ExpLang2),
	     parse_language2(ExpTokens3, ExpTokens4, GModuleName,
	                'ProgDefs.Exported.C0',	ExpLang2, ExpLang3),
	     'ParserPrograms.UpdateProgramLanguage.P4'(Prog2, GModuleName,
			ExpLang3, Prog3),
	     parse_delays_aux(ExpTokens4, ExpTokens5, GModuleName,
			ModulePartExp, ExpLang3, Prog3, Prog4, export),
	     'ParserPrograms.LocalSymbolTable.P3'(Prog4, GModuleName, LocLang),
	     parse_language1(LocTokens2, LocTokens3, GModuleName,
	                'ProgDefs.Hidden.C0', LocLang, LocLang2),
	     parse_language2(LocTokens3, LocTokens4, GModuleName,
	               'ProgDefs.Hidden.C0', LocLang2, LocLang3),
	     'ParserPrograms.UpdateProgramLanguage.P4'(Prog4, GModuleName,
			LocLang3, Prog5),
	     parse_delays_aux(LocTokens4, LocTokens5, GModuleName,
                        ModulePartLoc, LocLang3, Prog5, Prog6, local),
	     parse_statements(GModuleName, ExpTokens5, LocTokens5,
			LocLang3, Prog6, NewProg)
	)
   ).


lang_file_ok(ModuleName) :-
   sappend(ModuleName, '.lng', LangFile),
   open(LangFile, read, Stream),
   file_version(V),
   ( read(Stream, version(V, ordinary))
     -> close(Stream)
     ;  close(Stream), fail
   ).


%- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

make_modules([], Prog, Prog).
make_modules([GMod|Mods], Prog, NewProg) :-
   'ParserPrograms.QuickMakeModule.P3'(GMod, Prog, Prog2),
   make_modules(Mods, Prog2, NewProg).

/*------------------------------------------------------------------------------
 * parse_module_aux is the entry point for parsing IMPORT declarations.
 * This is also the place to do "make" and "compile" commands.
 * Left for future versions.
 */

parse_module_aux([], _, Loaded, Loaded, Program, Program).
parse_module_aux([Mod|Mods], Switch, Loaded, NewLoaded, OldProg, NewProg):-
   parse_module(Mod, Switch, Loaded, Loaded2, OldProg, Prog2),
   parse_module_aux(Mods, Switch, Loaded2, NewLoaded, Prog2, NewProg).


/*==============================================================================
 * module_as_items(+ModuleName, -list(item), -list(item))
 * module_as_items(+ModuleName, -Exp_list, -Loc_list)
 */

module_as_items(ModuleName, ExpTokens, LocTokens):-
   module_part(ModuleName, '.exp', ExpTokens),
   module_part(ModuleName, '.loc', LocTokens).


/*------------------------------------------------------------------------------
 * module_part(+ModuleName, +String, -List(item))
 */

module_part(ModuleName, String, Module):-
   sappend(ModuleName, String, FileName),
   ( open(FileName, read, Stream)
     -> my_format(user_output, 'Reading file "~w" ...~n', [FileName]),
	get_one_module(Stream, Module),	% in tokenizer.pl
	close(Stream)
     ;  Module = []	% nonexisting file is NOT regarded as an error.
   ).


/*==============================================================================
 * parse_module_decl(+ModuleName, +Switch, +ExpTokens, +LocTokens, +OldProg,
 *			-NewProg)
 * takes care of the constraints for module and the imported modules
 * the module-name declarations are not removed from the tokens.
 */

parse_module_decl(GModuleName, Switch, ExpTokens, ExpTokens2, LocTokens,
		LocTokens2, Loaded, NewLoaded, OldProg, NewProg):-
   gstring2string(GModuleName, ModuleName),
   parse_import(GModuleName, Switch, ExpTokens, ExpTokens3, LocTokens,
		LocTokens3, Loaded, NewLoaded, OldProg, NewProg),
   ( system_module_name(GModuleName)
     -> my_format(user_output, 'Parsing system module "~w" ...~n', [ModuleName])
     ;  my_format(user_output, 'Parsing module "~w" ...~n', [ModuleName])
   ),
   check_module(GModuleName, ExpTokens3, ExpTokens2, LocTokens3, LocTokens2).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

check_module(GModuleName, ExpTokens, ExpTokens2, LocTokens, LocTokens2):-
   gstring2string(GModuleName, ModuleName),
   ( LocTokens == [], ExpTokens == []
     -> ExpTokens2 = [],
	LocTokens2 = [],
	print_out_error('Error: module "~w" missing', [ModuleName], null, 0, 0,
			[], null)
     ;  ( ExpTokens == []
          -> ExpTokens2 =[],
	     ( LocTokens = [item([big_name('MODULE'), big_name(LocName)], _, _)
			    | LocTokens2]
	       -> true
	       ;  LocTokens = [_|LocTokens2],
		  print_out_error('Error: illegal module declaration in the export part of module "~w" or export part of module "~w" missing',
				[ModuleName, ModuleName], null, 0, 0, [], null)
	     )
	  ;  ( LocTokens == []
               -> LocTokens2 = [],
		  ( ExpTokens = [item([big_name('CLOSED'), big_name(ExpName)],
				      _, _) | ExpTokens2]
                    -> true
		    ;  ( ExpTokens = [item([big_name('EXPORT'),big_name(ExpName)
					   ], _, _) | ExpTokens2]
			 -> format(user_error, '~nWarning: local part of module "~w" missing.~n', [ModuleName])
                         ;  ExpTokens = [_|ExpTokens2],
		            print_out_error('Error: illegal module declaration in the export part of module "~w"',
					[ModuleName], null, 0, 0, [], null)
		       )
		  )
	       ;  ( ( ExpTokens = [item([big_name('EXPORT'), big_name(ExpName)],
					_, _) | ExpTokens2];
	              ExpTokens = [item([big_name('CLOSED'), big_name(ExpName)],
					 _, _) | ExpTokens2]
		    )
                    -> true
                    ;  ExpTokens = [_|ExpTokens2],
		       print_out_error('Error: illegal module declaration in the export part of module "~w"',
					[ModuleName], null, 0, 0, [], null)
		  ),
	          ( LocTokens = [item([big_name('LOCAL'), big_name(LocName)],
					_, _) | LocTokens2]
	            -> true
	            ;  LocTokens = [_|LocTokens2],
		       print_out_error('Error: illegal module declaration in the local part of module "~w"',
					[ModuleName], null, 0, 0, [], null)
	          )
	     )
	)
   ),
   % note LocName and ExpName may have not been instantiated.
   ( LocName = ModuleName
     -> true
     ;  format(user_error, '~nWarning: module name of the local part differs from the file name.~n', [])
   ),
   ( ExpName = ModuleName
     -> true
     ;  format(user_error, '~nWarning: module name of the export part differs from the file name.~n', [])
   ).

/*------------------------------------------------------------------------------
 * parse_import(+ModuleName, Switch, +ExpTokens, -ExpTokens2, +LocTokens,
 *		-LocTokens2, +Loaded, -NewLoaded, +OldProg, -NewProg)
 */

parse_import(ModuleName, Switch, ExpTokens, ExpTokens2, LocTokens, LocTokens2,
		Loaded, NewLoaded, OldProg, NewProg):-
   identify_module_part(ExpTokens, ModulePartExp, ModulePartLoc),
   extract_import_modules(ExpTokens, ExpTokens2, ML, ML_Sexp, export),
   sort(ML, ExpMods),
   insert_import_decl(ML_Sexp, ModuleName, ModulePartExp, OldProg, Prog2),
   extract_import_modules(LocTokens, LocTokens2, ML2, ML_Sloc, local),
   sort(ML2, LocMods),
   insert_import_decl(ML_Sloc, ModuleName, ModulePartLoc, Prog2, Prog3),
   append(LocMods, ExpMods, ML3),
   sort(ML3, Mods),
   parse_module_aux(Mods, Switch, Loaded, NewLoaded, Prog3, NewProg).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

insert_import_decl([], _, _, Prog, Prog).
insert_import_decl([ModList/Switch|Mods], ModuleName, ModulePart, OldProg,
		NewProg) :-
   insert_import_decl_aux(ModList, Switch, ModuleName, ModulePart, OldProg,
				Prog2),
   insert_import_decl(Mods, ModuleName, ModulePart, Prog2, NewProg).


insert_import_decl_aux([], _, _, _, Prog, Prog).
insert_import_decl_aux([Mod|ModList], Switch, ModuleName, ModulePart, OldProg,
				NewProg) :-
   string2Gstring(Mod, GMod),
   ( Switch = 'IMPORT'
     -> 'ParserPrograms.QuickInsertImport.P5'(OldProg, ModuleName, ModulePart,
				GMod, Prog2)
     ;  'ParserPrograms.QuickInsertLift.P4'(OldProg, ModuleName, GMod, Prog2)
   ),
   insert_import_decl_aux(ModList, Switch, ModuleName, ModulePart, Prog2,
				NewProg).

%------------------------------------------------------------------------------

extract_import_modules([], [], [], [], _).
extract_import_modules([Item|Items], Rest, Mods, Mod_Switch, WhichPart):-
   ( (  Item = item([big_name('IMPORT')|Tokens], Ln1, Ln2), Switch = 'IMPORT'
      ; Item = item([big_name('LIFT')|Tokens], Ln1, Ln2), Switch = 'LIFT'
     )
     -> ( Switch = 'LIFT', WhichPart = export
	  -> print_out_error('Error: LIFT declaration in the export part of the module',
		  [], WhichPart, Ln1, Ln2, [], null),
	     extract_import_modules(Items, Rest, Mods, Mod_Switch, WhichPart)
          ;  user_name_seq(Tokens, Tokens2, Mods2, ErrorNames),
	     ( ErrorNames = []
	       -> true
	       ;  print_out_error('Error: illegal module name(s) in ~w statement: ~w',
			[Switch, ErrorNames], WhichPart, Ln1, Ln2, [], null)
	     ),
	     ( Tokens2 = []
	       -> true
	       ;  length(Tokens2, Position),
	          print_out_error('Error: illegal symbol in ~w statement', [Switch],
		     WhichPart, Ln1, Ln2, [big_name(Switch)|Tokens], Position)
	     ),
	     extract_import_modules(Items, Rest, Mods3, Mod_Switch2, WhichPart),
	     Mod_Switch = [Mods2/Switch|Mod_Switch2],
	     append(Mods3, Mods2, Mods)
	)
     ;  Rest = [Item|Rest2],
	extract_import_modules(Items, Rest2, Mods, Mod_Switch, WhichPart)
   ).

/*------------------------------------------------------------------------------
 * identify_module_kind does not report any error.
 */

identify_module_kind(ExpTokens, ModuleKind) :-
   ( ExpTokens == []
     -> ModuleKind = 'ProgDefs.ModuleKind.C0'
     ;  ( ExpTokens = [item([big_name('EXPORT')|_], _, _) | _]
	  -> ModuleKind = 'ProgDefs.NormalKind.C0'
	  ;  ModuleKind = 'ProgDefs.ClosedKind.C0'
	)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

identify_module_part(ExpTokens, ModulePartExp, ModulePartLoc) :-
   ( ExpTokens = []
     -> ModulePartLoc = 'ProgDefs.Module.C0'
     ;  ( ExpTokens = [item([big_name('EXPORT')|_], _, _) | _]
	  -> ModulePartExp = 'ProgDefs.Export.C0'
	  ;  ModulePartExp = 'ProgDefs.Closed.C0'	% is this ok ?
	),
	ModulePartLoc = 'ProgDefs.Local.C0'
   ).


/*=============================================================================
 * parse_language1(+Items, -RestItems, +ModuleName, +Accessibility,
 *			+OldLang, -NewLang)
 * This parses the type declarations (constructor and base).
 * NOTE the accessibility of Opaque is ignored for the time being.
 */

parse_language1([], [], _, _, Lang, Lang).
parse_language1([Item|Items], RestItems, ModuleName, Accessibility,
		OldLang, NewLang):-
   ( Item = item([big_name(BigName)|Tokens], Ln1, Ln2),
     language_decl1(BigName, Tokens, Ln1, Ln2, ModuleName, Accessibility,
			OldLang, Lang2)
     -> % dot,
	parse_language1(Items, RestItems, ModuleName, Accessibility, Lang2,
			NewLang)
     ;  RestItems = [Item|RestItems2],
	parse_language1(Items, RestItems2, ModuleName, Accessibility, OldLang,
			NewLang)
   ).


/*------------------------------------------------------------------------------
 * Parse base declaration
 */

language_decl1('BASE', Tokens, Ln1, Ln2, ModuleName, Accessibility, OldLang,
		NewLang):-
   user_name_seq(Tokens, Tokens2, BaseNames, ErrorNames),
   ( ErrorNames = []
     -> true
     ;  accessibility2part(Accessibility, WhichPart),
        print_out_error('Error: illegal user name(s): ~w',
			[ErrorNames], WhichPart, Ln1, Ln2, [], null)
   ),
   ( Tokens2 = []
     -> insert_base_decl(BaseNames, ModuleName, Accessibility, Ln1, Ln2,
			OldLang, NewLang)
     ;  NewLang = OldLang,
	accessibility2part(Accessibility, WhichPart),
	length(Tokens2, Position),
        print_out_error('Error: illegal symbol in base declaration',
		[], WhichPart, Ln1, Ln2, [big_name('BASE')|Tokens], Position)
   ).


insert_base_decl([], _, _, _, _, Lang, Lang).
insert_base_decl([BaseName|BaseNames], ModuleName, Accessibility, Ln1, Ln2,
		OldLang, NewLang) :-
   string2Gstring(BaseName, GBaseName),
   'ParserPrograms.ParserTypeSymbols.P3'(GBaseName, OldLang, BNames),
   ( member('MetaDefs.Name.F4'(ModuleName, GBaseName, 'MetaDefs.Base.C0',0),
		BNames)
     -> NewLang2 = OldLang,
	accessibility2part(Accessibility, WhichPart),
	print_out_error('Error: base "~w" already declared',
			[BaseName], WhichPart, Ln1, Ln2, [], null)
     ;  'ParserPrograms.ParserTypeInsert.P5'(OldLang,
		'MetaDefs.Name.F4'(ModuleName, GBaseName, 'MetaDefs.Base.C0',0),
		Accessibility, 'ProgDefs.BaseDecl.C0', NewLang2)
   ),
   insert_base_decl(BaseNames, ModuleName, Accessibility, Ln1, Ln2,
		NewLang2, NewLang).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

accessibility2part('ProgDefs.Exported.C0', export).
accessibility2part('ProgDefs.Hidden.C0', local).

/*------------------------------------------------------------------------------
 * Parse constructor declaration
 */

language_decl1('CONSTRUCTOR', Tokens, Ln1, Ln2, ModuleName, Accessibility,
		OldLang, NewLang):-
   constructor_decl(Tokens, [big_name('CONSTRUCTOR')|Tokens], Ln1, Ln2,
			ModuleName, Accessibility, OldLang, NewLang).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

constructor_decl(Tokens, WholeTokens, Ln1, Ln2, ModuleName, Accessibility,
			OldLang, NewLang):-
   ( Tokens = [UserName, graphic_name('/'), number(Arity)|Tokens2]
     -> ( user_name(UserName, ConstrName)
          -> ( positive_int(Arity)
               -> string2Gstring(ConstrName, GConstrName),
		  'ParserPrograms.ParserTypeSymbols.P3'(GConstrName, OldLang, CCands),
		  ( member('MetaDefs.Name.F4'(ModuleName, GConstrName,
					'MetaDefs.Constructor.C0', Arity),
				CCands)
		    -> NewLang2 = OldLang,
		       accessibility2part(Accessibility, WhichPart),
		       print_out_error('Error: constructor "~w/~d" already declared',
			  [ConstrName, Arity], WhichPart, Ln1, Ln2, [], null)
		    ;  'ParserPrograms.ParserTypeInsert.P5'(OldLang,
				'MetaDefs.Name.F4'(ModuleName, GConstrName,
					'MetaDefs.Constructor.C0', Arity),
			    Accessibility, 'ProgDefs.ConstructorDecl.F1'(Arity),
			    NewLang2)
		  )
               ;  NewLang2 = OldLang,
		  accessibility2part(Accessibility, WhichPart),
		  print_out_error('Error: illegal arity for constructor "~w"',
				[ConstrName], WhichPart, Ln1, Ln2, [], null)
             )
	  ;  NewLang = OldLang,
	     length(Tokens, Position),
	     accessibility2part(Accessibility, WhichPart),
	     print_out_error('Error: illegal identifier in constructor declaration: "~w"',
			[UserName], WhichPart, Ln1, Ln2, WholeTokens, Position)
        ),
        ( Tokens2 = []
          -> NewLang = NewLang2
          ;  ( Tokens2 = [','|Tokens3]
	       -> constructor_decl(Tokens3, WholeTokens, Ln1, Ln2, ModuleName,
				Accessibility,
				NewLang2, NewLang)
	       ;  length(Tokens2, Position),
		  accessibility2part(Accessibility, WhichPart),
		  print_out_error('Error: "," expected', [], WhichPart,
				Ln1, Ln2, WholeTokens, Position),
		  split_list(Tokens2, ',', _, Tokens3),
	          constructor_decl(Tokens3, WholeTokens, Ln1, Ln2, ModuleName,
				Accessibility,
				NewLang2, NewLang)

	     )
	)
     ;  OldLang = NewLang,
	length(Tokens, Position),
	print_out_error('Error: syntax error in constructor declaration',
			[], WhichPart, Ln1, Ln2, WholeTokens, Position)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

positive_int(N) :-
   N > 0.

/*=============================================================================
 * parse_language2(+Tokens, -Tokens2, +ModuleName, +Accessibility,
 *			+OldLang, -NewLang)
 * This parses the rest of language declarations (constant, function,
 * proposition, predicate.
 */

parse_language2([], [], _, _, Lang, Lang).
parse_language2([Item|Items], Rest, ModuleName, Accessibility, OldLang,
			NewLang):-
   ( Item = item([big_name(BigName)|Tokens], Ln1, Ln2),
     language_decl2(BigName, Tokens, Ln1, Ln2, ModuleName, Accessibility,
			OldLang, Lang2)
     -> % dot,
	parse_language2(Items, Rest, ModuleName, Accessibility, Lang2,
			NewLang)
     ;  Rest = [Item|Rest2],
	parse_language2(Items, Rest2, ModuleName, Accessibility, OldLang,
			NewLang)
   ).

/*------------------------------------------------------------------------------
 * Parse constant declaration
 */

language_decl2('CONSTANT', Tokens, Ln1, Ln2, ModuleName, Accessibility, OldLang,
		NewLang):-
   constant_decl(Tokens, [big_name('CONSTANT')|Tokens], Ln1, Ln2, ModuleName,
		Accessibility, OldLang, NewLang).


constant_decl([], _, _, _, _, _, Lang, Lang) :- !.

constant_decl(Tokens, WholeTokens, Ln1, Ln2, ModuleName, Accessibility,
		OldLang, NewLang) :-
   accessibility2part(Accessibility, WhichPart),
   user_name_seq(Tokens, Tokens2, ConstNames, ErrorNames),
   ( ErrorNames = []
     -> true
     ;  ( ModuleName = '"Integers'
	  -> remove_number_constant(ErrorNames, ErrorNames2)
		% numbers as constants are not inserted into dictionary, but
		% simply removed from error message.
	  ;  ErrorNames = ErrorNames2
	),
	( ErrorNames2 = []
	  -> true
	  ;  print_out_error('Error: illegal constant(s): ~w',
			[ErrorNames2], WhichPart, Ln1, Ln2, [], null)
	)
   ),
   ( Tokens2 = [graphic_name(':')|Tokens3]
     -> declared_type(Tokens3, Tokens4, WholeTokens, Type, ModuleName, Ln1,
			Ln2, OldLang, WhichPart),
	( Type = null	% when there is an error in the type
	  -> split_list(Tokens4, ';', _, Tokens5),
	     constant_decl(Tokens5, WholeTokens, Ln1, Ln2, ModuleName,
				Accessibility, OldLang, NewLang)
	  ;  insert_constants(ConstNames, Type, ModuleName, Accessibility,
				Ln1, Ln2, OldLang, Lang2),
	     ( Tokens4 = []
	       -> NewLang = Lang2
	       ;  ( Tokens4 = [';'|Tokens5]
		    -> constant_decl(Tokens5, WholeTokens, Ln1, Ln2,
				ModuleName, Accessibility, Lang2, NewLang)
		    ;  length(Tokens4, Position),
		       print_out_error('Error: ";" or "." expected',
				[], WhichPart, Ln1, Ln2, WholeTokens, Position),
		       split_list(Tokens4, ';', _, Tokens5),
		       constant_decl(Tokens5, WholeTokens, Ln1, Ln2, ModuleName,
				      Accessibility, Lang2, NewLang)

		  )
	     )
	)
     ;  length(Tokens2, Position),
	print_out_error('Error: ":" expected', [], WhichPart, Ln1, Ln2,
				WholeTokens, Position),
	split_list(Tokens2, ';', _, Tokens3),
	constant_decl(Tokens3, WholeTokens, Ln1, Ln2, ModuleName, Accessibility,
			OldLang, NewLang)
   ).


insert_constants([], _, _, _, _, _, Lang, Lang).
insert_constants([Symbol|ConstNames], Type, ModuleName, Accessibility, Ln1, Ln2,
			OldLang, NewLang) :-
   string2Gstring(Symbol, GSymbol),
   'ParserPrograms.ParserSymbols.P3'(GSymbol, OldLang, Candidates),
   ( member('ParserPrograms.FCandidate.F2'('MetaDefs.Name.F4'(ModuleName, GSymbol,
		'MetaDefs.Constant.C0', 0), _), Candidates)
     -> Lang2 = OldLang,
	accessibility2part(Accessibility, WhichPart),
	print_out_error('Error: constant "~w" already declared',
			[Symbol], WhichPart, Ln1, Ln2, [], null)
     ;  'ParserPrograms.ParserInsert.P5'(OldLang, 'MetaDefs.Name.F4'(ModuleName,
					GSymbol, 'MetaDefs.Constant.C0', 0),
				Accessibility,
				'ProgDefs.ConstantDecl.F1'(Type), Lang2)
   ),
   insert_constants(ConstNames, Type, ModuleName, Accessibility, Ln1, Ln2,
			Lang2, NewLang).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

remove_number_constant([], []).
remove_number_constant([number(_)|ErrorNames], ErrorNames2) :- !,
   remove_number_constant(ErrorNames, ErrorNames2).
remove_number_constant([Token|ErrorNames], [Token|ErrorNames2]) :-
   remove_number_constant(ErrorNames, ErrorNames2).


/*------------------------------------------------------------------------------
 * Related module conditions (base and constructor) are imposed on type.
 */

declared_type([Token|Tokens], RestTokens, WholeTokens, Type, ModuleName,
		Ln1, Ln2, Language, WhichPart) :-
   type(Token, Tokens, RestTokens, WholeTokens, Type, ModuleName, Ln1, Ln2,
		Language, WhichPart).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * type(+Token, +Tokens, -RestTokens, +WholeTokens, -Type, ?ModuleName,
 *	+Ln1, +Ln2, +Language, +WhichPart)
 * Type = 'null' indicating error.
 * ModuleName can be instantiated or uninstantiated. Instantiated ModuleName
 * impose the required module condition.
 */


type(little_name(Name), Tokens, Tokens, _, 'MetaDefs.Par.F2'(GName, 0), _,
		_, _, _, _) :-
   !,
   string2Gstring(Name, GName).

type(UserName, Tokens, RestTokens, WholeTokens, Type, ModuleName, Ln1, Ln2,
		Language, WhichPart) :-
   ( user_name(UserName, Name)
     -> string2Gstring(Name, GName),
        'ParserPrograms.ParserTypeSymbols.P3'(GName, Language, Candidates),
	( Candidates = []
	  -> Type = null,
	     RestTokens = Tokens,
	     length(Tokens, Position),
	     print_out_error('Error: undeclared base or constructor: "~w"',
			[Name], WhichPart, Ln1, Ln2, WholeTokens, Position)
          ;  ( Tokens = ['('|Tokens2]
	       -> type_seq(Tokens2, RestTokens, WholeTokens, SubTypes, Error,
				Ln1, Ln2, Language, WhichPart),
	          ( nonvar(Error)
	            -> Type = null
	            ;  length(SubTypes, Arity),
		       ( ambiguous_checking(ModuleName, GName,
				  'MetaDefs.Constructor.C0', Arity, Ln1, Ln2,
				  Candidates, WhichPart)
		         -> Type = 'MetaDefs.Type.F2'(
					 'MetaDefs.Name.F4'(ModuleName, GName,
					      'MetaDefs.Constructor.C0', Arity),
				         SubTypes)
		         ;  Type = null
		       )
	          )
	       ;  RestTokens = Tokens,
	          ( ambiguous_checking(ModuleName, GName, 'MetaDefs.Base.C0', 0,
					Ln1, Ln2, Candidates, WhichPart)
	            -> Type = 'MetaDefs.BType.F1'('MetaDefs.Name.F4'(ModuleName,
						GName, 'MetaDefs.Base.C0', 0))
	            ;  Type = null
	          )
             )
	)
     ;  Type = null,
	RestTokens = Tokens,
	length(Tokens, Position),
	print_out_error('Error: illegal base or constructor identifier: "~w"',
			[UserName], WhichPart, Ln1, Ln2, WholeTokens, Position)
   ).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * This fails if there is an error.
 */

ambiguous_checking(ModuleName, Symbol, Category, Arity, Ln1, Ln2, Candidates,
		WhichPart) :-
   gstring2string(Symbol, S),
   ( var(ModuleName)
     -> ( delete_once(Candidates,
			'MetaDefs.Name.F4'(ModuleName, Symbol, Category, Arity),
			Candidates2)
	  -> ( member('MetaDefs.Name.F4'(ModuleName2, Symbol, Category, Arity),
			Candidates2)
	       ->
	          gstring2string(ModuleName, M),
	          gstring2string(ModuleName2, M2),
		  print_out_error('Error: ambiguous base/constructor "~w" from modules "~w" and "~w"',
			[S, M, M2], WhichPart, Ln1, Ln2, [], null),
		  fail
	       ;  true
	     )
	  ;  print_out_error('Error: undeclared base or constructor: "~w"',
				[S], WhichPart, Ln1, Ln2, [], null),
	     fail
	)
     ;  ( member('MetaDefs.Name.F4'(ModuleName, Symbol, Category, Arity),
			Candidates)
	  -> true
	  ;  print_out_error('Error: attempt to define symbol(s) of non-local type "~w"',
				[S], WhichPart, Ln1, Ln2, [], null),
	     fail
	)
   ).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * type_seq(+Tokens, -RestTokens, +WholeTokens, -SubTypes, -Error, +Ln1, +Ln2,
 *		+Language, +WhichPart)
 * Error being instantiate denotes error
 */

type_seq([], [], _, [], _, _, _, _, _).

type_seq([Token|Tokens], RestTokens, WholeTokens, SubTypes, Error, Ln1, Ln2,
		Language, WhichPart) :-
   type(Token, Tokens, Tokens2, WholeTokens, Type, _, Ln1, Ln2, Language,
		WhichPart),
   ( Type = null
     -> Error = yes,
	RestTokens = Tokens2
     ;  ( Tokens2 = [')'|RestTokens]
          -> SubTypes = [Type]
	  ;  ( Tokens2 = [','|Tokens3]
	       -> type_seq(Tokens3, RestTokens, WholeTokens, SubTypes2, Error,
				Ln1, Ln2, Language, WhichPart),
	          ( nonvar(Error)
	            -> true
	            ;  SubTypes = [Type|SubTypes2]
	          )
	       ;  ( Tokens2 = [Illegal|RestTokens]
		    -> length(RestTokens, Position),
		       print_out_error('Error: illegal symbol in type: "~w"',
			[Illegal], WhichPart, Ln1, Ln2, WholeTokens, Position)
		    ;  RestTokens = Tokens2,
		       length(RestTokens, Position),
		       print_out_error('Error: ")" expected', [], WhichPart,
				Ln1, Ln2, WholeTokens, Position)
		  )
	     )
	)
   ).


/*------------------------------------------------------------------------------
 * Parse function declaration
 */

language_decl2('FUNCTION', Tokens, Ln1, Ln2, ModuleName, Accessibility, OldLang,
		NewLang):-
   function_decl(Tokens, [big_name('FUNCTION')|Tokens], Ln1, Ln2,
			ModuleName, Accessibility, OldLang, NewLang).


function_decl([], _, _, _, _, _, Lang, Lang) :- !.

function_decl(Tokens, WholeTokens, Ln1, Ln2, ModuleName, Accessibility,
		OldLang, NewLang):-
   accessibility2part(Accessibility, WhichPart),
   user_name_seq(Tokens, Tokens2, FuncNames, ErrorNames),
   ( ErrorNames = []
     -> true
     ;  print_out_error('Error: illegal function identifier(s): ~w',
			[ErrorNames], WhichPart, Ln1, Ln2, [], null)
   ),
   spec_and_type(Tokens2, Tokens3, WholeTokens, Spec, DomainTypes,
		RangeType, Error, Ln1, Ln2, ModuleName, OldLang, WhichPart),
   ( nonvar(Error)
     -> % there is an error in spec and type
	split_list(Tokens3, ';', _, Tokens4),
	function_decl(Tokens4, WholeTokens, Ln1, Ln2, ModuleName,
				Accessibility, OldLang, NewLang)
     ;  ( transparency_check(DomainTypes, RangeType)
          -> length(DomainTypes, Arity),
	     insert_function_decl(FuncNames, 'ProgDefs.FunctionDecl.F4'(Arity,
						Spec, DomainTypes, RangeType),
		Arity, ModuleName, Accessibility, Ln1, Ln2, OldLang, Lang2),
	     ( Tokens3 =[]
	       -> NewLang = Lang2
	       ;  ( Tokens3 = [';'|Tokens5]
	            -> function_decl(Tokens5, WholeTokens, Ln1, Ln2, ModuleName,
					Accessibility, Lang2, NewLang)
	            ;  length(Tokens3, Position),
		       print_out_error('Error: ";" or "." expected', [],
				WhichPart, Ln1, Ln2, WholeTokens, Position),
		       split_list(Tokens3, ';', _, Tokens6),
		       function_decl(Tokens6, WholeTokens, Ln1, Ln2, ModuleName,
					Accessibility, Lang2, NewLang)
	          )
	     )
	  ;  print_out_error('Error: non-transparent function(s) ~w',
				[FuncNames], WhichPart, Ln1, Ln2, [], null),
	     split_list(Tokens3, ';', _, Tokens4),
	     function_decl(Tokens4, WholeTokens, Ln1, Ln2, ModuleName,
				Accessibility, OldLang, NewLang)
	)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

insert_function_decl([], _, _, _, _, _, _, Lang, Lang).
insert_function_decl([FuncName|FuncNames], Decl, Arity, ModuleName,
			Accessibility, Ln1, Ln2, OldLang, NewLang) :-
   string2Gstring(FuncName, GFuncName),
   'ParserPrograms.ParserSymbols.P3'(GFuncName, OldLang, Candidates),
   ( member('ParserPrograms.FCandidate.F2'('MetaDefs.Name.F4'(ModuleName, GFuncName,
		'MetaDefs.Function.C0', Arity), _),
		Candidates)
     -> Lang2 = OldLang,
	accessibility2part(Accessibility, WhichPart),
	print_out_error('Error: function "~w/~d" already declared',
			[FuncName, Arity], WhichPart, Ln1, Ln2, [], null)
     ;  'ParserPrograms.ParserInsert.P5'(OldLang, 'MetaDefs.Name.F4'(ModuleName,
				GFuncName, 'MetaDefs.Function.C0', Arity),
				Accessibility, Decl, Lang2)
   ),
   insert_function_decl(FuncNames, Decl, Arity, ModuleName, Accessibility,
		Ln1, Ln2, Lang2, NewLang).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

spec_and_type([], [], _, _, _, _, yes, _, _, _, _, _).
spec_and_type([graphic_name(':'), Token|Tokens], RestTokens, WholeTokens, Spec,
	DomainTypes, RangeType, Error, Ln1, Ln2, ModuleName, Lang, WhichPart) :-
   !,
   ( function_spec(Token, Spec, Prec, Arity)
     -> ( Tokens = ['(', number(Prec), ')'|Tokens2]
	  -> ( positive_int(Prec)
	       -> function_type(Tokens2, RestTokens, WholeTokens, DomainTypes,
		     RangeType, Error, Ln1, Ln2, ModuleName, Lang, WhichPart),
		  ( length(DomainTypes, Arity)
		    -> true
		    ;  Error = yes,
		       length(RestTokens, Position),
		       print_out_error('Error: inappropriate arity for operator',
				[], WhichPart, Ln1, Ln2, WholeTokens, Position)
		  )
	       ;  Error = yes,
		  RestTokens = Tokens,
		  length(Tokens, Position),
		  print_out_error('Error: illegal precedence',
				[], WhichPart, Ln1, Ln2, WholeTokens, Position)
	     )
	  ;  Error = yes,
	     RestTokens = Tokens,
	     length(Tokens, Position),
	     print_out_error('Error: illegal function specification (function precedence expected)',
				[], WhichPart, Ln1, Ln2, WholeTokens, Position)
	)
     ;  Spec = 'Syntax.NoFunctInd.C0',
	function_type([graphic_name(':'), Token|Tokens], RestTokens,
			WholeTokens, DomainTypes, RangeType, Error, Ln1, Ln2,
			ModuleName, Lang, WhichPart)
   ).

spec_and_type(Tokens, Tokens, WholeTokens, _, _, _, yes, Ln1, Ln2, _, _,
		WhichPart) :-
   length(Tokens, Position),
   print_out_error('Error: ":" expected', [], WhichPart, Ln1, Ln2,
			WholeTokens, Position).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

function_spec(big_name(Name), Spec, Prec, Arity) :-
	function_spec_aux(Name, Spec, Prec, Arity).
function_spec(little_name(Name), Spec, Prec, Arity) :-
	function_spec_aux(Name, Spec, Prec, Arity).

function_spec_aux('Fx', 'Syntax.FX.F1'(Prec), Prec, 1).
function_spec_aux('Fy', 'Syntax.FY.F1'(Prec), Prec, 1).
function_spec_aux('xF', 'Syntax.XF.F1'(Prec), Prec, 1).
function_spec_aux('yF', 'Syntax.YF.F1'(Prec), Prec, 1).
function_spec_aux('xFx', 'Syntax.XFX.F1'(Prec), Prec, 2).
function_spec_aux('xFy', 'Syntax.XFY.F1'(Prec), Prec, 2).
function_spec_aux('yFx', 'Syntax.YFX.F1'(Prec), Prec, 2).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * Error will be instantiated if there is an error
 */

function_type(Tokens, RestTokens, WholeTokens, DomainTypes, RangeType, Error,
		Ln1, Ln2, ModuleName, Language, WhichPart) :-
   ( Tokens = [graphic_name(':')|Tokens2]
     -> function_type_aux(Tokens2, RestTokens, WholeTokens, DomainTypes,
		RangeType, Error, Ln1, Ln2, ModuleName, Language, WhichPart)
     ;  Error = yes,
	RestTokens = Tokens,
	length(Tokens, Position),
	print_out_error('Error: ":" expected', [], WhichPart, Ln1, Ln2,
			WholeTokens, Position)
   ).


function_type_aux(Tokens, RestTokens, WholeTokens, DomainTypes, RangeType,
		Error, Ln1, Ln2, ModuleName, Language, WhichPart) :-
   star_type_seq(Tokens, Tokens2, WholeTokens, DomainTypes, Error, Ln1, Ln2,
		Language, WhichPart),
   ( var(Error)
     -> ( Tokens2 = [graphic_name('->')|Tokens3]
	  -> declared_type(Tokens3, RestTokens, WholeTokens, RangeType,
			ModuleName, Ln1, Ln2, Language, WhichPart),
	     ( RangeType = null
	       -> Error = yes
	       ;  true
	     )
	  ;  Error = yes,
	     RestTokens = Tokens2,
	     length(Tokens2, Position),
	     print_out_error('Error: "->" expected', [], WhichPart, Ln1, Ln2,
				WholeTokens, Position)
	)
     ;  RestTokens = Tokens2
   ).


star_type_seq([], [], _, [], _, _, _, _, _).

star_type_seq([Token|Tokens], RestTokens, WholeTokens, SubTypes, Error, Ln1,
		Ln2, Language, WhichPart):-
   type(Token, Tokens, Tokens2, WholeTokens, Type, _, Ln1, Ln2, Language,
		WhichPart),
   ( Type = null
     -> Error = yes,
	RestTokens = Tokens2
     ;  ( ( Tokens2 = [];		% for predicate decl
	    Tokens2 = [graphic_name('->')|_];	% for function decl
	    Tokens2 = [';'|_]	% for predicate decl
	  )
          -> SubTypes = [Type],
	     RestTokens = Tokens2
	  ;  ( Tokens2 = [graphic_name('*')|Tokens3]
	       -> star_type_seq(Tokens3, RestTokens, WholeTokens, SubTypes2,
				Error, Ln1, Ln2, Language, WhichPart),
	          ( nonvar(Error)
	            -> true
	            ;  SubTypes = [Type|SubTypes2]
	          )
	       ;  Error = yes,
		  ( Tokens2 = [Illegal|RestTokens]
		    -> length(RestTokens, Position),
		       print_out_error('Error: illegal symbol in type: "~w"',
			[Illegal], WhichPart, Ln1, Ln2, WholeTokens, Position)
		    ;  RestTokens = Tokens2,
		       length(RestTokens, Position),
		       print_out_error('Error: ")" expected', [], WhichPart,
				Ln1, Ln2, WholeTokens, Position)
		  )
	     )
	)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * transparency_check(+DomainTypes, +RangeType)
 * it fails if the function declaration is not transparent.
 */

transparency_check(DomainTypes, RangeType) :-
   get_parameter(DomainTypes, DomainParas, []),
   get_parameter(RangeType, RangeParas, []),
   subset(DomainParas, RangeParas).

get_parameter([], Paras, Paras).
get_parameter([Type|Types], Paras, Paras2) :-
   get_parameter(Type, Paras, Paras3),
   get_parameter(Types, Paras3, Paras2).

get_parameter('MetaDefs.Par.F2'(String, Int),
		['MetaDefs.Par.F2'(String, Int)|Paras], Paras).
get_parameter('MetaDefs.BType.F1'(_), Paras, Paras).
get_parameter('MetaDefs.Type.F2'(_, Types), Paras, Paras2) :-
   get_parameter(Types, Paras, Paras2).


/*------------------------------------------------------------------------------
 * Parse proposition declaration
 */

language_decl2('PROPOSITION', Tokens, Ln1, Ln2, ModuleName, Accessibility,
		OldLang, NewLang):-
   accessibility2part(Accessibility, WhichPart),
   user_name_seq(Tokens, Tokens2, PropNames, ErrorNames),
   ( ErrorNames = []
     -> true
     ;  print_out_error('Error: illegal proposition identifier(s): ~w',
			[ErrorNames], WhichPart, Ln1, Ln2, [], null)
   ),
   ( Tokens2 = []
     -> insert_proposition_decl(PropNames, ModuleName, Accessibility, Ln1, Ln2,
			OldLang, NewLang)
     ;  length(Tokens2, Position),
        print_out_error('Error: illegal symbol', [], WhichPart, Ln1, Ln2,
			Tokens, Position)
   ).


insert_proposition_decl([], _, _, _, _, Lang, Lang).
insert_proposition_decl([PropName|PropNames], ModuleName, Accessibility,
			Ln1, Ln2, OldLang, NewLang) :-
   string2Gstring(PropName, GPropName),
   ( reserved_proposition_name(PropName)
     -> Lang2 = OldLang,
	accessibility2part(Accessibility, WhichPart),
	print_out_error('Error: attempt to redefine reserved proposition "~w"',
		[PropName], WhichPart, Ln1, Ln2, [], null)
     ;  'ParserPrograms.ParserSymbols.P3'(GPropName, OldLang, Candidates),
        ( member('ParserPrograms.PCandidate.F2'('MetaDefs.Name.F4'(ModuleName,
		GPropName, 'MetaDefs.Proposition.C0', 0), _), Candidates)
          -> Lang2 = OldLang,
	     accessibility2part(Accessibility, WhichPart),
	     print_out_error('Error: proposition "~w" already declared',
			[PropName], WhichPart, Ln1, Ln2, [], null)
          ;  'ParserPrograms.ParserInsert.P5'(OldLang, 'MetaDefs.Name.F4'(ModuleName,
				GPropName, 'MetaDefs.Proposition.C0', 0),
			Accessibility, 'ProgDefs.PropositionDecl.C0', Lang2)
	)
   ),
   insert_proposition_decl(PropNames, ModuleName, Accessibility, Ln1, Ln2,
		Lang2, NewLang).


/*------------------------------------------------------------------------------
 * Parse predicate declaration
 * almost the same as the program for function declarations.
 */

language_decl2('PREDICATE', Tokens, Ln1, Ln2, ModuleName, Accessibility,
		OldLang, NewLang):-
   predicate_decl(Tokens, [big_name('PREDICATE')|Tokens], Ln1, Ln2,
			ModuleName, Accessibility, OldLang, NewLang).


predicate_decl([], _, _, _, _, _, Lang, Lang) :- !.

predicate_decl(Tokens, WholeTokens, Ln1, Ln2, ModuleName, Accessibility,
		OldLang, NewLang):-
   accessibility2part(Accessibility, WhichPart),
   user_name_seq(Tokens, Tokens2, PredNames, ErrorNames),
   ( ErrorNames = []
     -> true
     ;  print_out_error('Error: illegal predicate identifier(s): ~w',
			[ErrorNames], WhichPart, Ln1, Ln2, [], null)
   ),
   ( Tokens2 = [graphic_name(':'), Token|Tokens3]
     -> ( predicate_spec(Token, Spec, Arity)
	  -> predicate_type(Tokens3, Tokens4, WholeTokens, DomainTypes, Arity,
				Error, Ln1, Ln2, OldLang, WhichPart)
	  ;  Spec = 'Syntax.NoPredInd.C0',
	     predicate_type([graphic_name(':'), Token|Tokens3], Tokens4,
				WholeTokens, DomainTypes, _, Error, Ln1, Ln2,
				OldLang, WhichPart)
	),
	( var(Error)
	  -> length(DomainTypes, Arity),
	     insert_predicate_decl(PredNames, 'ProgDefs.PredicateDecl.F3'(Arity,
						Spec, DomainTypes),
		    Arity, ModuleName, Accessibility, Ln1, Ln2, OldLang, Lang2),
	     ( Tokens4 =[]
	       -> NewLang = Lang2
	       ;  ( Tokens4 = [';'|Tokens5]
		    -> predicate_decl(Tokens5, WholeTokens, Ln1, Ln2,
				ModuleName, Accessibility, Lang2, NewLang)
		    ;  length(Tokens4, Position1),
		       Position is Position1 - 1,
		       print_out_error('Error: illegal symbol', [], WhichPart,
				Ln1, Ln2, WholeTokens, Position),
		       split_list(Tokens4, ';', _, Tokens5),
		       predicate_decl(Tokens5, WholeTokens, Ln1, Ln2,
				ModuleName, Accessibility, OldLang, NewLang)
		  )
	     )
	  ;  split_list(Tokens4, ';', _, Tokens5),
	     predicate_decl(Tokens5, WholeTokens, Ln1, Ln2, ModuleName,
			 Accessibility, OldLang, NewLang)
	)
     ;  length(Tokens2, Position),
	print_out_error('Error: ":" expected', [], WhichPart, Ln1, Ln2,
			WholeTokens, Position),
	split_list(Tokens2, ';', _, Tokens3),
	predicate_decl(Tokens3, WholeTokens, Ln1, Ln2, ModuleName,
			Accessibility, OldLang, NewLang)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

predicate_type(Tokens, RestTokens, WholeTokens, DomainTypes, Arity, Error,
		Ln1, Ln2, Language, WhichPart) :-
   ( Tokens = [graphic_name(':')|Tokens2]
     -> star_type_seq(Tokens2, RestTokens, WholeTokens, DomainTypes, Error,
			Ln1, Ln2, Language, WhichPart),
	( var(Error)
	  -> ( length(DomainTypes, Arity)
	       -> true
	       ;  Error = yes,
		  length(RestTokens, Position),
		  print_out_error('Error: inappropriate arity for operator',
			[], WhichPart, Ln1, Ln2, WholeTokens, Position)
	     )
	  ;  true
	)
     ;  Error = yes,
	RestTokens = Tokens,
	length(Tokens, Position),
	print_out_error('Error: ":" expected', [], WhichPart, Ln1, Ln2,
			WholeTokens, Position)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

insert_predicate_decl([], _, _, _, _, _, _, Lang, Lang).
insert_predicate_decl([PredName|PredNames], Decl, Arity, ModuleName,
			Accessibility, Ln1, Ln2, OldLang, NewLang) :-
   string2Gstring(PredName, GPredName),
   ( reserved_predicate_name(PredName)
     -> Lang2 = OldLang,
	accessibility2part(Accessibility, WhichPart),
	print_out_error('Error: attempt to redefine reserved predicate "~w"',
			     [PredName], WhichPart, Ln1, Ln2, [], null)
     ;  'ParserPrograms.ParserSymbols.P3'(GPredName, OldLang, Candidates),
        ( member('ParserPrograms.PCandidate.F2'('MetaDefs.Name.F4'(ModuleName,
		GPredName, 'MetaDefs.Predicate.C0', Arity), _), Candidates)
          -> Lang2 = OldLang,
	     accessibility2part(Accessibility, WhichPart),
	     print_out_error('Error: predicate "~w/~d" already declared',
			[PredName, Arity], WhichPart, Ln1, Ln2, [], null)
          ;  'ParserPrograms.ParserInsert.P5'(OldLang, 'MetaDefs.Name.F4'(ModuleName,
				  GPredName, 'MetaDefs.Predicate.C0', Arity),
				Accessibility, Decl, Lang2)
	)
   ),
   insert_predicate_decl(PredNames, Decl, Arity, ModuleName, Accessibility,
		Ln1, Ln2, Lang2, NewLang).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

predicate_spec(big_name(Name), Spec, Arity) :-
	predicate_spec_aux(Name, Spec, Arity).
predicate_spec(little_name(Name), Spec, Arity) :-
	predicate_spec_aux(Name, Spec, Arity).

predicate_spec_aux('Pz', 'Syntax.PZ.C0', 1).
predicate_spec_aux('zP', 'Syntax.ZP.C0', 1).
predicate_spec_aux('zPz', 'Syntax.ZPZ.C0', 2).


/*=============================================================================
 * user_name_seq(+Token_of_usernames, -UserNames, -ErrorNames).
 * this ends with empty, and :.
 */

user_name_seq([], [], [], []).
user_name_seq([Token|Tokens], Tokens2, UserNames, ErrorNames):-
   ( Token = ','
     -> user_name_seq(Tokens, Tokens2, UserNames, ErrorNames)
     ;  ( Token = graphic_name(':')
	  -> Tokens2 = [Token|Tokens],
	     UserNames = [],
	     ErrorNames = []
	  ;  ( user_name(Token, UserName)
	       -> UserNames = [UserName|UserNames2],
		  ErrorNames = ErrorNames2
	       ;  UserNames = UserNames2,
		  ErrorNames = [Token|ErrorNames2]
	     ),
	     user_name_seq(Tokens, Tokens2, UserNames2, ErrorNames2)
	)
   ).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * user_name fails if it's a reserved word and not a valid user name.
 */

user_name(big_name(UserName), UserName) :-
   \+ reserved_word(UserName).

user_name(graphic_name(UserName), UserName) :-
   \+ reserved_word(UserName).


/*=============================================================================
 * parse_delays(+ModuleName, +ExpTokens, -ExpTokens2, +LocTokens, -LocTokens2,
 *		+ModulePartExp, +ModulePartLoc, +Language, +OldProg, -NewProg)
 * the module-name declarations are removed here
 */

parse_delays(ModuleName, ExpTokens, ExpTokens2, LocTokens, LocTokens2,
		ModulePartExp, ModulePartLoc, Language, OldProg, NewProg) :-
   parse_delays_aux(ExpTokens, ExpTokens2, ModuleName, ModulePartExp,
		Language, OldProg, Prog2, export),
   parse_delays_aux(LocTokens, LocTokens2, ModuleName, ModulePartLoc,
		Language, Prog2, NewProg, local).


parse_delays_aux([], [], _, _, _, Prog, Prog, _).
parse_delays_aux([Item|Items], RestItems, ModuleName, ModulePart, Language,
		OldProg, NewProg, WhichPart) :-
   ( Item = item([big_name('DELAY')|DelayPart], Ln1, Ln2)
     -> parse_delay_part(DelayPart, [big_name('DELAY')|DelayPart], ModuleName,
		ModulePart, Language, OldProg, Prog2, Ln1, Ln2, WhichPart),
	%dot,
	parse_delays_aux(Items, RestItems, ModuleName, ModulePart, Language,
			Prog2, NewProg, WhichPart)
     ;  RestItems = [Item|RestItems2],
	parse_delays_aux(Items, RestItems2, ModuleName, ModulePart, Language,
			OldProg, NewProg, WhichPart)
   ).


parse_delay_part([], _, _, _, _, Prog, Prog, _, _, _):- !.
parse_delay_part(Tokens, WholeTokens, ModuleName, ModulePart, Language,
		OldProg, NewProg, Ln1, Ln2, WhichPart):-
   underscore_init,     % initialising underscore label counter.
   headatom(Tokens, Tokens2, ModuleName, HeadAtoms, ErrorReturn, Language),
					%in statement.pl
   ( HeadAtoms = []
     -> print_error_return(ErrorReturn, WholeTokens, WhichPart, Ln1, Ln2),
	split_list(Tokens, ';', _, Tokens3),
	parse_delay_part(Tokens3, WholeTokens, ModuleName, ModulePart, Language,
			OldProg, NewProg, Ln1, Ln2, WhichPart)
     ;  'SharedPrograms.ProgramLanguage.P2'(OldProg, ProgLanguage),
	'ParserPrograms.ParserCheckFormula.P4'(HeadAtoms, ProgLanguage, HeadAtom,
		ErrorMessages),
        ( ErrorMessages = []
	  -> get_predicate_arity(HeadAtom, PredicateSymbol, Arity),
	     ( Arity = 0
	       -> gstring2string(PredicateSymbol, Proposition),
		  print_out_error('Warning: proposition "~w" in delay declaration',
			[Proposition], WhichPart, Ln1, Ln2, [], null)
	       ;  true
	     ),
             ( Tokens2 = [big_name('UNTIL')|Tokens3]
               -> ( cond(Tokens3, Tokens4, Condition, WholeTokens, Error,
				Ln1, Ln2, WhichPart),
		    ( var(Error)
		      -> ( delay_condition(OldProg, ModuleName, PredicateSymbol,
					Arity, HeadAtom)
			   -> collect_variables(HeadAtom, [], HeadVars),
			      collect_variables(Condition, [], CondVars),
			      set_minus(CondVars, HeadVars, BadVars),
			      strip_variables(BadVars, BadVars2),
			      ( BadVars2 = []
				-> true
				;  print_out_error('Warning: variables ~w in delay condition do not occur in the head-atom',
				     [BadVars2], WhichPart, Ln1, Ln2, [], null)
			      ),
			      'ParserPrograms.QuickInsertDelay.P7'(OldProg, ModuleName,
				PredicateSymbol, Arity, ModulePart,
				'ProgDefs.Delay.F2'(HeadAtom, Condition),
				Prog2)
			   ;  Prog2 = OldProg,
			      length(Tokens4, Position),
			      print_out_error('Error: headatom unifiable with previous delay declaration(s)', [], WhichPart, Ln1, Ln2, WholeTokens, Position)
			 )
		      ;  Prog2 = OldProg
		    ),
		    ( Tokens4 = []
		      -> NewProg = Prog2
		      ;  ( Tokens4 = [';'|Tokens5]
			   -> parse_delay_part(Tokens5, WholeTokens, ModuleName,
				ModulePart, Language, Prog2, NewProg, Ln1, Ln2,
				WhichPart)
			   ;  length(Tokens4, Position),
			      print_out_error('Error: missing ";" or "."',
				[], WhichPart, Ln1, Ln2, WholeTokens, Position),
		              split_list(Tokens4, ';', _, Tokens5),
			      parse_delay_part(Tokens5, WholeTokens, ModuleName,
				ModulePart, Language, Prog2, NewProg, Ln1, Ln2,
				WhichPart)
			 )
		    )
	          )
               ;  length(Tokens2, Position),
		  print_out_error('Error: "UNTIL" expected', [], WhichPart,
					Ln1, Ln2, WholeTokens, Position),
		  split_list(Tokens2, ';', _, Tokens3),
		  parse_delay_part(Tokens3, WholeTokens, ModuleName, ModulePart,
				Language, OldProg, NewProg, Ln1, Ln2, WhichPart)
	     )
	  ;  NewProg = OldProg,
	     print_type_error(ErrorMessages, WhichPart, Ln1, Ln2)
	)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * This picks up delay conditions previously declared and checks whether the
 * new headatom unifies with them.  If so, it fails.
 */

delay_condition(Prog, ModuleName, PredicateSymbol, Arity, HeadAtom) :-
   ( 'SharedPrograms.SControlInProgram.P5'(Prog, ModuleName,
		'MetaDefs.Name.F4'(ModuleName, PredicateSymbol, _, Arity),
		HeadAtomList, _)
     -> delay_condition_aux(HeadAtomList, HeadAtom)
     ;  true
   ).


delay_condition_aux([], _).
delay_condition_aux([Atom|HeadAtomList], HeadAtom) :-
   ( 'SharedSyntax.SEmptyTermSubst.P1'(EmptySubst),
     'SharedSyntax.SUnifyAtoms.P4'(Atom, HeadAtom, EmptySubst, _)
     -> fail
     ;  delay_condition_aux(HeadAtomList, HeadAtom)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

cond([], [], _, _, yes, _, _, _).

cond([Token|Tokens], RestTokens, Condition, WholeTokens, Error, Ln1, Ln2,
		WhichPart) :-
   cond1(Token, Tokens, RestTokens2, Cond1, WholeTokens, Error, Ln1, Ln2,
		WhichPart),
   ( var(Error)
     -> ( RestTokens2 = []
          -> Condition = Cond1,
             RestTokens = RestTokens2
          ;  RestTokens2 = [Token3|RestTokens3],
	     ( Token3 = graphic_name('&')
	       -> Condition = 'ProgDefs.And.F2'(Cond1, Cond2),
		  and_seq(RestTokens3, RestTokens, Cond2, WholeTokens, Error,
				Ln1, Ln2, WhichPart)
			% error will automatically returned
	       ;  ( Token3 = graphic_name('\\/')   % added \ djd
	            -> Condition = 'ProgDefs.Or.F2'(Cond1, Cond2),
		       or_seq(RestTokens3, RestTokens, Cond2, WholeTokens,
				Error, Ln1, Ln2, WhichPart)
	            ;  Condition = Cond1,
		       RestTokens = RestTokens2
	          )
	     )
	)
     ;  RestTokens = RestTokens2
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

cond1(big_name(ReservedWord), Tokens, RestTokens, Condition, WholeTokens,
		Error, Ln1, Ln2, WhichPart):-
   !,
   ( ReservedWord = 'TRUE'
     -> Condition = 'ProgDefs.TrueCond.C0',
	RestTokens = Tokens
     ;  ( Tokens = ['(', little_name(Var), ')' | RestTokens]
	  -> var_conversion(Var, 0, VarRep),
             ( ReservedWord = 'NONVAR'
	       -> Condition = 'ProgDefs.Nonvar.F1'(VarRep)
	       ;  ( ReservedWord = 'GROUND'
	            -> Condition = 'ProgDefs.Ground.F1'(VarRep)
	            ;  Error = yes,
		       length(Tokens, Position),
		       print_out_error('Error: illegal delay condition',
				[], WhichPart, Ln1, Ln2, WholeTokens, Position)
		  )
	     )
	  ;  Error = yes,
	     RestTokens = Tokens,
	     length(Tokens, Position),
	     print_out_error('Error: variable argument expected', [], WhichPart,
				Ln1, Ln2, WholeTokens, Position)
	)
   ).

cond1('(', Tokens, RestTokens, Condition, WholeTokens, Error, Ln1, Ln2,
		WhichPart) :-
   !,
   cond(Tokens, RestTokens2, Condition, WholeTokens, Error, Ln1, Ln2,
		WhichPart),
   ( nonvar(Error)
     -> RestTokens = RestTokens2
     ;  ( RestTokens2 = [')' | RestTokens]
          -> true
          ;  Error = yes,
	     RestTokens = RestTokens2,
	     length(RestTokens2, Position),
	     print_out_error('Error: ")" expected', [], WhichPart, Ln1, Ln2,
				WholeTokens, Position)
	)
   ).

% handling error cases
cond1(Token, Tokens, [Token|Tokens], _, WholeTokens, yes, Ln1, Ln2,
		WhichPart) :-
   length([Token|Tokens], Position),
   print_out_error('Error: unexpected symbols', [], WhichPart, Ln1, Ln2,
		WholeTokens, Position).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

and_seq([], [], _, _, yes, _, _, _).

and_seq([Token|Tokens], RestTokens, Condition, WholeTokens, Error, Ln1, Ln2,
		WhichPart) :-
   cond1(Token, Tokens, RestTokens2, Cond1, WholeTokens, Error, Ln1, Ln2,
		WhichPart),
   ( var(Error)
     -> ( RestTokens2 = [graphic_name('&')|RestTokens3]
	  -> Condition = 'ProgDefs.And.F2'(Cond1, Cond2),
	     and_seq(RestTokens3, RestTokens, Cond2, WholeTokens, Error,
			Ln1, Ln2, WhichPart)
	  ;  Condition = Cond1,
	     RestTokens = RestTokens2
	)
     ;  RestTokens = RestTokens2
   ).

or_seq([], [], _, _, yes, _, _, _).

or_seq([Token|Tokens], RestTokens, Condition, WholeTokens, Error, Ln1, Ln2,
		WhichPart) :-
   cond1(Token, Tokens, RestTokens2, Cond1, WholeTokens, Error, Ln1, Ln2,
		WhichPart),
   ( var(Error)
     -> ( RestTokens2 = [graphic_name('\\/')|RestTokens3] % added \ djd
	  -> Condition = 'ProgDefs.Or.F2'(Cond1, Cond2),
	     or_seq(RestTokens3, RestTokens, Cond2, WholeTokens, Error,
			Ln1, Ln2, WhichPart)
	  ;  Condition = Cond1,
	     RestTokens = RestTokens2
	)
     ;  RestTokens = RestTokens2
   ).


/*=============================================================================
 * parse_statements(+ModuleName, +ExpTokens, +LocTokens, +Language, +OldProg,
 *			-NewProg)
 */

parse_statements(ModuleName, ExpTokens, LocTokens, Language, OldProg, NewProg):-
   ( ExpTokens = []	% there should be no statement in export part
     -> true
     ;  assert(there_is_error),
	format(user_error, '~nError: there are illegal items in the export part of module "~w"~nThese items are:~n', [ModuleName]),
	print_error_items(ExpTokens)
   ),
   parse_statements_aux(LocTokens, ModuleName, Language, OldProg, NewProg).


parse_statements_aux([], _, _, Prog, Prog).
parse_statements_aux([Item|Items], ModuleName, Language, OldProg, NewProg):-
   statement(Item, ModuleName, Formulae, ErrorReturn, Language),
   Item = item(WholeTokens, Ln1, Ln2),	% for errors and other checking
   ( Formulae = []
     -> Prog2 = OldProg,
	print_error_return(ErrorReturn, WholeTokens, local, Ln1, Ln2)
     ;  'SharedPrograms.ProgramLanguage.P2'(OldProg, ProgLanguage),
        'ParserPrograms.ParserCheckStatement.P4'(Formulae, ProgLanguage,
			Statement, ErrorMessages),
	( ErrorMessages = []
	  -> get_predicate_arity(Statement, PredicateSymbol, Arity),
	     'ParserPrograms.QuickInsertStatement.P6'(OldProg, ModuleName,
			PredicateSymbol, Arity, Statement, Prog2),
	     ( checking_is_off
	       -> true
	       ;  singleton_variable_checking(Statement, PredicateSymbol, Arity,
				Ln1, Ln2),
	          quantified_variable_checking(Statement, Ln1, Ln2),
	          floundering_checking(Statement, Ln1, Ln2)
	     )
	  ;  Prog2 = OldProg,
	     print_type_error(ErrorMessages, local, Ln1, Ln2)
	)
   ),
   parse_statements_aux(Items, ModuleName, Language, Prog2, NewProg).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

get_predicate_arity('MetaDefs.<-''.F2'(Formula, _), PredicateSymbol, Arity):-
   get_predicate_arity(Formula, PredicateSymbol, Arity).
get_predicate_arity('MetaDefs.Atom.F2'(
			'MetaDefs.Name.F4'(_, PredicateSymbol, _, Arity), _),
		PredicateSymbol, Arity).
get_predicate_arity('MetaDefs.PAtom.F1'(
			'MetaDefs.Name.F4'(_, PredicateSymbol, _, Arity)),
		PredicateSymbol, Arity).

%------------------------------------------------------------------------------

my_format(Stream, Format, List) :-
   ( no_message
     -> true
     ;  format(Stream, Format, List)
   ).

/*=============================================================================
 * pretty_print_tokens(list(token))
 * no new-line is fed at the end unless there is a specific nl in the list.
 */

pretty_print_tokens([]).
pretty_print_tokens([H|T]):-
   pretty_print_token(H),
   pretty_print_tokens(T).

% nl for a new-line
pretty_print_token(nl):-
   !,
   format(user_error, '~n', []).
pretty_print_token(big_name(A)):-
   !,
   format(user_error, ' ~w', [A]).
pretty_print_token(little_name(A)):-
   !,
   format(user_error, ' ~w', [A]).
pretty_print_token('_'(A)):-
   !,
   format(user_error, ' ~w', [A]).
pretty_print_token(string(A)):-
   !,
   format(user_error, ' "~w"', [A]).
pretty_print_token('}'(1000000000)):-
   !,
   format(user_error, ' }', []).
pretty_print_token('}'(A)):-
   !,
   format(user_error, ' }_~w', [A]).
pretty_print_token(number(A)):-
   !,
   format(user_error, ' ~w', [A]).
pretty_print_token(float(A)):-
   !,
   format(user_error, ' ~e', [A]).
pretty_print_token(graphic_name(A)):-
   !,
   format(user_error, ' ~w', [A]).
pretty_print_token(','):-
   !,
   format(user_error, ',', []).
pretty_print_token(A):-
   format(user_error, ' ~w', [A]).


/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

print_error_items([]).
print_error_items([item(Tokens, Ln1, Ln2)|Items]) :-
   format(user_error, 'Item in lines ~d-~d : ', [Ln1, Ln2]),
   pretty_print_tokens(Tokens),
   format(user_error, '.~n', []),
   print_error_items(Items).


/*------------------------------------------------------------------------------
 */

print_error_return(ErrorReturn, Tokens, WhichPart, Ln1, Ln2) :-
   sort(ErrorReturn, ErrorReturn2),
   length(ErrorReturn2, Number_of_Errors),
   print_error_return(ErrorReturn2, Number_of_Errors, Tokens, WhichPart,
		Ln1, Ln2).


print_error_return([], _, _, _, _, _).
print_error_return([error(Format, Parameters)/Position|ErrorReturn],
	Number_of_Errors, Tokens, WhichPart, Ln1, Ln2) :-
   ( bad_message(Format, Parameters), Number_of_Errors > 1
     -> true
     ;  sappend('Error: ', Format, Format2),
        print_out_error(Format2, Parameters, WhichPart, Ln1, Ln2, Tokens,
			Position)
   ),
   print_error_return(ErrorReturn, Number_of_Errors, Tokens, WhichPart, Ln1, Ln2).

% this filters out complains about reservered words in term.
bad_message('undeclared or illegal symbol: "~w"', Parameters) :-
   token_to_pattern(Parameters, Parameters2),
   sort(Parameters2, Parameters3),
   intersection(Parameters3, ['ALL','ELSE','IF','SOME','THEN'], Set),
   Set \== [].


/*------------------------------------------------------------------------------
 * print_out_error(+Format, +Parameters, +WhichPart, +Ln1, +Ln2, +Tokens,
 *			+Position)
 *   Tokens can be [], indicating that the item is not going to be printed
 *   Position can be null, indicating '*here*' is not printed, or donot_print
 *        which switch off the whole printing.
 *   If WhichPart is null, line numbers and lines are not printed
 */

print_out_error(_, _, _, _, _, _, donot_print) :- !.

print_out_error(Format, Parameters, WhichPart, Ln1, Ln2, Tokens, Position) :-
   name(Format, Chars),
   ( Chars = [0'E, 0'r, 0'r, 0'o, 0'r, 0': | Rest]
     -> assert(there_is_error),		% message to stop compilation
	format(user_error, '~nError:', [])
     ;  ( Chars = [0'W, 0'a, 0'r, 0'n, 0'i, 0'n, 0'g, 0': | Rest]
	  -> format(user_error, '~nWarning:', [])
	  ;  Rest = Chars
	)
   ),
   token_to_pattern(Parameters, Parameters2),
   ( ( WhichPart = null; Ln1 = 0, Ln2 = 0 )
     -> true
     ;  format(user_error, ' in lines ~d-~d', [Ln1, Ln2]),
	( WhichPart = local
          -> format(user_error, ' of local part,', [])
          ;  format(user_error, ' of export part,', [])
	)
   ),
   name(Format2, Rest),
   format(user_error, Format2, Parameters2),
   format(user_error, '.~n', []),
   ( Tokens = []
     -> true
     ;  length(Tokens, N),
        Counter is N - Position,
        format(user_error, '   ', []),
        print_position(Counter, Tokens)
   ).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

print_position(null, Tokens) :-
   !,
   pretty_print_tokens(Tokens),
   format(user_error, '.~n', []).
print_position(0, Tokens) :-
   !,
   format(user_error, '~n**here**~n', []),
   pretty_print_tokens(Tokens),
   format(user_error, '.~n', []).
print_position(Counter, [Token|Tokens]) :-
   Counter2 is Counter - 1,
   pretty_print_token(Token),
   print_position(Counter2, Tokens).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 */

token_to_pattern([], []) :- !.
token_to_pattern([H|T], [H2|T2]) :- !,
   token_to_pattern(H, H2),
   token_to_pattern(T, T2).

token_to_pattern('MetaDefs.Var.F1'(_), 'v') :- !.
token_to_pattern('MetaDefs.Var.F2'(GSymbol, _), A) :- !,
   gstring2string(GSymbol, A).
token_to_pattern('MetaDefs.Name.F4'(_, GSymbol, _, _), A) :- !,
   gstring2string(GSymbol, A).
token_to_pattern(big_name(A), A) :- !.
token_to_pattern(little_name(A), A):- !.
token_to_pattern('_'(A), A):- !.
token_to_pattern(string(A), A):- !.
token_to_pattern(number(A), A):- !.
token_to_pattern(float(A), A):- !.
token_to_pattern(graphic_name(A), A):- !.
token_to_pattern(A, A).

/*------------------------------------------------------------------------------
 */


print_type_error(Msgs, Part, Ln1, Ln2) :-
   sort(Msgs, Msgs2),
   assert(there_is_error),
   ( Msgs2 = ['SharedPrograms.Ambiguity.C0'|_] ->
     print_ambiguity_error(Msgs2, Part, Ln1, Ln2)
   ; ( Part = null
       -> format(user_error, '~nType error in goal, possibly:~n', [])
       ;  format(user_error, '~nType error in lines ~d-~d of ~a part, possibly:~n'
                , [Ln1, Ln2, Part])
     ),
     print_type_error_aux(Msgs2)
   ).


print_type_error_aux([]).

print_type_error_aux([Msg|Msgs]) :-
   print_type_error_msg(Msg),
   print_type_error_aux(Msgs).

print_type_error_msg('SharedPrograms.TypeError.F3'(Term, Type, Context)) :-
   format(user_error, ' - type clash, ', []),
   print_type_error_term(Term),
   ( Term = 'MetaDefs.Num.F1'(_) ->
     format(user_error, ' cannot have type ', [])
   ; format(user_error, ' has type ', []),
     print_type_error_type(Type),
     format(user_error, ', does not match ', [])
   ),
   print_type_error_type(Context),
   nl(user_error).

print_type_error_msg('SharedPrograms.HeadError.F3'(Term, Type, Context)) :-
   format(user_error, ' - head type too specific, ', []),
   print_type_error_term(Term),
   format(user_error, ' has type ', []),
   print_type_error_type(Type),
   format(user_error, ', not type ', []),
   print_type_error_type(Context),
   nl(user_error).


print_ambiguity_error(_, Part, Ln1, Ln2) :-
   ( Part = null
     -> format(user_error, '~nError: ambiguity in the query.~n', [])
     ;  format(user_error, '~nError: ambiguity in lines ~d-~d of ~a part.~n'
      , [Ln1, Ln2, Part])
   ).


print_type_error_term('MetaDefs.Var.F1'(N)) :-
   ( N = 0 ->
     format(user_error, 'variable "~a"', ['v'])
   ; format(user_error, 'variable "~a_~d"', ['v', N])
   ).

print_type_error_term('MetaDefs.Var.F2'(S, N)) :-
   gstring2string(S, A),
   ( N = 0 ->
     format(user_error, 'variable "~a"', [A])
   ; format(user_error, 'variable "~a_~d"', [A, N])
   ).

print_type_error_term('MetaDefs.CTerm.F1'('MetaDefs.Name.F4'(_, S, _, _))) :-
   gstring2string(S, A),
   format(user_error, 'constant "~a"', [A]).

print_type_error_term('MetaDefs.Term.F2'('MetaDefs.Name.F4'(_, S, _, N), _)) :-
   gstring2string(S, A),
   format(user_error, 'term with functor "~a/~d"', [A, N]).

print_type_error_term('MetaDefs.Str.F1'(S)) :-
   format(user_error, 'string ~a"', [S]).

print_type_error_term('MetaDefs.Int.F1'(N)) :-
   format(user_error, 'integer "~d"', [N]).

print_type_error_term('MetaDefs.Num.F1'(N)) :-
   format(user_error, 'number "~d"', [N]).


% ** More here **


print_type_error_type('MetaDefs.Par.F2'(S, N)) :-
   gstring2string(S, A),
   ( N = 0 ->
     format(user_error, '~a', [A])
   ; format(user_error, '~a_~d', [A, N])
   ).

print_type_error_type('MetaDefs.Par.F1'(N)) :-
   ( N = 0 ->
     format(user_error, 'p', [])
   ; format(user_error, 'p_~d', [N])
   ).

print_type_error_type('MetaDefs.BType.F1'('MetaDefs.Name.F4'(_, S, _, _))) :-
   gstring2string(S, A),
   format(user_error, '~a', [A]).

print_type_error_type('MetaDefs.Type.F2'('MetaDefs.Name.F4'(_, S, _, _)
      , [Arg|Args])
      ) :-
   gstring2string(S, A),
   format(user_error, '~a(', [A]),
   print_type_error_type(Arg),
   print_type_error_type_list(Args),
   format(user_error, ')', []).

print_type_error_type_list([]).

print_type_error_type_list([Type|Types]) :-
   format(user_error, ',', []),
   print_type_error_type(Type),
   print_type_error_type_list(Types).

%==============================================================================
% A collection Goedel reserved words

system_module_name('"Integers').
system_module_name('"Rationals').
system_module_name('"Floats').
system_module_name('"Numbers').
system_module_name('"NumbersIO').

system_module_name('"Lists').
system_module_name('"Sets').
system_module_name('"Strings').
system_module_name('"Tables').

system_module_name('"Units').
system_module_name('"Flocks').
system_module_name('"FlocksIO').
system_module_name('"IO').

system_module_name('"Syntax').
system_module_name('"SharedSyntax').
system_module_name('"ExtraSyntax').
system_module_name('"Substs').
system_module_name('"MetaDefs').

system_module_name('"Programs').
system_module_name('"SharedPrograms').
system_module_name('"ProgDefs').
system_module_name('"ProgramCache').

system_module_name('"Scripts').
system_module_name('"ScriptsIO').
system_module_name('"ProgramsIO').
system_module_name('"Theories').
system_module_name('"TheoriesIO').
system_module_name('"AVLTrees').

%------------------------------------------------------------------------------

open_system_module('"Syntax').

%------------------------------------------------------------------------------

reserved_proposition_name('True').
reserved_proposition_name('False').

%- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

reserved_predicate_name('=').
reserved_predicate_name('~=').

%------------------------------------------------------------------------------

reserved_word('EXPORT').
reserved_word('LOCAL').
reserved_word('CLOSED').
reserved_word('MODULE').
reserved_word('THEORY').
reserved_word('IMPORT').
reserved_word('LIFT').
reserved_word('BASE').
reserved_word('CONSTRUCTOR').
reserved_word('CONSTANT').
reserved_word('FUNCTION').
reserved_word('PROPOSITION').
reserved_word('PREDICATE').
reserved_word('DELAY').
reserved_word('UNTIL').
reserved_word('GROUND').
reserved_word('NONVAR').
reserved_word('TRUE').
reserved_word('ALL').
reserved_word('SOME').
reserved_word('IF').
reserved_word('THEN').
reserved_word('ELSE').
reserved_word(':').
reserved_word('<-').
reserved_word('->').
reserved_word('<->').
reserved_word('&').
reserved_word('~').
reserved_word('\\/').  % added \ djd
reserved_word('|').

:- style_check(-singleton). % added djd
% Copyright (C) Goedel Group, University of Bristol, June 1992.
% Title and ownership of all Goedel software originating from the Goedel
% Group at the University of Bristol remains with the Goedel Group.
%
% The Goedel language was designed by P.M. Hill and J.W. Lloyd, and the
% language was implemented by A. Bowers and J. Wang. The design and
% implementation of the language was partly supported by the ESPRIT Basic
% Research Action 3012 (Compulog), a SERC Grant GR/F/26256, and the
% University of Bristol.
%
% This software is available ONLY for research and educational purposes.
% In particular, it may not be used for any commercial purpose whatsoever.
% The software is free and is provided "as is", without warranty of any kind.
% Users of the software are free to modify and experiment with it for
% research and educational purposes. However, users may not distribute
% the software (modified or not) to third parties without the express
% permission of the Goedel Group. The normal method of obtaining this
% software is by ftp from ftp.cs.kuleuven.ac.be.
%
% Any enquiries about this copyright notice or the use of this software
% should be directed to J.W. Lloyd at jwl@compsci.bristol.ac.uk.


/* File:	checking.pl
Subject:	Singleton variable checking, missing quantified variable
		checking, floundering checking.
Author:		Jiwei Wang
Date:		18 November 1993

================================================================================
*/

%% '$$module'('@(#)checking.pl 1.3 last updated 93/11/29 14:25:02 by jiwei').

:- module(checking).  %% converted djd

%------------------------------------------------------------------------------
% singleton_variable_checking is done before transform
% This checking excludes the case of variables appeared in disjuncts (or
% (Than and Else parts).  E.g. P(x) <- Q(x,y) \/ R(y).

singleton_variable_checking(Formula, GPredicate, Arity, Ln1, Ln2) :-
   collect_variables(Formula, [], Vars),
   singleton_variables(Vars, SingletonVars),
   strip_variables(SingletonVars, SingletonVars2),
   ( SingletonVars2 = []
     -> true
     ;  gstring2string(GPredicate, Predicate),
	print_out_error('Warning: singleton variable(s) ~w in predicate "~w/~d"',
		[SingletonVars2, Predicate, Arity], local, Ln1, Ln2, [], null)
   ).

%------------------------------------------------------------------------------
% collect_variables gathers free varibles.

collect_variables('MetaDefs.Var.F1'(V), Vars, ['MetaDefs.Var.F1'(V)|Vars]).
collect_variables('MetaDefs.Var.F2'(V,N), Vars, ['MetaDefs.Var.F2'(V,N)|Vars]).

collect_variables([], Vars, Vars).
collect_variables([H|T], Vars, Vars2) :-
	collect_variables(H, Vars, Vars3),
	collect_variables(T, Vars3, Vars2).

collect_variables('MetaDefs.CTerm.F1'(_), Vars, Vars).
collect_variables('MetaDefs.Num.F1'(_), Vars, Vars).	% for Rationals
collect_variables('MetaDefs.Int.F1'(_), Vars, Vars).
collect_variables('MetaDefs.Str.F1'(_), Vars, Vars).
collect_variables('MetaDefs.Flo.F1'(_), Vars, Vars).
collect_variables('MetaDefs.Term.F2'(_, Terms), Vars, NewVars) :-
	collect_variables(Terms, Vars, NewVars).

collect_variables('MetaDefs.SuchThat.F2'(Term1, Term2), Vars, NewVars) :-
	collect_variables(Term1, [], Vars1),
	collect_variables(Term2, [], Vars2),
	delete_sublist(Vars2, Vars1, Vars, NewVars).

collect_variables('MetaDefs.Empty.C0', Vars, Vars).
collect_variables('MetaDefs.PAtom.F1'(_), Vars, Vars).
collect_variables('MetaDefs.Atom.F2'(_, Terms), Vars, Vars2) :-
	collect_variables(Terms, Vars, Vars2).

collect_variables('MetaDefs.Commit.F2'(_, Formula), Vars, Vars2):-
	collect_variables(Formula, Vars, Vars2).

collect_variables('MetaDefs.~''.F1'(Formula), Vars, Vars2) :-
	collect_variables(Formula, Vars, Vars2).

collect_variables('MetaDefs.&''.F2'(Formula1, Formula2), Vars, Vars2) :-
	collect_variables(Formula1, Vars, Vars3),
	collect_variables(Formula2, Vars3, Vars2).

collect_variables('MetaDefs.\\/''.F2'(Formula1, Formula2), Vars, Vars2) :-  % added \ djd
	collect_variables(Formula1, Vars, Vars3),
	collect_variables(Formula2, Vars3, Vars2).

collect_variables('MetaDefs.->''.F2'(Formula1, Formula2), Vars, Vars2) :-
	collect_variables(Formula1, Vars, Vars3),
	collect_variables(Formula2, Vars3, Vars2).

collect_variables('MetaDefs.<-''.F2'(Formula1, Formula2), Vars, Vars2) :-
	collect_variables(Formula1, Vars, Vars3),
	collect_variables(Formula2, Vars3, Vars2).

collect_variables('MetaDefs.<->''.F2'(Formula1, Formula2), Vars, Vars2) :-
	collect_variables(Formula1, Vars, Vars3),
	collect_variables(Formula2, Vars3, Vars2).

collect_variables('MetaDefs.IT.F2'(Formula1, Formula2), Vars, Vars2) :-
	collect_variables(Formula1, Vars, Vars3),
	collect_variables(Formula2, Vars3, Vars2).

collect_variables('MetaDefs.ITE.F3'(Formula1, Formula2, Formula3),
			Vars, Vars2) :-
	collect_variables(Formula1, Vars, Vars3),
	collect_variables(Formula2, Vars3, Vars4),
	collect_variables(Formula3, Vars4, Vars2).

collect_variables('MetaDefs.All.F2'(VarList, Formula), Vars, Vars2) :-
	collect_variables(Formula, [], Vars3),
	delete_sublist(Vars3, VarList, Vars, Vars2).

collect_variables('MetaDefs.Some.F2'(VarList, Formula), Vars, Vars2) :-
	collect_variables(Formula, [], Vars3),
	delete_sublist(Vars3, VarList, Vars, Vars2).

collect_variables('MetaDefs.IST.F3'(VarList, Formula1, Formula2),
		Vars, Vars2) :-
	collect_variables(Formula1, [], Vars3),
	collect_variables(Formula2, Vars3, Vars4),
	delete_sublist(Vars4, VarList, Vars, Vars2).

collect_variables('MetaDefs.ISTE.F4'(VarList, Formula1, Formula2, Formula3),
		Vars, Vars2) :-
	collect_variables(Formula1, [], Vars3),
	collect_variables(Formula2, Vars3, Vars4),
	delete_sublist(Vars4, VarList, Vars, Vars5),
	collect_variables(Formula3, Vars5, Vars2).

% The following are for delay conditions
collect_variables('ProgDefs.TrueCond.C0', Vars, Vars).

collect_variables('ProgDefs.Ground.F1'(CondVar), Vars, Vars2) :-
	collect_variables(CondVar, Vars, Vars2).

collect_variables('ProgDefs.Nonvar.F1'(CondVar), Vars, Vars2) :-
	collect_variables(CondVar, Vars, Vars2).

collect_variables('ProgDefs.And.F2'(Cond1, Cond2), Vars, Vars2) :-
	collect_variables(Cond1, Vars, Vars3),
	collect_variables(Cond2, Vars3, Vars2).

collect_variables('ProgDefs.Or.F2'(Cond1, Cond2), Vars, Vars2) :-
	collect_variables(Cond1, Vars, Vars3),
	collect_variables(Cond2, Vars3, Vars2).

%- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
% The following are for formulas after Lloyd-Topor transformation.
% For collecting productive vars, the following are rather different from
% collecting free vars.

% negative transformed formulas do not contribute to variable instantiation.
collect_variables('MetaDefs.Neg.F2'(_, _), Vars, Vars).

% intensional sets do not contribute to variable instantiation.
collect_variables('MetaDefs.SuchThat.F3'(_, _, _), Vars, Vars).

% losing quantifiers in transformation is not a serious problem, as
% bound variables are uniquely renamed.
% It's still problematic that Then and Else are taken as conjucts.
collect_variables('MetaDefs.If.F4'(_Vars, _Cond, Then, Else), Vars, Vars2) :-
   collect_variables(Then, Vars, Vars3),
   collect_variables(Else, Vars3, Vars2).

collect_variables('MetaDefs.IfSome.F4'(_Vars, _Cond, Then, Else), Vars, Vars2):-
   collect_variables(Then, Vars, Vars3),
   collect_variables(Else, Vars3, Vars2).

%------------------------------------------------------------------------------
% underscore variables are removed.

strip_variables([], []).
strip_variables(['MetaDefs.Var.F1'(_)|VarList], ['v'|VarList2]) :- !,
   strip_variables(VarList, VarList2).
strip_variables(['MetaDefs.Var.F2'(GVar, _)|VarList], VarList2) :-
   ( name(GVar, [0'",0'_|_])
     -> VarList2 = VarList3
     ;  VarList2 = [Var|VarList3],
        gstring2string(GVar, Var)
   ),
   strip_variables(VarList, VarList3).


delete_sublist([], _, Vars, Vars).
delete_sublist([Var|OldVars], VarList, Vars, Vars2) :-
   ( member(Var, VarList)
     -> Vars2 = Vars3,
        delete_sublist(OldVars, VarList, Vars, Vars3)
     ;  Vars2 = [Var|Vars3],
        delete_sublist(OldVars, VarList, Vars, Vars3)
   ).

%- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

singleton_variables([], []).
singleton_variables([Var|Vars], SingletonVars) :-
	( special_delete_all(Vars, Var, Vars2)
	  -> singleton_variables(Vars2, SingletonVars)
	  ;  singleton_variables(Vars, SingletonVars2),
	     SingletonVars = [Var|SingletonVars2]
	).

/*- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 * special_delete_all(+Vars, +Var, -NewVars, -NewVars2)
 * It fails if Var does not occur in Vars.
 */

special_delete_all([Var|Vars], Var, NewVars) :-
	!,
	special_delete_all_aux(Vars, Var, NewVars).
special_delete_all([Var2|Vars], Var, [Var2|NewVars]) :-
	special_delete_all(Vars, Var, NewVars).


special_delete_all_aux([], _, []).
special_delete_all_aux([Var|Vars], Var, NewVars) :-
	!,
	special_delete_all_aux(Vars, Var, NewVars).
special_delete_all_aux([Var2|Vars], Var, [Var2|NewVars]) :-
	special_delete_all_aux(Vars, Var, NewVars).

%------------------------------------------------------------------------------

% quantified_variable_checking([], Ln1, Ln2) :- !. % unnecessary

quantified_variable_checking([Formula|Formulae], Ln1, Ln2) :-
   !,
   quantified_variable_checking(Formula, Ln1, Ln2),
   quantified_variable_checking(Formulae, Ln1, Ln2).

quantified_variable_checking('MetaDefs.Term.F2'(_, Terms), Ln1, Ln2) :-
   !,
   quantified_variable_checking(Terms, Ln1, Ln2).

quantified_variable_checking('MetaDefs.SuchThat.F2'(_, Formula), Ln1, Ln2) :-
   !,
   quantified_variable_checking(Formula, Ln1, Ln2).

quantified_variable_checking('MetaDefs.SuchThat.F3'(_, _, Formula), Ln1, Ln2) :-
   !,
   quantified_variable_checking(Formula, Ln1, Ln2).

quantified_variable_checking('MetaDefs.Atom.F2'(_, Terms), Ln1, Ln2) :-
   !,
   quantified_variable_checking(Terms, Ln1, Ln2).

quantified_variable_checking('MetaDefs.Commit.F2'(_, Formula), Ln1, Ln2):-
   !,
   quantified_variable_checking(Formula, Ln1, Ln2).

quantified_variable_checking('MetaDefs.~''.F1'(Formula), Ln1, Ln2) :-
   !,
   quantified_variable_checking(Formula, Ln1, Ln2).

quantified_variable_checking('MetaDefs.&''.F2'(Formula1, Formula2), Ln1, Ln2) :-
   !,
   quantified_variable_checking(Formula1, Ln1, Ln2),
   quantified_variable_checking(Formula2, Ln1, Ln2).

quantified_variable_checking('MetaDefs.\\/''.F2'(Formula1, Formula2), Ln1, Ln2):-   % added \ djd
   !,
   quantified_variable_checking(Formula1, Ln1, Ln2),
   quantified_variable_checking(Formula2, Ln1, Ln2).

quantified_variable_checking('MetaDefs.->''.F2'(Formula1, Formula2), Ln1, Ln2):-
   !,
   quantified_variable_checking(Formula1, Ln1, Ln2),
   quantified_variable_checking(Formula2, Ln1, Ln2).

quantified_variable_checking('MetaDefs.<-''.F2'(Formula1, Formula2), Ln1, Ln2):-
   !,
   quantified_variable_checking(Formula1, Ln1, Ln2),
   quantified_variable_checking(Formula2, Ln1, Ln2).

quantified_variable_checking('MetaDefs.<->''.F2'(Formula1, Formula2), Ln1, Ln2) :-
   !,
   quantified_variable_checking(Formula1, Ln1, Ln2),
   quantified_variable_checking(Formula2, Ln1, Ln2).

quantified_variable_checking('MetaDefs.IT.F2'(Formula1, Formula2), Ln1, Ln2) :-
   !,
   quantified_variable_checking(Formula1, Ln1, Ln2),
   quantified_variable_checking(Formula2, Ln1, Ln2).

quantified_variable_checking('MetaDefs.ITE.F3'(Formula1, Formula2, Formula3),
         Ln1, Ln2) :-
   !,
   quantified_variable_checking(Formula1, Ln1, Ln2),
   quantified_variable_checking(Formula2, Ln1, Ln2),
   quantified_variable_checking(Formula3, Ln1, Ln2).

quantified_variable_checking('MetaDefs.All.F2'(VarList, Formula), Ln1, Ln2) :-
   !,
   strip_variables(VarList, VarList2),
   process_quantified_variable(VarList2, VarList3, Ln1, Ln2),
   collect_variables(Formula, [], Vars),
   strip_variables(Vars, Vars2),
   set_minus(VarList3, Vars2, NotOccurredVars),
   ( NotOccurredVars = []
     -> true
     ;  print_out_error('Warning: quantified variable(s) ~w do not appear in their scope',
		     [NotOccurredVars], local, Ln1, Ln2, [], null)
   ),
   quantified_variable_checking(Formula, Ln1, Ln2).

quantified_variable_checking('MetaDefs.Some.F2'(VarList, Formula), Ln1, Ln2) :-
   !,
   strip_variables(VarList, VarList2),
   process_quantified_variable(VarList2, VarList3, Ln1, Ln2),
   collect_variables(Formula, [], Vars),
   strip_variables(Vars, Vars2),
   set_minus(VarList3, Vars2, NotOccurredVars),
   ( NotOccurredVars = []
     -> true
     ;  print_out_error('Warning: quantified variable(s) ~w do not appear in their scope',
		     [NotOccurredVars], local, Ln1, Ln2, [], null)
   ),
   quantified_variable_checking(Formula, Ln1, Ln2).

quantified_variable_checking('MetaDefs.IST.F3'(VarList, Formula1, Formula2),
      Ln1, Ln2) :-
   !,
   strip_variables(VarList, VarList2),
   process_quantified_variable(VarList2, VarList3, Ln1, Ln2),
   collect_variables([Formula1, Formula2], [], Vars),
   strip_variables(Vars, Vars2),
   set_minus(VarList3, Vars2, NotOccurredVars),
   ( NotOccurredVars = []
     -> true
     ;  print_out_error('Warning: quantified variable(s) ~w do not appear in their scope',
		     [NotOccurredVars], local, Ln1, Ln2, [], null)
   ),
   quantified_variable_checking(Formula1, Ln1, Ln2),
   quantified_variable_checking(Formula2, Ln1, Ln2).

quantified_variable_checking(
		'MetaDefs.ISTE.F4'(VarList, Formula1, Formula2, Formula3),
		Ln1, Ln2) :-
   !,
   strip_variables(VarList, VarList2),
   process_quantified_variable(VarList2, VarList3, Ln1, Ln2),
   collect_variables([Formula1, Formula2], [], Vars),
   strip_variables(Vars, Vars2),
   set_minus(VarList3, Vars2, NotOccurredVars),
   ( NotOccurredVars = []
     -> true
     ;  print_out_error('Warning: quantified variable(s) ~w do not appear in their scope',
		     [NotOccurredVars], local, Ln1, Ln2, [], null)
   ),
   quantified_variable_checking(Formula1, Ln1, Ln2),
   quantified_variable_checking(Formula2, Ln1, Ln2),
   quantified_variable_checking(Formula3, Ln1, Ln2).

quantified_variable_checking(_, _, _).

%------------------------------------------------------------------------------

process_quantified_variable(Vars, NewVars, Ln1, Ln2) :-
   process_quantified_variable_aux(Vars, NewVars, DupVars, []),
   ( DupVars = []
     -> true
     ;  print_out_error('Warning: quantified variable(s) ~w are specified more than once',
				   [DupVars], local, Ln1, Ln2, [], null)
   ).


process_quantified_variable_aux([], [], DupVars, DupVars).
process_quantified_variable_aux([Var|Vars], NewVars, DupVars, DupVars2) :-
   ( name(Var, [0'_|_])		% this is not in Gstring
     -> process_quantified_variable_aux(Vars, NewVars, DupVars, DupVars2)
     ;  ( member_check(Var, Vars)
	  -> DupVars = [Var|DupVars3],
	     process_quantified_variable_aux(Vars, NewVars, DupVars3, DupVars2)
	  ;  NewVars = [Var|NewVars2],
	     process_quantified_variable_aux(Vars, NewVars2, DupVars, DupVars2)
	)
   ).

%------------------------------------------------------------------------------
% floundering_checking(Statement, Ln1, Ln2)
% floundering checking needs the statement to be transformed.

floundering_checking('MetaDefs.<-''.F2'(HeadAtom, Body), Ln1, Ln2) :-
   ( Body = 'MetaDefs.Empty.C0'
     -> true
     ;  collect_variables(HeadAtom, [], HeadVars),
        toplev_conjunctions(Body, [], GoalList),
        f_checking(GoalList, HeadVars, [], Culprits),
	( Culprits = []
	  -> true
	  ;  sort(Culprits, Culprits2),
	     print_out_error('Warning: will flounder on variable(s) ~w',
				[Culprits2], local, Ln1, Ln2, [], null)
	)
   ).


floundering_checking_goal(Goal, Error) :-
   toplev_conjunctions(Goal, [], FGoalList),
   f_checking(FGoalList, [], [], Culprits),
   ( Culprits = []
     -> Error = no
     ;  sort(Culprits, Culprits2),
        Error = yes,
        print_out_error('Error: goal will flounder on variable(s) ~w',
                                [Culprits2], null, 0, 0, [], null)
   ).


floundering_checking_aux(Body, HeadVars, Culprits, Culprits2) :-
   conjunction_to_list(Body, [], GoalList),
   f_checking(GoalList, HeadVars, Culprits, Culprits2).

%- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

f_checking([], _, Culprits, Culprits).
f_checking([pair(Fomula, Vs)|Goals], PVars, Culprits, Culprits2) :-
   gather_productive_vars(Goals, PVars, PVars3),
   f_checking_aux(Fomula, PVars3, Culprits, Culprits3),
   append(Vs, PVars, PVars2),
   f_checking(Goals, PVars2, Culprits3, Culprits2).

%- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

f_checking_aux('MetaDefs.IfSome.F4'(FreeVars, Cond, Then, Else), PVars,
		Culprits, Culprits2):-
   set_minus(FreeVars, PVars, CulpritVars),
   strip_variables(CulpritVars, CulpritVars2),
   append(CulpritVars2, Culprits, Culprits3),
   collect_variables(Cond, PVars, PVars2),
   floundering_checking_aux(Then, PVars2, Culprits3, Culprits4),
   floundering_checking_aux(Else, PVars, Culprits4, Culprits2).

f_checking_aux('MetaDefs.If.F4'(FreeVars, _, Then, Else), PVars,
		Culprits, Culprits2):-
   set_minus(FreeVars, PVars, CulpritVars),
   strip_variables(CulpritVars, CulpritVars2),
   append(CulpritVars2, Culprits, Culprits3),
   floundering_checking_aux(Then, PVars, Culprits3, Culprits4),
   floundering_checking_aux(Else, PVars, Culprits4, Culprits2).

f_checking_aux('MetaDefs.Neg.F2'(FreeVars, Formula), PVars,
		Culprits, Culprits2):-
   set_minus(FreeVars, PVars, CulpritVars),
   strip_variables(CulpritVars, CulpritVars2),
   append(CulpritVars2, Culprits, Culprits3),
   floundering_checking_aux(Formula, PVars, Culprits3, Culprits2).

f_checking_aux('MetaDefs.SuchThat.F3'(FreeVars, _Term, Formula), PVars,
		Culprits, Culprits2):-
   set_minus(FreeVars, PVars, CulpritVars),
   strip_variables(CulpritVars, CulpritVars2),
   append(CulpritVars2, Culprits, Culprits3),
   floundering_checking_aux(Formula, PVars, Culprits3, Culprits2).
	% f_checking_aux(Term, PVars, Culprits3, Culprits4),
	% Free variables in Term are taken as quantified variables
	% floundering checking is not necessary

% to cope with lists of terms.
f_checking_aux([], _, Culprits, Culprits).
f_checking_aux([H|T], PVars, Culprits, Culprits2):-
   f_checking_aux(H, PVars, Culprits, Culprits3),
   f_checking_aux(T, PVars, Culprits3, Culprits2).

f_checking_aux('MetaDefs.Var.F1'(_), _, Culprits, Culprits).
f_checking_aux('MetaDefs.Var.F2'(_, _), _, Culprits, Culprits).
f_checking_aux('MetaDefs.CTerm.F1'(_), _, Culprits, Culprits).
f_checking_aux('MetaDefs.Num.F1'(_), _, Culprits, Culprits).
f_checking_aux('MetaDefs.Int.F1'(_), _, Culprits, Culprits).
f_checking_aux('MetaDefs.Str.F1'(_), _, Culprits, Culprits).
f_checking_aux('MetaDefs.Flo.F1'(_), _, Culprits, Culprits).

f_checking_aux('MetaDefs.Term.F2'(_, Terms), PVars, Culprits, Culprits2):-
   f_checking_aux(Terms, PVars, Culprits, Culprits2).

f_checking_aux('MetaDefs.Empty.C0', _, Culprits, Culprits).
f_checking_aux('MetaDefs.PAtom.F1'(_), _, Culprits, Culprits).

f_checking_aux('MetaDefs.Atom.F2'(_, Terms), PVars, Culprits, Culprits2):-
   f_checking_aux(Terms, PVars, Culprits, Culprits2).

f_checking_aux('MetaDefs.Commit.F2'(_, Formula), PVars, Culprits, Culprits2):-
   floundering_checking_aux(Formula, PVars, Culprits, Culprits2).

f_checking_aux('MetaDefs.&''.F2'(Formula1, Formula2), PVars,
		Culprits, Culprits2):-
   floundering_checking_aux('MetaDefs.&''.F2'(Formula1, Formula2), PVars,
		Culprits, Culprits2).

f_checking_aux('MetaDefs.\\/''.F2'(Formula1, Formula2), PVars,   % added \ djd
		Culprits, Culprits2):-
   floundering_checking_aux(Formula1, PVars, Culprits, Culprits3),
   floundering_checking_aux(Formula2, PVars, Culprits3, Culprits2).

%------------------------------------------------------------------------------

gather_productive_vars([], PVars, PVars).
gather_productive_vars([pair(_, Vs)|List], PVars, PVars2) :-
   append(Vs, PVars, PVars3),
   gather_productive_vars(List, PVars3, PVars2).

%------------------------------------------------------------------------------
% productive free var: a free variable is productive if it occurs in
%	1. a positive goal (after transformation)
%	2. appears both in the both branch of disjuction, Then and Else parts
%	3. in IF SOME
%	4. variables in the head
% However, it should be aware that this is not saying that the productive
% free vars are definitely produce instantiations for the variables.
% Thus the floundering checking may miss some floundering cases.
%
% One way of improving this is to consider the delay declarations for
% each predicate.

conjunction_to_list('MetaDefs.&''.F2'(Formula1, Formula2), GoalList,
		GoalList2) :-
   !,
   conjunction_to_list(Formula1, GoalList, GoalList3),
   conjunction_to_list(Formula2, GoalList3, GoalList2).

conjunction_to_list(Formula, GoalList, [pair(Formula, PVars)|GoalList]):-
   collect_variables(Formula, [], PVars). % collect productive vars

%- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
% this to make sure that formulas are transformed only once

toplev_conjunctions('MetaDefs.&''.F2'(Formula1, Formula2), GoalList,
                GoalList2) :-
   !,
   toplev_conjunctions(Formula1, GoalList, GoalList3),
   toplev_conjunctions(Formula2, GoalList3, GoalList2).

toplev_conjunctions(Formula, GoalList, [pair(Transformed, PVars)|GoalList]):-
   transform_body(Formula, Transformed, _),
   collect_variables(Transformed, [], PVars). % collect productive vars

