Commit 04fdbf74 authored by John van Groningen's avatar John van Groningen
Browse files

refactor, remove some unused functions and record, use =: instead of == to...

refactor, remove some unused functions and record, use =: instead of == to compare annotations and attributes in the parser
parent 88b7f0f0
......@@ -1504,7 +1504,7 @@ where
-> case opt_type of
Yes dyn_type
# (dyn_type, loc_type_vars, type_defs, class_defs, modules, type_heaps, cs)
= check_dynamic_type_in_pattern mod_index scope dyn_type type_defs class_defs modules type_heaps cs
= check_dynamic_type mod_index scope dyn_type type_defs class_defs modules type_heaps cs
| isEmpty loc_type_vars
# expr_heap = expr_heap <:= (dyn_info_ptr, EI_UnmarkedDynamic (Yes dyn_type) loc_dynamics)
-> check_local_dynamics mod_index scope loc_dynamics type_defs class_defs modules type_heaps expr_heap cs
......@@ -1516,7 +1516,7 @@ where
-> check_local_dynamics mod_index scope loc_dynamics type_defs class_defs modules type_heaps expr_heap cs
EI_DynamicType dyn_type loc_dynamics
# (dyn_type, loc_type_vars, type_defs, class_defs, modules, type_heaps, cs)
= check_dynamic_type_in_pattern mod_index scope dyn_type type_defs class_defs modules type_heaps cs
= check_dynamic_type mod_index scope dyn_type type_defs class_defs modules type_heaps cs
(type_defs, class_defs, modules, type_heaps, expr_heap, cs)
= check_local_dynamics mod_index scope loc_dynamics type_defs class_defs modules type_heaps expr_heap cs
cs_symbol_table = removeVariablesFromSymbolTable scope loc_type_vars cs.cs_symbol_table
......@@ -1526,21 +1526,7 @@ where
check_local_dynamics mod_index scope local_dynamics type_defs class_defs modules type_heaps expr_heap cs
= foldSt (check_dynamic mod_index (inc scope)) local_dynamics (type_defs, class_defs, modules, type_heaps, expr_heap, cs)
check_dynamic_type_in_expression mod_index scope dt=:{dt_uni_vars,dt_type,dt_contexts} type_defs class_defs modules type_heaps=:{th_vars} cs
# (dt_uni_vars, (th_vars, cs)) = add_type_variables_to_symbol_table scope dt_uni_vars th_vars cs
ots = { ots_type_defs = type_defs, ots_modules = modules }
oti = { oti_heaps = { type_heaps & th_vars = th_vars }, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] }
(contexts, type_defs, class_defs, modules, heaps, cs)
= checkTypeContexts dt_contexts mod_index class_defs ots {oti & oti_all_vars=[],oti_all_attrs=[],oti_global_vars=[]} cs
oti = {oti & oti_heaps=heaps}
ots = {ots_modules = modules, ots_type_defs = type_defs}
(dt_type, ({ots_type_defs, ots_modules}, oti, cs))
= checkOpenAType mod_index scope DAK_None dt_type (ots, oti, { cs & cs_x = {cs.cs_x & x_check_dynamic_types = True} })
= check_dynamic_type_uniqueness dt_type dt_uni_vars contexts oti ots_type_defs ots_modules class_defs cs
check_dynamic_type_in_pattern mod_index scope dt=:{dt_uni_vars,dt_type,dt_contexts} type_defs class_defs modules type_heaps=:{th_vars} cs
check_dynamic_type mod_index scope dt=:{dt_uni_vars,dt_type,dt_contexts} type_defs class_defs modules type_heaps=:{th_vars} cs
# (dt_uni_vars, (th_vars, cs)) = add_type_variables_to_symbol_table scope dt_uni_vars th_vars cs
ots = { ots_type_defs = type_defs, ots_modules = modules }
oti = { oti_heaps = { type_heaps & th_vars = th_vars }, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] }
......
......@@ -2507,7 +2507,7 @@ where
_
# (condefs, extensible_algebraic_type, pState) = want_constructor_list exi_vars token pState
# td & td_rhs = if extensible_algebraic_type (ExtensibleConses condefs) (ConsList condefs)
| annot == AN_None
| annot =: AN_None
-> (PD_Type td, pState)
-> (PD_Type td, parseError "Algebraic type" No ("No lhs strictness annotation for the algebraic type "+name) pState)
where
......@@ -2522,7 +2522,7 @@ where
pState = verify_annot_attr annot td_attribute name pState
(atype, pState) = want pState // Atype
td = {td & td_rhs = TypeSpec atype}
| annot == AN_None
| annot =: AN_None
= (PD_Type td, pState)
= (PD_Type td, parseError "Type synonym" No ("No lhs strictness annotation for the type synonym "+name) pState)
......@@ -2533,7 +2533,7 @@ where
(token, pState) = nextToken GeneralContext pState
(condef, pState) = want_newtype_constructor exi_vars token pState
td = { td & td_rhs = NewTypeCons condef }
| annot == AN_None
| annot =: AN_None
= (PD_Type td, pState)
= (PD_Type td, parseError "New type" No ("No lhs strictness annotation for the new type "+name) pState)
......@@ -2570,14 +2570,14 @@ where
module_name = file_name % (0,size file_name-4)
(type_ext_ident, pState) = stringToIdent name (IC_TypeExtension module_name) pState
td & td_rhs = MoreConses type_ext_ident condefs
| annot == AN_None
| annot =: AN_None
= (PD_Type td, pState)
= (PD_Type td, parseError "Algebraic type" No ("No lhs strictness annotation for the algebraic type "+name) pState)
want_type_rhs token parseContext td=:{td_attribute} annot pState
| isIclContext parseContext
= (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState)
| td_attribute == TA_Anonymous || td_attribute == TA_Unique || td_attribute == TA_None
| td_attribute =: TA_Anonymous || td_attribute =: TA_Unique || td_attribute =: TA_None
# (td_attribute, properties) = determine_properties annot td_attribute
# td = { td & td_attribute = td_attribute, td_rhs = EmptyRhs properties}
= (PD_Type td, tokenBack pState)
......@@ -2586,19 +2586,19 @@ where
verify_annot_attr :: !Annotation !TypeAttribute !String !ParseState -> ParseState
verify_annot_attr annot attr name pState
| annot <> AN_None
| not annot =: AN_None
= parseError "type definition" No ("No annotation, "+toString annot+", in the lhs of type "+name) pState
| attr == TA_None || attr == TA_Unique
| attr =: TA_None || attr =: TA_Unique
= pState
= parseError "type definition" No ("No attribute, "+toString attr+", in the lhs of type "+name) pState
determine_properties :: !Annotation !TypeAttribute -> (!TypeAttribute, !BITVECT)
determine_properties annot attr
| annot == AN_Strict
| attr == TA_Anonymous
| annot =: AN_Strict
| attr =: TA_Anonymous
= (TA_None, cIsHyperStrict)
= (attr, cIsHyperStrict bitor cIsNonCoercible)
| attr == TA_Anonymous
| attr =: TA_Anonymous
= (TA_None, cAllBitsClear)
= (attr, cIsNonCoercible)
......@@ -3661,7 +3661,7 @@ tryATypeToType atype pState
, atype.at_type
, parseError "simple type" No ("type instead of type annotation "+toString atype.at_annotation) pState
)
*/ | atype.at_attribute <> TA_None
*/ | not atype.at_attribute =: TA_None
= ( False
, atype.at_type
, parseError "simple type" No ("type instead of type attribute "+toString atype.at_attribute) pState
......
......@@ -35,11 +35,6 @@ import check_instances, genericsupport
, tc_coercible :: !Bool
}
:: SharedAttribute =
{ sa_attr_nr :: !Int
, sa_position :: !Expression
}
:: Requirements =
{ req_overloaded_calls :: ![ExprInfoPtr]
, req_type_coercions :: ![TypeCoercion]
......@@ -1000,7 +995,7 @@ fresh_overloaded_list_type [{ap_symbol}:patterns] pd_cons_symbol pd_nil_symbol d
make_cons_type_from_decons_type stdStrictLists_index decons_u_index common_defs ts
# {me_ident,me_type,me_type_ptr} = common_defs.[stdStrictLists_index].com_member_defs.[decons_u_index]
(fun_type_copy,ts) = determineSymbolTypeOfFunction pos me_ident 1 me_type me_type_ptr common_defs ts
{tst_args,tst_lifted,tst_result,tst_context,tst_attr_env}=fun_type_copy
{tst_args,tst_result,tst_context,tst_attr_env}=fun_type_copy
# result_type = case tst_args of [t] -> t
# argument_types = case tst_result.at_type of
TA _ args=:[arg1,arg2] -> args
......@@ -1033,7 +1028,7 @@ fresh_overloaded_maybe_type [{ap_symbol}:patterns] pd_just_symbol pd_none_symbol
make_just_type_from_from_just_type stdStrictMaybes_index from_just_index common_defs ts
# {me_ident,me_type,me_type_ptr} = common_defs.[stdStrictMaybes_index].com_member_defs.[from_just_index]
(fun_type_copy,ts) = determineSymbolTypeOfFunction pos me_ident 1 me_type me_type_ptr common_defs ts
{tst_args,tst_lifted,tst_result,tst_context,tst_attr_env}=fun_type_copy
{tst_args,tst_result,tst_context,tst_attr_env}=fun_type_copy
# result_type = case tst_args of [t] -> t
# argument_types = [tst_result]
= (argument_types,result_type,tst_context,tst_attr_env,ts)
......@@ -1636,7 +1631,7 @@ getSymbolType pos ti {symb_kind = SK_Constructor {glob_module,glob_object}} n_ap
getSymbolType pos ti {symb_kind = SK_NewTypeConstructor {gi_module,gi_index}} n_app_args ts
# (fresh_cons_type, ts) = standardRhsConstructorType pos gi_index gi_module n_app_args ti ts
= (fresh_cons_type, [], ts)
getSymbolType pos ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_LocalMacroFunction glob_object, symb_ident} n_app_args ts
getSymbolType pos ti=:{ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_LocalMacroFunction glob_object, symb_ident} n_app_args ts
| glob_object>=size ts.ts_fun_env
= abort symb_ident.id_name;
# (fun_type, ts) = ts!ts_fun_env.[glob_object]
......@@ -2442,7 +2437,6 @@ where
(th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (prop_type_heaps.th_vars, ts.ts_expr_heap)
(fresh_fun_type, ts) = freshSymbolType No cWithoutFreshContextVars ft_with_prop common_defs
{ts & ts_type_heaps={prop_type_heaps & th_vars=th_vars}, ts_expr_heap=ts_expr_heap, ts_td_infos=prop_td_infos, ts_error=ts_error}
// (lifted_args, ts) = fresh_non_unique_type_variables fun_lifted [] ts
(lifted_args, ts) = fresh_attributed_type_variables fun_lifted [] ts
(ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols)
......@@ -2477,14 +2471,7 @@ where
= (vars, ts)
# (var, ts) = freshAttributedVariable ts
= fresh_attributed_type_variables (dec n) [var : vars] ts
/*
fresh_non_unique_type_variables :: !Int ![AType] !*TypeState -> (![AType], !*TypeState)
fresh_non_unique_type_variables n vars ts
| n == 0
= (vars, ts)
# (var, ts) = freshNonUniqueVariable ts
= fresh_non_unique_type_variables (dec n) [var : vars] ts
*/
fresh_dynamics dyn_ptrs state
= foldSt fresh_dynamic dyn_ptrs state
where
......@@ -2601,11 +2588,9 @@ where
specification_error type type1 err
# err = errorHeading "Type error" err
format = { form_properties = cAttributed, form_attr_position = No}
# err = { err & ea_file = err.ea_file <<< "derived type conflicts with specified type:" <<< '\n' }
# format = { form_properties = cAttributed, form_attr_position = No}
# err = { err & ea_file = err.ea_file <<< " " <:: (format, type, Yes initialTypeVarBeautifulizer) <<< '\n' }
# format = { form_properties = cAttributed, form_attr_position = No}
# err = { err & ea_file = err.ea_file <<< " " <:: (format, type1, Yes initialTypeVarBeautifulizer) <<< '\n' }
= err
......@@ -2687,11 +2672,6 @@ where
# (printable_type, th_attrs) = beautifulizeAttributes clean_fun_type type_heaps.th_attrs
# (printable_type1, th_attrs) = beautifulizeAttributes fun_type th_attrs
= (fun_env, attr_var_env, { type_heaps & th_attrs = th_attrs }, expr_heap, specification_error printable_type printable_type1 error)
where
add_lifted_arg_types arity_diff args1 args2
| arity_diff > 0
= take arity_diff args2 ++ args1
= args1
check_caf_context fun_ident fun_pos FK_Caf {st_context=[_:_]} error
= checkErrorWithPosition fun_ident fun_pos "CAF cannot be overloaded" error
......
......@@ -303,10 +303,6 @@ errorHeadingWithPositionNameAndLine error_kind pos ident_name line_n err=:{ea_fi
= {err & ea_file = ea_file <<< ident_name <<< "]:", ea_ok = False}
= {err & ea_file = ea_file <<< line_n <<< ',' <<< ident_name <<< "]:", ea_ok = False}
contextError class_symb err
# err = errorHeading "Overloading error" err
= {err & ea_file = err.ea_file <<< " unresolved class \"" <<< class_symb <<< "\" not occurring in specified type\n"}
liftedContextError class_symb err
# err = errorHeading "Overloading error" err
= {err & ea_file = err.ea_file <<< " type variable of type of lifted argument appears in class \"" <<< class_symb <<< "\"\n"}
......
Markdown is supported
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