Commit c11d4387 authored by John van Groningen's avatar John van Groningen
Browse files

use strictness annotations in instance member types,

add instance member types in definition modules
parent db23a06d
This diff is collapsed.
......@@ -7,12 +7,14 @@ import syntax, checksupport
compareDefImp :: !Int !DclModule !(Optional {#Index}) !CopiedDefinitions !Int !*IclModule !*{#*{#FunDef}} !*Heaps !*ErrorAdmin
-> (!.IclModule,!.{#.{#FunDef}},!.Heaps,!.ErrorAdmin)
symbolTypesCorrespond :: !SymbolType !SymbolType !*TypeHeaps -> (!ComparisionErrorCode, !.TypeHeaps)
compare_specified_and_derived_instance_types :: !SymbolType !SymbolType !*TypeHeaps -> (!ComparisionErrorCode, !*TypeHeaps)
:: ComparisionErrorCode :== Int
// arg n not ok: n
CEC_ResultNotOK :== 0
CEC_Ok :== -1
CEC_ArgNrNotOk :== -2
CEC_ContextNotOK :== -3
CEC_AttrEnvNotOK :== -4
CEC_NrArgsNotOk :== -2
CEC_StrictnessOfArgsNotOk :== -3
CEC_ContextNotOK :== -4
CEC_AttrEnvNotOK :== -5
CEC_OkWithFirstMoreStrictness :== -6 // only for compare_specified_and_derived_instance_types
......@@ -36,7 +36,6 @@ where
= (icl_type_defs, icl_cons_defs, comp_st)
# comp_error = compareError type_def_error (newPosition icl_type_def.td_ident icl_type_def.td_pos) comp_st.comp_error
= (icl_type_defs, icl_cons_defs, { comp_st & comp_error = comp_error })
// ---> ("compare_type_defs", dcl_type_def.td_ident, dcl_type_def.td_rhs, icl_type_def.td_ident, icl_type_def.td_rhs)
= (icl_type_defs, icl_cons_defs, comp_st)
compare_rhs_of_types (AlgType dclConstructors) (AlgType iclConstructors) dcl_cons_defs icl_cons_defs comp_st
......@@ -120,7 +119,7 @@ where
| not copied_from_dcl.[class_index]
# dcl_class_def = dcl_class_defs.[class_index]
(icl_class_def, icl_class_defs) = icl_class_defs![class_index]
# (ok, icl_member_defs, comp_st) = compare_classes dcl_class_def dcl_member_defs icl_class_def icl_member_defs comp_st
(ok, icl_member_defs, comp_st) = compare_classes dcl_class_def dcl_member_defs icl_class_def icl_member_defs comp_st
| ok
= (icl_class_defs, icl_member_defs, comp_st)
# comp_error = compareError class_def_error (newPosition icl_class_def.class_ident icl_class_def.class_pos) comp_st.comp_error
......@@ -154,20 +153,69 @@ where
= (False, icl_member_defs, comp_st)
= (False, icl_member_defs, comp_st)
compareInstanceDefs :: !{# Int} !{# ClassInstance} !u:{# ClassInstance} !*CompareState -> (!u:{# ClassInstance}, !*CompareState)
compareInstanceDefs dcl_sizes dcl_instance_defs icl_instance_defs comp_st
compareInstanceDefs :: !{# Int} !{# ClassInstance} !u:{# ClassInstance} !*{#FunDef} !*CompareState
-> (!u:{# ClassInstance},!*{#FunDef},!*CompareState)
compareInstanceDefs dcl_sizes dcl_instance_defs icl_instance_defs icl_functions comp_st
# nr_of_dcl_instances = dcl_sizes.[cInstanceDefs]
= iFoldSt (compare_instance_defs dcl_instance_defs) 0 nr_of_dcl_instances (icl_instance_defs, comp_st)
= iFoldSt (compare_instance_defs dcl_instance_defs) 0 nr_of_dcl_instances (icl_instance_defs,icl_functions,comp_st)
where
compare_instance_defs :: !{# ClassInstance} !Index (!u:{# ClassInstance}, !*CompareState) -> (!u:{# ClassInstance}, !*CompareState)
compare_instance_defs dcl_instance_defs instance_index (icl_instance_defs, comp_st)
compare_instance_defs :: !{# ClassInstance} !Index !(!u:{# ClassInstance},!*{#FunDef},!*CompareState)
-> (!u:{# ClassInstance},!*{#FunDef},!*CompareState)
compare_instance_defs dcl_instance_defs instance_index (icl_instance_defs,icl_functions,comp_st)
# dcl_instance_def = dcl_instance_defs.[instance_index]
(icl_instance_def, icl_instance_defs) = icl_instance_defs![instance_index]
(ok, comp_st) = compare dcl_instance_def.ins_type icl_instance_def.ins_type comp_st
| ok
= (icl_instance_defs, comp_st)
# comp_error = compareError instance_def_error (newPosition icl_instance_def.ins_ident icl_instance_def.ins_pos) comp_st.comp_error
= (icl_instance_defs, { comp_st & comp_error = comp_error })
| not ok
# comp_st = instance_def_conflicts_error icl_instance_def.ins_ident icl_instance_def.ins_pos comp_st
= (icl_instance_defs,icl_functions, comp_st)
# (icl_functions,comp_st)
= member_types_equal dcl_instance_def.ins_member_types icl_instance_def.ins_members 0 icl_functions comp_st
= (icl_instance_defs,icl_functions,comp_st)
member_types_equal :: [FunType] {#ClassInstanceMember} Int *{#FunDef} *CompareState -> (!*{#FunDef},!*CompareState)
member_types_equal [] icl_instance_members icl_member_n icl_functions comp_st
| icl_member_n<size icl_instance_members
# function_index = icl_instance_members.[icl_member_n].cim_index
| icl_functions.[function_index].fun_info.fi_properties bitand FI_MemberInstanceRequiresTypeInDefMod<>0
# ({fun_ident,fun_pos},icl_functions) = icl_functions![function_index]
# comp_st = instance_def_conflicts_error fun_ident fun_pos comp_st
= member_types_equal [] icl_instance_members (icl_member_n+1) icl_functions comp_st
= member_types_equal [] icl_instance_members (icl_member_n+1) icl_functions comp_st
= (icl_functions,comp_st)
member_types_equal [instance_member_type:instance_member_types] icl_instance_members icl_member_n icl_functions comp_st
= member_type_and_types_equal instance_member_type instance_member_types icl_instance_members icl_member_n icl_functions comp_st
where
member_type_and_types_equal instance_member_type=:{ft_ident,ft_type,ft_pos} instance_member_types icl_instance_members icl_member_n icl_functions comp_st
| icl_member_n<size icl_instance_members
# {cim_ident,cim_index} = icl_instance_members.[icl_member_n]
| ft_ident.id_name<>cim_ident.id_name
| icl_functions.[cim_index].fun_info.fi_properties bitand FI_MemberInstanceRequiresTypeInDefMod<>0
# ({fun_ident,fun_pos},icl_functions) = icl_functions![cim_index]
# comp_st = instance_def_conflicts_error fun_ident fun_pos comp_st
= member_type_and_types_equal instance_member_type instance_member_types icl_instance_members (icl_member_n+1) icl_functions comp_st
= member_type_and_types_equal instance_member_type instance_member_types icl_instance_members (icl_member_n+1) icl_functions comp_st
# ({fun_type},icl_functions) = icl_functions![cim_index]
# (Yes icl_instance_member_type) = fun_type
# tc_state = { tc_type_vars = initial_hwn comp_st.comp_type_var_heap
, tc_attr_vars = initial_hwn comp_st.comp_attr_var_heap
, tc_strictness_flags = 0
}
# tc_state = init_symbol_type_vars ft_type icl_instance_member_type tc_state
# (corresponds, tc_state) = t_corresponds ft_type icl_instance_member_type tc_state
# comp_st = {comp_st & comp_type_var_heap=tc_state.tc_type_vars.hwn_heap,
comp_attr_var_heap=tc_state.tc_attr_vars.hwn_heap }
# comp_st = if (not corresponds)
(instance_def_conflicts_error ft_ident ft_pos comp_st)
comp_st
= member_types_equal instance_member_types icl_instance_members (icl_member_n+1) icl_functions comp_st
# comp_st = instance_def_conflicts_error ft_ident ft_pos comp_st
= member_types_equal instance_member_types icl_instance_members icl_member_n icl_functions comp_st
instance_def_conflicts_error ident pos comp_st
= {comp_st & comp_error = compareError instance_def_error (newPosition ident pos) comp_st.comp_error }
compareGenericDefs :: !{# Int} !{#Bool} !{# GenericDef} !u:{# GenericDef} !*CompareState -> (!u:{# GenericDef}, !*CompareState)
compareGenericDefs dcl_sizes copied_from_dcl dcl_generic_defs icl_generic_defs comp_st
......@@ -188,11 +236,9 @@ where
= (icl_generic_defs, { comp_st & comp_error = comp_error })
| otherwise
= (icl_generic_defs, comp_st)
class compare a :: !a !a !*CompareState -> (!Bool, !*CompareState)
instance compare (a,b) | compare a & compare b
where
compare (x1, y1) (x2, y2) comp_st
......@@ -376,13 +422,16 @@ initialyseAttributeVars [] [{av_info_ptr}:icl_type_vars] type_var_heap
= initialyseAttributeVars [] icl_type_vars (type_var_heap <:= (av_info_ptr, AVI_Empty));
initialyseAttributeVars [] [] type_var_heap
= type_var_heap
:: TypesCorrespondState =
{ tc_type_vars :: !.HeapWithNumber TypeVarInfo
, tc_attr_vars :: !.HeapWithNumber AttrVarInfo
, tc_ignore_strictness :: !Bool
, tc_strictness_flags :: !Int
}
AllowFirstMoreStrictness:==1;
FirstHasMoreStrictness:==2;
:: TypesCorrespondMonad
:== *TypesCorrespondState -> *(!Bool, !*TypesCorrespondState)
......@@ -414,9 +463,10 @@ initialyseAttributeVars [] [] type_var_heap
// arg n not ok: n
CEC_ResultNotOK :== 0
CEC_Ok :== -1
CEC_ArgNrNotOk :== -2
CEC_ContextNotOK :== -3
CEC_AttrEnvNotOK :== -4
CEC_NrArgsNotOk :== -2
CEC_StrictnessOfArgsNotOk :== -3
CEC_ContextNotOK :== -4
CEC_AttrEnvNotOK :== -5
class t_corresponds a :: !a !a -> *TypesCorrespondMonad
// whether two types correspond
......@@ -460,8 +510,8 @@ compareDefImp main_dcl_module_n main_dcl_module (Yes macro_conversion_table) {co
= compareClassDefs main_dcl_module.dcl_sizes copied_class_defs dcl_common.com_class_defs dcl_common.com_member_defs
icl_com_class_defs icl_com_member_defs comp_st
(icl_com_instance_defs, comp_st)
= compareInstanceDefs main_dcl_module.dcl_sizes dcl_common.com_instance_defs icl_com_instance_defs comp_st
(icl_com_instance_defs, icl_functions, comp_st)
= compareInstanceDefs main_dcl_module.dcl_sizes dcl_common.com_instance_defs icl_com_instance_defs icl_functions comp_st
(icl_com_generic_defs, comp_st)
= compareGenericDefs
......@@ -473,7 +523,7 @@ compareDefImp main_dcl_module_n main_dcl_module (Yes macro_conversion_table) {co
tc_state
= { tc_type_vars = initial_hwn th_vars
, tc_attr_vars = initial_hwn th_attrs
, tc_ignore_strictness = False
, tc_strictness_flags = 0
}
(icl_functions, macro_defs, hp_var_heap, hp_expression_heap, tc_state, error_admin)
= compareMacrosWithConversion main_dcl_module_n macro_conversion_table dcl_macros icl_functions macro_defs hp_var_heap hp_expression_heap tc_state error_admin
......@@ -494,9 +544,9 @@ compareDefImp main_dcl_module_n main_dcl_module (Yes macro_conversion_table) {co
compareFunctionTypes n_exported_global_functions dcl_fun_types icl_functions tc_state error_admin
= iFoldSt (compareTwoFunctionTypes dcl_fun_types) 0 n_exported_global_functions (icl_functions, tc_state, error_admin)
compareTwoFunctionTypes :: /*!{#Int}*/ !{#FunType} !Int !*(!u:{#FunDef},!*TypesCorrespondState,!*ErrorAdmin)
-> (!v:{#FunDef},!.TypesCorrespondState,!.ErrorAdmin) , [u <= v]
compareTwoFunctionTypes /*conversions*/ dcl_fun_types dclIndex (icl_functions, tc_state, error_admin)
compareTwoFunctionTypes :: !{#FunType} !Int !*(!u:{#FunDef},!*TypesCorrespondState,!*ErrorAdmin)
-> (!v:{#FunDef},!.TypesCorrespondState,!.ErrorAdmin) , [u <= v]
compareTwoFunctionTypes dcl_fun_types dclIndex (icl_functions, tc_state, error_admin)
# (fun_def=:{fun_type, fun_priority}, icl_functions) = icl_functions![dclIndex]
= case fun_type of
No -> generate_error "type of exported function is missing" fun_def icl_functions tc_state error_admin
......@@ -504,40 +554,43 @@ compareTwoFunctionTypes /*conversions*/ dcl_fun_types dclIndex (icl_functions, t
# {ft_type=dcl_symbol_type, ft_priority,ft_ident} = dcl_fun_types.[dclIndex]
# tc_state = init_symbol_type_vars dcl_symbol_type icl_symbol_type tc_state
(corresponds, tc_state)
= t_corresponds dcl_symbol_type icl_symbol_type tc_state // --->("comparing:", dcl_symbol_type ,icl_symbol_type)
= t_corresponds dcl_symbol_type icl_symbol_type tc_state
| corresponds && fun_priority==ft_priority
-> (icl_functions, tc_state, error_admin)
-> generate_error ErrorMessage fun_def icl_functions tc_state error_admin
symbolTypesCorrespond :: !SymbolType !SymbolType !*TypeHeaps -> (!ComparisionErrorCode, !.TypeHeaps)
symbolTypesCorrespond symbol_type_1 symbol_type_2 type_heaps=:{th_vars, th_attrs}
| length symbol_type_1.st_args<>length symbol_type_2.st_args
= (CEC_ArgNrNotOk, type_heaps)
# tc_state
= { tc_type_vars = initial_hwn th_vars
, tc_attr_vars = initial_hwn th_attrs
, tc_ignore_strictness = True
}
tc_state
= init_symbol_type_vars symbol_type_1 symbol_type_2 tc_state
compare_specified_and_derived_instance_types :: !SymbolType !SymbolType !*TypeHeaps -> (!ComparisionErrorCode, !*TypeHeaps)
compare_specified_and_derived_instance_types specified_instance_type derived_symbol_type type_heaps=:{th_vars, th_attrs}
| length specified_instance_type.st_args<>length derived_symbol_type.st_args
= (CEC_NrArgsNotOk, type_heaps)
# tc_state = { tc_type_vars = initial_hwn th_vars
, tc_attr_vars = initial_hwn th_attrs
, tc_strictness_flags = AllowFirstMoreStrictness
}
tc_state = init_symbol_type_vars specified_instance_type derived_symbol_type tc_state
(correspond_list, tc_state)
= map2St t_corresponds
[symbol_type_1.st_result:symbol_type_1.st_args]
[symbol_type_2.st_result:symbol_type_2.st_args]
[specified_instance_type.st_result:specified_instance_type.st_args]
[derived_symbol_type.st_result:derived_symbol_type.st_args]
tc_state
err_code
= firstIndex not correspond_list
err_code = firstIndex not correspond_list
| err_code<>CEC_Ok
= (err_code, tc_state_to_type_heaps tc_state)
# (arg_strictness_corresponds, tc_state)
= t_corresponds specified_instance_type.st_args_strictness derived_symbol_type.st_args_strictness tc_state
| not arg_strictness_corresponds
= (CEC_StrictnessOfArgsNotOk, tc_state_to_type_heaps tc_state)
# (context_corresponds, tc_state)
= t_corresponds symbol_type_1.st_context symbol_type_2.st_context tc_state
= t_corresponds specified_instance_type.st_context derived_symbol_type.st_context tc_state
| not context_corresponds
= (CEC_ContextNotOK, tc_state_to_type_heaps tc_state)
# (attr_env_corresponds, tc_state)
= t_corresponds symbol_type_1.st_attr_env symbol_type_2.st_attr_env tc_state
= t_corresponds specified_instance_type.st_attr_env derived_symbol_type.st_attr_env tc_state
| not attr_env_corresponds
= (CEC_AttrEnvNotOK, tc_state_to_type_heaps tc_state)
= (CEC_Ok, tc_state_to_type_heaps tc_state)
| tc_state.tc_strictness_flags bitand FirstHasMoreStrictness<>0
= (CEC_OkWithFirstMoreStrictness, tc_state_to_type_heaps tc_state)
= (CEC_Ok, tc_state_to_type_heaps tc_state)
where
tc_state_to_type_heaps {tc_type_vars, tc_attr_vars}
= { th_vars = tc_type_vars.hwn_heap, th_attrs = tc_attr_vars.hwn_heap}
......@@ -760,16 +813,36 @@ instance t_corresponds Annotation where
t_corresponds dcl_annotation icl_annotation
= t_corresponds` dcl_annotation icl_annotation
where
t_corresponds` dcl_annotation icl_annotation tc_state=:{tc_ignore_strictness}
= (tc_ignore_strictness || dcl_annotation==icl_annotation, tc_state)
t_corresponds` AN_Strict AN_Strict tc_state
= (True, tc_state)
t_corresponds` AN_Strict AN_None tc_state=:{tc_strictness_flags}
| tc_strictness_flags bitand AllowFirstMoreStrictness==0
= (False,tc_state)
| tc_strictness_flags bitand FirstHasMoreStrictness<>0
= (True,tc_state)
# tc_state = {tc_state & tc_strictness_flags = tc_strictness_flags bitor FirstHasMoreStrictness}
= (True,tc_state)
t_corresponds` AN_None AN_None tc_state
= (True, tc_state)
t_corresponds` AN_None AN_Strict tc_state
= (False, tc_state)
instance t_corresponds StrictnessList where
t_corresponds dcl_strictness icl_strictness
= t_corresponds` dcl_strictness icl_strictness
where
t_corresponds` dcl_strictness icl_strictness tc_state=:{tc_ignore_strictness}
= (tc_ignore_strictness || equal_strictness_lists dcl_strictness icl_strictness, tc_state)
t_corresponds` dcl_strictness icl_strictness tc_state=:{tc_strictness_flags}
| tc_strictness_flags bitand AllowFirstMoreStrictness==0
= (equal_strictness_lists dcl_strictness icl_strictness, tc_state)
| tc_strictness_flags bitand FirstHasMoreStrictness<>0
= (more_or_equal_strictness_lists dcl_strictness icl_strictness, tc_state)
| equal_strictness_lists dcl_strictness icl_strictness
= (True,tc_state)
| more_or_equal_strictness_lists dcl_strictness icl_strictness
# tc_state = {tc_state & tc_strictness_flags = tc_strictness_flags bitor FirstHasMoreStrictness}
= (True,tc_state)
= (False,tc_state)
instance t_corresponds AType where
t_corresponds dclDef iclDef
= t_corresponds dclDef.at_attribute iclDef.at_attribute
......@@ -804,25 +877,45 @@ instance t_corresponds AttributeVar where
= (unifiable, { tc_state & tc_attr_vars = tc_attr_vars })
instance t_corresponds Type where
t_corresponds (TA dclIdent dclArgs) icl_type=:(TA iclIdent iclArgs)
t_corresponds (TA dclIdent dclArgs) (TA iclIdent iclArgs)
= equal dclIdent.type_ident iclIdent.type_ident
&&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
&&& t_corresponds dclArgs iclArgs
t_corresponds (TA dclIdent dclArgs) icl_type=:(TAS iclIdent iclArgs iclStrictness)
t_corresponds (TA dclIdent dclArgs) (TAS iclIdent iclArgs iclStrictness)
= equal dclIdent.type_ident iclIdent.type_ident
&&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
&&& return (equal_strictness_lists NotStrict iclStrictness)
&&& return (is_not_strict iclStrictness)
&&& t_corresponds dclArgs iclArgs
t_corresponds (TAS dclIdent dclArgs dclStrictness) icl_type=:(TA iclIdent iclArgs)
t_corresponds (TAS dclIdent dclArgs dclStrictness) (TA iclIdent iclArgs)
= equal dclIdent.type_ident iclIdent.type_ident
&&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
&&& return (equal_strictness_lists dclStrictness NotStrict)
&&& compare_strictness dclStrictness
&&& t_corresponds dclArgs iclArgs
t_corresponds (TAS dclIdent dclArgs dclStrictness) icl_type=:(TAS iclIdent iclArgs iclStrictness)
where
compare_strictness dclStrictness tc_state=:{tc_strictness_flags}
| tc_strictness_flags bitand AllowFirstMoreStrictness==0
= (equal_strictness_lists dclStrictness NotStrict, tc_state)
| tc_strictness_flags bitand FirstHasMoreStrictness<>0 || equal_strictness_lists dclStrictness NotStrict
= (True, tc_state)
# tc_state = {tc_state & tc_strictness_flags = tc_strictness_flags bitor FirstHasMoreStrictness}
= (True, tc_state)
t_corresponds (TAS dclIdent dclArgs dclStrictness) (TAS iclIdent iclArgs iclStrictness)
= equal dclIdent.type_ident iclIdent.type_ident
&&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
&&& return (equal_strictness_lists dclStrictness iclStrictness)
&&& compare_strictness dclStrictness iclStrictness
&&& t_corresponds dclArgs iclArgs
where
compare_strictness dclStrictness iclStrictness tc_state=:{tc_strictness_flags}
| tc_strictness_flags bitand AllowFirstMoreStrictness==0
= (equal_strictness_lists dclStrictness iclStrictness, tc_state)
| tc_strictness_flags bitand FirstHasMoreStrictness<>0
= (more_or_equal_strictness_lists dclStrictness iclStrictness, tc_state)
| equal_strictness_lists dclStrictness iclStrictness
= (True, tc_state)
| more_or_equal_strictness_lists dclStrictness iclStrictness
# tc_state = {tc_state & tc_strictness_flags = tc_strictness_flags bitor FirstHasMoreStrictness}
= (True, tc_state)
= (False, tc_state)
t_corresponds (dclFun --> dclArg) (iclFun --> iclArg)
= t_corresponds dclFun iclFun
&&& t_corresponds dclArg iclArg
......@@ -941,19 +1034,6 @@ instance t_corresponds MemberDef where
&&& equal dclDef.me_priority iclDef.me_priority
&&& t_corresponds dclDef.me_type iclDef.me_type
instance t_corresponds ClassInstance where
t_corresponds dclDef iclDef
= t_corresponds` dclDef.ins_type iclDef.ins_type
where
t_corresponds` dclDef iclDef tc_state
# tc_state = init_attr_vars dclDef.it_attr_vars iclDef.it_attr_vars tc_state
tc_state = init_type_vars dclDef.it_vars iclDef.it_vars tc_state
(corresponds, tc_state)
= t_corresponds dclDef.it_types iclDef.it_types tc_state
| not corresponds
= (corresponds, tc_state)
= t_corresponds dclDef.it_context iclDef.it_context tc_state
instance t_corresponds DynamicType where
t_corresponds dclDef iclDef
= t_corresponds dclDef.dt_type iclDef.dt_type
......
......@@ -33,6 +33,7 @@ arg_strictness_annotation :: !Int !StrictnessList -> Annotation;
arg_is_strict :: !Int !StrictnessList -> Bool;
is_not_strict :: !StrictnessList -> Bool
equal_strictness_lists :: !StrictnessList !StrictnessList -> Bool
more_or_equal_strictness_lists :: !StrictnessList !StrictnessList -> Bool
add_next_strict :: !Int !Int !StrictnessList -> (!Int,!Int,!StrictnessList)
add_next_not_strict :: !Int !Int !StrictnessList -> (!Int,!Int,!StrictnessList)
append_strictness :: !Int !StrictnessList -> StrictnessList
......@@ -46,15 +47,15 @@ remove_first_n :: !Int !StrictnessList -> StrictnessList
:: IntKeyTree a = IKT_Leaf | IKT_Node !IntKey a !.(IntKeyTree a) !.(IntKeyTree a)
ikhEmpty :: .(IntKeyHashtable a)
ikhInsert :: !Bool !IntKey a !*(IntKeyHashtable a) -> (!Bool, !.IntKeyHashtable a)
ikhInsert :: !Bool !IntKey !a !*(IntKeyHashtable a) -> (!Bool, !.IntKeyHashtable a)
// input bool: overide old value, output bool: a new element was inserted
ikhInsert` :: !Bool !IntKey a !*(IntKeyHashtable a) -> .IntKeyHashtable a
ikhInsert` :: !Bool !IntKey !a !*(IntKeyHashtable a) -> .IntKeyHashtable a
// bool: overide old value
ikhSearch :: !IntKey !(IntKeyHashtable a) -> .Optional a
ikhSearch` :: !IntKey !(IntKeyHashtable a) -> a
ikhUSearch :: !IntKey !*(IntKeyHashtable a) -> (!.Optional a, !*IntKeyHashtable a)
iktUInsert :: !Bool !IntKey a !*(IntKeyTree a) -> (!Bool, !.IntKeyTree a)
iktUInsert :: !Bool !IntKey !a !*(IntKeyTree a) -> (!Bool, !.IntKeyTree a)
// input bool: overide old value, output bool: a new element was inserted
iktFlatten :: !(IntKeyTree a) -> [(IntKey, a)]
iktSearch :: !IntKey !(IntKeyTree a) -> .Optional a
......
......@@ -313,6 +313,22 @@ equal_strictness_lists (StrictList s1 l) (Strict s2)
equal_strictness_lists (StrictList s1 l1) (StrictList s2 l2)
= s1==s2 && equal_strictness_lists l1 l2
more_or_equal_strictness_lists :: !StrictnessList !StrictnessList -> Bool
more_or_equal_strictness_lists NotStrict s2
= is_not_strict s2
more_or_equal_strictness_lists (Strict s) NotStrict
= True
more_or_equal_strictness_lists (Strict s1) (Strict s2)
= (bitnot s1) bitand s2==0
more_or_equal_strictness_lists (Strict s1) (StrictList s2 l)
= (bitnot s1) bitand s2==0 && is_not_strict l
more_or_equal_strictness_lists (StrictList s l) NotStrict
= True
more_or_equal_strictness_lists (StrictList s1 l) (Strict s2)
= (bitnot s1) bitand s2==0
more_or_equal_strictness_lists (StrictList s1 l1) (StrictList s2 l2)
= (bitnot s1) bitand s2==0 && more_or_equal_strictness_lists l1 l2
add_next_strict :: !Int !Int !StrictnessList -> (!Int,!Int,!StrictnessList)
add_next_strict strictness_index strictness strictness_list
| strictness_index<32
......@@ -383,7 +399,7 @@ screw :== 80
ikhEmpty :: .(IntKeyHashtable a)
ikhEmpty = IntKeyHashtable 0 0 0 {}
ikhInsert :: !Bool !IntKey a !*(IntKeyHashtable a) -> (!Bool, !.IntKeyHashtable a)
ikhInsert :: !Bool !IntKey !a !*(IntKeyHashtable a) -> (!Bool, !.IntKeyHashtable a)
ikhInsert overide int_key value (IntKeyHashtable ikh_rehash_threshold ikh_nr_of_entries ikh_bitmask ikh_entries)
| ikh_rehash_threshold<=ikh_nr_of_entries
= ikhInsert overide int_key value (grow ikh_entries)
......@@ -391,7 +407,7 @@ ikhInsert overide int_key value (IntKeyHashtable ikh_rehash_threshold ikh_nr_of_
(tree, ikh_entries) = ikh_entries![hash_value]
(is_new, tree)
= iktUInsert overide int_key value tree
ikh_entries = { ikh_entries & [hash_value] = tree }
ikh_entries = {ikh_entries & [hash_value] = tree}
| is_new
= (is_new, (IntKeyHashtable ikh_rehash_threshold (ikh_nr_of_entries+1) ikh_bitmask ikh_entries))
= (is_new, (IntKeyHashtable ikh_rehash_threshold ikh_nr_of_entries ikh_bitmask ikh_entries))
......@@ -421,7 +437,7 @@ grow old_entries
= foldSt (\(key, value) ikh -> snd (ikhInsert False key value ikh)) list ikh
= (old_entries, ikh)
ikhInsert` :: !Bool !IntKey a !*(IntKeyHashtable a) -> .IntKeyHashtable a
ikhInsert` :: !Bool !IntKey !a !*(IntKeyHashtable a) -> .IntKeyHashtable a
ikhInsert` overide int_key value ikh
= snd (ikhInsert overide int_key value ikh)
......@@ -445,10 +461,10 @@ ikhUSearch int_key (IntKeyHashtable ikh_rehash_threshold ikh_nr_of_entries ikh_b
(ikt, ikh_entries) = ikh_entries![hash_value]
(opt_result, ikt)
= iktUSearch int_key ikt
ikh_entries = { ikh_entries & [hash_value] = ikt }
ikh_entries = {ikh_entries & [hash_value] = ikt}
= (opt_result, (IntKeyHashtable ikh_rehash_threshold ikh_nr_of_entries ikh_bitmask ikh_entries))
iktUInsert :: !Bool !IntKey a !*(IntKeyTree a) -> (!Bool, !.IntKeyTree a)
iktUInsert :: !Bool !IntKey !a !*(IntKeyTree a) -> (!Bool, !.IntKeyTree a)
iktUInsert overide int_key value IKT_Leaf
= (True, IKT_Node int_key value IKT_Leaf IKT_Leaf)
iktUInsert overide int_key value (IKT_Node key2 value2 left right)
......
......@@ -945,7 +945,7 @@ buildConversionTo
| not error.ea_ok
# (def_sym, funs_and_groups)
= (buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups)
= (def_sym, funs_and_groups, heaps, error)
= (def_sym, funs_and_groups, heaps, error)
# (def_sym, funs_and_groups)
= (buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups)
= (def_sym, funs_and_groups, heaps, error)
......@@ -1370,7 +1370,7 @@ where
, gs_varh = gs_varh
, gs_dcl_modules = gs_dcl_modules
, gs_symtab = gs_symtab }
= (common_defs, gs)
= (common_defs, gs)
// limitations:
// - context restrictions on generic variables are not allowed
......@@ -1420,7 +1420,7 @@ where
# glob_def_sym =
{ glob_module = pds_module
, glob_object = {ds_ident=pds_ident, ds_index=pds_def, ds_arity = 1}
}
}
# tc_class = TCGeneric
{ gtc_generic=glob_def_sym
, gtc_kind = kind
......@@ -1844,6 +1844,7 @@ where
, ins_class_ident = {ci_ident=Ident class_ident, ci_arity=1}
, ins_ident = class_ident
, ins_type = ins_type
, ins_member_types = []
, ins_members = {{cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}}
, ins_specials = SP_None
, ins_pos = gc_pos
......@@ -1923,6 +1924,7 @@ where
, ins_class_ident = {ci_ident=Ident class_ident, ci_arity=1}
, ins_ident = class_ident
, ins_type = ins_type
, ins_member_types = []
, ins_members = {class_instance_member}
, ins_specials = SP_None
, ins_pos = gc_pos
......
......@@ -22,6 +22,7 @@ set_hte_mark :: !Int !*HashTable -> *HashTable
| IC_Field !Ident
| IC_Selector
| IC_Instance ![Type]
| IC_InstanceMember ![Type]
| IC_Generic
| IC_GenericCase !Type
| IC_Unknown
......
......@@ -20,6 +20,7 @@ import predef, syntax, StdCompare, compare_constructor
| IC_Field !Ident
| IC_Selector
| IC_Instance ![Type]
| IC_InstanceMember ![Type]
| IC_Generic
| IC_GenericCase !Type
| IC_Unknown
......@@ -39,18 +40,8 @@ instance =< IdentClass
where
(=<) (IC_Instance types1) (IC_Instance types2)
= compare_types types1 types2
where
compare_types [t1 : t1s] [t2 : t2s]
# cmp = t1 =< t2
| cmp == Equal
= t1s =< t2s
= cmp
compare_types [] []
= Equal
compare_types [] _
= Smaller
compare_types _ []
= Greater
(=<) (IC_InstanceMember types1) (IC_InstanceMember types2)
= compare_types types1 types2
(=<) (IC_GenericCase type1) (IC_GenericCase type2)
= type1 =< type2
(=<) (IC_Field typ_id1) (IC_Field typ_id2)
......@@ -62,6 +53,18 @@ where
= Smaller
= Greater
compare_types [t1 : t1s] [t2 : t2s]
# cmp = t1 =< t2
| cmp == Equal
= t1s =< t2s
= cmp
compare_types [] []
= Equal
compare_types [] _
= Smaller
compare_types _ []
= Greater
instance =< (!a,!b) | =< a & =< b
where
(=<) (x1,y1) (x2,y2)
......
......@@ -475,7 +475,7 @@ where
try_function_symbol OpenToken pState
# (token, pState) = nextToken FunctionContext pState
= case token of
(IdentToken name)