Verified Commit 830ea083 authored by Camil Staps's avatar Camil Staps
Browse files

Allow generic instances of unboxed arrays of non-basic types

parent be79b171
......@@ -322,6 +322,14 @@ where
# cs = {cs & cs_error = checkError type_def.td_ident "type synonym not allowed" cs.cs_error}
= (TA type_cons [], TypeConsSymb type_cons, type_defs, modules, heaps, cs)
= (TA type_cons [], TypeConsSymb type_cons, type_defs, modules, heaps, cs)
check_instance_type module_index (TA type_cons=:{type_ident={id_name=PD_UnboxedArray_String,id_info}} [element_type]) type_defs modules heaps cs
# (entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
# cs & cs_symbol_table = cs_symbol_table
# (type_index, type_module) = retrieveGlobalDefinition entry STE_Type module_index
# type_cons & type_index = { glob_object = type_index, glob_module = type_module }
# (at_type, element_type_cons, type_defs, modules, heaps, cs) = check_instance_type module_index element_type.at_type type_defs modules heaps cs
# element_type & at_type = at_type
= (TA type_cons [element_type], TypeConsUnboxedArray element_type_cons, type_defs, modules, heaps, cs)
check_instance_type module_index (TB b) type_defs modules heaps cs
= (TB b, TypeConsBasic b, type_defs, modules,heaps, cs)
check_instance_type module_index TArrow type_defs modules heaps cs
......
......@@ -433,7 +433,6 @@ where
#! {pds_module, pds_def} = psd_predefs_a.[PD_UnboxedArrayType]
| type_index.glob_module == pds_module
&& type_index.glob_object == pds_def
&& (case args of [{at_type=TB _}] -> True; _ -> False)
-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
| otherwise
#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
......@@ -1731,6 +1730,8 @@ where
get_kind_of_type_cons :: !TypeCons !*TypeDefInfos -> (!TypeKind, !*TypeDefInfos)
get_kind_of_type_cons (TypeConsBasic _) td_infos
= (KindConst, td_infos)
get_kind_of_type_cons (TypeConsUnboxedArray _) td_infos
= (KindConst, td_infos)
get_kind_of_type_cons TypeConsArrow td_infos
= (KindArrow [KindConst,KindConst], td_infos)
get_kind_of_type_cons (TypeConsSymb {type_ident, type_index}) td_infos
......@@ -1780,6 +1781,8 @@ where
instance_vars_from_type_cons (TypeConsVar tv)
= [tv]
instance_vars_from_type_cons (TypeConsUnboxedArray element_type_cons)
= instance_vars_from_type_cons element_type_cons
instance_vars_from_type_cons _
= []
......
......@@ -104,6 +104,7 @@ genericIdentToFunIdent id_name type_cons
type_cons_to_string :: !TypeCons -> {#Char}
type_cons_to_string (TypeConsSymb {type_ident}) = toString type_ident
type_cons_to_string (TypeConsBasic bt) = toString bt
type_cons_to_string (TypeConsUnboxedArray tc) = "#ARRAY;" +++ type_cons_to_string tc
type_cons_to_string TypeConsArrow = "ARROW"
type_cons_to_string (TypeConsVar tv) = tv.tv_ident.id_name
type_cons_to_string (TypeConsQualifiedIdent _ type_name) = type_name
......
......@@ -45,9 +45,15 @@ where
(=<) (IC_InstanceMember types1) (IC_InstanceMember types2)
= compare_types types1 types2
(=<) (IC_GenericCase type1) (IC_GenericCase type2)
= type1 =< type2
# cmp = type1 =< type2
| cmp == Equal
= compare_unboxed_array_element_type type1 type2
= cmp
(=<) (IC_GenericDeriveClass type1) (IC_GenericDeriveClass type2)
= type1 =< type2
# cmp = type1 =< type2
| cmp == Equal
= compare_unboxed_array_element_type type1 type2
= cmp
(=<) (IC_Field typ_id1) (IC_Field typ_id2)
= typ_id1 =< typ_id2
(=<) (IC_TypeExtension module_name1) (IC_TypeExtension module_name2)
......@@ -71,6 +77,16 @@ compare_types [] _
compare_types _ []
= Greater
compare_unboxed_array_element_type (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type1}]) (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type2}])
= compare_unboxed_array_element_type` element_type1 element_type2
where
compare_unboxed_array_element_type` (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type1}]) (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=element_type2}])
= compare_unboxed_array_element_type` element_type1 element_type2
compare_unboxed_array_element_type` t1 t2
= t1 =< t2
compare_unboxed_array_element_type t1 t2
= Equal
instance =< (!a,!b) | =< a & =< b
where
(=<) (x1,y1) (x2,y2)
......
......@@ -574,27 +574,12 @@ where
# (ok, {at_type=type}, pState) = trySimpleType TA_None pState
# (ident, pState) = stringToIdent name (IC_GenericCase type) pState
# (generic_ident, pState) = stringToIdent name IC_Generic pState
# (type_cons, generic_fun_ident, pState) = get_type_cons type pState
# (type_cons, pState) = get_type_cons type pState
# (generic_fun_ident, pState) = make_generic_fun_ident type_cons pState
with
get_type_cons (TA type_symb []) pState
= make_generic_fun_ident (TypeConsSymb type_symb) pState
get_type_cons (TA type_symb _) pState
# pState = parseError "generic type, no constructor arguments allowed" No " |}" pState
= (abort_no_TypeCons, abort_no_TypeCons, pState)
get_type_cons (TB tb) pState
= make_generic_fun_ident (TypeConsBasic tb) pState
get_type_cons TArrow pState
= make_generic_fun_ident TypeConsArrow pState
get_type_cons (TV tv) pState
= make_generic_fun_ident (TypeConsVar tv) pState
get_type_cons _ pState
# pState = parseError "generic type" No " |}" pState
= (abort_no_TypeCons, abort_no_TypeCons, pState)
make_generic_fun_ident type_cons pState
# generic_fun_ident = genericIdentToFunIdent name type_cons
(generic_fun_ident,pState) = stringToIdent generic_fun_ident.id_name IC_Expression pState
= (type_cons, generic_fun_ident, pState)
= stringToIdent generic_fun_ident.id_name IC_Expression pState
# (token, pState) = nextToken GenericContext pState
# (geninfo_arg, gcf_generic_info, pState) = case token of
......@@ -660,8 +645,6 @@ where
}
= (True, PD_GenericCase generic_case generic_fun_ident, pState)
abort_no_TypeCons => abort "no TypeCons"
wantForeignExportDefinition pState
# (token, pState) = nextToken GeneralContext pState
# (file_name,line_nr,pState) = getFileAndLineNr pState
......@@ -2000,22 +1983,6 @@ where
gc_gcf = GCFC ident class_ident}
= (derive_def, pState)
get_type_cons :: Type !*ParseState -> (TypeCons, !*ParseState)
get_type_cons (TA type_symb []) pState
= (TypeConsSymb type_symb, pState)
get_type_cons (TB tb) pState
= (TypeConsBasic tb, pState)
get_type_cons TArrow pState
= (TypeConsArrow, pState)
get_type_cons (TV tv) pState
| isDclContext parseContext
= (TypeConsVar tv, pState)
get_type_cons (TQualifiedIdent module_id ident_name []) pState
= (TypeConsQualifiedIdent module_id ident_name, pState)
get_type_cons type pState
# pState = parseError "generic type" No " type constructor" pState
= (abort "no TypeCons", pState)
parse_info_fields "OBJECT" token pState
= parse_OBJECT_info_fields token 0 pState
parse_info_fields "CONS" token pState
......@@ -2125,6 +2092,24 @@ where
_
-> (GenericInstanceDependencies n_deps deps, token, pState)
get_type_cons :: !Type !*ParseState -> (TypeCons, !*ParseState)
get_type_cons (TA type_symb []) pState
= (TypeConsSymb type_symb, pState)
get_type_cons (TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type}]) pState
# (element_type_cons, pState) = get_type_cons at_type pState
= (TypeConsUnboxedArray element_type_cons, pState)
get_type_cons (TB tb) pState
= (TypeConsBasic tb, pState)
get_type_cons TArrow pState
= (TypeConsArrow, pState)
get_type_cons (TV tv) pState
= (TypeConsVar tv, pState)
get_type_cons (TQualifiedIdent module_id ident_name []) pState
= (TypeConsQualifiedIdent module_id ident_name, pState)
get_type_cons type pState
# pState = parseError "generic type" No "type constructor" pState
= (abort "no TypeCons", pState)
/*
Type definitions
*/
......
......@@ -459,6 +459,7 @@ instance == GenericDependency
:: TypeCons
= TypeConsSymb TypeSymbIdent
| TypeConsBasic BasicType
| TypeConsUnboxedArray TypeCons
| TypeConsArrow
| TypeConsVar TypeVar
| TypeConsQualifiedIdent !Ident !String
......
......@@ -2596,7 +2596,24 @@ where
= (error, IT_Node ins it_less it_greater)
| ins.glob_object==new_ins_index && ins.glob_module==new_ins_module
= (error, IT_Node ins it_less it_greater)
# cmp = check_unboxed_arrays ins_types it_types
| cmp == Smaller
# (error, it_less) = insert ins_types new_ins_index new_ins_module modules error it_less
= (error, IT_Node ins it_less it_greater)
| cmp == Greater
# (error, it_greater) = insert ins_types new_ins_index new_ins_module modules error it_greater
= (error, IT_Node ins it_less it_greater)
= (checkError ins_types " instance is overlapping" error, IT_Node ins it_less it_greater)
where
check_unboxed_arrays [TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=elem_type1}]] [TA {type_ident={id_name=PD_UnboxedArray_String}} [{at_type=elem_type2}]]
| elem_type1=:(TV _) || elem_type2=:(TV _)
= Equal
# cmp = elem_type1 =< elem_type2
| cmp <> Equal
= cmp
= check_unboxed_arrays [elem_type1] [elem_type2]
check_unboxed_arrays _ _
= Equal
check_types_of_instances ins_pos common_defs class_module class_index types state
# {class_cons_vars} = common_defs.[class_module].com_class_defs.[class_index]
......
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