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 */