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);
}
/*********************************
* *
* ge_ProcessQuery *
* *
*********************************/
static void
ge_ProcessQuery(PE_QUERY query) {
switch (query.tag) {
case STRNG :
st_PrintEntryInfo(st_NameToKey(query.info.query));
break;
case ABOUT :
clearBuff();
appendBuff(CHARITY_CONT_PROMPT "Charity Interpreter version "CHARITY_VERSION " was written by \n"
CHARITY_CONT_PROMPT " Charles Tuckey, \n"
CHARITY_CONT_PROMPT " Peter Vesely and \n"
CHARITY_CONT_PROMPT " Barry Yee \n"
CHARITY_CONT_PROMPT "from May to November, 1995.\n");
outputBuff(stdout);
break;
case SHOWCOMB :
st_PrintEntryInfo(st_NameToKey(query.info.showcomb));
if (isFunction(query.info.showcomb)) {
printMsg(MSG, "COMBINATOR DEFN for %s", query.info.showcomb);
CodeTableShowComb(query.info.showcomb);
}
else if (isDatatype(query.info.showcomb)) {
st_ShowDatatypeCombinators(st_NameToKey(query.info.showcomb));
}
else
; /* do nothing */
break;
case DUMPTABLE:
st_DumpTable();
break;
case REPLACE:
if (gb_ReplaceFunctions)
printMsg(MSG, "Functions replaced silently.");
else
printMsg(MSG, "User prompted to replace functions.");
printMsg(MSG, "User prompted to replace datatypes.");
break;
case INCLUDEDIRS:
printMsg(MSG,"Search path is %L.",(LIST *)g_strList_IncludeDirs);
break;
case SHOWMEM:
MemDisplayState();
break;
case QUERY:
ge_ShowHelp(QUERY);
break;
default:
printMsg(FATAL_MSG, "ge_ProcessQuery - Invalid tag (%d)", query.tag);
}
}
void tc_open_typechecker(void)
/*
* call this BEFORE calling tc_typecheck_PE_EXPR or tc_typecheck_PE_DEF
*/
{
tc_memory = MemAlloc("typecheck",50000,1); /* enough for now? */
next_new_var = 0;
typechecking_a_def = 0;
SubstList = 0;
product_con = st_NameToKey(PROD_TYPE);
terminal_type = type_con_expr(st_NameToKey(TERMINAL_TYPE), 0);
int_type = type_con_expr(st_NameToKey(INT_TYPENAME), 0);
char_type = type_con_expr(st_NameToKey(CHAR_TYPENAME), 0);
next_AT_con = -1;
}
static void typecheck_structor(char *name, TYPE_EXPR *domain, TYPE_EXPR *codomain)
{
TYPE_EXPR **types;
TYPE_EXPR *parent;
ST_KEY st_key;
ST_TYPE_SIG *st_type_sig;
st_key = st_NameToKey(name);
if (st_key == 0) printMsg(FATAL_MSG,"typecheck_structor: unknown structor \"%s\"", name);
else {
st_type_sig = st_GetTypeSig(st_key);
types = (TYPE_EXPR **) MHA(tc_memory, 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);
types[2] = 0;
parent = convert_ST_TYPE_to_TE(st_GetGenericStateType(st_key)); /* L(A) or R(A) */
/* replace C (-1) by parent */
types = subst_in_TEL(type_asmt(-1, parent), types);
/* rename the A's */
types = rename_vars_in_TEL(assign_new_vars(collect_vars_in_TE(parent)), types);
add_equation_to_SubstList(domain, types[0]);
add_equation_to_SubstList(types[1], codomain);
}
}
static void typecheck_fold(TYPED_PATT_LIST *context, PE_FOLD **phrases, TYPE_EXPR *domain, TYPE_EXPR *codomain)
{
ST_KEY constr_key;
int num_phrases, i;
TYPE_EXPR **types, **hash_types;
ST_TYPE_SIG *st_type_sig;
TYPE_ASMT_LIST *alist;
PE_PATT patt;
TYPE_EXPR *ptype[2];
if (!phrases || !(phrases[0])) printMsg(FATAL_MSG,"typecheck_fold: phrases is empty");
constr_key = st_NameToKey(phrases[0]->constr);
num_phrases = st_GetNumStructors(st_GetStructorParent(constr_key));
types = (TYPE_EXPR **) MHA(tc_memory, num_phrases+2, sizeof(TYPE_EXPR *));
hash_types = (TYPE_EXPR **) MHA(tc_memory, num_phrases+1, sizeof(TYPE_EXPR *));
types[0] = convert_ST_TYPE_to_TE(st_GetGenericStateType(constr_key)); /* L(A) */
for (i=0; i<num_phrases; i++) {
st_type_sig = st_GetTypeSig(st_NameToKey(phrases[i]->constr));
types[i+1] = convert_ST_TYPE_to_TE(st_type_sig->domain); /* Ei(A,C) */
hash_types[i] = copy_TE(types[i+1]);
}
types[num_phrases+1] = 0;
hash_types[num_phrases] = 0;
/* rename the A's */
alist = assign_new_vars(collect_vars_in_TE(types[0]));
types = rename_vars_in_TEL(alist, types);
hash_types = rename_vars_in_TEL(alist, hash_types);
/* replace C (-1) by codomain */
types = subst_in_TEL(type_asmt(-1,codomain), types);
/* replace C (-1) by L(A) in hash types */
hash_types = subst_in_TEL(type_asmt(-1,types[0]), hash_types);
ptype[1] = 0;
patt.tag = P_VAR;
patt.info.var = HASH_NAME;
for (i=0; i<num_phrases; i++) {
ptype[0] = hash_types[i];
typecheck_PE_LIST_T_PHRASE(add_patt_to_context(context, &patt, ptype), phrases[i]->phrases, types[i+1], codomain);
/*
typecheck_PE_LIST_T_PHRASE(context, phrases[i]->phrases, types[i+1], codomain);
*/
}
add_equation_to_SubstList(domain, types[0]);
}
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_record(TYPED_PATT_LIST *context, PE_RECORD **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;
if (!phrases || !(phrases[0])) printMsg(FATAL_MSG,"typecheck_record: 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);
/* replace C (-1) by R(A) */
types = subst_in_TEL(type_asmt(-1,types[0]), types);
for (i=0; i<num_phrases; i++) {
destr_key = st_NameToKey(phrases[i]->destr);
j=i*2;
if (st_IsHO(destr_key)) { /* higher order di:Ei(A)*C->Fi(A,C) */
if (types[j+1]->tag == TYPE_CON && types[j+1]->id.con == product_con) {
typecheck_PE_TERM(context, phrases[i]->cases, types[j+1]->params[0], types[j+2]);
}
else printMsg(FATAL_MSG, "typecheck_record: h.o. destr has illegal domain");
}
else { /* first order di:C->Fi(A,C) */
typecheck_PE_EXPR(context, phrases[i]->expr, types[j+2]);
}
}
add_equation_to_SubstList(domain, terminal_type);
add_equation_to_SubstList(types[0], codomain);
}
static void typecheck_PE_MAP(TYPED_PATT_LIST *context, PE_MAP *map, TYPE_EXPR *domain, TYPE_EXPR *codomain)
{
ST_KEY st_key;
int numParams, i;
TYPE_EXPR **A_types, **B_types;
PE_MAP_PHRASE *map_phrase;
st_key = st_NameToKey(map->type_name);
numParams = st_GetNumParams(st_key);
A_types = (TYPE_EXPR **) MHA(tc_memory, numParams+1, sizeof(TYPE_EXPR *));
B_types = (TYPE_EXPR **) MHA(tc_memory, numParams+1, sizeof(TYPE_EXPR *));
for (i=0; i<numParams; i++) {
A_types[i] = type_var_expr(new_type_var()); /* Ai */
B_types[i] = type_var_expr(new_type_var()); /* Bi */
map_phrase = (map->phrases)+i;
if (map_phrase->positive) {
if (map_phrase->negative) {
/* bivariant (*) phrase (p:Ai->Bi & n:Bi->Ai) */
typecheck_PE_LIST_T_PHRASE(context, map_phrase->positive, A_types[i], B_types[i]);
typecheck_PE_LIST_T_PHRASE(context, map_phrase->negative, B_types[i], A_types[i]);
}
else {
/* covariant (+) phrase (p:Ai->Bi) */
typecheck_PE_LIST_T_PHRASE(context, map_phrase->positive, A_types[i], B_types[i]);
}
}
else {
if (map_phrase->negative) {
/* contra-variant (-) phrase (n:Bi->Ai) */
typecheck_PE_LIST_T_PHRASE(context, map_phrase->negative, B_types[i], A_types[i]);
}
else {
/* non-variant (?) phrase ( _ ) */
/* do nothing */
}
}
} /* for */
A_types[numParams] = 0;
B_types[numParams] = 0;
add_equation_to_SubstList(domain, type_con_expr(st_key, A_types)); /* dom=T(As) */
add_equation_to_SubstList(type_con_expr(st_key, B_types), codomain); /* cod=T(Bs) */
}
TYPED_PATT_LIST *add_patt_to_context(TYPED_PATT_LIST *context, PE_PATT *patt, TYPE_EXPR **patt_type)
/*
* given a pattern (patt) and its type (patt_type), decompose the pattern and
* add any variables it contains to the context while also updating SubstList
* return the extended context
*/
{
TYPE_EXPR **types;
P_STRUCTOR **structors;
ST_KEY structor_key;
ST_TYPE_SIG *st_type_sig;
int num_destrs, i;
TYPE_EXPR *parent_type;
TYPE_ASMT_LIST *alist;
TYPE_ASMT *asmt;
if (!patt) printMsg(FATAL_MSG,"add_patt_to_context: patt is NULL");
if (patt->tag == P_HOVAR) {
if (TEL_length(patt_type) != 2) {
printMsg(FATAL_MSG,"add_patt_to_context: illegal type for higher-order pattern");
}
}
else {
if (TEL_length(patt_type) != 1) {
printMsg(FATAL_MSG,"add_patt_to_context: illegal type for first-order pattern");
}
}
switch (patt->tag) {
case P_VAR:
case P_HOVAR:
context = TPL_cons(typed_patt(patt, patt_type), context);
break;
case P_RECORD:
structors = patt->info.record; /* should be nt array with > 0 entries */
if (!structors || !(structors[0])) {
printMsg(FATAL_MSG,"add_patt_to_context: illegal record pattern");
}
structor_key = st_NameToKey(structors[0]->id);
num_destrs = st_GetNumStructors(st_GetStructorParent(structor_key));
parent_type = convert_ST_TYPE_to_TE(st_GetGenericStateType(structor_key));
alist = assign_new_vars(collect_vars_in_TE(parent_type));
asmt = type_asmt(-1, parent_type);
for (i=0; i<num_destrs; i++) {
structor_key = st_NameToKey(structors[i]->id);
st_type_sig = st_GetTypeSig(structor_key);
if (st_IsHO(structor_key)) {
types = (TYPE_EXPR **) MHA(tc_memory, 3, sizeof(TYPE_EXPR *));
types[0] = convert_ST_TYPE_to_TE(st_type_sig->domain); /* Ei(A)*C */
if (types[0]->tag == TYPE_CON && types[0]->id.con == product_con) {
types[0] = types[0]->params[0]; /* Ei(A) */
}
else printMsg(FATAL_MSG,"add_patt_to_context: failed on h.o. destructor pattern");
types[1] = convert_ST_TYPE_to_TE(st_type_sig->codomain); /* Fi(A,C) */
types[2] = 0;
}
else {
types = (TYPE_EXPR **) MHA(tc_memory, 2, sizeof(TYPE_EXPR *));
types[0] = convert_ST_TYPE_to_TE(st_type_sig->codomain); /* Fi(A,C) */
types[1] = 0;
}
types = subst_in_TEL(asmt, types); /* C:=R(A) */
types = rename_vars_in_TEL(alist, types); /* rename A's */
context = add_patt_to_context(context, structors[i]->arg, types);
}
parent_type = rename_vars_in_TE(alist, parent_type); /* rename A's */
add_equation_to_SubstList(parent_type, patt_type[0]);
break;
case P_PAIR:
types = (TYPE_EXPR **) MHA(tc_memory, 4, sizeof(TYPE_EXPR *));
types[0] = type_var_expr(new_type_var());
types[1] = 0;
types[2] = type_var_expr(new_type_var());
types[3] = 0;
context = add_patt_to_context(context, patt->info.ppair.l, types);
context = add_patt_to_context(context, patt->info.ppair.r, types+2);
add_equation_to_SubstList(product_type_expr(types[0], types[2]), patt_type[0]);
break;
case P_CONSTR:
structor_key = st_NameToKey(patt->info.constr->id);
parent_type = convert_ST_TYPE_to_TE(st_GetGenericStateType(structor_key));
alist = assign_new_vars(collect_vars_in_TE(parent_type));
st_type_sig = st_GetTypeSig(structor_key);
types = (TYPE_EXPR **) MHA(tc_memory, 2, sizeof(TYPE_EXPR *));
types[0] = convert_ST_TYPE_to_TE(st_type_sig->domain); /* Ei(A,C) */
types[0] = subst_in_TE(type_asmt(-1,parent_type), types[0]); /* C:=R(A) */
types[0] = rename_vars_in_TE(alist, types[0]); /* rename A's */
types[1] = 0;
context = add_patt_to_context(context, patt->info.constr->arg, types);
parent_type = rename_vars_in_TE(alist, parent_type); /* rename A's */
add_equation_to_SubstList(parent_type, patt_type[0]);
break;
case P_BANG:
add_equation_to_SubstList(terminal_type, patt_type[0]);
break;
case P_INT:
add_equation_to_SubstList(int_type, patt_type[0]);
break;
case P_CHAR:
add_equation_to_SubstList(char_type, patt_type[0]);
break;
default:
printMsg(FATAL_MSG,"add_patt_to_context: unknown tag");
}
return context;
}
