Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/prolog/modprolg/mod-prol.lha/Prolog/modlib/src/$consult.P

Text File | 1992-06-01 | 58.2 KB | 1,757 lines

/****************************************************************************
 *                                                                          *
 * This file has been changed by to include Modules Extensions              *
 * Changes by : Brian Paxton 1991/92                                        *
 * Last update : June 1992                                                  *
 *                                                                          *
 * Organisation : University of Edinburgh.                                  *
 * For : Departments of Computer Science and Artificial Intelligence        *
 *       Fourth Year Project.                                               *
 *                                                                          *
 ****************************************************************************/

/* $consult.P */

/* consult(Filename) consults the named file for interpretation.
   The second (optional) parameter to consult is a list of options.
   The third (optional) parameter is used to return a list of
   predicate/arity pairs that were defined by the consult. This list
   can be passed to trace/1 so that they can be traced.
*/

$consult_export([$consult/1,$consult/2,$consult/3,$consult_list/1]).

/* Details of the module environment database structures are given here :

   $module_structure(Name,Tag,Substrs,Preds,Funs)

     Stores the the signatures of the top structures declared at the
     top level only. Substrs is a list of substructure maps of the form
     'Name ---> Tag', and Preds and Funs are lists of items of the form
     'Name ---> Internalname'.  Name is a module environment name of the
     form 'A : B : ... : D', tags are simply integers and Internalname is a
     tagged atom.

   $module_signature(Name,Tag,Substrs,Preds,Funs)

     Stores the names of any signatures defined at the top level. As
     above.

   $module_functor(Name,Tag,Atids,Substrs,Preds,Funs,Strexpr,P,Q,R)

     Stores the names of any functors defined at the top level.
     Substrs, Preds and Funs as above, Strexpr is the body of the functor,
     and P, Q and R are the structure, signature and functor environments
     respectively, at the time the functor declaration was made. These are
     simply a list of integer tags referring to the tag entries in these
     predicates.

   $mapped_function(X,Arity,Y,Str)

     Any declaration of the form 'fun X = Y' is stored as a clause in
     this predicate. Str is the tag of the structure in which the
     declaration was made.

   $declared_function(X)

     In order to preserve the function/predicate distinction in this
     Prolog, any function defined as 'fun X' or 'fun X = ...' is stored in
     this predicate.  It is later used only by assert/retract to ensure
     that no attempt is made to assert a declared function into the
     database (which has the effect of turning the function into a
     predicate). This preserves functions as functions. Preserving
     predicates as predicates is easier. If a predicate is defined by a
     series of clauses, when those clauses are asserted by the consult
     code, the predicate becomes a predicate. If it is defined by a 'pred
     X' declaration, the consult code calls $assert_abolish_i(X), which has
     the effect of turning X into a predicate by creating it as an 'empty'
     predicate which simply fails when calls.


     Note that throughout, P is the structure environment, Q is the
     signature environment and R is the functor environment, each stored
     as a list of Name ---> X mappings, where X is either a tag or a
     datatype describing the construct.
*/

% $consult(File)
%
%

$consult(File) :-
        $consult(File, [v], _).

% $consult(File, Opts)
%
%

$consult(File, Opts) :-
        $consult(File, Opts, _).

% $consult_list(Filelist)
%
%

$consult_list([]).
$consult_list([H|T]) :- $consult_list1(H), $consult_list(T).

% $consult_list1(File)
%
%

$consult_list1('-'(File)) :- !, $consult(File).
$consult_list1(File) :- $consult(File).

% $consult(File, Opts, Preds)
%
% Opts is a list containing :
%  'v'  for 'verbose' loading.
%  't'  to enable tracing on all loaded predicates.

$consult(File, Opts, Preds) :-
    ( $mod_exists(File) ->
        ( $see(File),
          ( $memberchk(v, Opts) ->
          ( $writename('[Opening '),
            $writename(File),
            $writename(']'),$nl ) ;
          true ),
          $mod_read_data(Data),
          $seen,
          $mod_convert_to_internal(Data, Opts, Preds),
          ( $memberchk(v, Opts) ->
          ( $writename('[Closing '),
            $writename(File),
            $writename(']'),$nl ) ;
            true ) ) ;
        $mod_error(['** Consult Error : File',File,'not found']) ), !.

% $mod_exists(File)
%
%

$mod_exists(user).
$mod_exists(File) :- exists(File).

% $mod_read_data(Input)
%

$mod_read_data(List) :-
    $read_module(Input),
    ( Input == end_of_file ->
          List = [] ;
          ( $mod_read_data(Rest),
            List = [Input|Rest] ) ).

% $mod_convert_to_internal(Data, Opts, Preds)
%

$mod_convert_to_internal(Data, Opts, AllPreds) :-
    $mod_explode_database(Sig, P, Q, R),
        $mod_dec(Data, Sig, P, Q, R, sig(Substrs, Preds, Funs),
                  P1, Q1, R1, Code, Opts, 0, yes, [], Funmap2), !,
        $mod_translate_code(Code, Preds, Funs, Code1, 0), !,
    ( $memberchk(v, Opts) ->
        ( $writename('Updating database ...'), $nl ) ;
        true ),
    $mod_assert_code(Code1, [], AllPreds),
    $mod_assert_functions(Funmap2),
    $retract(($module_structure(root, 0, _, _, _) :- _)),
    $mod_assert_structure(root, 0, Substrs, Preds, Funs),
    ( $memberchk(t, Opts) -> $mod_trace_all(AllPreds) ;
                             true ), !.

% $mod_assert_code(Code, Partial, Preds)
%
%

$mod_assert_code([], Preds, Preds).
$mod_assert_code(['_$done'(Head)|List], Preds, Result) :-
    $assert(Head),
    $mod_get_name(Head, Name),
    ( $memberchk(Name, Preds) ->
        $mod_assert_code(List, Preds, Result) ;
        $mod_assert_code(List, [Name|Preds], Result) ).
$mod_assert_code(['_$blank'(Name/Arity)|List], Preds, Result) :-
    $bldstr(Name,Arity,Head),
    $assert_abolish_i(Head), /* Create 'empty' predicate which will fail*/
    ( $memberchk(Name/Arity, Preds) ->
        $mod_assert_code(List, Preds, Result) ;
        $mod_assert_code(List, [Name/Arity|Preds], Result) ).

% $mod_get_name(Clause, Name/Arity)
%
%

$mod_get_name((X :- _), Name) :- !,
    $mod_get_name(X, Name).
$mod_get_name(Head, Name/Arity) :-
    $functor0(Head, Name),
    $arity(Head, Arity).

% $mod_assert_functions(Code)
%
%

$mod_assert_functions(Code) :-
    Code == [] -> true ;
                  ( Code = [Head|List],
            $mod_assert_functions(List),
                $asserta(Head) ).

% $mod_trace_all(Predlist)
%
%

$mod_trace_all([]).
$mod_trace_all([Pred|Rest]) :-
    $symtype('_$traced_preds'(_), Type),
    Type > 0, !,
    ( '_$traced_preds'(Pred) -> true ;
                               $trace(Pred) ),
    $mod_trace_all(Rest).
$mod_trace_all([Pred|Rest]) :-
    $trace(Pred),
    $mod_trace_all(Rest).


% $mod_explode_database(Sig, P, Q, R).
%
% P is the structure environment.
% Q is the signature environment.
% R is the functor environment.
%
% Explode grabs condensed form in database and expands it to full
% environment datastructures.

$mod_explode_database(sig(Substrs, Preds, Funs), P, Q, R) :-
    $bagof(Name ---> Tag, Name^Tag^Substrs^Preds^Funs^
               $module_structure(Name, Tag, Substrs, Preds, Funs), P1),
    $mod_remove_root(P1, P),
    $bagof(Name ---> Tag, Name^Tag^Substrs^Preds^Funs^
               $module_signature(Name, Tag, Substrs, Preds, Funs), Q),
    $bagof(Name ---> Tag,
           Name^Tag^Atids^Substrs^Preds^Funs^Strexpr^P0^Q0^R0^
                $module_functor(Name, Tag, Atids, Substrs, Preds, Funs,
                                Strexpr, P0, Q0, R0), R),
    $module_structure(root, 0, Substrs, Preds, Funs), !.

% $mod_remove_root(Environment, Result)
%
%

$mod_remove_root([root ---> 0|Rest], Rest).
$mod_remove_root([], []).
$mod_remove_root([Head|Tail], [Head|Result]) :-
    $mod_remove_root(Tail, Result).

%****************************************************************************

% $mod_fit(Arg, Sig1, Str, Namestr, Namesig)
%
% Fitting a structure to a signature.
%

$mod_fit(str(Tag, Sig), Sig1, str(Tag, Newsig), Namestr, Namesig) :- !,
        $mod_fit0(Sig, Sig1, Newsig, Namestr, Namesig).

$mod_fit(Sig, Sig1, str(Tag, Newsig), Namestr, Namesig) :-
    gennum(Tag),
        $mod_fit0(Sig, Sig1, Newsig, Namestr, Namesig).

% $mod_fit0(Sig1, Sig2, Sig3, Namestr, Namesig)
%
%

$mod_fit0(sig(Substrs, Preds, Funs), sig(Substrs1, Preds1, Funs1),
                      sig(Substrs2, Preds2, Funs2), _, _) :-
    $mod_domain_restrict(Substrs, Substrs1, Substrs2),
    $mod_domain_restrict(Preds, Preds1, Preds2),
    $mod_domain_restrict(Funs, Funs1, Funs2),
    $mod_check_pairs(Substrs1, Substrs),
    $mod_check_pairs(Preds1, Preds),
    $mod_check_pairs(Funs1, Funs), !.

$mod_fit0(Str, Sig, _, Namestr, Namesig) :-
    $mod_error(['** Consult Error : Fitting', Namestr,'to',Namesig]).

% $mod_check_pairs(One, Two)
%
%

$mod_check_pairs([],_).
$mod_check_pairs([A ---> Tag|Tail], Two) :-
    $memberchk(B ---> Tag,Tail) ->
            ( $memberchk(A ---> Tag2, Two),
              $memberchk(B ---> Tag2, Two),
                  $mod_check_pairs(Tail, Two) ) ;
        $mod_check_pairs(Tail, Two).

%$mod_check_pairs(One, Two) :-
%    $member(A ---> X, One),
%    $member(B ---> X, One),
%    A \= B,
%    '_$savecp'(Cp),
%    $mod_check_pair(A, B, Two, Cp),
%    fail.
%$mod_check_pairs(_, _).
%
%% $mod_check_pair(A, B, Two, Cp)
%%
%%
%
%$mod_check_pair(A, B, Two, Cp) :-
%    $member(A ---> X, Two),
%    $member(B ---> X, Two).
%$mod_check_pair(_, _, _, Cp) :-
%    '_$cutto'(Cp),
%    fail.

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

% $mod_tag(Sig1, Sig2)
%
% Generating new internal names for constants.
% Note that this predicate is only ever called to handle signatures. If
% the signatures were those of actual structures, then the maps would be
% atoms. When we are dealing with signatures on their own, we only
% require a datatype that satisfies sharing constraints - ie. distinct
% values for distinct items, equal values for 'shared' items. We therefore
% simplify and use only integers.

$mod_tag(sig(Substrs, Preds, Funs), sig(Substrs1, Preds1, Funs1)) :-
    $mod_tag(Substrs, Substrs1),
    $mod_tag(Preds, Preds1),
    $mod_tag(Funs, Funs1).

% $mod_tag(Map1, Map2)
%
%

$mod_tag(Old,New) :-
    $setof(Map, X^Map^( member(X ---> Map,Old),
                        not($pervasive(X)) ), Maps),
    $mod_tag_pairs(Maps,Newmaps),
    $mod_retag(Old,Newmaps,New).

$mod_tag_pairs([],[]).
$mod_tag_pairs([Map|Tail],[(Map,New)|Ntail]) :-
    $gennum(New),
    $mod_tag_pairs(Tail,Ntail).

$mod_retag([],_,[]).
$mod_retag([X ---> Old|Tail], Pairs, [X ---> New|Ntail]) :-
    ( $memberchk((Old,New),Pairs) -> true ;
                                         New = Old ),
    $mod_retag(Tail,Pairs,Ntail).

%$mod_tag([], []).
%$mod_tag([X ---> Y|Rest], [X ---> Z|New]) :-
%    ( $pervasive(X) -> X = Z ; $gennum(Z) ),
%    $mod_tag(Rest, New).

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

% $mod_identify(Idlist, Sig, Newsig)
%
% Identifying substructures in a signature.
%

$mod_identify([], Sig, Sig).
$mod_identify([[Id, Id1]|Rest], Sig, Newsig) :-
    $mod_identify(Rest, Sig, Sig1),
    $mod_identify(Id, Id1, Sig1, Newsig).

% $mod_identify(Id, Id1, Sig1, Sig2)
%
%

$mod_identify(Id, Id1, sig(Substrs,Preds,Funs), sig(Substrs1,Preds1,Funs1)) :-
    $mod_identify_pairs(Preds, Preds, Ppairs, Id, Id1),
    $mod_identify_pairs(Funs, Funs, Fpairs, Id, Id1),
    $gennum(Tag),
    $mod_replace_mappings([Id ---> Tag, Id1 ---> Tag], Substrs, Substrs1),
    $mod_identify_items(Ppairs, Preds, Preds1),
    $mod_identify_items(Fpairs, Funs, Funs1), !.

$mod_identify(Id, Id1, _, _) :-
    $mod_error(['** Consult Error : Sharing violation with',Id and Id1]).

% $mod_identify_pairs(Preds, Other, Result, Id, Id1)
%
%

$mod_identify_pairs([], _, [], _, _).
$mod_identify_pairs([Pred/Arity ---> _|Rest], Other,
                [[Pred/Arity, Pred1/Arity]|Result], Id, Id1) :-
    $mod_prefix_path(Id, Pred, Extra), !,
    $member(Pred1/Arity ---> _, Other),
    $mod_prefix_path(Id1, Pred1, Extra), !,
    $mod_identify_pairs(Rest, Other, Result, Id, Id1).
$mod_identify_pairs([_|Rest], Other, Result, Id, Id1) :- !,
    $mod_identify_pairs(Rest, Other, Result, Id, Id1).

% $mod_identify_items(Pairs, Items, Result)
%
%

$mod_identify_items([], Items, Items).
$mod_identify_items([[Item1, Item2]|Rest], Items, Result) :-
    $mod_identify_items(Rest, Items, Part),
    $gennum(Tag),
    $mod_replace_mappings([Item1 ---> Tag, Item2 ---> Tag], Part, Result).

% $mod_prefix_path(Id, Path, Extra)
%
%

$mod_prefix_path(X:Id, X:Path, Extra) :-
    $mod_prefix_path(Id, Path, Extra).
$mod_prefix_path(X, X:Path, Path) :-
    $atom(X).

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

% $mod_substructure(Id, Sig, Str)
%
% Extracting a substructure from a signature/structure.
%

$mod_substructure(Id, sig(Substrs, Preds, Funs),
              str(Tag, sig(Substrs1, Preds1, Funs1))) :-
    $memberchk(Id ---> Tag, Substrs),
    $bagof(N/A ---> Tag0, $member(Id:N/A ---> Tag0, Substrs), Substrs1),
    $bagof(N/A ---> Tag0, $member(Id:N/A ---> Tag0, Preds), Preds1),
    $bagof(N/A ---> Tag0, $member(Id:N/A ---> Tag0, Funs), Funs1).

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

% $mod_addsubstrs(List, Sig, Sig1)
%
% Adding new substructures to a structure/signature.
%

$mod_addsubstrs(List, Sig, Sig1) :-
    $mod_add_tags(List, New),
    $mod_addsubstrs0(New, Sig, Sig1).

%  $mod_addsubstrs0(List, Sig1, Sig2)
%
%

$mod_addsubstrs0(List, sig(Substrs, Preds, Funs),
             sig(Substrs2, Preds2, Funs2)) :-
    $mod_addsubstrs1(List, sig(Substrs1, Preds1, Funs1)),
        $mod_addsubstrs_union(Substrs, Substrs1, Substrs2),
        $mod_addsubstrs_union(Preds, Preds1, Preds2),
        $mod_addsubstrs_union(Funs, Funs1, Funs2).

% $mod_addsubstrs1(Substrs, Sig)
%
%

$mod_addsubstrs1([], sig([],[],[])).
$mod_addsubstrs1([[Atid1, str(Tag1, sig(Substrs1, Preds1, Funs1))]|Rest],
                 sig([Atid1 ---> Tag1|Nsubstrs], Npreds, Nfuns)) :-
    $bagof(Atid1:Id ---> Tag, $member(Id ---> Tag, Substrs1), Substrs2),
    $bagof((Atid1:Id)/Arity ---> Tag, $member(Id/Arity ---> Tag, Preds1),
                Preds2),
    $bagof((Atid1:Id)/Arity ---> Tag, $member(Id/Arity ---> Tag, Funs1),
                Funs2),
    $mod_addsubstrs1(Rest, sig(Substrs3, Preds3, Funs3)),
    $mod_addsubstrs_union(Substrs2, Substrs3, Nsubstrs),
    $mod_addsubstrs_union(Preds2, Preds3, Npreds),
    $mod_addsubstrs_union(Funs2, Funs3, Nfuns), !.

% $mod_add_tags(List, Taggedlist)
%
%

$mod_add_tags([],[]).
$mod_add_tags([[Atid,Sig]|Rest],[[Atid,str(Tag,Sig)]|New]) :-
    $gennum(Tag),
    $mod_add_tags(Rest,New).

% $mod_addsubstrs_union(X, Y, Union)
%
%

$mod_addsubstrs_union([], X, X).
$mod_addsubstrs_union([Name ---> Map|Tail], List, Nlist) :-
    $memberchk(Name ---> _, List), !,
    $mod_addsubstrs_union(Tail, List, Nlist).
$mod_addsubstrs_union([Map|Tail], List, [Map|Nlist]) :-
    $mod_addsubstrs_union(Tail, List, Nlist).

%****************************************************************************

% sigb ::= atid = sigexpr
%
% $mod_sigb(Sigexpr, Q, Atid, Result, Opts ,Addcode)
%

$mod_sigb(Atid = Sigexpr, Q, Atid, Result, Opts ,Addcode) :- !,
    $mod_valid_name(Atid, signature),
    $mod_sigexpr(Sigexpr, Q, sig(Substrs, Preds, Funs)),
    $gennum(Tag),
    ( Addcode == yes ->
          ( Result = Tag,
            $mod_assert_signature(Atid, Tag, Substrs, Preds, Funs) ) ;
          Result = sig(Substrs, Preds, Funs) ),
    $mod_print_signature(Opts, Atid, sig(Substrs, Preds, Funs)).

$mod_sigb(Sigb, _, _, _, _, _) :-
    $mod_error(['** Consult Error : Bad signature binding',Sigb]).

% $mod_print_signature(Opts, Atid, Sig)
%
%

$mod_print_signature(Opts, Atid, sig(Substrs, Preds, Funs)) :-
    $memberchk(v, Opts) ->
      ( $writename('signature '),
        $write(Atid), $nl,
        $writename('  sig'), $nl,
        $mod_write_lists('    structure ', Substrs),
        $mod_write_lists('    pred ', Preds),
        $mod_write_lists('    fun ', Funs),
        $writename('  end.'), $nl ) ;
      true.

% $mod_write_lists(Text, List)
%
%

$mod_write_lists(_, []).
$mod_write_lists(Text, [Head ---> _|Tail]) :-
    $writename(Text),
    $write(Head), $nl,
    $mod_write_lists(Text, Tail).

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

% funb ::= atid(plist) = strexpr
%
% $mod_funb(Funb, P, Q, R, Atid, Fun, Opts ,Addcode
%

:- mode $mod_funb(+,++,++,+,-,-,+,++).

$mod_funb(Name/Sig = Body/Sig0, P, Q, R, Atid, Fun, Opts ,Addcode) :- !,
    (Sig = Sig0 ->
          $mod_funb(Name = Body/Sig, P, Q, R, Atid, Fun, Opts ,Addcode) ;
          ($mod_warning(['** Consult Warning : Functor', Name,
                          ': signature mismatch -', Sig0 and Sig,
                  '- using', Sig]),
           $mod_funb(Name = Body/Sig, P, Q, R, Atid, Fun, Opts ,Addcode))).

$mod_funb(Name/Sig = Body, P, Q, R, Atid, Fun, Opts ,Addcode) :- !,
        (var(Sig) ->
              ( $mod_warning(['** Consult Warning : Functor',Name,
                              ': signature is a variable - ignoring']),
        $mod_funb(Name = Body, P, Q, R, Atid, Fun, Opts ,Addcode) ) ;
          $mod_funb(Name = Body/Sig, P, Q, R, Atid, Fun, Opts ,Addcode)).

$mod_funb(Name = Body/Sig, P, Q, R, Atid, Fun, Opts ,Addcode) :-
        var(Sig), !,
        $mod_warning(['** Consult Warning : Functor',Name,
                      ': signature is a variable - ignoring']),
    $mod_funb(Name = Body, P, Q, R, Atid, Fun, Opts ,Addcode).

$mod_funb(Head = Strexpr, P, Q, R, Atid, Result, Opts ,Addcode) :-
        $structure(Head), !,
    Head \= [_|_],
    $univ(Head, [Atid|Plist]),
    $mod_valid_name(Atid, functor), !,
    $mod_plist(Plist, Q, Atids, sig(Substrs, Preds, Funs)),
    $mod_replace_mappings(Atids, sig(Substrs, Preds, Funs), P, P1),
    $mod_remove(v, Opts, Nopts),
    $mod_strexpr(Strexpr, P1, Q, R, _, _, Nopts, no, [], _),
    $gennum(Tag),
    ( Addcode == yes ->
           ( Result = Tag,
             $mod_assert_functor(Atid, Tag, Atids, Substrs, Preds, Funs,
                                 Strexpr, P, Q, R) ) ;
           Result = fun(Atids, Substrs, Preds, Funs, Strexpr, P, Q, R) ),
    ( $memberchk(v,Opts) -> ( $writename('functor '),
                              $write(Head), $nl ) ;
                    true ).

$mod_funb(Funb, _, _, _, _, _, _, _) :-
    $mod_error(['** Consult Error : Bad functor binding', Funb]).

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

% plist ::= atid1/sigexpr1, ... , atidn/sigexprn
%                [sharing patheq1 and ... and patheqn]   n => 0, m => 1.
%
% $mod_plist(Paramlist, Q, Params, Sig)
%

$mod_plist(Paramlist, Q, Params, Sig) :-
     $mod_pre_process_plist(Paramlist, Args, Sharing),
    $mod_convert_to_ands0(Args, NewParams), !,
    $mod_spec(structure(NewParams), sig([], [], []), Q, Sig0),
        ( Sharing = [] -> Sig = Sig0 ;
                          $mod_spec(sharing(Sharing), Sig0, Q, Sig) ),
    $bagof(Param, Param^Dummy^$member(Param/Dummy, Args), Params), !.

% $mod_pre_process_plist(Paramlist, Args, Sharing)
%
%

$mod_pre_process_plist([sharing(Arg, Sharing)], [Arg], Sharing).
$mod_pre_process_plist([], [], []).
$mod_pre_process_plist([Head|Tail], [Head|Args], Sharing) :-
    $mod_pre_process_plist(Tail, Args, Sharing).

% $mod_convert_to_ands0(List, Anded)
%
%

$mod_convert_to_ands0([Arg], Arg).
$mod_convert_to_ands0([Arg|Rest], Arg and New) :-
    $mod_convert_to_ands0(Rest, New).

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

% patheq ::= id1 = ... = idn                                   n => 1
%
% $mod_patheq(Patheq, Sig, Result)
%

$mod_patheq(Id1 = Idi, sig(Substrs, _, _), Result) :- !,
    (var(Id1) ->
        $mod_error(['** Consult Error : Variable in sharing constraint',
                    Id1 = Idi]) ;
        ( $memberchk(Id1 ---> _, Substrs) ->
             $mod_patheq2(Id1, Idi, Substrs, Result) ;
             ( $mod_error([
           '** Consult Error : Unknown substructure in sharing constraint',
                                   Patheq]) ) )).

$mod_patheq(Path, _, _) :-
    $mod_error(['** Consult Error : Bad path equation',Path]).

% $mod_patheq2(Id1, Idi, Substrs, Pairs)
%
%

$mod_patheq2(Id1, Idi = Idj, Substrs, [[Id1, Idi]|Rest]) :- !,
    ( var(Idi) -> $mod_error([
                           '** Consult Error : Variable in sharing constraint',
                       Id1 = Idi]) ;
                ( $memberchk(Idi ---> _, Substrs),
              $mod_patheq2(Id1, Idj, Substrs, Rest) ) ).
$mod_patheq2(Id1, Idi, Substrs, [[Id1, Idi]]) :-
    var(Idi) -> $mod_error([
                        '** Consult Error : Variable in sharing constraint']) ;
                $memberchk(Idi ---> _, Substrs).

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

% strb ::= atid = strexpr
%
% $mod_strb(Strb, Sig1, P, Q, R, Atid, Str, Code, Opts, Addcode,
%           Funmap1, Funmap2)
%

:- mode $mod_strb(+,+,++,++,+,-,-,-,+,++,++,-).

$mod_strb(Name/Sig = Body/Sig0, Sig1, P, Q, R, Atid, Str, Code, Opts, Addcode,
      Funmap1, Funmap2) :- !,
    (Sig = Sig0 ->
            $mod_strb(Name = Body/Sig, Sig1, P, Q, R, Atid, Str, Code,
                      Opts, Addcode, Funmap1, Funmap2) ;
        ( $mod_warning(['** Consult Warning : Structure', Name,
                        ': signature mismatch -',
                                Sig0 and Sig, '- will use', Sig]),
          $mod_strb(Name = Body/Sig, Sig1, P, Q, R, Atid, Str, Code,
                    Opts, Addcode, Funmap1, Funmap2) ) ).

$mod_strb(Name/Sig0 = Body, Sig, P, Q, R, Atid, Str, Code, Opts ,Addcode,
      Funmap1, Funmap2) :- !,
        (var(Sig0) ->
                ( $mod_warning(['** Consult Warning : Structure', Name,
                        ': signature is a variable - ignoring']),
          $mod_strb(Name = Body, Sig, P, Q, R, Atid, Str, Code, Opts,
                        Addcode, Funmap1, Funmap2) ) ;
        $mod_strb(Name = Body/Sig0, Sig, P, Q, R, Atid, Str, Code,
                  Opts, Addcode, Funmap1, Funmap2)).

$mod_strb(Name = Body/Sig0, Sig, P, Q, R, Atid, Str, Code, Opts ,Addcode,
      Funmap1, Funmap2) :-
        var(Sig0), !,
        $mod_warning(['** Consult Warning : Structure', Name,
                  ': signature is a variable - ignoring']),
    $mod_strb(Name = Body, Sig, P, Q, R, Atid, Str, Code, Opts ,Addcode,
              Funmap1, Funmap2).

$mod_strb(Atid = Strexpr, Sig, P, Q, R, Atid, str(Tag, sig(Substrs, Preds,
      Funs)), Code, Opts, Addcode, Funmap1, Funmap2) :- !,
    $mod_valid_name(Atid, structure),
    $mod_remove(v, Opts, Nopts),
    $mod_strexpr(Strexpr, P, Q, R, str(Tag, sig(Substrs, Preds, Funs)),
                 Code, Nopts, no, Funmap1, Funmap2),
    ( Addcode == yes ->
             $mod_assert_structure(Atid, Tag, Substrs, Preds, Funs) ;
         true ),
    ( $memberchk(v,Opts) -> ( $writename('structure '),
                              $write(Atid), $nl ) ;
                    true ).

$mod_strb(Strb, _, _, _, _, _, _, _, _, _, _, _) :-
    $mod_error(['** Consult Error : Bad structure binding', Strb]).

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

% sigexpr ::= SIG dec END
%
% $mod_sigexpr(Sigexpr, Q, Sig)
%

:- mode $mod_sigexpr(+,++,-).

$mod_sigexpr(X, _, _) :-
    var(X), !,
    $mod_error(['** Consult Error : Signature expression is a variable']).

$mod_sigexpr([A|B], Q, Sig) :- !,
    $mod_spec([A|B], sig([], [], []), Q, Sig).

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

% sigexpr ::= atid

$mod_sigexpr(Atid, Q, sig(Substrs, Preds, Funs)) :-
    $atom(Atid), !,
    ($memberchk(Atid ---> sig(Substrs, Preds, Funs), Q) -> true ;
     ( ( $memberchk(Atid ---> Tag, Q),
       $module_signature(_, Tag, Substrs, Preds, Funs) ) -> true ;
       $mod_error(['** Consult Error : Unknown signature', Atid]) )), !.

$mod_sigexpr(Sigexpr, _, _) :-
    $mod_error(['** Error : Bad signature expression']).

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

% spec ::= PRED atid/nat
%
% $mod_spec(Spec, Sig, Q, Sig2)
%

:- mode $mod_spec(+,++,++,-).

$mod_spec(X, _, _, _) :-
    var(X), !,
    $mod_error(['** Consult Error : Specification is a variable']).

$mod_spec(pred Pred and Preds ,Sig, Q, Sig2) :- !,
    $mod_spec(pred Pred ,Sig, Q, Sig1),
    $mod_spec(pred Preds ,Sig1, Q, Sig2).

$mod_spec(pred Atid/Nat, _, _, _) :-
    (var(Atid) ; var(Nat)), !,
        $mod_error(['** Consult Error : Variable in predicate specification']).

$mod_spec(pred Atid/Nat, sig(Substrs, Preds, Funs), _,
          sig(Substrs, [Atid/Nat ---> Tag|Preds], Funs)) :-
    $atom(Atid),
    integer(Nat),
        not($mod_member_or_pervasive(Atid/Nat ---> _, Preds)), !,
    ( ( $memberchk(Atid/Nat ---> _, Funs) ;
        $pervasive_function(Atid/Nat) ) ->
           $mod_error(['** Consult Error : Trying to redefine function',
                       Atid/Nat, 'as a predicate in signature']) ;
           $gennum(Tag) ).

$mod_spec(pred Atid/Nat, Sig, _, Sig) :-
    $atom(Atid),
    integer(Nat), !,
        ( $pervasive_predicate(Atid/Nat) ->
              $mod_warning([
                '** Consult Warning : Cannot redefine pervasive predicate',
                    Atid/Nat, 'in signature']) ;
              $mod_warning(['** Consult Warning : Predicate', Atid/Nat,
                            'defined twice in signature']) ).

$mod_spec(pred Pred, _, _, _) :- !,
    $mod_error(['** Consult Error : Bad predicate specification',
                pred Pred]).

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

% spec ::= FUN atid/nat

$mod_spec(fun Fun and Funs ,Sig, Q, Sig2) :- !,
    $mod_spec(fun Fun ,Sig, Q, Sig1),
    $mod_spec(fun Funs ,Sig1, Q, Sig2).

$mod_spec(fun Atid/Nat, _, _, _) :-
    (var(Atid) ; var(Nat)), !,
    $mod_error(['** Consult Error : Variable in function specification']).

$mod_spec(fun Atid/Nat, sig(Substrs, Preds, Funs), _,
          sig(Substrs, Preds, [Atid/Nat ---> Tag|Funs])) :-
    $atom(Atid),
    integer(Nat),
    not($mod_member_or_pervasive(Atid/Nat ---> _, Funs)), !,
    ( ( $memberchk(Atid/Nat ---> _, Preds) ;
        $pervasive_predicate(Atid/Nat) ) ->
           $mod_error(['** Consult Error : Trying to redefine predicate',
                       Atid/Nat, 'as a function in signature']) ;
           $gennum(Tag) ).

$mod_spec(fun Atid/Nat, Sig, _, Sig) :-
    $atom(Atid),
    integer(Nat), !,
        ( $pervasive_function(Atid/Nat) ->
             $mod_warning([
                '** Consult Warning : Cannot redefine pervasive function',
                    Atid/Nat, 'in signature']) ;
             $mod_warning(['** Consult Warning : Function', Atid/Nat,
                           'defined twice in signature']) ).

$mod_spec(fun Fun, _, _, _) :- !,
    $mod_error(['** Consult Error : Bad function specification', fun Fun]).

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

% spec ::= sharing patheq1 and ... and patheqn           n => 1.

$mod_spec(sharing(Shared), Sig, _, Newsig) :- !,
    $mod_patheq_all(Shared, Sig, Union),
    $mod_identify(Union, Sig, Newsig).

% $mod_patheq_all(Patheq, Sig1, Result)
%
%

$mod_patheq_all(Patheq and Rest, Sig1, Result) :- !,
    $mod_patheq_all(Rest, Sig1, Bit),
    $mod_patheq(Patheq, Sig1, Bit2),
    $append(Bit, Bit2, Result).
$mod_patheq_all(Patheq, Sig1, Result) :-
    $mod_patheq(Patheq, Sig1, Result).

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

% spec ::= structure specstrb1 and ... and specstrbn          n => 1.

$mod_spec(structure Specstrbs, sig(Substrs, Preds, Funs), Q, Newsig) :- !,
    $mod_spec_all(Specstrbs, sig(Substrs, Preds, Funs), Q, Results),
    ( $mod_check_spec(Results) ->
        $mod_addsubstrs(Results, sig(Substrs, Preds, Funs), Newsig) ;
        $mod_error(['** Consult Error : Bad structure spec', Specstrbs,
          ': Either duplicate structure names or structure already defined'])),
    !.

% $mod_spec_all(Specstrb, Sig, Q, Result)
%
%

$mod_spec_all(Specstrb and Rest, Sig, Q, [[Atid, Sig1]|Tail]) :- !,
    $mod_specstrb(Specstrb, Sig, Q, Atid, Sig1),
    $mod_spec_all(Rest, Sig, Q, Tail).
$mod_spec_all(Specstrb, Sig, Q, [[Atid, Sig1]]) :-
    $mod_specstrb(Specstrb, Sig, Q, Atid, Sig1).

% $mod_check_spec(List)
%
%

$mod_check_spec([]).
$mod_check_spec([[Atid, _]|After]) :-
    $not_memberchk([Atid, _], After),
    $mod_check_spec(After).

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

% spec ::= spec spec'

$mod_spec([Spec|Rest], Sig, Q, Result) :- !,
    $mod_spec(Spec, Sig, Q, Sig1),
    $mod_spec(Rest, Sig1, Q, Result).

$mod_spec([], Sig, Q, Sig) :- !.

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

$mod_spec(Spec, _, _, _) :-
    $mod_error(['** Consult Error : Bad specification',Spec]).

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

% specstrb ::= atid/sigexpr
%
% $mod_specstrb(Specstrb, Sig, Q, Atid, Newsig)
%

:- mode $mod_specstrb(+,++,++,-,-).

$mod_specstrb(Atid/Sigexpr, _, _, _, _) :-
    (var(Atid) ; var(Sigexpr)), !,
    $mod_error(['** Consult Error : Variable in structure specification']).

$mod_specstrb(Atid/Sigexpr, sig(Substr, _, _), Q, Atid, Newsig) :- !,
    ( $memberchk(Atid ---> _, Substr) ->
              $mod_error(['** Consult Error : Structure', Atid,
                      'already defined in signature']) ;
          ( $mod_sigexpr(Sigexpr, Q, Sig),
            $mod_tag(Sig, Newsig) ) ).

$mod_specstrb(Specstrb, _, _, _, _) :-
    $mod_error(['** Consult Error : Bad structure specification',
                Specstrb]).

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

% strexpr ::= STRUCT dec END
%
% $mod_strexpr(Strexpr, P, Q, R, Str, Code, Opts ,Addcode, Funmap1, Funmap2)
%

:- mode $mod_strexpr(+,++,++,+,-,-,+,+,+,-).

$mod_strexpr(X, _, _, _, _, _, _, _, _, _) :-
    var(X), !,
    $mod_error(['** Consult Error : Structure expression is a variable']).

$mod_strexpr([A|B], P, Q, R, str(Tag, sig(Substrs, Preds, Funs)), Code1,
         Opts ,Addcode, Funmap1, Funmap2) :- !,
    $gennum(Tag),
    $mod_dec([A|B], sig([],[],[]), P, Q, R, sig(Substrs, Preds, Funs),
             P1, Q1, R1, Code, Opts, Tag ,Addcode, Funmap1, Funmap2),
    $mod_translate_code(Code, Preds, Funs, Code1, Tag).

% After a clause has been translated into its new internal form, the
% clause is passed around as '_$done'(Clause) which forms a mark
% to ensure that a second translation is not attempted later.
% '_$blank'(Name/Arity) is used to specify predicates which should be
% created but are empty (they have been declared using a 'pred Name/Arity'
% declaration.

% $mod_translate_code(Code, Preds, Funs, Translated, Opts)
%
%

:- mode $mod_translate_code(+,++,++,-,++).

$mod_translate_code([], _, _, [],_).
$mod_translate_code(['_$blank'(Clause)|Rest], Preds, Funs,
                ['_$blank'(Clause)|Tail], Tag) :- !,
    $mod_translate_code(Rest, Preds, Funs, Tail, Tag).
$mod_translate_code(['_$done'(Clause)|Rest], Preds, Funs,
                ['_$done'(Clause)|Tail], Tag) :- !,
    $mod_translate_code(Rest, Preds, Funs, Tail, Tag).
$mod_translate_code([Clause|Rest], Preds, Funs,
                ['_$done'(NClause1)|Tail], Tag) :-
    ( $mod_translate(Clause, Preds, Funs, NClause, Tag),
      $fun_rel(NClause, NClause1, Tag) ) ->
           $mod_translate_code(Rest, Preds, Funs, Tail, Tag) ;
           $mod_error(['** Consult Error : Cannot translate', Clause]).

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

% strexpr ::= strexpr/sigexpr

$mod_strexpr(Strexpr/Sigexpr, P, Q, R, Str, Code, _, Addcode,
         Funmap1, Funmap2) :- !,
    $mod_strexpr(Strexpr, P, Q, R, Str1, Code, [], Addcode,
                 Funmap1, Funmap2),
    $mod_sigexpr(Sigexpr, Q, Sig),
        ( Strexpr = [_|_] -> Namestr = ('structure') ; Namestr = Strexpr ),
        ( Sigexpr = [_|_] -> Namesig = 'its signature' ; Namesig = Sigexpr ),
    $mod_fit(Str1, Sig, Str, Namestr, Namesig).

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

% strexpr ::= id

$mod_strexpr(Atid, P, Q, R, str(Tag, sig(Substrs, Preds, Funs)), [], _, _,
         Funmap, Funmap) :-
    $atom(Atid), !,
    ( $memberchk(Atid ---> str(Tag, sig(Substrs, Preds, Funs)), P) -> true;
     (( $memberchk(Atid ---> Tag, P),
        $module_structure(_, Tag, Substrs, Preds, Funs) ) -> true ;
      $mod_error(['** Consult Error : Structure', Atid, 'is unknown']))),!.

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

% strexpr ::= atid:id

$mod_strexpr(Atid:Id, P, Q, R, Str, [], _, _, Funmap, Funmap) :-
    $atom(Atid), !,
    nonvar(Id),
    ( ( $memberchk(Atid ---> str(Tag, sig(Substrs, Preds, Funs)), P) ;
        ( $memberchk(Atid ---> Tag, P),
          $module_structure(_, Tag, Substrs, Preds, Funs) ) ) ->
             $mod_substructure(Id, sig(Substrs, Preds, Funs), Str) ;
         $mod_error(['** Consult Error : Structure', Atid,
                     'is unknown']) ).

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

% strexpr ::= atid(strexpr1,...,strexprn)              n => 0.

$mod_strexpr(Compound, P, Q, R, Str1, Code, _, _, Funmap1, Funmap3) :-
    $structure(Compound), !,
    $univ(Compound, [Atid|Strexprs]),
    ( $memberchk(Atid ---> fun(Atids, sig(Substrs, Preds, Funs), Strexpr,
                               P1, Q1, R1), R) -> true ;
      ( ( $memberchk(Atid ---> Tag, R),
              $module_functor(_, Tag, Atids, Substrs, Preds, Funs,
                          Strexpr, P1, Q1, R1) ) -> true ;
        $mod_error(['** Consult Error : Functor', Atid, 'is unknown']))),
    $length(Strexprs, Len1),
     $length(Atids, Len2),
    ( Len1 == Len2 -> true ;
      $mod_error(['** Consult Error :', Len1, 'arguments to functor', Atid,
                      'instead of', Len2]) ),
    $mod_apply_strexpr(Strexprs, Atids, P, Q, R, Pairs, Code1, [],
                       Funmap1, Funmap2),
    $mod_addsubstrs0(Pairs, sig([], [], []), Result),
    $mod_fit(Result, sig(Substrs, Preds, Funs), str(_, Strsig),
             Compound, 'its signature'),
    $mod_replace_mappings(Atids, Strsig, P1, P2),
    $mod_strexpr(Strexpr, P2, Q1, R1, Str1, Code2, [], no,
                 Funmap2, Funmap3),
    $append(Code1, Code2, Code).

$mod_strexpr(Strexpr, _, _, _, _, _, _, _, _, _) :-
    $mod_error(['** Consult Error : Bad structure expression', Strexpr]).

% $mod_apply_strexpr(Strexprs, Atids, P, Q, R, Pairs, Code, Opts,
%                    Funmap1, Funmap3)
%
%

$mod_apply_strexpr([], [], _, _, _, [], [], _, Funmap, Funmap).
$mod_apply_strexpr([Strexpr|Strexprs], [Atid|Atids], P, Q, R,
                   [[Atid, Str]|Rest], Code, Opts, Funmap1, Funmap3) :-
    $mod_strexpr(Strexpr, P, Q, R, Str, Code1, Opts, no, Funmap1, Funmap2),
    $mod_apply_strexpr(Strexprs, Atids, P, Q, R, Rest, Code2, Opts,
                       Funmap2, Funmap3),
    $append(Code1, Code2, Code).

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

% $mod_dec(Dec, Sig, P, Q, R, Sig1, P1, Q1, R1, Code, Opts)
%
%

:- mode $mod_dec(+,++,++,++,+,-,-,-,-,-,+,++,++,++,-).

$mod_dec(X, _, _, _, _, _, _, _, _, _, _, _, _, _, _) :-
    var(X), !,
    $mod_error(['** Consult Error : Declaration is a variable']).

$mod_dec(inherit Atid ,Sig, P, Q, R, Sig1, P1, Q1, R1, Code, Opts, Strtag,
     Addcode, Funmap1, Funmap2) :- !,
    $mod_dec(structure Atid = Atid ,Sig, P, Q, R, Sig1, P1, Q1, R1, Code,
             Opts, Strtag, Addcode, Funmap1, Funmap2).

$mod_dec(fun Fun and Funs ,Sig, P, Q, R, Sig2, P2, Q2, R2, [], Opts, Strtag,
     Addcode, Funmap1, Funmap3) :- !,
    $mod_dec(fun Fun ,Sig, P, Q, R, Sig1, P1, Q1, R1, _, Opts, Strtag,
             Addcode, Funmap1, Funmap2),
    $mod_dec(fun Funs ,Sig1, P1, Q1, R1, Sig2, P2, Q2, R2, _, Opts,
             Strtag, Addcode, Funmap2, Funmap3).

$mod_dec(pred Pred and Preds ,Sig, P, Q, R, Sig2, P2, Q2, R2, Code3, Opts,
         Strtag, Addcode, Funmap1, Funmap3) :- !,
    $mod_dec(pred Pred ,Sig, P, Q, R, Sig1, P1, Q1, R1, Code1, Opts,
             Strtag, Addcode, Funmap1, Funmap2),
    $mod_dec(pred Preds ,Sig1, P1, Q1, R1, Sig2, P2, Q2, R2, Code2, Opts,
             Strtag, Addcode, Funmap2, Funmap3),
    $append(Code1, Code2, Code3).

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

% dec ::= PRED atid/nat.

$mod_dec(pred Atid/Nat, _, _, _, _, _, _, _, _, _, _, _, _, _, _) :-
    (var(Atid) ; var(Nat)), !,
    $mod_error(['** Consult Error : Variable in predicate declaration']).

$mod_dec(pred Atid/Nat, sig(Substrs, Preds, Funs), P, Q, R,
         sig(Substrs, [Atid/Nat ---> Map|Preds], Funs), P, Q, R,
     ['_$blank'(Map/Nat)], _, Strtag, _, Funmap, Funmap) :-
    $atom(Atid),
    integer(Nat),
    not($mod_member_or_pervasive(Atid/Nat ---> _, Preds)), !,
    ( ( $memberchk(Atid/Nat ---> _, Funs) ;
        $pervasive_function(Atid/Nat) ) ->
           $mod_error(['** Consult Error : Trying to redefine function',
                       Atid/Nat, 'as a predicate']) ;
           $dismantle_name(Map, Atid, Strtag) ).

$mod_dec(pred Atid/Nat, Sig, P, Q, R, Sig, P, Q, R, [], _, _, _,
     Funmap, Funmap) :-
    $atom(Atid),
    integer(Nat), !,
        ( $pervasive_predicate(Atid/Nat) ->
              $mod_warning([
                '** Consult Warning : Cannot redefine pervasive predicate',
                    Atid/Nat, 'in structure']) ;
          $mod_warning(['** Consult Warning : Predicate', Atid/Nat,
                            'defined twice in structure']) ).

$mod_dec(pred Pred, _, _, _, _, _, _, _, _, _, _, _, _, _, _) :- !,
    $mod_error(['** Consult Error : Bad predicate declaration',pred Pred]).

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

% dec ::= FUN atid/nat = id

$mod_dec(fun Atid/Nat = Id, _, _, _, _, _, _, _, _, _, _, _, _, _, _) :-
    (var(Atid) ; var(Nat) ; var(Id)), !,
    $mod_error(['** Consult Error : Variable in function declaration']).

$mod_dec(fun Atid/Nat = Id, sig(Substrs, Preds, Funs), P, Q, R,
         sig(Substrs, Preds, [Atid/Nat ---> Map|Funs]),  P, Q, R, [], _,
         Strtag, Addcode, Funmap,
     [$mapped_function(Name, Nat, Map, Strtag),
      $declared_function(Compound)|Funmap]) :-
    $atom(Atid),
    integer(Nat),
    not($mod_member_or_pervasive(Atid/Nat ---> _, Funs)), !,
    ( ( $memberchk(Atid/Nat ---> _, Preds) ;
        $pervasive_predicate(Atid/Nat) ) ->
           $mod_error(['** Consult Error : Trying to redefine predicate',
                       Atid/Nat, 'as a function']) ;
           ( $mod_fun(Id, Nat, sig(Substrs, Preds, Funs), P, Map),
         $dismantle_name(Name, Atid, Strtag),
         $bldstr(Name, Nat, Compound) ) ).

$mod_dec(fun Atid/Nat = _, Sig, P, Q, R, Sig, P, Q, R, [], _, _, _,
     Funmap, Funmap) :-
    $atom(Atid),
    integer(Nat), !,
    ( $pervasive_function(Atid/Nat) ->
             $mod_warning([
                '** Consult Warning : Cannot redefine pervasive function',
                    Atid/Nat, 'in structure']) ;
         $mod_warning(['** Consult Warning : Function', Atid/Nat,
                            'defined twice in structure']) ).

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

$mod_dec(fun Atid = Id, _, _, _, _, _, _, _, _, _, _, _, _, _, _) :-
    var(Atid), !,
    $mod_error(['** Consult Error : Variable in function declaration']).

$mod_dec(fun Atid = Id, sig(Substrs, Preds, Funs), P, Q, R, Sig, NewP,
         NewQ, NewR, Code, Opts, Strtag, Addcode, Funmap1, Funmap2) :-
    $atom(Atid), !,
    ( Id = Structure:Name ->
        $mod_strexpr(Structure, P, Q, R, str(_, sig(_, _, Otherfuns)), _,
                         _, _, _, _) ;
        ( Otherfuns = Funs, Name = Id ) ),
    $mod_member_chop(Name/Nat ---> _, Otherfuns, Rest), !,
    ( $memberchk(Name/_ ---> _, Rest) ->
                $mod_error(['** Consult Error : Ambiguous function', Id,
                            'when defining function', Atid]) ;
            $mod_dec(fun Atid/Nat = Id, sig(Substrs, Preds, Funs), P, Q,R,
                         Sig, NewP, NewQ, NewR, Code, Opts, Strtag, Addcode,
             Funmap1, Funmap2) ).

$mod_dec(fun Atid = Id, _, _, _, _, _, _, _, _, _, _, _, _, _, _) :- !,
    $mod_error(['** Consult Error : Bad function declaration',
                 fun Atid = Id]).

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

% dec ::= FUN atid/nat

$mod_dec(fun Atid/Nat, _, _, _, _, _, _, _, _, _, _, _, _, _, _) :-
    (var(Atid) ; var(Nat) ), !,
    $mod_error(['** Consult Error : Variable in function declaration']).

$mod_dec(fun Atid/Nat, sig(Substrs, Preds, Funs), P, Q, R,
         sig(Substrs, Preds, [Atid/Nat ---> Map|Funs]), P, Q, R, [], _,
     Strtag, Addcode, Funmap, [$declared_function(Compound)|Funmap]) :-
    $atom(Atid),
    integer(Nat),
    not($mod_member_or_pervasive(Atid/Nat ---> _, Funs)), !,
    ( ( $memberchk(Atid/Nat ---> _, Preds) ;
        $pervasive_predicate(Atid/Nat) ) ->
           $mod_error(['** Consult Error : Trying to redefine predicate',
                       Atid/Nat, 'as a function']) ;
           ( $dismantle_name(Map,Atid,Strtag),
             $bldstr(Map,Nat,Compound) ) ).

$mod_dec(fun Atid/Nat, Sig, P, Q, R, Sig, P, Q, R, [], _, _, _, Funmap,
     Funmap) :-
    $atom(Atid),
    integer(Nat), !,
        ( $pervasive_function(Atid/Nat) ->
              $mod_warning([
                 '** Consult Warning : Cannot redefine pervasive function',
                 Atid/Nat, 'in structure']) ;
          $mod_warning(['** Consult Warning : Function', Atid/Nat,
                            'defined twice in structure']) ).

$mod_dec(fun Fun, _, _, _, _, _, _, _, _, _, _, _, _, _, _) :- !,
    $mod_error(['** Consult Error : Bad function declaration', fun Fun]).

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

% dec ::= STRUCTURE strb

$mod_dec(structure Strb, Sig, P, Q, R, Sig1, [Atid ---> Result|P], Q, R, Code,
     Opts, _, Addcode, Funmap1, Funmap2) :- !,
    $mod_strb(Strb, Sig, P, Q, R, Atid, str(Tag, Strsig), Code, Opts,
              Addcode, Funmap1, Funmap2),
    $mod_addsubstrs0([[Atid, str(Tag, Strsig)]], Sig, Sig1),
    ( Addcode == yes -> Result = Tag ;
                        Result = str(Tag, Strsig) ).

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

% dec ::= SIGNATURE sigb

$mod_dec(signature Sigb, Sig, P, Q, R, Sig, P, [Atid ---> Sig1|Q], R, [], Opts,
         _, Addcode, Funmap, Funmap) :- !,
    $mod_sigb(Sigb, Q, Atid, Sig1, Opts, Addcode).

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

% dec ::= FUNCTOR funb

$mod_dec(functor Funb, Sig, P, Q, R, Sig, P, Q, [Atid ---> Fun|R], [], Opts,
         _, Addcode, Funmap, Funmap) :- !,
    $mod_funb(Funb, P, Q, R, Atid, Fun, Opts, Addcode).

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

% dec ::= dec dec'

$mod_dec([Dec|Restdec], Sig, P, Q, R, Sig2, P2, Q2, R2, Code3, Opts, Strtag,
     Addcode, Funmap1, Funmap3) :- !,
      $mod_dec(Dec, Sig, P, Q, R, Sig1, P1, Q1, R1, Code1, Opts, Strtag,
           Addcode, Funmap1, Funmap2),
      $mod_dec(Restdec, Sig1, P1, Q1, R1, Sig2, P2, Q2, R2, Code2, Opts,
           Strtag, Addcode, Funmap2, Funmap3),
      $append(Code1, Code2, Code3).

$mod_dec([], Sig, P, Q, R, Sig, P, Q, R, [], _, _, _, Funmap, Funmap) :- !.

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

/* Note the following pecularity with this implementation :
        structure test =
            struct
                fun f/2.
                fun g = f.
                :- op(500,xfx,g).
            end.
   The infix operator status will be placed on f/2 and not g/2!!
*/


$mod_dec(':-'(Call), sig(Substrs, Preds, Funs), P, Q, R,
     sig(Substrs, Preds, Funs), P, Q, R,
     [], _, Strtag, _, Funmap, Funmap) :- !,
    ( var(Call) ->
         $mod_error(['** Consult Error : Argument to :-/1 is a variable']);
         true ),
    $mod_translate_body(Call, Preds, Funs, Ncall ,Strtag),
    $expand_body(Ncall, Final, Strtag),
    ( call(Final) ; true ), !.

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

% dec ::= atid(term1,...,termn) [:- atom1,...,atomm]     (Prolog clause)

$mod_dec((X --> Y), Sig, P, Q, R, Sig1, P1, Q1, R1, Code, Opts, Strtag,
     Addcode, Funmap1, Funmap2) :- !,
    ( $dcg((X --> Y), Clause) ->
            $mod_dec(Clause, Sig, P, Q, R, Sig1, P1, Q1, R1, Code, Opts,
                 Strtag, Addcode, Funmap1, Funmap2) ;
        $mod_error(['** Consult Error : Bad DCG clause ', (X --> Y)])).

$mod_dec((Head :- Body), sig(Substrs, Preds, Funs), P, Q, R,
         sig(Substrs, Preds, Funs), P, Q, R, [(Head :- Body)], _, _, _,
     Funmap, Funmap) :-
    nonvar(Head),
    $functor(Head, Atid, N),
    $memberchk(Atid/N ---> _, Preds), !.

$mod_dec((Head :- Body), sig(Substrs, Preds, Funs), P, Q, R,
         sig(Substrs, [Atid/N ---> Tag|Preds], Funs), P, Q, R,
     [(Head :- Body)], _, Strtag, _, Funmap, Funmap) :- !,
    nonvar(Head),
    $functor(Head, Atid, N),
    ( $pervasive_predicate(Atid/N) ->
           $mod_error([
             '** Consult Error : Trying to redefine pervasive predicate',
                           Atid/N]) ;
               true ),
    ( ( $memberchk(Atid/N ---> _, Funs) ;
        $pervasive_function(Atid/N) ) ->
           $mod_error(['** Consult Error : Trying to redefine function',
                       Atid/N, 'as a predicate']) ;
           $dismantle_name(Tag, Atid, Strtag) ).

$mod_dec(Head, sig(Substrs, Preds, Funs), P, Q, R, sig(Substrs, Preds, Funs),
     P, Q, R, [Head], _, _, _, Funmap, Funmap) :-
    nonvar(Head),
    $functor(Head, Atid, N),
    $memberchk(Atid/N ---> _, Preds), !.

$mod_dec(Head, sig(Substrs, Preds, Funs), P, Q, R,
         sig(Substrs, [Atid/N ---> Tag|Preds], Funs), P, Q, R, [Head], _,
     Strtag, _, Funmap, Funmap) :- !,
    nonvar(Head),
    $functor(Head, Atid, N),
    ( $pervasive_predicate(Atid/N) ->
           $mod_error([
             '** Consult Error : Trying to redefine pervasive predicate',
                           Atid/N]) ;
               true ),
    ( ( $memberchk(Atid/N ---> _, Funs) ;
        $pervasive_function(Atid/N) ) ->
           $mod_error(['** Consult Error : Trying to redefine function',
                       Atid/N, 'as a predicate']) ;
           $dismantle_name(Tag, Atid, Strtag) ).

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

$mod_dec(Dec, _, _, _, _, _, _, _, _, _, _, _, _, _, _) :-
    $mod_error(['** Consult Error : Bad declaration', Dec,'in structure']).

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

% $mod_fun(Atid, Nat, Sig, P, Map)
%
%

$mod_fun(Atid:Id, Nat, Sig, P, Map) :- !,
    ( ( var(Atid) ; var(Id) ) ->
          $mod_error(['** Consult Error : Variable in function name']);
          true ),
    $mod_strexpr(Atid, P, _, _, str(_, sig(_, _, Funs)), _,
                     _, _, _, _),
    ( $mod_member_or_pervasive(Id/Nat ---> Map, Funs) -> true ;
          $mod_error(['** Consult Error : Unknown function', Atid:Id/Nat])).

$mod_fun(Atid, Nat, sig(_, _, Funs), _, Map) :-
    $mod_member_or_pervasive(Atid/Nat ---> Map, Funs) -> true ;
        $mod_error(['** Consult Error : Function', Atid/Nat, 'is unknown']).

%****************************************************************************

% $mod_translate(Clause, Preds, Funs, NClause, Tag)
%
%

$mod_translate((Head :- Body), Preds, Funs, (Nhead :- Nbody), Strtag) :-
    !, $mod_translate(Head, Preds, Funs, Nhead, Strtag),
    $mod_translate_body(Body, Preds, Funs, Nbody, Strtag).

$mod_translate(Head, Preds, Funs, Nhead, Strtag) :-
    $univ(Head, [Name|Args]),
    $length(Args, Arity),
    ( Name == ':' ->
            $mod_error(['** Consult Error : Illegal predicate',Head]) ;
                ( ( $memberchk(Name/Arity ---> Internal, Preds) ;
            ( $pervasive(Name/Arity),
              Internal = Name) ;
            $mod_translate_local(Name, Arity, Strtag, Internal) ) ->
            ( $mod_translate_args(Args, Preds, Funs, Nargs,
                                  Strtag),
              $mod_univ(Nhead, [Internal|Nargs]) ) ;
            $mod_error(['** Consult Error : Unknown predicate',
                        Name/Arity, in, Head]) ) ).

% $mod_translate_body(Call, Preds, Funs, NCall)
%
%

:- mode $mod_translate_body(+,++,++,-,++).

$mod_translate_body((A, B), Preds, Funs, (NA, NB), Strtag) :- !,
    $mod_translate_body(A, Preds, Funs, NA, Strtag),
    $mod_translate_body(B, Preds, Funs, NB, Strtag).

$mod_translate_body((A; B), Preds, Funs, (NA; NB), Strtag) :- !,
    $mod_translate_body(A, Preds, Funs, NA, Strtag),
    $mod_translate_body(B, Preds, Funs, NB, Strtag).

$mod_translate_body((A -> B), Preds, Funs, (NA -> NB), Strtag) :- !,
    $mod_translate_body(A, Preds, Funs, NA, Strtag),
    $mod_translate_body(B, Preds, Funs, NB, Strtag).

$mod_translate_body(Call, Preds, Funs, NCall, Strtag) :-
    ( Call = ':'(_,_) -> $mod_translate_colon(Call, Name, Args) ;
                         $univ(Call, [Name|Args]) ),
    $length(Args, Arity),
    ( ( $memberchk(Name/Arity ---> Tag, Preds) ;
            ( $pervasive(Name/Arity), Tag = Name ) ;
        $mod_translate_local(Name, Arity, Strtag, Tag) ) ->
          ( $mod_translate_args(Args, Preds, Funs, Nargs, Strtag),
            $mod_univ(NCall, [Tag|Nargs]) ) ;
          $mod_error(['** Consult Error : Unknown/hidden predicate',
                      Name/Arity])).

% $mod_translate_args(Args, Preds, Funs, NArgs)
%
%

:- mode $mod_translate_args(+,++,++,-,++).

$mod_translate_args(Item, _, _, Item,_) :-
    ( var(Item) ; number(Item) ; $is_buffer(Item) ), !.

$mod_translate_args([], _, _, [],_) :- !.

$mod_translate_args([Head|Tail], Preds, Funs, [NHead|NTail], Strtag) :-
    !, $mod_translate_args(Head, Preds, Funs, NHead, Strtag),
    $mod_translate_args(Tail, Preds, Funs, NTail, Strtag).

$mod_translate_args(Item, Preds, Funs, Nstruct, Strtag) :-
        ( Item = ':'(_,_) -> $mod_translate_colon(Item, Name, Args) ;
                         $univ(Item, [Name|Args]) ),
    $length(Args, Arity),
    ( ( $memberchk(Name/Arity ---> Tag, Preds) ;
        $memberchk(Name/Arity ---> Tag, Funs) ;
            ( $pervasive(Name/Arity), Tag = Name ) ;
        $mod_translate_local(Name, Arity, Strtag, Tag) ) ->
          ( $mod_translate_args(Args, Preds, Funs, Nargs, Strtag),
            $mod_univ(Nstruct, [Tag|Nargs]) ) ;
          $mod_error(['** Consult Error : Predicate/function', Name/Arity,
                      'unknown in translation phase']) ).

% $mod_translate_local(Name, Arity, Tag, Local)
%
%

$mod_translate_local(Name, Arity, Tag, Local) :-
    Name \= (_:_),
    $dismantle_name(Local, Name, Tag),
    $mod_warning(['** Consult Warning : Undeclared predicate/function',
                  Name/Arity,'in code']).

% $mod_translate_colon(Struct, Name, Args)
%
%

$mod_translate_colon(Atom:Rest, Atom:Name, Args) :- !,
        $mod_translate_colon(Rest, Name, Args).
$mod_translate_colon(Struct, Name, Args) :-
    ( $structure(Struct) -> true ;
        $atom(Struct) ),
        $univ(Struct, [Name|Args]).

% $mod_univ(Term, List)
%
%

$mod_univ(X, [Head|Tail]) :-
    number(Head) -> X = anything ;         % <--- (1)
                    $univ(X, [Head|Tail]).


% Line (1). We encounter problems if we try to create a structure with
% an integer as its name, instead of an atom as its name. However, this case
% only arises when we check that a functor body is a valid one. This code
% is discarded anyway, so we forget about wasting time processing an integer,
% and simply return a dummy value here.

%****************************************************************************

% UTILITY PREDICATES

% $mod_valid_name(Name, Type)
%
%

$mod_valid_name(Name, Type) :-
    ( $atom(Name),
      $name(Name, Xname),
      not( (Xname = [0'$ | _] ;
            Xname = [0'_, 0'$|_]) ) )
        -> true ;
           $mod_error(['** Consult Error : Illegal name', Name, for,Type]).

% $mod_replace_mappings(Itemlist, List, Result)
%
%

$mod_replace_mappings(Itemlist, List, Result) :-
    Itemlist == [] ->
             Result = List ;
         ( Itemlist = [Item ---> Tag|Rest],
           $mod_replace(Item ---> _, Item ---> Tag, List, Newlist),
           $mod_replace_mappings(Rest, Newlist, Result) ).

% $mod_replace_mappings(Atidlist, Sig, P, NewP)
%
%

$mod_replace_mappings(Atidlist, Sig, P, NewP) :-
    Atidlist == [] ->
             NewP = P ;
         ( Atidlist = [Atid|Atids],
           $mod_substructure(Atid, Sig, Map),
           $mod_replace(Atid ---> _, Atid ---> Map, P, P1),
           $mod_replace_mappings(Atids, Sig, P1, NewP) ).

% $mod_replace(Map, Map2, List, Newlist)
%
%

$mod_replace(_, Map2, [], [Map2]).
$mod_replace(Map, Map2, [Map|Rest], [Map2|Rest]).
$mod_replace(Map, Map2, [Head|Rest], [Head|Newtail]) :-
    $mod_replace(Map, Map2, Rest, Newtail).

% $mod_domain_restrict(X, Y, Result)
%
%

$mod_domain_restrict(_, [], []).
$mod_domain_restrict(List, [X ---> _|Tail], [X ---> Z|New]) :-
    $memberchk(X ---> Z, List),
    $mod_domain_restrict(List, Tail, New).

% $mod_error(List)
%
%

$mod_error([]) :-
    $nl,
    fail.
$mod_error([Head|Tail]) :-
    $write(Head),
    $writename(' '),
    $mod_error(Tail).

% $mod_warning(List)
%
%

$mod_warning([]) :-
    $nl.
$mod_warning([Head|Tail]) :-
    $write(Head),
    $writename(' '),
    $mod_warning(Tail).

% $mod_member_or_pervasive(Map, List)
%
%

$mod_member_or_pervasive(Atid/Nat ---> Tag, Y) :-
    $memberchk(Atid/Nat ---> Tag, Y), !.
$mod_member_or_pervasive(Atid/Nat ---> Atid, _) :-
    $pervasive(Atid/Nat).

% $mod_member_chop(Item, List, Leftover)
%
%

$mod_member_chop(X, [Head|Tail], Rest) :-
    Head = X -> Rest = Tail ;
                 $mod_member_chop(X, Tail, Rest).

% $mod_remove(Item, List, Newlist)
%
%

$mod_remove(_, [], []).
$mod_remove(X, [X|Y], Y) :- !.
$mod_remove(X, [Head|Rest], [Head|New]) :-
    $mod_remove(X, Rest, New).

%****************************************************************************

% An interesting problem with SB-Prolog appeared when writing the next
% set of predicates. They do a simple job - assert the module
% environments into the database. However, SB-Prolog is restricted to
% very small clauses when asserting, and module environments are very
% large (the root structure for instance very rapidly runs into hundreds
% of individually mapped predicates and functions). These predicates
% were therefore written to hack the original clause to bits, and assert
% the parts into the database one at a time. This is how is works :

% Basically, instead of asserting the following into the database (for
% example) :
%
%   $module_structure(root,0,
%                     [btreedata1 ---> 34,btreedata2 ---> 36, ...],
%                     [btreedata1 : rightchild / 2 ---> '34__rightchild', ...],
%                     [test2 : a / 1 ---> '122__a', ...]).
%
% Where the lists are very long, we assert the following :
%
%   $module_structure(root,0,V0,V1,V2) :-
%         $module_data135(V0),
%         ($module_data138(V3,V1),
%         $module_data137(V4,V3),
%         $module_data136(V4)
%         ),
%         $module_data139(V2).
%
%   $module_data135([btreedata1 ---> 34,btreedata2 ---> 36, ... ]).
%   $module_data138(V0,[btreedata1 : rightchild / 2 ---> '34__rightchild',
%                       ... |V0]).
%   $module_data137(V0,[btreeeq : c : isnode / 1 ---> '36__isnode',
%                       ... |V0]).
%   $module_data136([test1 : pp / 1 ---> '132__pp']).
%   $module_data139([test2 : a / 1 ---> '122__a', ... ]).
%
% Each clause is now guaranteed to be within the restrictive clause size
% limits imposed by SB-Prolog.
%
% Note that
%                  $module_structure(a,1,[],[],[]).
% is stored as
%                  $module_structure(a,1,V0,V1,V2) :-
%                       V0 = [],
%                       V1 = [],
%                       V2 = [].
%
% Like the business about cutting back to almost the top level when an
% error occurs, this technique is messy, but it works.

% $mod_assert_structure(Module, Tag, Substrs, Preds, Funs)
%
%

$mod_assert_structure(Module, Tag, Substrs, Preds, Funs) :-
        $mod_split(Substrs, Nsubstrs),
        $mod_split(Preds, Npreds),
        $mod_split(Funs, Nfuns),
        $mod_make_split(Nsubstrs, Subterm, Subvar),
        $mod_make_split(Npreds, Predterm, Predvar),
        $mod_make_split(Nfuns, Funterm, Funvar), !,
        $asserta(($module_structure(Module, Tag, Subvar, Predvar, Funvar) :-
                           Subterm, Predterm, Funterm)).

$mod_assert_structure(Module, _, _, _, _) :-
    $mod_error(['** Consult Error : Problem asserting structure', Module,
                    'into database - signature too large?']).

% $mod_assert_functor(Name, Tag, Atids, Substrs, Preds, Funs, Strexpr, P, Q, R)
%
%

$mod_assert_functor(Name, Tag, Atids, Substrs, Preds, Funs, Strexpr, P, Q,
                    R) :-
        $mod_split(Substrs, Nsubstrs),
        $mod_split(Preds, Npreds),
        $mod_split(Funs, Nfuns),
        $mod_split(Strexpr, NStrexpr),
    $mod_split(P, NP),
    $mod_split(Q, NQ),
    $mod_split(R, NR),
        $mod_make_split(Nsubstrs, Subterm, Subvar),
        $mod_make_split(Npreds, Predterm, Predvar),
        $mod_make_split(Nfuns, Funterm, Funvar),
        $mod_make_split(NStrexpr, Strterm, Strvar),
    $mod_make_split(NP, Pterm, Pvar),
    $mod_make_split(NQ, Qterm, Qvar),
    $mod_make_split(NR, Rterm, Rvar), !,
        $asserta(($module_functor(Name, Tag, Atids, Subvar, Predvar, Funvar,
                                 Strvar, Pvar, Qvar, Rvar) :-
                           Subterm, Predterm, Funterm, Strterm,
               Pterm, Qterm, Rterm)).

$mod_assert_functor(Module, _, _, _, _, _, _, _, _, _) :-
    $mod_error(['** Consult Error : Problem asserting functor', Module,
                    'into database - signature/code/environments too large?']).

% $mod_assert_signature(Name, Tag, Substrs, Preds, Funs)
%
%

$mod_assert_signature(Name, Tag, Substrs, Preds, Funs) :-
        $mod_split(Substrs, Nsubstrs),
        $mod_split(Preds, Npreds),
        $mod_split(Funs, Nfuns),
        $mod_make_split(Nsubstrs, Subterm, Subvar),
        $mod_make_split(Npreds, Predterm, Predvar),
        $mod_make_split(Nfuns, Funterm, Funvar), !,
        $asserta(($module_signature(Name, Tag, Subvar, Predvar, Funvar) :-
                           Subterm, Predterm, Funterm)).

$mod_assert_signature(Module, _, _, _, _) :-
    $mod_error(['** Consult Error : Problem asserting signature', Module,
                    'into database - too large?']).

% $mod_make_split(List, Call, Var)
%
%

$mod_make_split([], (Var = []), Var).
$mod_make_split([List], Call, Var) :-
    $gensym($module_data ,Name),
    $univ(Clause, [Name, List]),
    $univ(Call, [Name, Var]),
    $assert(Clause).
$mod_make_split([List|Tail], (Call, Term), Newvar) :-
        $mod_make_split(Tail, Term, Var),
    $gensym($module_data, Name),
        $mod_open_end(List, Nlist, Nvar),
    $univ(Clause,[Name, Nvar, Nlist]),
    $univ(Call, [Name, Var, Newvar]),
    $assert(Clause).

% $mod_open_end(List, Newlist, Var)
%
%

$mod_open_end([], Var, Var).
$mod_open_end([Head|Tail], [Head|New], Var) :-
        $mod_open_end(Tail, New, Var).

% $mod_split(List, Result
%
%

$mod_split([], []).
$mod_split(List, Result) :-
        $mod_split(List, 250, Bit, Leftover),
    ( Bit = [] -> Result = [Leftover] ;
                  ( $mod_split(Leftover, Rest),
                Result = [Bit|Rest] ) ).

% $mod_split(List, Count, Result, Leftover)
%
%

$mod_split([], _, [], []).
$mod_split([Item|Tail], Count, [Item|Bit], Leftover) :-
        $mod_term_length(Item, Len),
        Ncount is Count - Len - 1,
        Ncount > 0,
        $mod_split(Tail, Ncount, Bit, Leftover).
$mod_split(List, _, [], List).

% $mod_term_length(X, Length)
%
%

$mod_term_length(X, 1) :-
        ( number(X) ; var(X) ; $is_buffer(X) ),!.
$mod_term_length([], 1).
$mod_term_length(Str, Total) :-
        $mod_length_args(1, Str, Bit),
        Total is Bit + 1.

% $mod_length_args(No, Str, Total
%
%

$mod_length_args(No, Str, Total) :-
        $arg(No, Str, Arg),
        $mod_term_length(Arg, Len),
        Newno is No + 1,
        $mod_length_args(Newno, Str, Sofar),
        Total is Sofar + Len.
$mod_length_args(_, _, 0).

%****************************************************************************