/*
* Copyright (c) 1995, 1996 Gunther Schadow. All rights reserved.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/*
* Make header files for messages
*
*/
:- module(mkc_msg,[mkc/0, memo_incl/1, memo_incl/2, print_incl/0,
build_vdecl/2, memo_repstruc/2,
itemtab_h/1, itemtab_cc/4, init/1]).
:- style_check(+string).
:- use_module(desc-files).
:- use_module(desc-names).
:- use_module(db-inter).
:- use_module(mkc-print).
:- use_module(mkc-grp).
:- use_module(mkc-var).
:- use_module(mkc-evs).
:- use_module(mkc-html).
/*
* This was a forall construct, but pl-2.1.0 couldn't handle it on AIX3.2
*/
fa([]).
fa([[EvL,[msh,evn|Def]]|R]) :- fa1(EvL, Def), fa(R).
fa1(EvL, Def) :- varname(EvL,VarName),
varname(EvL,VarName),
format("~n[~w", [VarName]),
mkc_var(adt,VarName,Def),
format("]"),
forall(member(E,EvL),
(
message(M,E,_,_),
format("[~w~w", [M,E]), flush,
mkc_evs(M,E,VarName,Def),
format("]")
)).
mkc :-
format("Making code for messages:~n"),
vcgnew,
event_selected(adt,DefL,EvcL),
format("Event selected adt messages are:~n~p", [EvcL]),
fa(DefL),
format("~nUniqe messages:~n"),
forall(
(
implemented(_:message(M,E,_,_)),
\+ member(E,EvcL)
),
(
format("[~w~w", [M, E]), flush,
mkc_msg(M,E),
format("]")
)), nl,
mkc_groups,
format("~nWriting segconf"),
print_segconf,
format(".~nWriting repstruc"),
print_repstruc,
format(".~n").
racrdc([A],A,[]).
racrdc([H|T],L,[H|Hd]) :- racrdc(T,L,Hd).
racrdc([],[]).
mkc_msg(M,E) :-
file(message,msg(M,E),Fnh),
header_segment(MHS),
message(M,E,Comm,[MHS|DefL1]),
( ( trailer_segment(MTS),
racrdc(DefL1, MTS, DefL) );
DefL = DefL1 ),
message_type(M, _, FunArea),
evco(E,Ec),
unimesg(M,Ec,Mu),
msgname(Mu,Mn),
%groups(DefL,GrpL,DefLG),
groups(DefL,DefLG), GrpL = [],
memo_incl(DefLG, GrpL),
build_vdecl(DefLG,DecL),
memo_repstruc(Mn,DecL),
htell(Fnh,Def,message),
nl,
main_package(P), package(P,_,Pfx,R,_),
uppercase(Pfx,UP),
concat(UP,'Message',PMessage),
format("~n#include <~w~w.h>~n", [R, PMessage]),
comment('MESSAGE',M,FunArea,Comm),
print_incl,
class_begin(Mn, PMessage),
( length(GrpL,0)
-> true;
(
ppublic,
mkc_grps_h(GrpL,Mn),
format("/*~n * Resume ~w~n */",Mn),
pprivate
)
),
typedef_groups(DefLG),
print_vdecl(DecL),
/* itemtab */
length(DecL, NOItems),
itemtab_h(DecL),
ppublic,
/* ctor */
format("~n~w();~n", Mn),
/* get */
forall(
(
member([Type,_,Name,_,_], DecL),
Type \= '// void'
),
format("~nconst ~w& get~w() const;", [Type, Name])),
/* set */
nl,
forall(
(
member([Type,_,Name,_,_], DecL),
Type \= '// void'
),
format("~nvoid set~w(const ~w &x);", [Name, Type])),
class_end,
iccinclude(Fnh),
htold(Def),
cctell(Fnh, message),
nl,
format("#include ~'~w.h~'~n", [PMessage]),
format("#include ~'UniMesIdCode.h~'~n"),
comment('MESSAGE',Mn,FunArea,Comm),
/* itemtab */
itemtab_cc(Mn, DecL, DefLG, GrpL),
/* ctor */
valname(Mu,Muv),
format("~n~n~w::~w() : ~w(UniMesIdCode::~w, ~w, itemtab)",
[Mn, Mn, PMessage, Muv, NOItems]),
init(DecL),
nl,
( length(GrpL,0) ->
true;
mkc_grps_cc(GrpL,Mn)
),
cctold,
icctell(Fnh, message),
/* get */
forall(
(
member([Type,_,Name,_,_], DecL),
Type \= '// void'
),
(
%scopetype(Mn,Type,ScopeType),
ScopeType = Type,
format("~ninline~n"),
format("const ~w& ~w::get~w() const~n",
[ScopeType, Mn, Name]),
format("{~n"),
format(" return ~w;~n", Name),
format("}~n")
)),
/* set */
nl,
forall(
(
member([Type,_,Name,_,_], DecL),
Type \= '// void'
),
(
format("~ninline~n"),
format("void ~w::set~w(const ~w &x)~n", [Mn,Name,Type]),
format("{~>~n"),
format("~w = x;~n", [Name]),
format("set();"),
format("~<~n}~n")
)),
( length(GrpL,0) ->
true;
mkc_grps_icc(GrpL,Mn)
),
nl,
icctold,
vcgtell,
% node
format("node: {~>~ntitle: ~'~w~'~n", [Mn]),
uppercase(M,UM),
uppercase(E,UE),
format("label: ~'~w^~w~'~n", [UM, UE]),
format("color: darkgreen~n"),
format("level: 0~<~n}~n"),
% edges
forall(member([Type,_,_,_,Name], DecL),
(
format("edge: {~>~n"),
uppercase(Name,UName),
( ( concat("repstruc<",Tp0,Type), concat(Tp1,">",Tp0) )
-> format("label: ~'~w(r)~'~n", [UName]);
( Type = 'repANYseg'
-> ( Tp1 = 'ANYseg',
format("label: ~'~w(r)~'~n", [UName]) );
( format("label: ~'~w~'~n", [UName]),
Tp1 = Type ) ) ),
format("sourcename: ~'~w~'~n", [Mn]),
format("targetname: ~'~w~'~<~n}~n", [Tp1])
)),
vcgtold.
/*
htmltell(Fnh),
sformat(H1, "MESSAGE ~w^~w - ~w", [UM, UE, Comm]),
html_headline(1,H1,UM,FunArea),
format("~>"),
pp_msg(DefL),
format("~<~n
~>~n"),
pp_msg(DefLG),
format("~<~n~n"),
htmltold.
*/
/*
NAME
memo_incl/1, print_incl/0 -- collect and print dependencies
memo_incl/2
SYNOPSIS
memo_incl(+DefL).
memo_incl(+DefL, +GrpL).
print_incl.
DESCRIPTION
The predicate memo_incl/1 takes the segment structure `DefL'
and memoizes all dependencies i.e. all those segments which
have to be included from other files before they can be
referenced. Beside the normal segments, there are two
classes, which may have to be included as well: the `ANYseg'
and the `repstruc' template class.
The memoized dependencies are usually output as #include
directives at the beginnig of the header source file by means
of the predicate print_incl/0. This has the side effect of
draining the memory. Thus, print_incl/0 can only be called
once.
*/
memo_incl(DefL, _ /* GrpL */) :-
memo_incl(DefL)
%, memo_inclgl(GrpL)
.
memo_inclgl([]).
memo_inclgl([[_, Gdf]|T]) :-
groups(Gdf, GrpL, GdfG),
memo_incl(GdfG, GrpL),
memo_inclgl(T).
memo_incl([]).
memo_incl([H|T]) :-
memo_incl1(H),
memo_incl(T).
memo_incl1(grp(G)) :-
memo_incl2(grp(G)).
memo_incl1(grp(G,N)) :-
memo_incl2(grp(G,N)).
%memo_incl1(G) :-
% G =.. [grp|_],
% memo_incl2(group).
memo_incl1(O) :-
O =.. [opt|A],
memo_incl(A).
memo_incl1(R) :-
R =.. [rep|A],
( (
[B] = A,
B =.. [any|L]
) ->
(
memo_incl2(repANYseg),
memo_incl(L)
);
(
memo_incl2(repstruc),
memo_incl(A)
)
).
memo_incl1(A) :-
A =.. [any|L],
memo_incl2(any),
memo_incl(L).
memo_incl1(A) :-
atom(A),
memo_incl2(A).
memo_incl2(X) :-
predicate_property(memo_incl_memory(_), _),
memo_incl_memory(X).
memo_incl2(X) :-
assert(memo_incl_memory(X)).
print_incl :-
findall(Dep, memo_incl_memory(Dep), DepL),
mkc_print:print_incl(DepL),
abolish(memo_incl_memory, 1).
/*
NAME
memo_segconf/1, print_segconf
-- handle segments that are required in ANY segments
SYNOPSIS
memo_segconf(+SegL).
print_segconf.
DESCRIPTION
Works just like memo_incl/1 and print_incl/0. The predicate
memo_segconf/1 memoizes any segment that is found in the list
`SegL' while print_segconf/0 prints and forgets them.
*/
memo_segconf([]).
memo_segconf([H|T]) :-
uppercase(H,Sn),
memo_segconf1(Sn),
memo_segconf(T).
memo_segconf1(X) :-
predicate_property(memo_segconf_memory(_), _),
memo_segconf_memory(X).
memo_segconf1(X) :-
assert(memo_segconf_memory(X)).
print_segconf :-
predicate_property(memo_segconf_memory(_), _),
path(message,Path),
concat(Path,'ANYseg.conf',File),
tell(File),
forall(memo_segconf_memory(X), format("~w~n", X)),
told,
abolish(memo_segconf_memory, 1).
print_segconf :-
format("... no ANY segments."),
path(base,Path),
concat(Path,'ANYseg.conf',File),
tell(File),
told.
/*
NAME
memo_repstruc/1
memo_repstruc/2, print_repstruc
-- repstruc template configuration facility
SYNOPSIS
memo_repstruc(+Prefix,+DecL).
memo_repstruc(+DecL).
print_repstruc.
DESCRIPTION
Works just like memo_incl/1 and print_incl/0. The predicate
memo_repstruc/2 memoizes the base type of each usage of a
repstruc template in the declaration list `DecL' which is
either a segment or a group while print_repstruc/0 prints and
forgets what was memoized since the last print_repstruc was
done.
*/
memo_repstruc(X) :- memo_repstruc('',X).
memo_repstruc(_,[]).
memo_repstruc(Prefix,[H|T]) :-
memo_repstruc1(Prefix,H),
memo_repstruc(Prefix,T).
memo_repstruc1(_,[Type,_,_,_,_]) :-
concat('repstruc<',X,Type),
concat(X1,'>',X),
% ( concat(_,'grp',X1) ->
% concat_atom([Prefix,'::',X1],X2);
% X2 = X1 ),
% memo_repstruc2(X2).
memo_repstruc2(X1).
memo_repstruc1(_,_).
memo_repstruc2(X) :-
predicate_property(memo_repstruc_memory(_), _),
memo_repstruc_memory(X).
memo_repstruc2(X) :-
assert(memo_repstruc_memory(X)).
print_repstruc :-
predicate_property(memo_repstruc_memory(_), _),
path(base,Path),
concat(Path,'repstruc.conf',File),
tell(File),
forall(memo_repstruc_memory(X),
format("~w~n", X)),
told,
abolish(memo_repstruc_memory, 1).
print_repfield :-
format("... no repeated structures."),
path(base,Path),
concat(Path,'repfield.conf',File),
tell(File),
told.
/*
NAME
build_vdecl/2 -- build list of variable/parameter declarations
SYNOPSIS
build_vdecl(+DefL, ?DecL).
DESCRIPTION
The predicate build_vdecl/2 takes a segment structure `Defl' and
generates from it a list of declarations. This informations is
needed when the member variables of the class have to be
declared, and to generate the parameter list of member
functions or even different member functions like selectors.
In fact the declarations list (`Decl') is the most important
data structure for the definition of classes.
The declarations list is a list of equal length sub lists.
Each of the sublists contain the information of one variable:
[Type,PtRef,Name,Index,Comment]
Note that pragmatics has precedence over semantics here: even
though `PtRef' and `Index' was formally meant as pointers and
array indices (at the time before I invented the `repfield'
and `repstruc' class templates) they do now mean other things.
`PtRef' takes the flag that signals optionality, and `Index'
takes the list of allowed segments for the ANY segment.
*/
build_vdecl(DefL,DecL) :-
build_vdecl1(DefL,NDecL),
uniq_names(NDecL,DecL).
build_vdecl1([],[]).
build_vdecl1([H|T],[Hn|Tn]) :-
build_vdecl2(H,Hn),
build_vdecl1(T,Tn).
build_vdecl2(A,[Type,'',Name,'',Ds]) :- atom(A),
segname(A,Type),
segment(A,Ds,_),
cname(Ds,Name).
build_vdecl2(opt(A),[Type,opt,Name,I,Ds])
:- build_vdecl2(A,[Type,_,Name,I,Ds]).
build_vdecl2(rep(A),[Rtype,Opt,Name,I,Ds])
:- build_vdecl2(A,[Type,Opt,Name,I,Ds]),
( Type = 'ANYseg' ->
Rtype = 'repANYseg';
concat_atom(['repstruc<', Type, '>'], Rtype)
).
build_vdecl2(G,[Type,'',Name,'',"a group"])
:- G =.. [grp|_],
grptname(G,Type),
grpvname(G,Name).
build_vdecl2(any(S),D)
:- fformat(user_error, "warning: ANY with just one choice: `~w'", [S]),
build_vdecl2(S,D).
build_vdecl2(A,['ANYseg','',any,Al,"Any-of segment"])
:- A =.. [any|Al],
memo_segconf(Al).
/*
NAME
uniq_names/3 -- provide for unique names
SYNOPSIS
uniq_names(+DecL, ?UDecL).
DESCRIPTION
The predicate uniq_names/3 makes names unique. If we woul not
care the two PID segments in ADTA24msg would cause a name
conflict. The predicate takes a declarations list (`DecL') as
input and constructs a declarations list in which all names
are unique (`UDecL').
It first constructs a simple list of all names. This list is
then sorted such that equal name entries are at succeeding
nodes. The predicate uniq_names1/2 constructs an other list
which is made of pairs whose CAR is a name and whose CDR is
the number of occurences of that name.
uniq_names2 constructs the declarations list with
unique names from the list of [name|count] pairs and the
original declarations list by scanning the former for names
which have a count greater than one.
Finally uniq_names3 scans the declarations list for any
occurence of the name in question, and modifies it by
appending the actual counter to the name.
*/
uniq_names(DecL,UDecL) :-
findall(N, member([_,_,N,_,_],DecL), NL),
msort(NL,SNL),
uniq_names1(SNL,CNL),
uniq_names2(CNL,DecL,UDecL).
uniq_names1([],[]).
uniq_names1([X|R],[[X|UN]|UR]) :-
uniq_names1(R,[[X|N]|UR]),
UN is N + 1.
uniq_names1([X|R],[[X|1]|UR]) :-
uniq_names1(R,UR).
uniq_names2([],DecL,DecL).
uniq_names2([[_|1]|R],DecL,UDecL) :-
uniq_names2(R,DecL,UDecL).
uniq_names2([[N|I]|R],DecL,UDecL) :-
uniq_names3(N,1,I,DecL,IDecL),
uniq_names2(R,IDecL,UDecL).
uniq_names3(_,C,I,UDecL,UDecL) :- C is I + 1.
uniq_names3(N,C,I,[[X1,X2,N,X4,X5]|R],[[X1,X2,UN,X4,X5]|UR]) :-
concat(N,C,UN),
Cn is C + 1,
uniq_names3(N,Cn,I,R,UR).
uniq_names3(N,C,I,[H|R],[H|UR]) :-
uniq_names3(N,C,I,R,UR).
/*
NAME:-
itemtab_h/1, itemtab_cc/2 -- output the static array `itemtab'.
*/
itemtab_h(DecL) :-
length(DecL, NOItems),
format("~nstatic itemdesc itemtab[~w];~n", NOItems).
itemtab_cc(Class, DecL, DefLG, GrpL) :-
length(DecL, NOItems),
length(DefLG, Proof),
(
NOItems \= Proof ->
fformat(user_error, "e:DecL and DefLG differ in lenths~n"),
trace;
true
),
format("SegStruc::itemdesc ~w::itemtab[~w] = {~>", [Class, NOItems]),
itemtab_cc1(Class, DecL, DefLG, GrpL),
format("~<~n};~n").
itemtab_cc1(_, [], [], _).
itemtab_cc1(Class, [DecH], [Def], GrpL) :-
nl,
itemtab_cc2(Class, DecH, Def, GrpL).
itemtab_cc1(Class, [DecH|DecR], [Def|DefR], GrpL) :-
nl,
itemtab_cc2(Class, DecH, Def, GrpL),
format(","),
itemtab_cc1(Class, DecR, DefR, GrpL).
itemtab_cc2(Class, [Type,Rq,Name,_,Cmt], Def, GrpL) :-
Type \= '// void',
leader(Def, GrpL, LdrSeg),
(
LdrSeg \= '' ->
valname(LdrSeg, Sv),
concat('SegTypeCode::', Sv, Leader);
/* fformat(user_error, "w: no leader for group `~w'~n", [Def]), */
Leader = 'SegStruc::any_leader'
),
required_segment(Rq, Rq1),
format("{ ~w, (::Structure (::SegStruc::*))&~w::~w, ~w, ~'~w~' }",
[Leader, Class, Name, Rq1, Cmt]).
required_segment(opt, optional).
required_segment(_, required).
leader(X, GrpL, Leader) :-
X =.. [opt|A],
leader1(A, GrpL, Leader).
leader(X, GrpL, Leader) :-
leader1(X, GrpL, Leader).
leader1(X, _, X) :- atom(X).
leader1([X|_], GrpL, L) :-
leader1(X, GrpL, L).
leader1(grp(X), GrpL, Leader) :-
lookup(grp(X), GrpL, GrpD),
leader1(GrpD, GrpL, Leader).
leader1(X, GrpL, Leader) :-
X =.. [rep|A],
leader1(A, GrpL, Leader).
leader1(_, _, '').
lookup(Grp, [], GrpD) :-
group_lookup(Grp, GrpD);
fformat(user_error, "e: definition of group `~w' not found~n", Grp),
trace.
lookup(Grp, [[Grp, GrpD]|_], GrpD).
lookup(Grp, [_|T], GrpD) :-
lookup(Grp, T, GrpD).
init(DecL) :-
(
member([Type,_,_,_,_], DecL),
( Type = 'repANYseg' ;
Type = 'ANYseg' )
) ->
(
format("~n{~>~n"),
format("/*~n * initialize the ANYseg~n */~n"),
forall(
(
member([Type,_,Name,Set,_], DecL),
( Type = 'repANYseg' ; %% here, how shall this work?
Type = 'ANYseg' )
),
(
forall(member(Seg, Set),
(
valname(Seg,SV),
format("~w.allow(SegTypeCode::~w);~n", [Name, SV])
))
)),
format("~<~n}~n")
) ;
format(" {}~n").