Skip to content
GitLab
Commit c36bdc7f authored by Artem Alimarine's avatar Artem Alimarine
Browse files

removed usage of fun_index 

fixed bugs in generics
reimplemented kind-indexed type specialization
parent bfb99888
Expand all Hide whitespace changes
Inline Side-by-side
coclmaindll/cocl.prj
View file @ c36bdc7f
This diff is collapsed.
frontend/StdCompare.dcl
View file @ c36bdc7f
......@@ -13,8 +13,9 @@ instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, (Global
instance =< Type, SymbIdent
instance == BasicType, TypeVar, AttributeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue,
FunKind, (Global a) | == a, Priority, Assoc, Type, ConsVariable, SignClassification
instance == BasicType, TypeVar, AttributeVar, AttrInequality, TypeSymbIdent, DefinedSymbol,
TypeContext , BasicValue, FunKind, (Global a) | == a, Priority, Assoc, Type,
ConsVariable, SignClassification
instance < MemberDef
......
frontend/StdCompare.icl
View file @ c36bdc7f
......@@ -11,6 +11,10 @@ where
instance == AttributeVar
where
(==) varid1 varid2 = varid1.av_info_ptr == varid2.av_info_ptr
instance == AttrInequality
where
(==) ai1 ai2 = ai1.ai_demanded == ai2.ai_demanded && ai1.ai_offered == ai2.ai_offered
//..AA
instance == FunKind
......@@ -60,7 +64,7 @@ where
instance == DefinedSymbol
where
(==) ds1 ds2
= ds1.ds_ident == ds2.ds_ident && ds1.ds_index == ds2.ds_index
= ds1.ds_index == ds2.ds_index //&& ds1.ds_ident == ds2.ds_ident
instance == Type
where
......
frontend/check.icl
View file @ c36bdc7f
......@@ -43,9 +43,11 @@ checkGenerics
#! {cs_error} = cs
#! (gt_vars, st_vars, cs_error) = split_vars gen_type.gt_vars gt_type.st_vars cs_error
/*
#! cs_error = case gt_type.st_context of
[] -> cs_error
_ -> checkError "" "class contexts are not supported in generic types" cs_error
*/
#! cs = {cs & cs_error = cs_error}
#! gt_type = {gt_type & st_vars = st_vars}
......@@ -2734,26 +2736,30 @@ where
= (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols}
<=< adjustPredefSymbol PD_TypeISO mod_index STE_Type
<=< adjustPredefSymbol PD_ConsISO mod_index STE_Constructor
<=< adjustPredefSymbol PD_iso_from mod_index (STE_Field pd_type_iso.pds_ident)
<=< adjustPredefSymbol PD_iso_from mod_index (STE_Field pd_type_iso.pds_ident)
<=< adjustPredefSymbol PD_iso_to mod_index (STE_Field pd_type_iso.pds_ident)
<=< adjustPredefSymbol PD_TypeUNIT mod_index STE_Type
<=< adjustPredefSymbol PD_ConsUNIT mod_index STE_Constructor
<=< adjustPredefSymbol PD_TypePAIR mod_index STE_Type
<=< adjustPredefSymbol PD_ConsPAIR mod_index STE_Constructor
<=< adjustPredefSymbol PD_TypeUNIT mod_index STE_Type
<=< adjustPredefSymbol PD_ConsUNIT mod_index STE_Constructor
<=< adjustPredefSymbol PD_TypePAIR mod_index STE_Type
<=< adjustPredefSymbol PD_ConsPAIR mod_index STE_Constructor
<=< adjustPredefSymbol PD_TypeEITHER mod_index STE_Type
<=< adjustPredefSymbol PD_ConsLEFT mod_index STE_Constructor
<=< adjustPredefSymbol PD_ConsRIGHT mod_index STE_Constructor
<=< adjustPredefSymbol PD_TypeARROW mod_index STE_Type
<=< adjustPredefSymbol PD_ConsARROW mod_index STE_Constructor
<=< adjustPredefSymbol PD_isomap_ARROW_ mod_index STE_DclFunction
<=< adjustPredefSymbol PD_isomap_ID mod_index STE_DclFunction
<=< adjustPredefSymbol PD_ConsLEFT mod_index STE_Constructor
<=< adjustPredefSymbol PD_ConsRIGHT mod_index STE_Constructor
<=< adjustPredefSymbol PD_TypeARROW mod_index STE_Type
<=< adjustPredefSymbol PD_ConsARROW mod_index STE_Constructor
<=< adjustPredefSymbol PD_isomap_ARROW_ mod_index STE_DclFunction
<=< adjustPredefSymbol PD_isomap_ID mod_index STE_DclFunction
<=< adjustPredefSymbol PD_TypeConsDefInfo mod_index STE_Type
<=< adjustPredefSymbol PD_ConsConsDefInfo mod_index STE_Constructor
<=< adjustPredefSymbol PD_TypeTypeDefInfo mod_index STE_Type
<=< adjustPredefSymbol PD_ConsTypeDefInfo mod_index STE_Constructor
<=< adjustPredefSymbol PD_TypeCONS mod_index STE_Type
<=< adjustPredefSymbol PD_ConsCONS mod_index STE_Constructor
<=< adjustPredefSymbol PD_cons_info mod_index STE_DclFunction)
<=< adjustPredefSymbol PD_TypeCONS mod_index STE_Type
<=< adjustPredefSymbol PD_ConsCONS mod_index STE_Constructor
<=< adjustPredefSymbol PD_cons_info mod_index STE_DclFunction
<=< adjustPredefSymbol PD_TypeType mod_index STE_Type
<=< adjustPredefSymbol PD_ConsTypeApp mod_index STE_Constructor
<=< adjustPredefSymbol PD_ConsTypeVar mod_index STE_Constructor
)
# (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdMisc]
| pre_mod.pds_def == mod_index
= (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols}
......
frontend/checkKindCorrectness.icl
View file @ c36bdc7f
......@@ -257,6 +257,7 @@ checkKindCorrectness main_dcl_module_n icl_instances fun_defs common_defs
# (th_vars, error_admin)
= unify_var_kinds expected_kind tv th_vars error_admin
= (th_vars, td_infos, error_admin)
check_type expected_kind arg_nr (l --> r) state
# state
= check_atype KindConst arg_nr l state
......
frontend/compilerSwitches.dcl
View file @ c36bdc7f
definition module compilerSwitches
SwitchGenerics on off :== off
SwitchGenerics on off :== on
PA_BUG on off :== off
......
frontend/compilerSwitches.icl
View file @ c36bdc7f
implementation module compilerSwitches
SwitchGenerics on off :== off
SwitchGenerics on off :== on
PA_BUG on off :== off
......
frontend/generics.icl
View file @ c36bdc7f
This diff is collapsed.
frontend/overloading.icl
View file @ c36bdc7f
......@@ -129,8 +129,7 @@ containsContext new_tc []
= False
containsContext new_tc [tc : tcs]
= new_tc == tc || containsContext new_tc tcs
FoundObject object :== object.glob_module <> NotFound
ObjectNotFound :== { glob_module = NotFound, glob_object = NotFound }
......@@ -268,6 +267,10 @@ where
= adjust_type_attribute defs type1 type2 (ok, coercion_env, type_heaps)
adjust_type_attribute defs (arg_type1 --> res_type1) (arg_type2 --> res_type2) state
= adjust_attributes_and_subtypes defs [arg_type1, res_type1] [arg_type2, res_type2] state
// AA..
adjust_type_attribute defs (TArrow1 x) (TArrow1 y) state
= adjust_attributes_and_subtypes defs [x] [y] state
// ..AA
adjust_type_attribute defs (_ :@: types1) (_ :@: types2) state
= adjust_attributes_and_subtypes defs types1 types2 state
adjust_type_attribute _ (TA type_cons1 cons_args1) type2 (ok, coercion_env, type_heaps)
......@@ -1698,6 +1701,12 @@ where
= equalTypeVars tv var_number type_var_heap
equalTypes (arg_type1 --> restype1) (arg_type2 --> restype2) type_var_heap
= equalTypes (arg_type1,restype1) (arg_type2,restype2) type_var_heap
// AA ..
equalTypes TArrow TArrow type_var_heap
= (True, type_var_heap)
equalTypes (TArrow1 x) (TArrow1 y) type_var_heap
= equalTypes x y type_var_heap
// .. AA
equalTypes (TA tc1 types1) (TA tc2 types2) type_var_heap
| tc1 == tc2
= equalTypes types1 types2 type_var_heap
......
frontend/predef.dcl
View file @ c36bdc7f
......@@ -148,7 +148,6 @@ PD_ModuleID :== 173
PD_ModuleConsSymbol :== 174
/* Generics */
PD_StdGeneric :== 175
PD_TypeISO :== 176
......@@ -177,7 +176,11 @@ PD_ConsCONS :== 195
PD_isomap_ARROW_ :== 196
PD_isomap_ID :== 197
PD_NrOfPredefSymbols :== 198
PD_TypeType :== 198
PD_ConsTypeApp :== 199
PD_ConsTypeVar :== 200
PD_NrOfPredefSymbols :== 201
GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2
GetTupleTypeIndex tup_arity :== PD_Arity2TupleType + tup_arity - 2
......
frontend/predef.icl
View file @ c36bdc7f
......@@ -95,7 +95,7 @@ PD_UnqArraySizeFun :== 137
/* Enum/Comprehension functions */
PD_SmallerFun :== 138
PD_LessOrEqualFun:== 139
PD_LessOrEqualFun :== 139
PD_IncFun :== 140
PD_SubFun:== 141
PD_From :== 142
......@@ -104,12 +104,12 @@ PD_FromTo :== 144
PD_FromThenTo :== 145
/* StdMisc */
PD_StdMisc :== 146
PD_abort :== 147
PD_undef :== 148
PD_Start :== 149
PD_DummyForStrictAliasFun :== 150
PD_StdStrictLists:==151
......@@ -148,7 +148,6 @@ PD_ModuleID :== 173
PD_ModuleConsSymbol :== 174
/* Generics */
PD_StdGeneric :== 175
PD_TypeISO :== 176
......@@ -177,7 +176,11 @@ PD_ConsCONS :== 195
PD_isomap_ARROW_ :== 196
PD_isomap_ID :== 197
PD_NrOfPredefSymbols :== 198
PD_TypeType :== 198
PD_ConsTypeApp :== 199
PD_ConsTypeVar :== 200
PD_NrOfPredefSymbols :== 201
(<<=) infixl
(<<=) state val
......@@ -346,7 +349,10 @@ where
<<- ("_TypeDefInfo", IC_Expression, PD_ConsTypeDefInfo)
<<- ("CONS", IC_Type, PD_TypeCONS)
<<- ("CONS", IC_Expression, PD_ConsCONS)
<<- ("_cons_info", IC_Expression, PD_cons_info)
<<- ("CONS_INFO", IC_Expression, PD_cons_info)
<<- ("Type", IC_Type, PD_TypeType)
<<- ("TypeApp", IC_Expression, PD_ConsTypeApp)
<<- ("TypeVar", IC_Expression, PD_ConsTypeVar)
<<- ("StdMisc", IC_Module, PD_StdMisc)
<<- ("abort", IC_Expression, PD_abort)
......
frontend/syntax.icl
View file @ c36bdc7f
......@@ -1281,18 +1281,18 @@ where
instance <<< TypeVar
where
(<<<) file varid = file <<< varid.tv_name
// (<<<) file varid = file <<< varid.tv_name <<< "<" <<< varid.tv_info_ptr <<< ">"
// (<<<) file varid = file <<< varid.tv_name
(<<<) file varid = file <<< varid.tv_name <<< "<" <<< varid.tv_info_ptr <<< ">"
instance <<< AttributeVar
where
// (<<<) file {av_name,av_info_ptr} = file <<< av_name <<< "[" <<< av_info_ptr <<< "]"
(<<<) file {av_name,av_info_ptr} = file <<< av_name
(<<<) file {av_name,av_info_ptr} = file <<< av_name <<< "[" <<< av_info_ptr <<< "]"
// (<<<) file {av_name,av_info_ptr} = file <<< av_name
instance toString AttributeVar
where
// toString {av_name,av_info_ptr} = toString av_name + "[" + toString (ptrToInt av_info_ptr) + "]"
toString {av_name,av_info_ptr} = toString av_name
toString {av_name,av_info_ptr} = toString av_name + "[" + toString (ptrToInt av_info_ptr) + "]"
// toString {av_name,av_info_ptr} = toString av_name
instance <<< AType
where
......
frontend/type.icl
View file @ c36bdc7f
......@@ -378,6 +378,8 @@ simplifyTypeApplication (TempQV tv_number) type_args
//AA..
simplifyTypeApplication TArrow [type1, type2]
= (True, type1 --> type2)
simplifyTypeApplication TArrow [type]
= (True, TArrow1 type)
simplifyTypeApplication (TArrow1 type1) [type2]
= (True, type1 --> type2)
//..AA
......@@ -417,7 +419,7 @@ unifyCVwithType is_exist tv_number type_args type=:(TA type_cons cons_args) modu
= (False, subst, heaps)
= (False, subst, heaps)
// AA..
// AA..
unifyCVwithType is_exist tv_number [type_arg1, type_arg2] type=:(atype1 --> atype2) modules subst heaps
# (succ, subst, heaps) = unify (type_arg1, type_arg2) (atype1, atype2) modules subst heaps
| succ
......@@ -428,7 +430,21 @@ unifyCVwithType is_exist tv_number [type_arg] type=:(atype1 --> atype2) modules
| succ
= unifyTypes (toTV is_exist tv_number) TA_Multi (TArrow1 atype1) TA_Multi modules subst heaps
= (False, subst, heaps)
unifyCVwithType is_exist tv_number [] type=:(atype1 --> atype2) modules subst heaps
= unifyTypes (toTV is_exist tv_number) TA_Multi type TA_Multi modules subst heaps
unifyCVwithType is_exist tv_number [type_arg] type=:(TArrow1 atype) modules subst heaps
# (succ, subst, heaps) = unify type_arg atype modules subst heaps
| succ
= unifyTypes (toTV is_exist tv_number) TA_Multi TArrow TA_Multi modules subst heaps
= (False, subst, heaps)
unifyCVwithType is_exist tv_number [] type=:(TArrow1 atype) modules subst heaps
= unifyTypes (toTV is_exist tv_number) TA_Multi type TA_Multi modules subst heaps
unifyCVwithType is_exist tv_number [] TArrow modules subst heaps
= unifyTypes (toTV is_exist tv_number) TA_Multi TArrow TA_Multi modules subst heaps
// ..AA
unifyCVwithType is_exist tv_number type_args type modules subst heaps
= (False, subst, heaps)
......
frontend/typesupport.icl
View file @ c36bdc7f
......@@ -894,6 +894,8 @@ where
= equiv (arg_type1,restype1) (arg_type2,restype2) heaps
equiv (TArrow1 arg_type1) (TArrow1 arg_type2) heaps
= equiv arg_type1 arg_type2 heaps
equiv TArrow TArrow heaps
= (True, heaps)
equiv (TA tc1 types1) (TA tc2 types2) heaps
| tc1 == tc2
= equiv types1 types2 heaps
......
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