static ATbool Reduce(void) {
ATerm proc = MCRLgetProc();
ATermList sums = MCRLgetListOfSummands(),
pars = MCRLgetListOfPars();
ATermList newsums = ATmakeList0();
if (proverFlag) {
Declare_vars(pars);
if (invariant) MCRLparseInvariants(invariant);
}
else
RWdeclareVariables(pars);
for (cnt=0,newcnt = 0;!ATisEmpty(sums);sums=ATgetNext(sums),cnt++) {
ATerm sum = ATgetFirst(sums), newsum = NULL;
ATermList vars = (ATermList) ATgetArgument((ATermAppl) sum,0);
ATerm actname = ATgetArgument((ATermAppl) sum, 1);
ATermList actargs = (ATermList) ATgetArgument((ATermAppl) sum,2);
ATerm procarg = ATgetArgument((ATermAppl) sum, 3);
ATerm cond = ATgetArgument((ATermAppl) sum,4);
ATbool invariantUsed = ATfalse;
if (proverFlag) {
if (!ATisEmpty(vars)) Declare_vars(vars);
cond = Prove(cond);
if (invariant) {
ATerm cond1 = ProveCondition(cond);
if (!ATisEqual(cond1, cond)) {
invariantUsed = ATtrue;
cond = cond1;
}
/* ATwarning("QQQ cond = %t", cond); */
}
cond = RWrewrite(cond);
}
else {
if (!ATisEmpty(vars)) RWdeclareVariables(vars);
cond = RWrewrite(cond);
}
/* if (monitor) ATwarning("Condition of summand %d is rewritten", cnt+1); */
if (ATisEqual(cond, MCRLterm_false)) continue;
newcnt++;
actargs = RWrewriteList(actargs);
if (!ATisEqual(procarg, MCRLterm_terminated)) {
ATermList states = (ATermList) ATgetArgument((ATermAppl) procarg, 0);
states = proverFlag?ProveList(states):RWrewriteList(states);
procarg = (ATerm) ATmakeAppl1(MCRLsym_i, (ATerm) states);
}
newsum = ATmake("smd(<term>,<term>,<term>,<term>,<term>)",vars, actname,
actargs,procarg, cond);
newsums = ATinsert(newsums, newsum);
if (monitor && !ATisEqual(sum, newsum))
ATwarning("Summand %d is rewritten %s", cnt+1,
invariantUsed?"(invariant is used)":"");
}
MCRLsetProc(ATmake("initprocspec(<term>,<term>,<term>)",
(ATerm) RWrewriteList((ATermList) MCRLgetListOfInitValues()),
pars, (ATerm) ATreverse(newsums)));
return !ATisEqual(MCRLgetProc(), proc);
}
static ATerm ofp_getArgType(ATerm term, ATbool * isOptType)
{
int i;
ATerm kind, name;
if (ATmatch(term, "[<term>,<term>]", &kind, &name)) {
// MATCHED (kind, name)
}
else {
*isOptType = ATfalse;
return ATmake("None");
}
for (i = 0; i < ATgetLength(gTypeTable); i++) {
ATerm typeName, typeList;
ATbool matched = ATfalse;
ATerm name_type = ATelementAt(gTypeTable, i);
if (ATmatch(name_type, "Type(<term>,<term>)", &typeName, &typeList)) {
matched = ATtrue;
*isOptType = ATfalse;
}
else if (ATmatch(name_type, "OptType(<term>,<term>)", &typeName, &typeList)) {
matched = ATtrue;
*isOptType = ATtrue;
}
if (matched && ATisEqual(name, typeName)) {
return typeList;
}
}
*isOptType = ATfalse;
return ATmake("None");
}
ATbool ofp_traverse_OpDeclInj(ATerm term, pOFP_Traverse OpDeclInj)
{
ATerm name, type, opt;
int isOptType = 0;
if (ATmatch(term, "OpDeclInj(<term>)", &OpDeclInj->term)) {
#ifdef DEBUG_PRINT
printf("\nofp_traverse_OpDeclInj: %s\n", ATwriteToString(OpDeclInj->term));
#endif
if (ATmatch(OpDeclInj->term, "FunType(<term>,<term>)", &type, &name)) {
if (ATmatch(type, "[ConstType(Sort(<term>,<term>))]", &opt, &type)) {
// MATCHED option object type
if (ATmatch(type, "[SortNoArgs(<term>)]", &type) && ATisEqual(opt, ATmake("\"Option\""))) {
isOptType = 1;
} else return ATfalse;
}
else if (ATmatch(type, "[ConstType(SortNoArgs(<term>))]", &type)) {
// MATCHED object type
}
if (ATmatch(name, "ConstType(SortNoArgs(<term>))", &name)) {
// MATCHED object name
} else return ATfalse;
} else return ATfalse;
if (isOptType) {
OpDeclInj->term = ATmake("OptType(<term>,[<term>])", name, type);
}
else {
OpDeclInj->term = ATmake("Type(<term>,[<term>])", name, type);
}
return ATtrue;
}
return ATfalse;
}
int ATR_compare(const ATerm t1, const ATerm t2) {
if (ATisEqual(t1,t2))
return 0;
if (ATR_isSet(t1) && ATR_isSet(t2)) {
ATbool b1, b2;
if (ATR_cardinality(t1) < ATR_cardinality(t2)) {
return -1;
}
if (ATR_cardinality(t1) > ATR_cardinality(t2)) {
return +1;
}
if ((b1 = ATR_subSetOf(t1, t2))) {
return -1;
}
if ((b2 = ATR_subSetOf(t2, t1))) {
return +1;
}
if (b1 && b2) {
return 0;
}
return ATcompare((ATerm)ATsort(ATR_toList(t1), ATR_compare),
(ATerm)ATsort(ATR_toList(t2), ATR_compare));
}
return ATcompare(t1, t2);
}
static ATerm CaseRewrite(ATerm t) {
AFun f = ATgetAFun(t);
int n = ATgetArity(f);
ATerm u;
// ATwarning("%t", t);
if (n==0) return tasks->RWrewrite(t);
u = ATtableGet(norm, t);
if (u) return u;
{
int i;
ATerm *a = calloc(n, sizeof(ATerm));
ATbool changed = ATfalse;
ATprotectArray(a, n);
for (i=0; i<n; i++) {
ATerm arg = ATgetArgument((ATermAppl) t, i);
a[i] = CaseRewrite(arg);
if (!ATisEqual(a[i], arg)) changed = ATtrue;
}
u = CaseRewriteStep(changed?(ATerm) ATmakeApplArray(f, a):t);
ATtablePut(norm, t, u);
ATunprotect(a);
free(a);
return u;
}
}
static ATerm ProveCondition(ATerm c) {
ATerm result = NULL;
while (!ATisEqual(result, c)) {
result = c;
c = _ProveCondition(c);
}
return result;
}
static ATerm CaseRewriteStep(ATerm t) {
ATerm result;
do {
result = t;
t = tasks->RWrewrite(MCRLcaseDistribution(CaseRewrite, result));
}
while (!ATisEqual(t, result));
return result;
}
ATermList ofp_coalesceTypeTable(ATermList oldTable)
{
// Assumes:
// 1. Contains list of terms Type(<str>,<list>) or OptType(<str>,<list>)
// a. <str> is type name
// b. <list> is [type] of length 1
// 2. Portions of table to be coalesced are in order
// 3. If OptType must match "(Some(<term>))"
//
ATerm head;
int isOptType;
ATermList table = (ATermList) ATmake("[]");
ATermList types = (ATermList) ATmake("[]");
ATermList tail = (ATermList) ATmake("<term>", oldTable);
if (ATisEmpty(tail)) {
return oldTable;
}
head = ATgetFirst(tail);
tail = ATgetNext(tail);
while (1) {
ATerm headName, headType, next, nextName, nextType;
if (ATisEmpty(tail)) next = ATmake("Type(None,[None])");
else next = ATgetFirst(tail);
if ( ATmatch(head, "Type(<term>,[<term>])", &headName, &headType) ) isOptType = 0;
else if ( ATmatch(head, "OptType(<term>,[<term>])", &headName, &headType) ) isOptType = 1;
else assert(0);
assert( ATmatch(next, "Type(<term>,[<term>])", &nextName, &nextType)
|| ATmatch(next, "OptType(<term>,[<term>])", &nextName, &nextType)
);
types = ATappend(types, headType);
// check for need to coalesce
if (! ATisEqual(headName, nextName)) {
if (isOptType) {
table = ATappend((ATermList)table, ATmake("OptType(<term>,<term>)", headName, types));
} else {
table = ATappend((ATermList)table, ATmake( "Type(<term>,<term>)", headName, types));
}
types = (ATermList) ATmake("[]");
if (ATisEmpty(tail)) break;
}
head = ATgetFirst(tail);
tail = ATgetNext(tail);
}
return table;
}
static void DisabledEdges(ATermList gs) {
ATermList smds = MCRLgetListOfSummands(),
pars = MCRLgetListOfPars();
int false_cnt = 0, true_cnt = 0, n = ATgetLength(smds);
static int k = 1;
SubstituteInPars(pars, gs);
for (;!ATisEmpty(smds);smds=ATgetNext(smds)) {
ATerm smd = ATgetFirst(smds),
c = ATgetArgument((ATermAppl) smd,4),
cw = NULL;
if (!ATisEmpty((ATermList) ATgetArgument((ATermAppl) smd, 0)))
ATerror("Flag -extra is used while sum variables occur");
cw = RWrewrite(c);
if (
ATisEqual(cw, MCRLterm_false)) false_cnt++;
if (
ATisEqual(cw, MCRLterm_true)) true_cnt++;
}
fprintf(stdout, "Summand %d N = %d disabled %d enabled %d\n",
k++, n, false_cnt, true_cnt);
}
void register_prod(ATerm prod, funcptr func, Symbol sym)
{
unsigned int hnr; /* hash number */
bucket *b; /* single bucket */
/* Heuristics for deciding when to rehash */
if((nr_entries*100)/table_size > MAX_LOAD) {
c_rehash(table_size*2);
}
#ifdef NO_SHARING
/* calc_hash is recursive, so no mod included */
hnr = calc_hash(prod);
hnr %= table_size;
#else
hnr = HASH_PROD(prod, table_size);
#endif
/* Find out if this function has already been registered */
b = prod_table[hnr];
while(b && !ATisEqual(b->prod, prod))
b = b->next_prod;
/* if already registered, we are done */
if(b)
return;
/* Else we should add a new bucket */
b = malloc(sizeof(bucket));
if(!b)
ATabort("out of memory in register.\n");
b->next_prod = prod_table[hnr];
prod_table[hnr] = b;
/* Add it to the sym table also. */
hnr = HASH_SYM(sym, table_size);
b->next_sym = sym_table[hnr];
sym_table[hnr] = b;
/* The prod field of the bucket is protected against
* the gc.
*/
b->prod = prod;
ATprotect((ATerm*)&(b->prod));
b->func = func;
b->sym = sym;
}
ATRelation ATR_compose(ATRelation relation1, ATRelation relation2) {
ATIterator iter1 = ATR_getIterator(relation1);
ATIterator iter_saved = ATR_getIterator(relation2);
ATRelation composition = ATR_empty();
while (!ATR_isEmpty(iter1)) {
ATTuple tuple1 = ATR_getHead(iter1);
ATIterator iter2 = iter_saved;
while (!ATR_isEmpty(iter2)) {
ATTuple tuple2 = ATR_getHead(iter2);
if (ATisEqual(ATR_getSecond(tuple1), ATR_getFirst(tuple2))) {
composition = ATR_insert(composition,
ATR_makeTuple(ATR_getFirst(tuple1),
ATR_getSecond(tuple2)));
}
iter2 = ATR_getTail(iter2);
}
iter1 = ATR_getTail(iter1);
}
return composition;
}
static ATerm _ProveCondition(ATerm c) {
/* Obliged that last branch must be "if (b, T, F)"
Invariant will be used at each first argument of "if" */
ATerm result = c;
ATermList ts = ATempty;
while (ATgetAFun(c)==MCRLsym_ite &&
ATgetArgument((ATermAppl) c, 2) == MCRLterm_false) {
ts = ATinsert(ts, ATgetArgument((ATermAppl) c, 0));
c = ATgetArgument((ATermAppl) c, 1);
}
if (ATisEmpty(ts)) return result;
else {
int n = ATgetLength (ts), i;
DECLA(ATerm, l, n);DECLA(ATerm, r, n); DECLA(ATerm, s, n);
ATerm I = MCRLgetInvariant(0);
for (i=n-1;i>=0;i--, ts = ATgetNext(ts))
l[i] = ATgetFirst(ts);
for (i=0;i<n;i++) {
int j, p;
for (p = 0, j=n-1;j>=0;j--)
if (i!=j) {
s[p] =
(ATerm) ATmakeAppl3(MCRLsym_ite, l[j],
p>0?s[p-1]:MCRLterm_true,MCRLterm_false);
p++;
}
r[i] = p>0?s[p-1]:MCRLterm_true;
}
for (i=0;i<n;i++) {
/* If proven (I and r) -> l then (c = l and r) will be replaced by r */
ATerm IandR = (ATerm) ATmakeAppl2(MCRLsym_and, I, r[i]),
arrow = Prove((ATerm) ATmakeAppl3(MCRLsym_ite, IandR, l[i],
MCRLterm_true));
/* ATwarning("QQQA %t", MCRLprint(arrow)); */
if (ATisEqual(arrow, MCRLterm_true)) {
return r[i];
}
}
return result;
}
}
Symbol lookup_sym(ATerm prod)
{
bucket *b;
unsigned int hnr;
#ifdef NO_SHARING
hnr = calc_hash(prod);
hnr %= table_size;
#else
hnr = HASH_PROD(prod, table_size);
#endif
b = prod_table[hnr];
while(b) {
if(ATisEqual(b->prod, prod))
return b->sym;
b = b->next_prod;
}
ATabort("Unknown function: %t\n", prod);
return (Symbol) 0; /* silence the compiler, we never get here. */
}
funcptr basic_lookup_func(ATerm prod)
{
bucket *b;
unsigned int hnr;
#ifdef NO_SHARING
hnr = calc_hash(prod);
hnr %= table_size;
#else
hnr = HASH_PROD(prod, table_size);
#endif
b = prod_table[hnr];
while(b) {
if(ATisEqual(b->prod, prod))
return b->func;
b = b->next_prod;
}
return (funcptr) NULL;
}
int main(int argc, char *argv[])
{
ATerm bottomOfStack;
ATerm data[20];
ATinit(argc, argv, &bottomOfStack);
initBuiltinsApi();
/* Note that there is still a bug in ApiGen,
* If all of these constructors were in the same sort,
* wrong code would have been generated. This needs
* to be fixed!
*/
data[0] = (ATerm) makeDIinteger(1);
assert(data[0] && ATisEqual(data[0], ATparse("int([1])")));
data[1] = (ATerm) makeDDdouble(1.0);
assert(data[1] && ATisEqual(data[1], ATparse("double(1.0)")));
data[2] = (ATerm) makeDSstring("one");
assert(data[2] && ATisEqual(data[2], ATparse("str(\"one\")")));
data[3] = (ATerm) makeDTrm(ATparse("one"));
assert(data[3] && ATisEqual(data[3], ATparse("term(one)")));
data[4] = (ATerm) makeDLst((ATermList) ATparse("[one]"));
assert(data[4] && ATisEqual(data[4], ATparse("list([one])")));
data[5] = (ATerm) makeLexicalDefault("hello");
assert(data[5] && ATisEqual(data[5], ATparse("string([104,101,108,108,111])")));
assert(strcmp(getLexicalString((Lexical) data[5]), "hello") == 0);
data[6] = (ATerm) makeCharacterDefault('A');
assert(data[6] && ATisEqual(data[6], ATparse("character(65)")));
assert(getCharacterCh((Character) data[6]) == 'A' );
return 0;
}
static void testRolodex()
{
char * names[2];
PhoneNumber phone[2];
Rolodex rolo[2];
RoloList list;
names[0] = "Pieter";
names[1] = "CWI";
phone[0] = makePhoneNumberFromTerm(ATparse("voice(1234)"));
phone[1] = makePhoneNumberFax(5678);
rolo[0] = makeRolodexHome(names[0], phone[0]);
rolo[1] = makeRolodexWork(names[1], phone[1]);
list = makeRoloListEmpty();
list = makeRoloListMany(rolo[1], list);
list = makeRoloListMany(rolo[0], list);
list = visitRoloList(list, acceptRolodex);
assert(ATisEqual(makeRolodexFromTerm(makeTermFromRolodex(rolo[0])),
rolo[0]));
assert(isValidRolodex(rolo[0]));
assert(isValidRolodex(rolo[1]));
assert(!isRolodexWork(rolo[0]));
assert(!isRolodexHome(rolo[1]));
assert(streq(getRolodexName(rolo[0]),names[0]));
assert(streq(getRolodexCompany(rolo[1]),names[1]));
rolo[1] = setRolodexCompany(rolo[1], names[0]);
assert(streq(getRolodexCompany(rolo[1]),names[0]));
}
/**
* Return a list of types associated with this name or None
*/
static ATerm ofp_getTypeList(ATerm name, ATbool * isOptType)
{
int i;
for (i = 0; i < ATgetLength(gTypeTable); i++) {
ATerm typeName, typeList;
ATbool matched = ATfalse;
ATerm name_type = ATelementAt(gTypeTable, i);
if (ATmatch(name_type, "Type(<term>,<term>)", &typeName, &typeList)) {
*isOptType = ATfalse;
matched = ATtrue;
}
else if (ATmatch(name_type, "OptType(<term>,<term>)", &typeName, &typeList)) {
*isOptType = ATtrue;
matched = ATtrue;
}
if (matched && ATisEqual(name, typeName)) {
return typeList;
}
}
*isOptType = ATfalse;
return ATmake("None");
}
/** Make traversal calls for a production
*/
ATbool ofp_build_old_node_traversal(ATerm name, ATerm arg, ATerm kind)
{
ATerm typeList;
ATbool isOptType;
char * root_name = "None";
char * arg_name = "None";
arg_name = ofp_getArgNameStr(arg, &arg_name);
typeList = ofp_getArgType(arg, &isOptType);
assert(ATmatch(name, "<str>", &root_name));
if (isOptType) {
// Some optional productions lead to temporary terms that can be reduced to (Some(<term>)).
// For example, ('PROGRAM' ProgramName?)? in EndProgramStmt produces
// Some((Some(ProgramName("main")))). Get the argname from the type namelist.
//
assert(ATmatch(typeList, "[<str>]", &arg_name));
}
// handle primitive types and terminals
//
if (ATisEqual(ofp_getArgName(arg), ATmake("\"Ident\""))) {
printf("::::::::::::found Ident:::::::: %s\n", ATwriteToString(arg));
printf(" char * %s_val;\n", arg_name);
printf(" if (ATmatch(%s_term.term, ", arg_name);
printf("\"<str>\"");
printf(", &%s_val)) {\n", arg_name);
printf(" // MATCHED %s\n", arg_name);
printf(" } else return ATfalse;\n\n");
}
else if (ofp_isStringType(typeList)) {
printf(" char * %s_val;\n", arg_name);
printf(" if (ATmatch(%s_term.term, ", arg_name);
if (ofp_isArgOptionKind(arg)) printf("\"Some(<str>)\"");
else printf("\"<str>\"");
printf(", &%s_val)) {\n", arg_name);
printf(" // MATCHED %s\n", arg_name);
if (ofp_isArgOptionKind(arg)) printf(" }\n\n");
else printf(" } else return ATfalse;\n\n");
}
// handle list type
//
else if (ofp_isArgListKind(arg)) {
printf(" OFP_Traverse %s;\n", arg_name);
printf(" ATermList %s_tail = (ATermList) ATmake(\"<term>\", %s_list.term);\n", arg_name, arg_name);
printf(" while (! ATisEmpty(%s_tail)) {\n", arg_name);
printf(" %s.term = ATgetFirst(%s_tail);\n", arg_name, arg_name);
printf(" %s_tail = ATgetNext(%s_tail);\n", arg_name, arg_name);
printf(" if (ofp_traverse_%s(%s.term, &%s)) {\n", arg_name, arg_name, arg_name);
printf(" // MATCHED %s\n", arg_name);
if (! ATmatch(kind, "\"Or\"")) printf(" } else return ATfalse;\n");
else printf(" }\n");
printf(" }\n");
}
// handle generic type
//
else {
printf(" OFP_Traverse %s;\n", arg_name);
printf(" if (ATmatch(%s_term.term, ", root_name);
if (ofp_isArgOptionOptionKind(arg)) printf("\"Some((Some(<term>)))\"");
else if (ofp_isArgOptionKind(arg)) printf("\"Some(<term>)\"");
else printf("\"<term>\"");
printf(", &%s.term)) {\n", arg_name);
printf(" if (ofp_traverse_%s(%s.term, &%s)) {\n", arg_name, arg_name, arg_name);
printf(" // MATCHED %s\n", arg_name);
if (ATmatch(kind, "\"Or\"")) printf(" return ATtrue;\n");
printf(" } else return ATfalse;\n");
if (ofp_isOptionOrKind(kind)) printf(" }\n\n");
else printf(" } else return ATfalse;\n\n");
}
return ATtrue;
}
