Commit 42a497e8 authored by Artem Alimarine's avatar Artem Alimarine
Browse files

added support for constructors (for toString like usage),

fromString is not yet supported
some error handling improved
parial instances are temporary disabled
parent b6ff9814
......@@ -23,15 +23,21 @@ checkGenerics
| gen_index == size generic_defs
= (generic_defs, class_defs, type_defs, modules, type_heaps, cs)
// otherwise
# (gen_def=:{gen_name, gen_type, gen_pos}, generic_defs) = generic_defs![gen_index]
# (generic_def=:{gen_name, gen_type, gen_pos}, generic_defs) = generic_defs![gen_index]
# position = newPosition gen_name gen_pos
# cs_error = setErrorAdmin position cs_error
//---> ("checkGenerics generic type 1", gen_type.gt_type)
// add * for kind-star instances and *->* for arrays
# kinds =
[ KindConst
, KindArrow [KindConst, KindConst]
]
# (kinds_ptr, th_vars) = newPtr (TVI_Kinds kinds) th_vars
# cs = {cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }
# type_heaps = {type_heaps & th_vars = th_vars}
//# (gt_type, _, type_defs, class_defs, modules, type_heaps, cs) =
// checkSymbolType module_index gen_type.gt_type SP_None type_defs class_defs modules type_heaps cs
# (gt_type, type_defs, class_defs, modules, type_heaps, cs) =
checkMemberType module_index gen_type.gt_type type_defs class_defs modules type_heaps cs
......@@ -40,7 +46,13 @@ checkGenerics
#! cs = {cs & cs_error = cs_error}
#! gt_type = {gt_type & st_vars = st_vars}
# generic_defs = {generic_defs & [gen_index] . gen_type = { gen_type & gt_vars = gt_vars, gt_type = gt_type }}
# generic_def =
{ generic_def &
gen_type = { gen_type & gt_vars = gt_vars, gt_type = gt_type }
, gen_kinds_ptr = kinds_ptr
}
# generic_defs = {generic_defs & [gen_index] = generic_def}
//---> ("checkGenerics generic type 2", gt_type)
= checkGenerics (inc gen_index) module_index generic_defs class_defs type_defs modules type_heaps cs
where
......@@ -2537,6 +2549,7 @@ where
# (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_PredefinedModule]
| pre_mod.pds_def == mod_index
= (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols}
<=< adjust_predef_symbol PD_StringType mod_index STE_Type
<=< adjust_predef_symbols PD_ListType PD_UnboxedArrayType mod_index STE_Type
<=< adjust_predef_symbols PD_ConsSymbol PD_Arity32TupleSymbol mod_index STE_Constructor
<=< adjust_predef_symbol PD_TypeCodeClass mod_index STE_Class
......@@ -2581,7 +2594,12 @@ where
<=< adjust_predef_symbol PD_TypeARROW mod_index STE_Type
<=< adjust_predef_symbol PD_ConsARROW mod_index STE_Constructor
<=< adjust_predef_symbol PD_isomap_ARROW_ mod_index STE_DclFunction
<=< adjust_predef_symbol PD_isomap_ID mod_index STE_DclFunction)
<=< adjust_predef_symbol PD_isomap_ID mod_index STE_DclFunction
<=< adjust_predef_symbol PD_TypeCONSInfo mod_index STE_Type
<=< adjust_predef_symbol PD_ConsCONSInfo mod_index STE_Constructor
<=< adjust_predef_symbol PD_TypeCONS mod_index STE_Type
<=< adjust_predef_symbol PD_ConsCONS mod_index STE_Constructor
<=< adjust_predef_symbol PD_cons_info mod_index STE_DclFunction)
# (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}
......
......@@ -871,22 +871,28 @@ checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_stat
-> (!Expression, ![FreeVar], !*ExpressionState, !*ExpressionInfo, !*CheckState)
check_generic_expr
free_vars entry=:{ste_kind=STE_Generic,ste_index} id kind
e_input=:{ei_mod_index} e_state
e_input=:{ei_mod_index} e_state
e_info=:{ef_generic_defs} cs
//#! e_info = {e_info & ef_generic_defs = add_kind ef_generic_defs ste_index kind}
#! (ef_generic_defs, e_state) = add_kind ste_index kind ef_generic_defs e_state
#! e_info = { e_info & ef_generic_defs = ef_generic_defs }
= check_it free_vars ei_mod_index ste_index id kind e_input e_state e_info cs
check_generic_expr
free_vars entry=:{ste_kind=STE_Imported STE_Generic mod_index, ste_index} id kind
e_input e_state
e_info=:{ef_modules} cs
//#! (dcl_module, ef_modules) = ef_modules ! [mod_index]
//#! (dcl_common, dcl_module) = dcl_module ! dcl_common
//#! (com_generic_defs, dcl_common) = dcl_common ! com_generic_defs
//#! dcl_common = {dcl_common & com_generic_defs = add_kind com_generic_defs ste_index kind}
//#! dcl_module = {dcl_module & dcl_common = dcl_common}
//#! ef_modules = {ef_modules & [mod_index] = dcl_module}
//#! e_info = { e_info & ef_modules = ef_modules }
#! (dcl_module, ef_modules) = ef_modules ! [mod_index]
#! (dcl_common, dcl_module) = dcl_module ! dcl_common
#! (com_generic_defs, dcl_common) = dcl_common ! com_generic_defs
#! (com_generic_defs, e_state) = add_kind ste_index kind com_generic_defs e_state
#! dcl_common = {dcl_common & com_generic_defs = com_generic_defs}
#! dcl_module = {dcl_module & dcl_common = dcl_common}
#! ef_modules = {ef_modules & [mod_index] = dcl_module}
#! e_info = { e_info & ef_modules = ef_modules }
= check_it free_vars mod_index ste_index id kind e_input e_state e_info cs
check_generic_expr free_vars entry=:{ste_kind=STE_Empty} id kind e_input e_state e_info cs=:{cs_error}
......@@ -903,11 +909,15 @@ checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_stat
#! cs = { cs & cs_x.x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric }
= (App app, free_vars, e_state, e_info, cs)
add_kind :: !*{#GenericDef} !Index !TypeKind -> !*{#GenericDef}
add_kind generic_defs generic_index kind
# (generic_def, generic_defs) = generic_defs ! [generic_index]
= {generic_defs & [generic_index] = addGenericKind generic_def kind}
add_kind :: !Index !TypeKind !u:{#GenericDef} !*ExpressionState
-> (!u:{#GenericDef}, !*ExpressionState)
add_kind generic_index kind generic_defs e_state=:{es_type_heaps=es_type_heaps=:{th_vars}}
#! (generic_def=:{gen_kinds_ptr}, generic_defs) = generic_defs ! [generic_index]
#! (TVI_Kinds kinds, th_vars) = readPtr gen_kinds_ptr th_vars
#! kinds = eqMerge [kind] kinds
#! th_vars = writePtr gen_kinds_ptr (TVI_Kinds kinds) th_vars
#! e_state = { e_state & es_type_heaps = {es_type_heaps & th_vars = th_vars}}
= (generic_defs, e_state)
// ..AA
checkExpression free_vars expr e_input e_state e_info cs
= abort "checkExpression (checkFunctionBodies.icl, line 868)" // <<- expr
......@@ -947,6 +957,15 @@ where
#! (var_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
= (Var {var_name = id, var_info_ptr = info_ptr, var_expr_ptr = var_expr_ptr}, free_vars,
{e_state & es_expr_heap = es_expr_heap}, e_info, cs)
// AA..
check_id_expression {ste_kind = STE_Generic} is_expr_list free_vars id e_input e_state e_info cs=:{cs_error}
= (EE, free_vars, e_state, e_info,
{ cs & cs_error = checkError id "generic: missing kind argument" cs_error})
check_id_expression {ste_kind = STE_Imported STE_Generic _} is_expr_list free_vars id e_input e_state e_info cs=:{cs_error}
= (EE, free_vars, e_state, e_info,
{ cs & cs_error = checkError id "generic: missing kind argument" cs_error})
// ..AA
check_id_expression entry is_expr_list free_vars id=:{id_info} e_input e_state e_info cs
# (symb_kind, arity, priority, is_a_function, e_state, e_info, cs) = determine_info_of_symbol entry id_info e_input e_state e_info cs
symbol = { symb_name = id, symb_kind = symb_kind, symb_arity = 0 }
......
......@@ -1247,7 +1247,7 @@ where
-> (!*{#ClassDef}, !w:{#DclModule}, !v:[SymbolPtr], !u:Indexes, !*TypeVarHeap, !*VarHeap, !*CheckState)
create_class_dictionary mod_index class_index class_defs =:{[class_index] = class_def } modules rev_dictionary_list
indexes type_var_heap var_heap cs=:{cs_symbol_table,cs_error}
# {class_name,class_args,class_arity,class_members,class_context,class_dictionary=ds=:{ds_ident={id_info}}} = class_def
# {class_name,class_args,class_arity,class_members,class_context,class_dictionary=ds=:{ds_ident={id_name,id_info}}} = class_def
| isNilPtr id_info
# (type_id_info, cs_symbol_table) = newPtr EmptySymbolTableEntry cs_symbol_table
nr_of_members = size class_members
......@@ -1315,7 +1315,7 @@ where
ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })
<:= (cons_id_info, { ste_kind = STE_DictCons cons_def, ste_index = index_cons,
ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })})
# ({ste_kind}, cs_symbol_table) = readPtr id_info cs_symbol_table
| ste_kind == STE_Empty
= (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap,
......
......@@ -130,14 +130,19 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
# heaps = { heaps & hp_type_heaps = type_heaps }
#! (components, ti_common_defs, fun_defs, generic_range, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) =
case False of
case True of
True -> convertGenerics
components main_dcl_module_n ti_common_defs fun_defs td_infos
heaps hash_table predef_symbols dcl_mods error_admin
False -> (components, ti_common_defs, fun_defs, {ir_to=0,ir_from=0}, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin)
# icl_common = ti_common_defs.[main_dcl_module_n]
# error = error_admin.ea_file
#! ok = error_admin.ea_ok
| not ok
= (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
// ..AA
# (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error,out)
......
......@@ -9,6 +9,10 @@ import check
from transform import Group
import analtypes
supportConsInfo :== True
supportConsInfoByType :== True
supportPartialInstances :== False
:: *GenericState = {
gs_modules :: !*{#CommonDefs},
gs_fun_defs :: !*{# FunDef},
......@@ -31,25 +35,27 @@ import analtypes
:: GenericTypeDefInfos :== {# .{GenericTypeDefInfo}}
:: GenericTypeRep = {
gtr_type :: !AType, // generic type representation
gtr_type_args :: ![TypeVar], // same as in td_info
gtr_iso :: !DefinedSymbol, // isomorphim function index
gtr_isomap_group :: !Index, // isomap function group
gtr_isomap :: !DefinedSymbol, // isomap function for the type
gtr_isomap_from :: !DefinedSymbol, // from-part of isomap
gtr_isomap_to :: !DefinedSymbol // to-part
:: GenericTypeRep =
{ gtr_type :: !AType // generic type representation
, gtr_type_args :: ![TypeVar] // same as in td_info
, gtr_iso :: !DefinedSymbol // isomorphim function index
, gtr_isomap_group :: !Index // isomap function group
, gtr_isomap :: !DefinedSymbol // isomap function for the type
, gtr_isomap_from :: !DefinedSymbol // from-part of isomap
, gtr_isomap_to :: !DefinedSymbol // to-part
, gtr_cons_infos :: ![DefinedSymbol] // constructor informations
}
EmptyDefinedSymbol :== MakeDefinedSymbol {id_name="",id_info=nilPtr} NoIndex 0
EmptyGenericType :== {
gtr_type = makeAType TE TA_None,
gtr_type_args = [],
gtr_iso = EmptyDefinedSymbol,
gtr_isomap_group = NoIndex,
gtr_isomap = EmptyDefinedSymbol,
gtr_isomap_from = EmptyDefinedSymbol,
gtr_isomap_to = EmptyDefinedSymbol
EmptyGenericType :==
{ gtr_type = makeAType TE TA_None
, gtr_type_args = []
, gtr_iso = EmptyDefinedSymbol
, gtr_isomap_group = NoIndex
, gtr_isomap = EmptyDefinedSymbol
, gtr_isomap_from = EmptyDefinedSymbol
, gtr_isomap_to = EmptyDefinedSymbol
, gtr_cons_infos = []
}
:: IsoDirection = IsoTo | IsoFrom
......@@ -93,40 +99,84 @@ convertGenerics
gs_predefs = gs_predefs,
gs_error = error}
#! (generic_types, gs) = collectGenericTypes gs
//---> "*** collect generic types"
//#! {gs_error} = gs
//| not gs_error.ea_ok
// = abort "collecting generic types failed"
//#! gs = {gs & gs_error = gs_error}
#! gs = collectInstanceKinds gs
//---> "*** collect kinds used in generic instances and update generics with them"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! gs = buildClasses gs
//---> "*** build generic classes for all used kinds"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! (generic_types, gs) = collectGenericTypes gs
//---> "*** collect types of generics (needed for generic representation)"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! (instance_types, gs) = convertInstances gs
//---> "*** build classes and bind instances"
//---> "*** bind generic instances to classes and collect instance types"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! (td_indexes, gs) = collectGenericTypeDefs (generic_types ++ instance_types) gs
#! (td_indexes, gs) = collectGenericTypeDefs generic_types instance_types gs
//---> "*** collect type definitions for which a generic representation must be created"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! (iso_funs, iso_groups, gs) = buildIsoFunctions td_indexes gs
//---> "*** build isomorphisms for type definitions"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! (isomap_type_funs, isomap_type_groups, gs) = buildIsomapsForTypeDefs td_indexes gs
//---> "*** build maps for type definitions"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! (isomap_gen_funs, isomap_gen_groups, gs) = buildIsomapsForGenerics gs
//---> "*** build maps for generic function types"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! (instance_funs, instance_groups, gs) = buildInstances gs
//---> "*** build instances"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! (star_funs, star_groups, gs) = buildKindConstInstances gs
//---> "*** build shortcut instances for kind *"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
// the order in the lists below is important!
// Indexes are allocated in that order.
#! new_funs = iso_funs ++ isomap_type_funs ++ isomap_gen_funs ++ instance_funs ++ star_funs
#! new_groups = iso_groups ++ isomap_type_groups ++ isomap_gen_groups ++ instance_groups ++ star_groups
//---> ("created isomaps", length isomap_funs, length isomap_groups)
#! gs = addFunsAndGroups new_funs new_groups gs
//---> "*** add geenrated functions"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
#! gs = determineMemberTypes 0 0 gs
//---> "*** determine types of member instances"
#! (ok,gs) = gs!gs_error.ea_ok
| not ok
= return gs predefs hash_table dcl_modules
//| True
// = abort "-----------------\n"
......@@ -148,44 +198,59 @@ convertGenerics
}
}
# (common_defs, gs_modules) = gs_modules![main_dcl_module_n]
# class_defs = { x \\ x <-: common_defs.com_class_defs } // make unique copy
# {hp_type_heaps=hp_type_heaps=:{th_vars}, hp_var_heap} = gs_heaps
# (class_defs, dcl_modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, hp_var_heap, cs) =
createClassDictionaries
main_dcl_module_n
class_defs
dcl_modules
(size common_defs.com_type_defs)
(size common_defs.com_selector_defs)
(size common_defs.com_cons_defs)
th_vars hp_var_heap cs
# gs_heaps = {gs_heaps & hp_var_heap = hp_var_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}
#! (dcl_modules, gs_modules, gs_heaps, cs) =
create_class_dictionaries 0 dcl_modules gs_modules gs_heaps cs
// create_class_dictionaries1 main_dcl_module_n dcl_modules gs_modules gs_heaps cs
//---> "*** create class dictionaries"
# common_defs = { common_defs &
com_class_defs = class_defs,
com_type_defs = arrayPlusList common_defs.com_type_defs new_type_defs,
com_selector_defs = arrayPlusList common_defs.com_selector_defs new_selector_defs,
com_cons_defs = arrayPlusList common_defs.com_cons_defs new_cons_defs}
# gs_modules = { gs_modules & [main_dcl_module_n] = common_defs }
# {cs_symbol_table, cs_predef_symbols, cs_error} = cs
# hash_table = { hash_table & hte_symbol_heap = cs_symbol_table }
# index_range = {ir_from = gs.gs_first_fun, ir_to = gs.gs_last_fun}
#! index_range = {ir_from = gs.gs_first_fun, ir_to = gs.gs_last_fun}
= ( gs_groups, gs_modules, gs_fun_defs, index_range, gs_td_infos, gs_heaps, hash_table,
cs_predef_symbols, dcl_modules, cs_error)
where
return {gs_modules, gs_groups, gs_fun_defs, gs_td_infos, gs_gtd_infos, gs_heaps, gs_main_dcl_module_n, gs_error} predefs hash_table dcl_modules
= ( gs_groups, gs_modules, gs_fun_defs, {ir_from=0,ir_to=0},
gs_td_infos, gs_heaps, hash_table, predefs, dcl_modules, gs_error)
create_class_dictionaries module_index dcl_modules modules heaps cs
#! size_of_modules = size modules
| module_index == size_of_modules
= (dcl_modules, modules, heaps, cs)
#! (dcl_modules, modules, heaps, cs) =
create_class_dictionaries1 module_index dcl_modules modules heaps cs
= create_class_dictionaries (inc module_index) dcl_modules modules heaps cs
create_class_dictionaries1
module_index dcl_modules modules
heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}, hp_var_heap}
cs
#! (common_defs, modules) = modules![module_index]
#! class_defs = { x \\ x <-: common_defs.com_class_defs } // make unique copy
#! (class_defs, dcl_modules, new_type_defs, new_selector_defs, new_cons_defs, th_vars, hp_var_heap, cs) =
createClassDictionaries
module_index
class_defs
dcl_modules
(size common_defs.com_type_defs)
(size common_defs.com_selector_defs)
(size common_defs.com_cons_defs)
th_vars hp_var_heap cs
#! common_defs = { common_defs &
com_class_defs = class_defs,
com_type_defs = arrayPlusList common_defs.com_type_defs new_type_defs,
com_selector_defs = arrayPlusList common_defs.com_selector_defs new_selector_defs,
com_cons_defs = arrayPlusList common_defs.com_cons_defs new_cons_defs}
#! heaps = {heaps & hp_var_heap = hp_var_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}
#! modules = { modules & [module_index] = common_defs }
= (dcl_modules, modules, heaps, cs)
// for each generic instance
// - generate class and class member, if needed
// - rebind generic instance from generic to class
// - returns list of instance types for building generic representation
convertInstances :: !*GenericState
-> (![Type], !*GenericState)
-> (![Global Index], !*GenericState)
convertInstances gs
= convert_modules 0 gs
where
......@@ -215,30 +280,85 @@ where
= (new_types ++ types, instance_defs, gs)
convert_instance :: !Index !Index !*{#ClassInstance} !*GenericState
-> (![Type], !*{#ClassInstance}, !*GenericState)
convert_instance module_index instance_index instance_defs gs=:{gs_td_infos}
-> (![Global Index], !*{#ClassInstance}, !*GenericState)
convert_instance module_index instance_index instance_defs gs=:{gs_td_infos, gs_modules, gs_error}
#! (instance_def, instance_defs) = instance_defs ! [instance_index]
#! (instance_def=:{ins_class,ins_ident,ins_pos}, instance_defs) = instance_defs ! [instance_index]
| not instance_def.ins_is_generic
= ([], instance_defs, {gs & gs_td_infos = gs_td_infos})
= ([], instance_defs, {gs & gs_td_infos = gs_td_infos, gs_modules = gs_modules, gs_error = gs_error})
// determine the kind of the instance type
#! it_type = hd instance_def.ins_type.it_types
#! (kind, gs_td_infos) = kindOfType it_type gs_td_infos
#! gs = {gs & gs_td_infos = gs_td_infos}
// generate class and update the instance to point to the class
#! (_, gs) = buildClassDef instance_def.ins_class KindConst gs
#! (class_glob, gs) = buildClassDef instance_def.ins_class kind gs
#! ins_ident = instance_def.ins_ident
#! ins_ident = { ins_ident & id_name = ins_ident.id_name +++ ":" +++ (toString kind)}
#! instance_def = { instance_def & ins_class = class_glob, ins_ident = ins_ident }
#! (generic_def, gs_modules) = getGenericDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules
#! (ok, class_ds) = getGenericClassForKind generic_def kind
| not ok
= abort ("no class " +++ ins_ident.id_name +++ "for kind" +++ toString kind)
#! instance_def =
{ instance_def
& ins_class = {glob_module=ins_class.glob_module, glob_object=class_ds}
, ins_ident = makeIdent (ins_ident.id_name +++ ":" +++ (toString kind))
}
#! instance_defs = { instance_defs & [instance_index] = instance_def}
| instance_def.ins_generate
= ([it_type], instance_defs, gs)
= ([], instance_defs, gs)
#! (ok, gs_modules, gs_error) = check_instance instance_def gs_modules gs_error
| not ok
= ([], instance_defs, { gs & gs_td_infos = gs_td_infos, gs_modules = gs_modules, gs_error = gs_error })
# (maybe_td_index, gs_modules, gs_error) =
determine_type_def_index it_type instance_def gs_modules gs_error
= (maybe_td_index, instance_defs, { gs & gs_td_infos = gs_td_infos, gs_modules = gs_modules, gs_error = gs_error })
determine_type_def_index
(TA {type_index} _)
{ins_generate, ins_ident, ins_pos}
gs_modules gs_error
# ({td_rhs, td_index}, gs_modules) = getTypeDef type_index.glob_module type_index.glob_object gs_modules
= determine_td_index td_rhs gs_modules gs_error
where
determine_td_index (AlgType _) gs_modules gs_error
= (if ins_generate [type_index] [], gs_modules, gs_error)
determine_td_index (RecordType _) gs_modules gs_error
= (if ins_generate [type_index] [], gs_modules, gs_error)
determine_td_index (SynType _) gs_modules gs_error
# gs_error = checkErrorWithIdentPos
(newPosition ins_ident ins_pos)
"generic instance type cannot be a sysnonym type"
gs_error
= ([], gs_modules, gs_error)
determine_td_index (AbstractType _) gs_modules gs_error
| ins_generate
# gs_error = checkErrorWithIdentPos
(newPosition ins_ident ins_pos)
"cannot generate an instance for an abstract data type"
gs_error
= ([], gs_modules, gs_error)
= ([], gs_modules, gs_error)
determine_type_def_index (TB _) _ gs_modules gs_error
= ([], gs_modules, gs_error)
determine_type_def_index _ {ins_ident,ins_pos} gs_modules gs_error
# gs_error = checkErrorWithIdentPos
(newPosition ins_ident ins_pos)
"generic instance type must be a type constructor"
gs_error
= ([], gs_modules, gs_error)
check_instance
instance_def=:{ins_class={glob_module,glob_object}, ins_ident, ins_pos, ins_type, ins_generate}
gs_modules gs_error
| ins_generate
= (True, gs_modules, gs_error)
# (class_def=:{class_members}, gs_modules) =
getClassDef glob_module glob_object.ds_index gs_modules
# (member_def, gs_modules) =
getMemberDef glob_module class_def.class_members.[0].ds_index gs_modules
| member_def.me_type.st_arity <> instance_def.ins_members.[0].ds_arity
# gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "generic instance function has incorrect arity" gs_error
= (False, gs_modules, gs_error)
= (True, gs_modules, gs_error)
collectGenericTypes :: !*GenericState -> (![Type], !*GenericState)
collectGenericTypes gs=:{gs_modules}
......@@ -257,32 +377,131 @@ where
# (types, gs_modules) = collect_in_modules module_index (inc generic_index) gs_modules
= ([at_type \\ {at_type} <- [st_result:st_args]] ++ types, gs_modules)
/*
collectInstanceKinds :: !*GenericState -> !*GenericState
collectInstanceKinds gs
= collect_instance_kinds 0 0 gs
where
collect_instance_kinds module_index instance_index gs=:{gs_modules}
#! size_modules = size gs_modules
| module_index == size_modules
= gs
#! (common_defs, gs_modules) = gs_modules ! [module_index]
#! size_instance_defs = size common_defs.com_instance_defs
| instance_index == size_instance_defs
= collect_instance_kinds (inc module_index) 0 {gs & gs_modules = gs_modules}
#! gs = collect_instance module_index instance_index {gs & gs_modules = gs_modules}
= collect_instance_kinds module_index (inc instance_index) gs
collect_instance module_index instance_index gs=:{gs_heaps, gs_modules, gs_td_infos}
#! (instance_def=:{ins_class, ins_is_generic, ins_type}, gs_modules) =
getInstanceDef module_index instance_index gs_modules
| not instance_def.ins_is_generic
= {gs & gs_modules = gs_modules, gs_heaps = gs_heaps }
#! (generic_def, gs_modules) = getGenericDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules
#! (kind, gs_td_infos) = kindOfType (hd ins_type.it_types) gs_td_infos
#! gs_heaps = update_kind generic_def kind gs_heaps
= {gs & gs_modules = gs_modules, gs_heaps = gs_heaps, gs_td_infos = gs_td_infos}
update_kind {gen_kinds_ptr} kind gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
#! (TVI_Kinds kinds, th_vars) = readPtr gen_kinds_ptr th_vars
#! kinds = eqMerge [kind] kinds
#! th_vars = writePtr gen_kinds_ptr (TVI_Kinds kinds) th_vars
= {gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}
buildClasses :: !*GenericState -> !*GenericState
buildClasses gs=:{gs_modules}
# (types, gs_modules) = collect_in_modules 0 0 gs_modules
= (types, {gs & gs_modules = gs_modules})
buildClasses gs
= build_modules 0 gs