Commit a0cc660b authored by Martijn Vervoort's avatar Martijn Vervoort
Browse files

fixed bugs; partially implemented type dependent functions

parent ad585fe6
......@@ -10,4 +10,7 @@ convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !*{! Gr
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !*{! Group} !*{#FunDef} !*PredefinedSymbols
!*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap
-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap)
*/
\ No newline at end of file
*/
instance toString GlobalTCType
instance toString BasicType
\ No newline at end of file
......@@ -191,7 +191,7 @@ where
app_info_ptr = nilPtr },
let_info_ptr = let_info_ptr}, ci)
convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
= convertTypecode cinp type_code ci
= abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci
convertDynamics cinp bound_vars default_expr EE ci
= (EE, ci)
convertDynamics cinp bound_vars default_expr expression ci
......@@ -202,6 +202,11 @@ convertTypecode cinp TCE_Empty ci
= (EE, ci)
convertTypecode cinp (TCE_Var var_info_ptr) ci
= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, ci)
// MV ..
convertTypecode cinp (TCE_TypeTerm var_info_ptr) ci
= (Var {var_name = v_tc_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, ci)
// .. MV
convertTypecode cinp (TCE_Constructor index typecode_exprs) ci
# (typecons_symb, ci) = getSymbol PD_TypeConsSymbol SK_Constructor 2 ci
constructor = get_constructor cinp.cinp_glob_type_inst index
......@@ -227,6 +232,58 @@ convertTypecodes cinp [typecode_expr : typecode_exprs] ci
app_info_ptr = nilPtr}, ci)
/*
// MV ..
//mv_convertTypecode :: !ConversionInput TypeCodeExpression !*ConversionInfo -> (Expression,!*ConversionInfo)
mv_convertTypecode cinp TCE_Empty ci
= (EE, ci)
mv_convertTypecode cinp (TCE_Var var_info_ptr) ci
= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, ci)
mv_convertTypecode cinp (TCE_TypeTerm var_info_ptr) ci
= (Var {var_name = v_tc_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}, ci)
mv_convertTypecode cinp (TCE_Constructor index typecode_exprs) ci
# (typecons_symb, ci) = mv_getSymbol PD_TypeConsSymbol SK_Constructor 2 ci
constructor = mv_get_constructor cinp.cinp_glob_type_inst index
(typecode_exprs, ci) = mv_convertTypecodes cinp typecode_exprs ci
= (App {app_symb = typecons_symb,
app_args = [constructor , typecode_exprs],
app_info_ptr = nilPtr}, ci)
mv_convertTypecodes _ [] ci
= abort "dummy"
*/
/*
mv_convertTypecode cinp (TCE_Selector selections var_info_ptr) ci
= (Selection No (Var { var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }) selections, ci)
mv_convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo -> (Expression,!*ConversionInfo)
mv_convertTypecodes _ [] ci
# (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci
= (App { app_symb = nil_symb,
app_args = [],
app_info_ptr = nilPtr}, ci)
mv_convertTypecodes cinp [typecode_expr : typecode_exprs] ci
# (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci
(expr, ci) = mv_convertTypecode cinp typecode_expr ci
(exprs, ci) = mv_convertTypecodes cinp typecode_exprs ci
= (App { app_symb = cons_symb,
app_args = [expr , exprs],
app_info_ptr = nilPtr}, ci)
*/
// Aux
mv_getSymbol :: Index ((Global Index) -> SymbKind) Int !*PredefinedSymbols -> (SymbIdent, !*PredefinedSymbols)
mv_getSymbol index symb_kind arity predef_symb
# ({pds_module, pds_def, pds_ident}, predef_symb) = predef_symb![index]
symbol = { symb_name = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity }
= (symbol,predef_symb)
// .. MV
determine_defaults :: (Optional Expression) DefaultExpression !*ConversionInfo -> (Optional Expression, DefaultExpression, !*ConversionInfo)
/***
determine_defaults :: case_default default_expr varheap -> (this_case_default, nested_case_default, var_heap)
......@@ -539,6 +596,7 @@ getConstructor index arity ci=:{ci_predef_symb}
a_ij_var_name :== { id_name = "a_ij", id_info = nilPtr }
v_tc_name :== { id_name = "convertDynamicsvTC", id_info = nilPtr }
case_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo)
case_ptr ci=:{ci_expr_heap}
......
......@@ -45,8 +45,8 @@ tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Ind
}
removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap
!*TypeCodeInfo !*VarHeap !*ErrorAdmin
-> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin)
!*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol} //!*{#PredefinedSymbol}
-> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol})
updateDynamics :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin
-> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin)
updateDynamics :: ![Index] ![LocalTypePatternVariable] !*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol}
-> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol})
This diff is collapsed.
......@@ -1053,7 +1053,8 @@ cIsNotStrict :== False
| ArraySelection !(Global DefinedSymbol) !ExprInfoPtr !Expression
| DictionarySelection !BoundVar ![Selection] !ExprInfoPtr !Expression
:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr
//:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr
:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr /* MV */ | TCE_TypeTerm !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr
:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent | GTT_Function
......@@ -1127,7 +1128,8 @@ instance == ModuleKind, Ident
instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, TypeVar, SymbolType, Expression, Type, Ident, (Global object) | <<< object,
Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, (Bind a b) | <<< a & <<< b, ParsedConstructor, (TypeDef a) | <<< a, TypeVarInfo,
BasicValue, ATypeVar, TypeRhs, FunctionPattern, (Import from_symbol) | <<< from_symbol, ImportDeclaration, ImportedIdent, CasePatterns,
(Optional a) | <<< a, ConsVariable, BasicType, Annotation, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance, SignClassification
(Optional a) | <<< a, ConsVariable, BasicType, Annotation, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance, SignClassification,
TypeCodeExpression
instance == TypeAttribute
instance == Annotation
......
......@@ -994,7 +994,7 @@ cIsNotStrict :== False
| ArraySelection !(Global DefinedSymbol) !ExprInfoPtr !Expression
| DictionarySelection !BoundVar ![Selection] !ExprInfoPtr !Expression
:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr
:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr /* MV */ | TCE_TypeTerm !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr
:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent | GTT_Function
......@@ -1365,7 +1365,7 @@ where
(<<<) file (MatchExpr _ cons expr) = file <<< cons <<< " =: " <<< expr
(<<<) file EE = file <<< "** E **"
(<<<) file (NoBind _) = file <<< "** NB **"
(<<<) file (DynamicExpr {dyn_expr,dyn_uni_vars,dyn_type_code}) = writeVarPtrs (file <<< "dynamic " <<< dyn_expr <<< " :: ") dyn_uni_vars <<< dyn_type_code
(<<<) file (DynamicExpr {dyn_expr,dyn_uni_vars,dyn_type_code}) = writeVarPtrs (file <<< "dynamic " <<< dyn_expr <<< " :: dyn_uni_vars") dyn_uni_vars <<< "dyn_type_code=" <<< dyn_type_code
// (<<<) file (TypeCase type_case) = file <<< type_case
(<<<) file (TypeCodeExpression type_code) = file <<< type_code
(<<<) file (Constant symb _ _ _) = file <<< "** Constant **" <<< symb
......@@ -1405,11 +1405,15 @@ where
(<<<) file TCE_Empty
= file
(<<<) file (TCE_Var info_ptr)
= file <<< "VAR " <<< ptrToInt info_ptr
= file <<< "TCE_Var " <<< ptrToInt info_ptr
// MV ..
(<<<) file (TCE_TypeTerm info_ptr)
= file <<< "TCE_TypeTerm " <<< ptrToInt info_ptr
// .. MV
(<<<) file (TCE_Constructor index exprs)
= file <<< "CONS " <<< index <<< ' ' <<< exprs
= file <<< "TCE_Constructor " <<< index <<< ' ' <<< exprs
(<<<) file (TCE_Selector selectors info_ptr)
= file <<< "CONS " <<< selectors <<< "VAR " <<< ptrToInt info_ptr
= file <<< "TCE_Selector " <<< selectors <<< "VAR " <<< ptrToInt info_ptr
instance <<< Selection
where
......@@ -1534,8 +1538,8 @@ instance <<< DynamicType
where
(<<<) file {dt_uni_vars,dt_type}
| isEmpty dt_uni_vars
= file <<< dt_type
= file <<< "A." <<< dt_uni_vars <<< ":" <<< dt_type
= file <<< "DynamicType" <<< dt_type
= file <<< "DynamicType" <<< "A." <<< dt_uni_vars <<< ":" <<< dt_type
instance <<< SignClassification
......
......@@ -1168,7 +1168,6 @@ InitFunEnv :: !Int -> *{! FunctionType}
InitFunEnv nr_of_fun_defs
= createArray nr_of_fun_defs EmptyFunctionType
//CreateInitialSymbolTypes :: ![Int] !u:{# FunDef} !{# CommonDefs } !*TypeState -> (!u:{# FunDef}, !*TypeState)
CreateInitialSymbolTypes start_index common_defs [] defs_and_state
= defs_and_state
CreateInitialSymbolTypes start_index common_defs [fun : funs] (fun_defs, pre_def_symbols, req_cons_variables, ts)
......@@ -1254,7 +1253,7 @@ where
tc_member_symb = { symb_name = pds_ident, symb_kind = SK_OverloadedFunction {glob_module = pds_module, glob_object = pds_def }, symb_arity = 0}
(new_var_ptr, var_heap) = newPtr VI_Empty var_heap
context = {tc_class = tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr}
(expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
(expr_ptr, expr_heap) = newPtr EI_Empty expr_heap //---> ("^EI_Dynamic No=" +++ toString var_store)
-> (inc var_store, type_heaps, var_heap,
expr_heap <:= (dyn_ptr, EI_TempDynamicType No tdt_type [context] expr_ptr tc_member_symb), predef_symbols)
EI_DynamicTypeWithVars loc_type_vars dt=:{dt_type,dt_global_vars} loc_dynamics
......@@ -1520,7 +1519,7 @@ where
# (subst, ts_type_heaps, ts_error)
= unify_requirements_of_functions fun_reqs ti (createArray nr_of_type_variables TE) ts.ts_type_heaps ts.ts_error
| not ts_error.ea_ok
| not ts_error.ea_ok //---> (("begin\n" ---> subst.[2]) ---> "\nend")
= (True, fun_defs, predef_symbols, special_instances, create_erroneous_function_types comp
{ ts & ts_type_heaps = ts_type_heaps, ts_error = { ts_error & ea_ok = True }, ts_var_store = 0, ts_attr_store = FirstAttrVar})
# {ts_attr_store,ts_var_heap,ts_var_store,ts_expr_heap,ts_td_infos} = ts
......@@ -1558,8 +1557,8 @@ where
# ts_type_heaps = ts.ts_type_heaps
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances,
tci_type_var_heap = ts_type_heaps.th_vars }
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error)
= updateDynamics comp local_pattern_variables fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error, os_predef_symbols)
= updateDynamics comp local_pattern_variables fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols
= ( type_error || not ts_error.ea_ok,
fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances },
{ ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True },
......@@ -1567,9 +1566,9 @@ where
# ts_type_heaps = ts.ts_type_heaps
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances,
tci_type_var_heap = ts_type_heaps.th_vars }
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error)
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error, os_predef_symbols)
= removeOverloadedFunctions comp local_pattern_variables fun_defs ts.ts_fun_env
ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error
ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols
= ( type_error || not ts_error.ea_ok,
fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances },
{ ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True },
......@@ -1628,18 +1627,19 @@ where
collect_and_expand_overloaded_calls [] calls subst_and_heap
= (calls, subst_and_heap)
collect_and_expand_overloaded_calls [{ fe_context=Yes context, fe_requirements={req_overloaded_calls}, fe_location, fe_index}:reqs] calls (subst, expr_heap)
# (context, subst) = arraySubst context subst
# (context, subst) = arraySubst context subst
= collect_and_expand_overloaded_calls reqs [(Yes context, req_overloaded_calls, fe_location, fe_index) : calls]
(foldSt expand_type_contexts req_overloaded_calls (subst, expr_heap))
collect_and_expand_overloaded_calls [{fe_context, fe_requirements={req_overloaded_calls}, fe_location, fe_index}:reqs] calls (subst, expr_heap)
= collect_and_expand_overloaded_calls reqs [(fe_context, req_overloaded_calls, fe_location, fe_index) : calls]
(foldSt expand_type_contexts req_overloaded_calls (subst, expr_heap))
(foldSt expand_type_contexts req_overloaded_calls (subst, expr_heap))
expand_type_contexts over_info_ptr (subst, expr_heap)
# (EI_Overloaded info, expr_heap) = readPtr over_info_ptr expr_heap
(oc_context, subst) = arraySubst info.oc_context subst
= (subst, expr_heap <:= (over_info_ptr, EI_Overloaded { info & oc_context = oc_context }))
= (subst, expr_heap <:= (over_info_ptr, EI_Overloaded { info & oc_context = oc_context })) ---> oc_context
expand_types_of_cases_and_lets [] heap_and_subst
= heap_and_subst
......@@ -1787,20 +1787,20 @@ where
instance <<< AttrCoercion
where
(<<<) file {ac_demanded,ac_offered} = file <<< ac_demanded <<< '~' <<< ac_offered
(<<<) file {ac_demanded,ac_offered} = file <<< "AttrCoercion: " <<< ac_demanded <<< '~' <<< ac_offered
instance <<< TypeCoercion
where
(<<<) file {tc_demanded,tc_offered} = file <<< tc_demanded <<< '~' <<< tc_offered
(<<<) file {tc_demanded,tc_offered} = file <<< "TypeCoercion: " <<< tc_demanded <<< '~' <<< tc_offered
instance <<< TypeContext
where
(<<<) file co = file <<< co.tc_class <<< " <" <<< ptrToInt co.tc_var <<< '>' <<< " " <<< co.tc_types
(<<<) file co = file <<< "TypeContext: (tc_class)=" <<< co.tc_class <<< " (tc_var)=" <<< ptrToInt co.tc_var <<< " (tc_types)=" <<< " " <<< co.tc_types
instance <<< DefinedSymbol
where
(<<<) file {ds_ident}
= file <<< ds_ident
= file <<< "DefinedSymbol: " <<< ds_ident
instance <<< FunctionType
where
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment