-> (!Expression, ![FreeVar], !*ExpressionState, !*ExpressionInfo, !*CheckState)

check_generic_expr

free_vars entry=:{ste_kind=STE_Generic,ste_index} id kind

= 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

= 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}

= (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id "undefined generic" cs_error })

#! e_state = { e_state & es_expr_heap = es_expr_heap }

#! cs = { cs & cs_x.x_needed_modules = cs_x.x_needed_modules bitor cNeedStdGeneric }

= (App app, free_vars, e_state, e_info, cs)

// ..AA

checkExpression free_vars expr e_input e_state e_info cs

= abort "checkExpression (checkFunctionBodies.icl, line 868)" // <<- expr

EmptyDefinedSymbol :== MakeDefinedSymbol {id_name="",id_info=nilPtr} NoIndex 0

EmptyGenericType :== {

gt_type_args = [],

gt_iso = EmptyDefinedSymbol,

gt_isomap_group = NoIndex,

gs_error = error}

#! (generic_types, gs) = collectGenericTypes gs

#! (instance_types, gs) = convertInstances gs

#! (td_indexes, gs) = collectGenericTypeDefs (generic_types ++ instance_types) gs

#! (iso_funs, iso_groups, gs) = buildIsoFunctions td_indexes gs

#! (isomap_type_funs, isomap_type_groups, gs) = buildIsomapsForTypeDefs td_indexes gs

#! (isomap_gen_funs, isomap_gen_groups, gs) = buildIsomapsForGenerics gs

#! (instance_funs, instance_groups, gs) = buildInstances gs

#! (star_funs, star_groups, gs) = buildKindConstInstances gs

// the order in the lists below is important!

// Indexes are allocated in that order.

//---> ("created isomaps", length isomap_funs, length isomap_groups)

#! gs = addFunsAndGroups new_funs new_groups gs

#! gs = determineMemberTypes 0 0 gs

//| True

// = abort "-----------------\n"

# {gen_type={st_args, st_result}} = generic_defs . [generic_index]

# (types, gs_modules) = collect_in_modules module_index (inc generic_index) gs_modules

= ([at_type \\ {at_type} <- [st_result:st_args]] ++ types, gs_modules)

// find all types whose generic representation is needed

collectGenericTypeDefs :: ![Type] !*GenericState

| toBool gtd_info // already marked

= ([], {gs & gs_gtd_infos = gs_gtd_infos})

#! gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = GTDI_Generic EmptyGenericType}

#! (type_def, gs_modules) = getTypeDef glob_module glob_object gs_modules

#! (td_info, gs_td_infos) = gs_td_infos ! [glob_module, glob_object]

# gs = {gs & gs_td_infos = gs_td_infos, gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules}

= (merge_td_indexes [(type_index, td_info.tdi_group_nr)] td_indexes, gs)

collect_in_type (arg --> res) gs

#! (td_indexes1, gs) = collect_in_type arg.at_type gs

collect_in_type _ gs

= ([], gs)

-> (![(Global Index, Int)], !*GenericState)

= collect_in_conses mod cons_def_symbols gs

= collect_in_conses mod [rt_constructor] gs

= collect_in_type at_type gs

collect_in_type_def_rhs mod _ gs

collect_in_conses :: !Index ![DefinedSymbol] !*GenericState

-> (![(Global Index, Int)], !*GenericState)

= ([], gs)

collect_in_conses mod [{ds_index, ds_ident} : cons_def_symbols] gs=:{gs_modules}

#! ({cons_type={st_args}}, gs_modules) = getConsDef mod ds_index gs_modules

#! types = [ at_type \\ {at_type} <- st_args]

#! (td_indexes1, gs) = collect_in_types types {gs & gs_modules=gs_modules}

#! (td_indexes2, gs) = collect_in_conses mod cons_def_symbols gs

# (funs, gs) = build_isomap_functions td_indexes gs

# (last_group, gs) = gs ! gs_last_group

# groups = createArray (last_group - first_group) []

# groups = collect_groups first_group funs groups

# groups = [ {group_members = fs} \\ fs <-: groups ]

= (funs, groups, gs)

# funs = [ from_fun_def, to_fun_def, rec_fun_def ]

= (funs, gs)

collect_groups :: !Index ![FunDef] !*{[Index]} -> !*{[Index]}

collect_groups first_group_index [] groups = groups

# (type_def_info, gs_td_infos) = gs_td_infos ! [module_index, type_def_index]

# gs_gtd_infos = update_group group_index type_def_info.tdi_group gs_gtd_infos

= (group_index, { gs & gs_gtd_infos = gs_gtd_infos, gs_td_infos = gs_td_infos})

update_group :: !Index ![Global Index] !*GenericTypeDefInfos -> !*GenericTypeDefInfos

update_group group_index [] gtd_infos = gtd_infos

ds_arity = member_def.me_type.st_arity

}

# instance_def = { instance_def & ins_members = {fun_def_sym} }

# instance_defs = {instance_defs & [instance_index] = instance_def}

= ([], [], [], { gs & gs_td_infos = gs_td_infos, gs_modules = gs_modules, gs_heaps = gs_heaps})

# (generic_def, gs_modules) = getGenericDef ins_generic.glob_module ins_generic.glob_object gs_modules

| not ok

= abort "no class for kind *"

# (class_def, gs_modules) = getClassDef ins_generic.glob_module class_def_sym.ds_index gs_modules

ins_generate = False,

ins_generic = ins_generic

}

= ([fun_def], [{group_members = [fun_index]}], [new_instance_def], gs)

# type_var_names = ["a" +++ toString i \\ i <- [1 .. (length kinds) - 1]]

# (type_vars, heaps) = mapSt buildTypeVar type_var_names heaps

# type_var_types = map TV type_vars

# (TA type_symb_ident=:{type_arity} type_args) = hd it_types

# new_type = TA {type_symb_ident & type_arity = type_arity + length new_type_args} (type_args ++ new_type_args)

it_context = it_context ++ new_contexts

}

= (new_ins_type, heaps)

build_type_var name heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}

# (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars

gs_fun_defs = gs_fun_defs,

gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap}

}

= determineMemberTypes module_index (inc ins_index) gs

#! (generic_def=:{gen_name=gen_name=:{id_name}, gen_type, gen_pos, gen_classes}, com_generic_defs) = com_generic_defs![ds_index]

// check if the class is already created

| found

= ( {glob_module = glob_module, glob_object = class_symbol},

{gs & gs_modules = gs_modules})

#! com_class_defs = append_array com_class_defs class_def

#! com_member_defs = append_array com_member_defs member_def

#! com_generic_defs = {(copy_array com_generic_defs) & [ds_index] = generic_def}

#! common_defs = {common_defs &

com_class_defs = com_class_defs,

gs_heaps = { gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap}

}

= (glob_class, gs)

where

copy_array array = {x \\ x <-: array}

// create an instance of a polykinded (generic) type of a given kind

// each generic variable is substituted by generic application

#! (gen_type, type_heaps) = generate_member_type gen_type gen_args kind class_vars type_heaps

#! (fresh_st_args, type_heaps) = substitute gen_type.st_args type_heaps

#! (fresh_st_result, type_heaps) = substitute gen_type.st_result type_heaps

st_vars = gen_type.st_vars ++ fresh_st_vars,

st_args = fresh_st_args,

st_result = fresh_st_result

}

where

generate_member_type :: !SymbolType ![TypeVar] !TypeKind ![TypeVar] !*TypeHeaps -> (!SymbolType, !*TypeHeaps)

generate_member_type

//---> ("subst var for kind *", type_var, type_cons_var)

subst_generic_var type_var type_cons_var kind=:(KindArrow kinds) type_heaps=:{th_vars}

# (new_vars, th_vars) = fresh_type_vars ((length kinds) - 1) type_var th_vars

# th_vars = th_vars <:= (type_var.tv_info_ptr, TVI_Type type)

= (new_vars, {type_heaps & th_vars = th_vars})

//---> ("subst var for kind " +++ toString kind, type_var, type)

generate gen_type gen_args [kind:kinds] [type_vars:type_varss] type_heaps

# (symbol_type, type_heaps) = generate_member_type gen_type gen_args kind type_vars type_heaps

//---> ("generate arg for kind " +++ toString kind, type_vars)

# (types, type_heaps) = generate gen_type gen_args kinds type_varss type_heaps

= ([type:types], type_heaps)

generate gen_type gen_args kinds type_varss type_heaps

= abort "inconsistent kind and type var lists"

buildGenericRepType :: !TypeRhs !PredefinedSymbols !CommonDefs

-> AType

# (cons_var_expr, _, gs_heaps) = buildBoundVarExpr cons_arg_var gs_heaps

= (sel_expr @ [cons_var_expr], {gs & gs_heaps = gs_heaps})

build_type :: !IsoDirection !Int !Int !*GenericState

-> (!SymbolType, !*GenericState)

build_type

tsp_coercible = False

}

}

# (arg_type, res_type) = case iso_dir of

IsoTo -> (type1, type2)

IsoFrom -> (type2, type1)

build_arg_type predefs arg_no heaps

# (type_var1, heaps) = buildTypeVar ("a"+++toString arg_no) heaps

# (type_var2, heaps) = buildTypeVar ("b"+++toString arg_no) heaps

# iso_type = buildATypeISO type1 type2 predefs

= (iso_type, type_var1, type_var2, heaps)

buildIsomapForGeneric def_sym group_index {gen_type, gen_arity, gen_args} gs=:{gs_heaps}

#! arg_names = [ "iso" +++ toString n \\ n <- [1 .. gen_arity]]

#! (arg_vars, gs_heaps) = buildFreeVars arg_names gs_heaps

#! fun_def = makeFunction def_sym group_index arg_vars body_expr No [] []

= (fun_def, gs)

curry_symbol_type :: SymbolType -> AType

curry_symbol_type {st_args, st_result}

= type

// expression that does mapping of a type

}

#! (adaptor_expr, gs) = build_adaptor_expr gt gen_isomap gs

#! (instance_expr, gs) = build_instance_expr gt_type gt_type_args generated_arg_vars gen_glob_def_sym gs

#! body_expr = (adaptor_expr @ [instance_expr]) @ original_arg_exprs

getGenericMember :: !(Global Index) !TypeKind !{#CommonDefs} -> (Bool, Global Index)

getGenericMember {glob_module, glob_object} kind modules

# (generic_def, modules) = getGenericDef glob_module glob_object modules

| not ok = (False, undef)

# (class_def, modules) = getClassDef glob_module def_sym.ds_index modules

# {ds_index} = class_def.class_members.[0]

= (True, {glob_module = glob_module, glob_object = ds_index})

//===================================

// Types

//===================================

buildPredefTypeApp :: !Int [AType] !PredefinedSymbols -> !AType

buildPredefTypeApp predef_index args predefs

# {pds_ident, pds_module, pds_def} = predefs.[predef_index]

# global_index = {glob_module = pds_module, glob_object = pds_def}

# type_symb = MakeTypeSymbIdent global_index pds_ident (length args)

buildATypeISO x y predefs = buildPredefTypeApp PD_TypeISO [x, y] predefs

buildATypeUNIT predefs = buildPredefTypeApp PD_TypeUNIT [] predefs

check_group group_index [] funs = funs

check_group group_index [fun_index:fun_indexes] funs

# (fun, funs) = funs ! [fun_index]

| fun.fun_info.fi_group_index == group_index

= check_group group_index fun_indexes funs

= abort ("inconsistent group " +++ toString group_index +++ ": " +++

= ([expr:exprs], [free_var:free_vars], heaps)

transpose [] = []

}

// AA ...

:: GenericDef =

, gen_args :: ![TypeVar]

, gen_type :: !SymbolType

, gen_pos :: !Position

}

// ... AA

:: InstanceType =

, gen_arity :: !Int // number of gen_args

, gen_type :: !SymbolType

, gen_pos :: !Position

}

// ..AA

:: InstanceType =