static void typecheck_PE_FUNCTION(TYPED_PATT_LIST *context, PE_FUNCTION *fn, TYPE_EXPR *domain, TYPE_EXPR *codomain)
{
TYPE_EXPR **types;
ST_KEY st_key;
ST_TYPE_SIG *st_type_sig;
int num_macros, i, j;
PE_LIST_T_PHRASE **params;
types = find_var_in_context(context, fn->fun_name); /* look in context first */
if (types) {
/* must be a higher-order variable */
if (TEL_length(types) != 2) printMsg(FATAL_MSG,"typecheck_PE_FUNCTION: illegal type for h.o. variable");
add_equation_to_SubstList(domain, types[0]);
add_equation_to_SubstList(types[1], codomain);
}
else {
/* must be a previously defined function */
st_key = st_NameToKey(fn->fun_name);
if (st_key == 0) printMsg(FATAL_MSG,"typecheck_PE_FUNCTION: unknown function \"%s\"", fn->fun_name);
st_type_sig = st_GetTypeSig(st_key);
num_macros = st_GetNumMacros(st_key);
/* get function and macro types from st and rename all type vars */
types = (TYPE_EXPR **) MHA(tc_memory, (num_macros*2)+3, sizeof(TYPE_EXPR *));
types[0] = convert_ST_TYPE_to_TE(st_type_sig->domain);
types[1] = convert_ST_TYPE_to_TE(st_type_sig->codomain);
for (i=0; i<num_macros; i++) {
j=(i*2);
types[j+2] = convert_ST_TYPE_to_TE(st_type_sig->params[i]->domain);
types[j+3] = convert_ST_TYPE_to_TE(st_type_sig->params[i]->codomain);
}
types[(num_macros*2)+2] = 0;
types = rename_vars_in_TEL(assign_new_vars(collect_vars_in_TEL(types)), types);
/* typecheck all the macro args passed to the function */
params = fn->macros;
for (i=0; i<num_macros; i++) {
j=i*2;
if (params[i]) {
typecheck_PE_LIST_T_PHRASE(context, params[i], types[j+2], types[j+3]);
}
else {
tc_close_typechecker(0);
printMsg(ERROR_MSG, "too few macro arguments to function %s", fn->fun_name);
}
}
if (params && (params[i])) {
tc_close_typechecker(0);
printMsg(ERROR_MSG, "too many macro arguments to function %s", fn->fun_name);
}
add_equation_to_SubstList(domain, types[0]);
add_equation_to_SubstList(types[1], codomain);
}
}
static void typecheck_unfold(TYPED_PATT_LIST *context, PE_UNFOLD **phrases, TYPE_EXPR *domain, TYPE_EXPR *codomain)
{
ST_KEY destr_key;
int num_phrases, i, j;
TYPE_EXPR **types;
ST_TYPE_SIG *st_type_sig;
PE_PATT patt;
TYPE_EXPR *ptype[3];
TYPE_ASMT *asmt1, *asmt2;
if (!phrases || !(phrases[0])) printMsg(FATAL_MSG,"typecheck_unfold: phrases is empty");
destr_key = st_NameToKey(phrases[0]->destr);
num_phrases = st_GetNumStructors(st_GetStructorParent(destr_key));
types = (TYPE_EXPR **) MHA(tc_memory, (num_phrases*2)+2, sizeof(TYPE_EXPR *));
types[0] = convert_ST_TYPE_to_TE(st_GetGenericStateType(destr_key)); /* R(A) */
for (i=0; i<num_phrases; i++) {
j=i*2;
st_type_sig = st_GetTypeSig(st_NameToKey(phrases[i]->destr));
types[j+1] = convert_ST_TYPE_to_TE(st_type_sig->domain);
types[j+2] = convert_ST_TYPE_to_TE(st_type_sig->codomain);
}
types[(num_phrases*2)+1] = 0;
/* rename the A's */
types = rename_vars_in_TEL(assign_new_vars(collect_vars_in_TE(types[0])), types);
/* @ : R(A) -> (C @ R(A)) */
ptype[0] = types[0]; /* R(A) */
ptype[1] = product_type_expr(domain, types[0]); /* dom @ R(A) */
next_AT_con--;
ptype[1]->id.con = next_AT_con; /* new @ type constructor (-2 and lower) */
ptype[2] = 0;
patt.tag = P_HOVAR;
patt.info.var = AT_NAME;
context = add_patt_to_context(context, &patt, ptype);
asmt1 = type_asmt(-1,domain); /* C := dom */
asmt2 = type_asmt(-1,ptype[1]); /* C := dom @ R(A) */
for (i=0; i<num_phrases; i++) {
j=i*2;
types[j+1] = subst_in_TE(asmt1,types[j+1]); /* replace C by dom in phrase domain */
types[j+2] = subst_in_TE(asmt2,types[j+2]); /* replace C by dom@R(A) in Fi(A,C) */
typecheck_PE_LIST_T_PHRASE(context, phrases[i]->phrases, types[j+1], types[j+2]);
}
add_equation_to_SubstList(types[0], codomain);
/* apply SubstList to codomain and check that it contains no @ from present level */
if (type_con_occurs_in_TE(next_AT_con, subst_all_in_TE(SubstList,codomain))) {
tc_close_typechecker(0);
printMsg(ERROR_MSG,"@ type occurs in unfold codomain");
}
/* remove all @ occurrences (present level only) from SubstList */
SubstList = eliminate_AT_in_TAL(next_AT_con, SubstList);
}
/***********************
* *
* ProcessCmd cmd *
* *
***********************/
int
ProcessCmd(PARSE_RESULT *result)
{
CT_EXPR *ctExpr = NULL;
COMB_EXPR *combExpr = NULL;
M_INSTR *macroCode = NULL;
CT_VAR_BASE *var_base = NULL;
ST_TYPE *st_type;
ST_KEY funKey;
switch (result->tag) {
case SETCOMMAND:
ge_ProcessSetCommand(result->info.setcommand);
break;
case COMMAND:
return (ge_ProcessCommand(result->info.command));
break;
case QUERY:
ge_ProcessQuery(result->info.query);
break;
case DATA:
addDatatype(result->info.data);
break;
case ALIAS:
addAlias (result->info.alias);
break;
case DEF:
#if 0
printf("RHS PARSE TREE:\n");
display_PE_EXPR(result->info.def->expr, 0);
#endif
funKey = st_AddFunction(result->info.def);
/* typecheck the term logic parse tree */
tc_open_typechecker();
tc_typecheck_PE_DEF(result->info.def, funKey);
/* if this point reached then typecheck of def was successful */
ctExpr = pmTranslate(result->info.def->expr,1);
if ( printCT_EXPR ) {
printMsg(MSG, "\nCore term logic for the function is: \n");
printMsg(MSG, "def %s{%L} = %V =>", result->info.def->id,
result->info.def->macros,
var_base);
printMsg(MSG, "%r\n", ctExpr);
} /* fi */
/* close after typecheck & patt translation are complete */
/* we need to remove DEF if patt translation fails */
tc_close_typechecker(0);
ct_TranslateOpen();
/* if function definition contains any macros, we must add the */
/* environment to the variable base */
if (result->info.def->macros) {
var_base = VarBasePairNew(parseHeapDesc,
vb_pmTranslate(result->info.def->var_base),
&ct_vb_env);
}
else
var_base = vb_pmTranslate(result->info.def->var_base);
ctExpr = ctPreTranslate (ctExpr); /* [#@] */
combExpr = ctTranslate(result->info.def->id,
var_base,
ctExpr);
printMsg(MSG,"Function added: %s%S",st_KeyToName(funKey),st_GetTypeSig(funKey));
macroCode = Compile(result->info.def->id, combExpr);
CodeTableAdd(result->info.def->id, combExpr,
macroCode);
ct_TranslateClose();
break;
case EXPR:
#if 0
printf("PARSE TREE:\n");
display_PE_EXPR(result->info.expr, 0);
#endif
/* typecheck the term logic parse tree */
tc_open_typechecker();
st_type = tc_typecheck_PE_EXPR(result->info.expr);
/* if this point reached then typecheck was successful */
/* don't close typechecker until AFTER result st_type is printed below */
ctExpr = pmTranslate(result->info.expr,0);
if ( printCT_EXPR )
printMsg(MSG, "\nCore term logic for the expression is: \n%r\n", ctExpr);
ct_TranslateOpen();
ctExpr = ctPreTranslate (ctExpr); /* [#@] */
combExpr = ctTranslate(NULL, vb_pmTranslate(VBbang()), ctExpr);
mc_MachineOpen();
combExpr = Evaluate(combExpr, st_type);
kludge = 1;
combExprPrint(combExpr,PP_MAX_SHOW_DEPTH,PP_MAX_RECORD_DEPTH,st_type);
mc_MachineClose();
tc_close_typechecker(0);
ct_TranslateClose();
break;
case EMPTY_INPUT:
break;
default:
printMsg(FATAL_MSG, "ProcessCmd - Invalid tag (%d)", result->tag);
break;
}
return(1);
} /* end ProcessCmd */
