diff options
| -rw-r--r-- | frontend/generics.dcl | 10 | ||||
| -rw-r--r-- | frontend/generics.icl | 4209 |
2 files changed, 0 insertions, 4219 deletions
diff --git a/frontend/generics.dcl b/frontend/generics.dcl deleted file mode 100644 index 95465a4..0000000 --- a/frontend/generics.dcl +++ /dev/null @@ -1,10 +0,0 @@ -definition module generics - -import checksupport -from transform import ::Group - -convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} /*!(Optional {#Index})*/ !*ErrorAdmin - -> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, /*!(Optional {#Index}),*/ !*ErrorAdmin) - -getGenericMember :: !(Global Index) !TypeKind !{#CommonDefs} -> (Bool, Global Index) -
\ No newline at end of file diff --git a/frontend/generics.icl b/frontend/generics.icl deleted file mode 100644 index ef67407..0000000 --- a/frontend/generics.icl +++ /dev/null @@ -1,4209 +0,0 @@ -implementation module generics - -import StdEnv -import _aconcat -import hashtable -import checksupport -import checktypes -import check -import analtypes - -from transform import ::Group - -// whether to generate CONS -// (needed for function that use CONS, like toString) -supportCons :== False - -// whether to bind _cons_info to actual constructor info -// (needed for functions that create CONS, like fromString) -supportConsInfo :== True && supportCons - -// whether generate missing alternatives -supportPartialInstances :== False - -:: *GenericState = - { gs_modules :: !*{#CommonDefs} - , gs_fun_defs :: !*{# FunDef} - , gs_groups :: !{!Group} - , gs_td_infos :: !*TypeDefInfos - , gs_gtd_infos :: !*GenericTypeDefInfos - , gs_heaps :: !*Heaps - , gs_main_dcl_module_n :: !Index - , gs_first_fun :: !Index - , gs_last_fun :: !Index - , gs_first_group :: !Index - , gs_last_group :: !Index - , gs_predefs :: !PredefinedSymbols - , gs_dcl_modules :: !*{#DclModule} - , gs_opt_dcl_icl_conversions :: !*(Optional !*{#Index}) - , gs_error :: !*ErrorAdmin - } - -:: GenericTypeDefInfo - = GTDI_Empty // no generic rep needed - | GTDI_Generic GenericTypeRep // generic representataion - -:: 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 - , gtr_type_info :: !DefinedSymbol // type def info - , 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 - , gtr_type_info = EmptyDefinedSymbol - , gtr_cons_infos = [] - } - -:: IsoDirection = IsoTo | IsoFrom - -instance toBool GenericTypeDefInfo where - toBool GTDI_Empty = False - toBool (GTDI_Generic _) = True - -convertGenerics :: !{!Group} !Int !{#CommonDefs} !*{# FunDef} !*TypeDefInfos !*Heaps !*HashTable !*PredefinedSymbols !u:{# DclModule} /*!(Optional {#Index})*/ !*ErrorAdmin - -> (!{!Group}, !{#CommonDefs}, !*{# FunDef}, !IndexRange, !*TypeDefInfos, !*Heaps, !*HashTable, !*PredefinedSymbols, !u:{# DclModule}, /*!(Optional {#Index}),*/ !*ErrorAdmin) -convertGenerics - groups main_dcl_module_n modules fun_defs td_infos heaps - hash_table predefs dcl_modules - //opt_dcl_icl_conversions - error - - #! (fun_defs_size, fun_defs) = usize fun_defs - #! groups_size = size groups - - #! (predef_size, predefs) = usize predefs - #! (gs_predefs, predefs) = arrayCopyBegin predefs predef_size - - // determine sized of type def_infos: - // ??? How to map 2-d unique array not so ugly ??? - #! (td_infos_sizes, td_infos) = get_sizes 0 td_infos - with - get_sizes :: Int !*TypeDefInfos -> ([Int], !*TypeDefInfos) - get_sizes n td_infos - #! td_infos_size = size td_infos - | n == td_infos_size = ([], td_infos) - #! row_size = size td_infos.[n] - # (row_sizes, td_infos) = get_sizes (n + 1) td_infos - = ([row_size : row_sizes], td_infos) - #! gtd_infos = { createArray s GTDI_Empty \\ s <- td_infos_sizes } - - #! gs = - { gs_modules = {m \\m <-: modules} // unique copy - , gs_groups = groups - , gs_fun_defs = fun_defs - , gs_td_infos = td_infos - , gs_gtd_infos = gtd_infos - , gs_heaps = heaps - , gs_main_dcl_module_n = main_dcl_module_n - , gs_first_fun = fun_defs_size - , gs_last_fun = fun_defs_size - , gs_first_group = groups_size - , gs_last_group = groups_size - , gs_predefs = gs_predefs - , gs_dcl_modules = { x \\ x <-: dcl_modules } // unique copy - , gs_opt_dcl_icl_conversions = No -/* - case opt_dcl_icl_conversions of - No -> No - Yes xs -> Yes {x \\ x <-: xs} // unique copy -*/ - , gs_error = error - } - - - #! gs = collectInstanceKinds gs - //---> "*** collect kinds used in generic instances and store them in the generics" - #! (ok,gs) = gs!gs_error.ea_ok - | not ok - = return gs predefs hash_table - - #! gs = buildClasses gs - //---> "*** build generic classes for all used kinds" - #! (ok,gs) = gs!gs_error.ea_ok - | not ok - = return gs predefs hash_table - - #! (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 - - #! (instance_types, gs) = convertInstances gs - //---> "*** bind generic instances to classes and collect instance types" - #! (ok,gs) = gs!gs_error.ea_ok - | not ok - = return gs predefs hash_table - - #! gs = checkConsInstances gs - //---> "*** check that cons instances are provided for all generics" - #! (ok,gs) = gs!gs_error.ea_ok - | not ok - = return gs predefs hash_table - - #! (cons_funs, cons_groups, gs) = buildConsInstances gs - | not ok - //---> "*** bind function for CONS" - = return gs predefs hash_table - - #! (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 - - #! (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 - - #! (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 - - #! (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 - - #! (instance_funs, instance_groups, gs) = buildInstances gs - //---> "*** build instances" - #! (ok,gs) = gs!gs_error.ea_ok - | not ok - = return gs predefs hash_table - - #! (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 - - // the order in the lists below is important! - // Indexes are allocated in that order. - #! new_funs = cons_funs ++ iso_funs ++ isomap_type_funs ++ isomap_gen_funs ++ instance_funs ++ star_funs - #! new_groups = cons_groups ++ iso_groups ++ isomap_type_groups ++ isomap_gen_groups ++ instance_groups ++ star_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 - - #! gs = determineMemberTypes 0 0 gs - //---> "*** determine types of member instances" - #! (ok,gs) = gs!gs_error.ea_ok - | not ok - = return gs predefs hash_table - - //| True = abort "-----------------\n" - - # { gs_modules, gs_groups, gs_fun_defs, gs_td_infos, gs_heaps, gs_dcl_modules, - gs_opt_dcl_icl_conversions, - gs_error} - = gs - - #! {hte_symbol_heap} = hash_table - #! cs = - { cs_symbol_table = hte_symbol_heap - , cs_predef_symbols = predefs - , cs_error = gs_error - , cs_x = - { x_needed_modules = 0 - , x_main_dcl_module_n = main_dcl_module_n -// , x_is_dcl_module = False -// , x_type_var_position = 0 - } - } - - #! (gs_dcl_modules, gs_modules, gs_heaps, cs_symbol_table) = - create_class_dictionaries 0 gs_dcl_modules gs_modules gs_heaps cs.cs_symbol_table -// create_class_dictionaries1 main_dcl_module_n dcl_modules gs_modules gs_heaps cs - //---> "*** create class dictionaries" - - # hash_table = { hash_table & hte_symbol_heap = cs_symbol_table } - - #! 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.cs_predef_symbols, gs_dcl_modules, /*gs_opt_dcl_icl_conversions,*/ cs.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_dcl_modules, gs_opt_dcl_icl_conversions, gs_error} - predefs hash_table - = ( gs_groups, gs_modules, gs_fun_defs, {ir_from=0,ir_to=0}, - gs_td_infos, gs_heaps, hash_table, predefs, gs_dcl_modules, - /*gs_opt_dcl_icl_conversions,*/ gs_error) - - create_class_dictionaries module_index dcl_modules modules heaps symbol_table - #! size_of_modules = size modules - | module_index == size_of_modules - = (dcl_modules, modules, heaps, symbol_table) - #! (dcl_modules, modules, heaps, symbol_table) = - create_class_dictionaries1 module_index dcl_modules modules heaps symbol_table - = create_class_dictionaries (inc module_index) dcl_modules modules heaps symbol_table - - create_class_dictionaries1 - module_index dcl_modules modules - heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}, hp_var_heap} - symbol_table - #! (common_defs, modules) = modules![module_index] - #! class_defs = { x \\ x <-: common_defs.com_class_defs } // make unique copy - # type_defs = { x \\ x <-: common_defs.com_type_defs } // make unique copy - # cons_defs = { x \\ x <-: common_defs.com_cons_defs } // make unique copy - # selector_defs = { x \\ x <-: common_defs.com_selector_defs } // make unique copy - # (size_type_defs,type_defs) = usize type_defs - #! (new_type_defs, new_selector_defs, new_cons_defs,_,type_defs,selector_defs,cons_defs,class_defs, dcl_modules, th_vars, hp_var_heap, symbol_table) = - createClassDictionaries - False //(abort "create_class_dictionaries1 True or False ?") - module_index - size_type_defs - (size common_defs.com_selector_defs) - (size common_defs.com_cons_defs) - type_defs selector_defs cons_defs class_defs dcl_modules th_vars hp_var_heap symbol_table - - #! common_defs = { common_defs & - com_class_defs = class_defs, - com_type_defs = arrayPlusList type_defs new_type_defs, - com_selector_defs = arrayPlusList selector_defs new_selector_defs, - com_cons_defs = arrayPlusList 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, symbol_table) - -convertInstances :: !*GenericState - -> (![Global Index], !*GenericState) -convertInstances gs - = convert_modules 0 gs -where - - convert_modules module_index gs=:{gs_modules} - #! num_modules = size gs_modules - | module_index == num_modules - = ([], gs) - #! (common_defs, gs_modules) = gs_modules ! [module_index] - #! instance_defs = {i \\ i <-: common_defs.com_instance_defs} // make unique copy - - #! (new_types, instance_defs, gs) = - convert_instances module_index 0 instance_defs {gs & gs_modules = gs_modules} - #! (types, gs) = convert_modules (inc module_index) gs - - #! {gs_modules} = gs - #! (common_defs, gs_modules) = gs_modules ! [module_index] - #! gs_modules = { gs_modules & [module_index] = {common_defs & com_instance_defs = instance_defs}} - = (new_types ++ types, {gs & gs_modules = gs_modules}) - - convert_instances module_index instance_index instance_defs gs - #! num_instance_defs = size instance_defs - | instance_index == num_instance_defs - = ([], instance_defs, gs) - #! (new_types, instance_defs, gs) = convert_instance module_index instance_index instance_defs gs - #! (types, instance_defs, gs) = convert_instances module_index (inc instance_index) instance_defs gs - = (new_types ++ types, instance_defs, gs) - - convert_instance :: !Index !Index !*{#ClassInstance} !*GenericState - -> (![Global Index], !*{#ClassInstance}, !*GenericState) - convert_instance - module_index instance_index instance_defs - gs=:{gs_td_infos, gs_modules, gs_error, gs_fun_defs, gs_predefs, gs_heaps} -// = abort "generics; convert_instance" - - #! (instance_def=:{ins_class,ins_ident}, instance_defs) = instance_defs ! [instance_index] - | not instance_def.ins_is_generic - # gs = { gs - & gs_td_infos = gs_td_infos - , gs_modules = gs_modules - , gs_fun_defs = gs_fun_defs - , gs_heaps = gs_heaps - , gs_error = gs_error } - = ([], instance_defs, gs) - - // 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 - - #! (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) - - // bind the instance to the class - #! instance_def = - { instance_def - & ins_class = {glob_module=ins_class.glob_module, glob_object=class_ds} - , ins_ident = makeIdent ins_ident.id_name - } - #! (is_partial, gs_fun_defs) = check_if_partial instance_def gs_predefs gs_fun_defs - - # (ok, gs_modules, gs_error) = check_instance_args instance_def gs_modules gs_error - | not ok - #! instance_defs = { instance_defs & [instance_index] = instance_def} - #! gs = { gs - & gs_td_infos = gs_td_infos - , gs_modules = gs_modules - , gs_fun_defs = gs_fun_defs - , gs_heaps = gs_heaps - , gs_error = gs_error - } - = ([], instance_defs, gs) - - # gs_heaps = check_cons_instance generic_def instance_def it_type gs_predefs gs_heaps - - # (maybe_td_index, instance_def, gs_modules, gs_error) = - determine_type_def_index it_type instance_def is_partial gs_modules gs_error - # gs = { gs - & gs_td_infos = gs_td_infos - , gs_modules = gs_modules - , gs_fun_defs = gs_fun_defs - , gs_heaps = gs_heaps - , gs_error = gs_error } - #! instance_defs = { instance_defs & [instance_index] = instance_def} - = (maybe_td_index, instance_defs, gs) - - determine_type_def_index - (TA {type_index, type_ident} _) - instance_def=:{ins_generate, ins_ident, ins_pos} - is_partial - 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 - | ins_generate - = ([type_index], instance_def, gs_modules, gs_error) - | supportPartialInstances && is_partial - = ([type_index], {instance_def & ins_partial = True}, gs_modules, gs_error) - //---> ("collected partial instance type", type_ident, type_index) - | otherwise - = ([], instance_def, gs_modules, gs_error) - determine_td_index (RecordType _) gs_modules gs_error - | ins_generate - = ([type_index], instance_def, gs_modules, gs_error) - | supportPartialInstances && is_partial - = ([type_index], {instance_def & ins_partial = True}, gs_modules, gs_error) - //---> ("collected partial instance type", type_ident, type_index) - | otherwise - = ([], instance_def, 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 synonym type" - gs_error - = ([], instance_def, 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 - = ([], instance_def, gs_modules, gs_error) - = ([], instance_def, gs_modules, gs_error) - determine_type_def_index TArrow instance_def=:{ins_generate,ins_ident,ins_pos} _ gs_modules gs_error - | ins_generate - # gs_error = checkErrorWithIdentPos - (newPosition ins_ident ins_pos) - "cannot generate an instance for arrow type" - gs_error - = ([], instance_def, gs_modules, gs_error) - = ([], instance_def, gs_modules, gs_error) - determine_type_def_index (TArrow1 _) instance_def=:{ins_generate,ins_ident,ins_pos} _ gs_modules gs_error - | ins_generate - # gs_error = checkErrorWithIdentPos - (newPosition ins_ident ins_pos) - "cannot generate an instance for arrow type" - gs_error - = ([], instance_def, gs_modules, gs_error) - = ([], instance_def, gs_modules, gs_error) - determine_type_def_index (TB _) instance_def=:{ins_generate,ins_ident,ins_pos} _ gs_modules gs_error - | ins_generate - # gs_error = checkErrorWithIdentPos - (newPosition ins_ident ins_pos) - "cannot generate an instance for a basic type" - gs_error - = ([], instance_def, gs_modules, gs_error) - = ([], instance_def, gs_modules, gs_error) - determine_type_def_index _ instance_def=:{ins_ident,ins_pos} _ gs_modules gs_error - #! gs_error = checkErrorWithIdentPos - (newPosition ins_ident ins_pos) - "generic instance type must be a type constructor or a primitive type" - gs_error - = ([], instance_def, gs_modules, gs_error) - - check_if_partial :: !ClassInstance !PredefinedSymbols !*{#FunDef} -> (!Bool, !*{#FunDef}) - check_if_partial instance_def=:{ins_members, ins_ident, ins_type, ins_generate} gs_predefs gs_fun_defs - = case supportPartialInstances of - True - | ins_generate - -> (False, gs_fun_defs) - | check_if_predef (hd ins_type.it_types) gs_predefs - -> (False, gs_fun_defs) // PAIR, EITHER, CONS, UNIT - #! ins_fun_ds = ins_members.[0] - | ins_fun_ds.ds_index == NoIndex // can this happen? - -> (False, gs_fun_defs) - | otherwise - #! (fun_def, gs_fun_defs) = gs_fun_defs ! [ins_fun_ds.ds_index] - # (TransformedBody {tb_rhs}) = fun_def.fun_body - -> case tb_rhs of - Case {case_default=No} -> (True, gs_fun_defs) - _ -> (False, gs_fun_defs) - False -> (False, gs_fun_defs) - where - check_if_predef (TA {type_index={glob_module, glob_object}} _) gs_predefs - # {pds_module, pds_def} = gs_predefs.[PD_TypeUNIT] - | glob_module == pds_module && glob_object == pds_def - = True - # {pds_module, pds_def} = gs_predefs.[PD_TypePAIR] - | glob_module == pds_module && glob_object == pds_def - = True - # {pds_module, pds_def} = gs_predefs.[PD_TypeEITHER] - | glob_module == pds_module && glob_object == pds_def - = True - # {pds_module, pds_def} = gs_predefs.[PD_TypeCONS] - | glob_module == pds_module && glob_object == pds_def - = True - | otherwise - = False - check_if_predef _ gs_predefs - = False - - check_cons_instance - {gen_cons_ptr} {ins_members} - (TA {type_index={glob_module, glob_object}} _) - predefs heaps - | not supportConsInfo - = heaps - # {pds_module, pds_def} = predefs.[PD_TypeCONS] - | glob_module <> pds_module || glob_object <> pds_def - = heaps - # {hp_type_heaps=hp_type_heaps=:{th_vars}}=heaps - # th_vars = writePtr gen_cons_ptr (TVI_ConsInstance ins_members.[0]) th_vars - = {heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}} - check_cons_instance _ _ _ _ heaps - = heaps - - check_instance_args - 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 && instance_def.ins_members.[0].ds_arity <> (-1) - # 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) - -// check that CONS instances are provided for all generics -checkConsInstances :: !*GenericState -> !*GenericState -checkConsInstances gs - | supportConsInfo - = check_cons_instances 0 0 gs - = gs - -where - check_cons_instances module_index generic_index gs=:{gs_modules, gs_heaps, gs_error} - #! size_gs_modules = size gs_modules - | module_index == size_gs_modules - = {gs & gs_modules = gs_modules} - # (generic_defs, gs_modules) = gs_modules ! [module_index].com_generic_defs - #! size_generic_defs = size generic_defs - | generic_index == size_generic_defs - = check_cons_instances (inc module_index) 0 {gs & gs_modules = gs_modules} - - # (gs_heaps, gs_error) = check_generic generic_defs.[generic_index] gs_heaps gs_error - = check_cons_instances - module_index (inc generic_index) - {gs & gs_modules = gs_modules, gs_heaps = gs_heaps, gs_error = gs_error} - - check_generic - {gen_cons_ptr, gen_ident, gen_pos} - gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} - gs_error - # (info, th_vars) = readPtr gen_cons_ptr th_vars - # gs_error = case info of - TVI_ConsInstance _ - -> gs_error - _ - -> reportError gen_ident gen_pos "instance on CONS must be provided" gs_error - = ({gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}, gs_error) - - -collectGenericTypes :: !*GenericState -> (![Type], !*GenericState) -collectGenericTypes gs=:{gs_modules} - # (types, gs_modules) = collect_in_modules 0 0 gs_modules - = (types, {gs & gs_modules = gs_modules}) -where - collect_in_modules module_index generic_index gs_modules - #! size_gs_modules = size gs_modules - | module_index == size_gs_modules - = ([], gs_modules) - # (generic_defs, gs_modules) = gs_modules ! [module_index].com_generic_defs - #! size_generic_defs = size generic_defs - | generic_index == size_generic_defs - = collect_in_modules (inc module_index) 0 gs_modules - # {gen_type={gt_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) - - -buildConsInstances :: !*GenericState -> (![FunDef], ![Group], !*GenericState) -buildConsInstances gs - | supportConsInfo - = build_cons_instances 0 0 gs - = ([], [], gs) -where - build_cons_instances module_index generic_index gs=:{gs_modules} - #! size_gs_modules = size gs_modules - | module_index == size_gs_modules - = ([], [], {gs & gs_modules = gs_modules}) - # (generic_defs, gs_modules) = gs_modules ! [module_index].com_generic_defs - # gs = {gs & gs_modules = gs_modules} - #! size_generic_defs = size generic_defs - | generic_index == size_generic_defs - = build_cons_instances (inc module_index) 0 gs - # (fun, group, gs) = build_cons_instance generic_defs.[generic_index] gs - # (funs, groups, gs) = build_cons_instances module_index (inc generic_index) gs - = ([fun:funs], [group:groups], gs) - - build_cons_instance generic_def gs - #! (fun_index, group_index, gs) = newFunAndGroupIndex gs - #! (ins_fun_def_sym, gs) = get_cons_fun generic_def gs - #! {gs_fun_defs, gs_predefs, gs_heaps} = gs - #! fun_def_sym = - { ds_ident = makeIdent (ins_fun_def_sym.ds_ident.id_name +++ ":cons_info") - , ds_arity = ins_fun_def_sym.ds_arity + 1 - , ds_index = fun_index - } - #! gs_heaps = set_cons_fun generic_def fun_def_sym gs_heaps - - #! (ins_fun_def, gs_fun_defs) = gs_fun_defs ! [ins_fun_def_sym.ds_index] - - #! (fun_def, gs_heaps) = copyFunDef ins_fun_def fun_index group_index gs_heaps - - #! (fun_def, gs_heaps) = parametrize_with_cons_info fun_def gs_predefs gs_heaps - - #! group = {group_members = [fun_index]} - - = (fun_def, group, {gs & gs_fun_defs = gs_fun_defs, gs_heaps = gs_heaps}) - //---> ("build_cons_instance", ins_fun_def, fun_def) - where - parametrize_with_cons_info fun_def=:{fun_arity, fun_body} predefs heaps - # (var_expr, var, heaps) = buildVarExpr "cons_info" heaps - # (TransformedBody tb=:{tb_args, tb_rhs}) = fun_body - # (tb_rhs, heaps) = mapExprSt (replace_cons_info var_expr) tb_rhs heaps - # fun_def = - { fun_def - & fun_arity = fun_arity + 1 - , fun_body = TransformedBody {tb & tb_args = [var:tb_args], tb_rhs = tb_rhs} - } - = (fun_def, heaps) - where - {pds_module,pds_def} = predefs.[PD_cons_info] - replace_cons_info - var_expr - expr=:(App {app_symb={symb_kind=SK_Function {glob_object, glob_module}}}) - heaps - | pds_module == glob_module && pds_def == glob_object - = (var_expr, heaps) - //---> ("replace_cons_info", expr, var_expr) - = (expr, heaps) - //---> ("replace_cons_info: App expr1", expr) - - replace_cons_info var_expr expr=:(App app) heaps - = (expr, heaps) - //---> ("replace_cons_info: App expr2", expr) - - replace_cons_info var_expr expr heaps - = (expr, heaps) - - get_cons_fun - {gen_cons_ptr, gen_pos, gen_ident} - gs=:{gs_heaps=gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}, gs_error} - # (info, th_vars) = readPtr gen_cons_ptr th_vars - # gs_heaps = { gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars }} - # (fun_def_sym, gs_error) = case info of - TVI_ConsInstance fun_def_sym - -> (fun_def_sym, gs_error) - TVI_Empty - -> (EmptyDefinedSymbol, reportError gen_ident gen_pos "no CONS instance provided" gs_error) - = (fun_def_sym, {gs & gs_heaps = gs_heaps, gs_error = gs_error}) - - set_cons_fun - {gen_cons_ptr} fun_def_sym - gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} - # th_vars = writePtr gen_cons_ptr (TVI_ConsInstance fun_def_sym) th_vars - = { gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars }} - -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 - = build_modules 0 gs -where - build_modules module_index gs=:{gs_modules} - #! size_gs_modules = size gs_modules - | module_index == size_gs_modules - = { gs & gs_modules = gs_modules } - - #! common_defs = gs_modules . [module_index] - #! (common_defs, gs=:{gs_modules}) = build_module module_index common_defs gs - #! gs = {gs & gs_modules = {gs_modules & [module_index] = common_defs}} - - = build_modules (inc module_index) gs - - build_module module_index common_defs gs - - #! {com_generic_defs,com_class_defs, com_member_defs} = common_defs - - #! class_index = size com_class_defs - #! member_index = size com_member_defs - #! com_generic_defs = {x \\ x <-: com_generic_defs} // make unique copy - - # (new_class_defs, new_member_defs, com_generic_defs, _, _, gs) = - build_generics module_index 0 class_index member_index com_generic_defs gs - - # common_defs = - { common_defs - & com_class_defs = arrayPlusRevList com_class_defs new_class_defs - , com_member_defs = arrayPlusRevList com_member_defs new_member_defs - , com_generic_defs = com_generic_defs - } - = (common_defs, gs) - - build_generics module_index generic_index class_index member_index generic_defs gs - #! size_generic_defs = size generic_defs - | generic_index == size_generic_defs - = ([], [], generic_defs, class_index, member_index, gs) - #! (generic_def, generic_defs) = generic_defs ! [generic_index] - #! (new_class_defs, new_member_defs, generic_def, class_index, member_index, gs) = - build_generic module_index class_index member_index generic_def gs - #! generic_defs = {generic_defs & [generic_index] = generic_def} - #! (new_class_defs1, new_member_defs1, generic_defs, class_index, member_index, gs) = - build_generics module_index (inc generic_index) class_index member_index generic_defs gs - = (new_class_defs ++ new_class_defs1, new_member_defs ++ new_member_defs1, - generic_defs, class_index, member_index, gs) - - build_generic module_index class_index member_index generic_def gs - # (kinds, gs) = get_kinds generic_def gs - = build_classes kinds generic_def module_index class_index member_index gs - - build_classes :: ![TypeKind] !GenericDef !Index !Index !Index !*GenericState - -> (![ClassDef], ![MemberDef], !GenericDef, !Index, !Index, !*GenericState) - build_classes [] generic_def module_index class_index member_index gs - = ([], [], generic_def, class_index, member_index, gs) - build_classes [kind:kinds] generic_def module_index class_index member_index gs - #! (class_def, member_def, generic_def, gs) = - buildClassDef module_index class_index member_index generic_def kind gs - #! (class_defs, member_defs, generic_def, class_index, member_index, gs) = - build_classes kinds generic_def module_index (inc class_index) (inc member_index) gs - = ([class_def:class_defs], [member_def:member_defs], generic_def, class_index, member_index, gs) - - get_kinds {gen_kinds_ptr} gs=:{gs_heaps=gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}} - #! (TVI_Kinds kinds, th_vars) = readPtr gen_kinds_ptr th_vars - #! th_vars = writePtr gen_kinds_ptr TVI_Empty th_vars - = (kinds, {gs & gs_heaps = {gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}}) - -// find all types whose generic representation is needed -collectGenericTypeDefs :: ![Type] [Global Index] !*GenericState - -> (![Global Index], !*GenericState) -collectGenericTypeDefs generic_types instance_td_indexes gs - # (td_indexes, gs) = collect_in_types generic_types gs - # (td_indexes, gs) = add_instance_indexes td_indexes instance_td_indexes gs - = (map fst td_indexes, gs) -where - add_instance_indexes td_indexes [] gs - = (td_indexes, gs) - add_instance_indexes - td_indexes - [type_index=:{glob_module, glob_object} : itdis] - gs=:{gs_gtd_infos, gs_td_infos} - # (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [glob_module, glob_object] - # gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = GTDI_Generic EmptyGenericType} - # (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} - | toBool gtd_info // already marked - = add_instance_indexes td_indexes itdis gs - //---> ("instance type already added", type_index) - # gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = GTDI_Generic EmptyGenericType} - = add_instance_indexes (merge_td_indexes [(type_index, td_info.tdi_group_nr)] td_indexes) itdis gs - //---> ("add instance type index", type_index) - - collect_in_types :: ![Type] !*GenericState - -> (![(Global Index, Int)], !*GenericState) - collect_in_types [] gs = ([], gs) - collect_in_types [type:types] gs - # (td_indexes1, gs) = collect_in_type type gs - # (td_indexes2, gs) = collect_in_types types gs - = (merge_td_indexes td_indexes1 td_indexes2, gs) - - collect_in_type :: !Type !*GenericState - -> (![(Global Index, Int)], !*GenericState) - collect_in_type (TA type_symb arg_types) gs - # (td_indexes1, gs) = collect_in_atypes arg_types gs - # (td_indexes2, gs) = collect_in_type_app type_symb gs - = (merge_td_indexes td_indexes1 td_indexes2, gs) - where - collect_in_type_app {type_arity=0} gs - // types with no arguments do not need mapping to be built: - // their mapping is identity - = ([], gs) - collect_in_type_app - {type_index=type_index=:{glob_module, glob_object}, type_ident} - gs=:{gs_gtd_infos, gs_td_infos, gs_modules} - # (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [glob_module, glob_object] - | toBool gtd_info // already marked - = ([], {gs & gs_gtd_infos = gs_gtd_infos}) - //---> ("already marked type", type_ident, type_index) - | otherwise // not yet marked - # gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = GTDI_Generic EmptyGenericType} - # (td_info, gs_td_infos) = gs_td_infos ! [glob_module, glob_object] - # (type_def, gs_modules) = getTypeDef glob_module glob_object gs_modules - # gs = {gs & gs_td_infos = gs_td_infos, gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules} - # (td_indexes1, gs) = collect_in_type_def_rhs glob_module type_def gs - # td_indexes2 = [(type_index, td_info.tdi_group_nr)] - = (merge_td_indexes td_indexes1 td_indexes2, gs) - //---> ("mark type", type_ident, type_index) - - collect_in_type (arg_type --> res_type) gs - #! (td_indexes1, gs) = collect_in_atype arg_type gs - #! (td_indexes2, gs) = collect_in_atype res_type gs - = (merge_td_indexes td_indexes1 td_indexes2, gs) - collect_in_type (TArrow1 arg_type) gs - = collect_in_atype arg_type gs - collect_in_type (cons_var :@: args) gs - #! types = [ at_type \\ {at_type} <- args] - = collect_in_types types gs - collect_in_type _ gs - = ([], gs) - - collect_in_atype :: !AType !*GenericState - -> (![(Global Index, Int)], !*GenericState) - collect_in_atype {at_type} gs = collect_in_type at_type gs - - collect_in_atypes :: ![AType] !*GenericState - -> (![(Global Index, Int)], !*GenericState) - collect_in_atypes [] gs = ([], gs) - collect_in_atypes [atype:atypes] gs - # (td_indexes1, gs) = collect_in_atype atype gs - # (td_indexes2, gs) = collect_in_atypes atypes gs - # merged_td_indexes = merge_td_indexes td_indexes1 td_indexes2 - = (merged_td_indexes, gs) - - collect_in_type_def_rhs :: !Index !CheckedTypeDef !*GenericState - -> (![(Global Index, Int)], !*GenericState) - collect_in_type_def_rhs mod {td_rhs=(AlgType cons_def_symbols)} gs - = collect_in_conses mod cons_def_symbols gs - collect_in_type_def_rhs mod {td_rhs=(RecordType {rt_constructor})} gs - = collect_in_conses mod [rt_constructor] gs - collect_in_type_def_rhs mod {td_rhs=(SynType {at_type})} gs - = collect_in_type at_type gs - collect_in_type_def_rhs mod {td_rhs=(AbstractType _), td_ident, td_pos} gs=:{gs_error} - #! gs_error = checkErrorWithIdentPos - (newPosition td_ident td_pos) - "cannot build generic type representation for an abstract type" - gs_error - = ([], {gs & gs_error = gs_error}) - //= ([], {gs & gs_error = checkWarning td_ident "abstract data type" gs_error}) - - collect_in_conses :: !Index ![DefinedSymbol] !*GenericState - -> (![(Global Index, Int)], !*GenericState) - collect_in_conses mod [] gs - = ([], 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 - //---> ("mark cons " +++ ds_ident.id_name) - #! 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 - = (merge_td_indexes td_indexes1 td_indexes2, gs) - - collect_in_symbol_type {st_args, st_result} gs - #! (td_indexes1, gs) = collect_in_types (map (\x->x.at_type) st_args) gs - #! (td_indexes2, gs) = collect_in_type st_result.at_type gs - = (merge_td_indexes td_indexes1 td_indexes2, gs) - - merge_td_indexes x y - = mergeBy (\(_,l) (_,r) ->l < r) x y - - -buildIsoFunctions :: ![Global Index] !*GenericState - -> (![FunDef], ![Group], !*GenericState) -buildIsoFunctions [] gs = ([], [], gs) -buildIsoFunctions [type_index:type_indexes] gs - #! (iso_funs1, iso_groups1, gs) = build_function type_index gs - #! (iso_funs2, iso_groups2, gs) = buildIsoFunctions type_indexes gs - = (iso_funs1 ++ iso_funs2, iso_groups1 ++ iso_groups2, gs) -where - build_function {glob_module, glob_object} gs - - # (generic_rep_type, gs) = buildGenericRepType glob_module glob_object gs - - # (type_info_def_sym, cons_info_def_syms, info_fun_defs, info_groups, gs) = - build_cons_infos glob_module glob_object gs - - # (iso_def_sym, iso_fun_defs, iso_groups, gs) = - build_isos glob_module glob_object cons_info_def_syms gs - - # gs = fill_generic_type_info - glob_module glob_object - generic_rep_type - iso_def_sym - type_info_def_sym cons_info_def_syms - gs - - = (info_fun_defs ++ iso_fun_defs, info_groups ++ iso_groups, gs) - - fill_generic_type_info - module_index type_def_index - generic_rep_type - iso_def_sym - type_info_def_sym - cons_info_def_syms - gs=:{gs_gtd_infos, gs_modules} - - # (type_def=:{td_args}, gs_modules) = getTypeDef module_index type_def_index gs_modules - # gtd_info = GTDI_Generic - { gtr_type = generic_rep_type - , gtr_type_args = [atv_variable \\ {atv_variable} <- td_args] - , gtr_iso = iso_def_sym - , gtr_isomap_group= NoIndex - , gtr_isomap = EmptyDefinedSymbol - , gtr_isomap_from = EmptyDefinedSymbol - , gtr_isomap_to = EmptyDefinedSymbol - , gtr_type_info = type_info_def_sym - , gtr_cons_infos = cons_info_def_syms - } - # gs_gtd_infos = {gs_gtd_infos & [module_index, type_def_index] = gtd_info} - = {gs & gs_modules = gs_modules, gs_gtd_infos = gs_gtd_infos} - - build_isos module_index type_def_index cons_infos gs - - # (from_fun_index, from_group_index, gs) = newFunAndGroupIndex gs - # (to_fun_index, to_group_index, gs) = newFunAndGroupIndex gs - # (iso_fun_index, iso_group_index, gs) = newFunAndGroupIndex gs - - # {gs_modules} = gs - # (type_def=:{td_ident}, gs_modules) = getTypeDef module_index type_def_index gs_modules - # gs = {gs & gs_modules = gs_modules} - - # iso_def_sym = { - ds_ident = {id_name="iso_"+++type_def.td_ident.id_name, id_info = nilPtr }, - ds_index = iso_fun_index, - ds_arity = 0 - } - - # from_def_sym = { - ds_ident = {id_name="iso_from_generic_to_"+++type_def.td_ident.id_name, id_info = nilPtr }, - ds_index = from_fun_index, - ds_arity = 1 - } - - # to_def_sym = { - ds_ident = {id_name="iso_to_generic_from_"+++type_def.td_ident.id_name, id_info = nilPtr }, - ds_index = to_fun_index, - ds_arity = 1 - } - # (from_fun_def, gs) = buildIsoFrom from_def_sym from_group_index module_index type_def gs - # (to_fun_def, gs) = buildIsoTo to_def_sym to_group_index module_index type_def cons_infos gs - - # (iso_fun_def, gs) = - //buildUndefFunction iso_fun_index iso_group_index iso_name 1 gs_predefs gs_heaps - buildIsoRecord iso_def_sym iso_group_index from_def_sym to_def_sym gs - - # fun_defs = [from_fun_def, to_fun_def, iso_fun_def] - # groups = - [ {group_members=[from_fun_index]} - , {group_members=[to_fun_index]} - , {group_members=[iso_fun_index]} - ] - = (iso_def_sym, fun_defs, groups, gs) - - build_cons_infos module_index type_def_index gs - = case supportCons of - False -> (EmptyDefinedSymbol, [], [], [], gs) - True -> build_cons_infos1 module_index type_def_index gs - - build_cons_infos1 module_index type_def_index gs=:{gs_modules} - # (type_def=:{td_rhs}, gs_modules) = getTypeDef module_index type_def_index gs_modules - # (common_defs, gs_modules) = gs_modules ! [module_index] - # gs = {gs & gs_modules = gs_modules} - - # (type_fun_index, group_index, gs) = newFunAndGroupIndex gs - # type_fun_sym = - { ds_ident = makeIdent ("type_info_" +++ type_def.td_ident.id_name) - , ds_index = type_fun_index - , ds_arity = 0 - } - - # (cons_fun_syms, cons_fun_defs, gs) = case td_rhs of - (AlgType alts) - -> build_alg_cons_infos alts 0 type_fun_sym group_index common_defs gs - (RecordType {rt_constructor}) - -> build_alg_cons_infos [rt_constructor] 0 type_fun_sym group_index common_defs gs - _ -> ([], [], gs) - - # (type_fun_def, gs) = - build_typedef_info type_def type_fun_sym group_index cons_fun_syms gs - - # group = - { group_members = [type_fun_index : [ds_index \\ {ds_index} <- cons_fun_syms]] - } - = (type_fun_sym, cons_fun_syms, [type_fun_def:cons_fun_defs], [group], gs) - - build_alg_cons_infos [] cons_num type_info_def_sym group_index common_defs gs - = ([], [], gs) - build_alg_cons_infos [cons_def_sym:cons_def_syms] cons_num type_info_def_sym group_index common_defs gs - # (fi, fd, gs) = build_cons_info cons_def_sym cons_num type_info_def_sym group_index common_defs gs - # (fis, fds, gs) = build_alg_cons_infos cons_def_syms (inc cons_num) type_info_def_sym group_index common_defs gs - = ([fi:fis], [fd:fds], gs) - - build_cons_info {ds_index,ds_arity} cons_num type_info_def_sym group_index common_defs gs=:{gs_main_dcl_module_n} - # {cons_ident, cons_pos, cons_type} = common_defs.com_cons_defs.[ds_index] - # (fun_index, gs) = newFunIndex gs - # def_sym = - { ds_ident = makeIdent ("cons_info_" +++ cons_ident.id_name) - , ds_index = fun_index - , ds_arity = 0 - } - # {gs_modules,gs_heaps, gs_predefs, gs_main_dcl_module_n} = gs - # cons_name_expr = makeStringExpr ("\""+++cons_ident.id_name+++"\"") gs_predefs - # cons_arity_expr = makeIntExpr ds_arity - # cons_num_expr = makeIntExpr cons_num - # (cons_type_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n type_info_def_sym [] gs_heaps - - # gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules} - # (cons_arg_type_exprs, gs=:{gs_heaps}) = build_type_infos cons_type.st_args gs - # (cons_arg_types_expr, gs_heaps) = makeListExpr cons_arg_type_exprs gs_predefs gs_heaps - - # (cons_info_expr, gs_heaps) = buildPredefConsApp - PD_ConsConsDefInfo - [ cons_name_expr - , cons_arity_expr - , cons_num_expr - , cons_type_expr - , cons_arg_types_expr - ] - gs_predefs gs_heaps - # fun_def = makeFunction def_sym group_index [] cons_info_expr No [] gs_main_dcl_module_n cons_pos - - //# (fun_def, gs_heaps) = buildUndefFunction def_sym group_index gs_predefs gs_heaps - = (def_sym, fun_def, {gs & gs_heaps=gs_heaps}) - - build_type_infos [] gs = ([], gs) - build_type_infos [t:ts] gs - # (e, gs) = build_type_info t gs - # (es, gs) = build_type_infos ts gs - = ([e:es], gs) - - build_type_def name arity vars cons_info_def_syms gs=:{gs_main_dcl_module_n, gs_predefs, gs_heaps} - # name_expr = makeStringExpr ("\""+++name+++"\"") gs_predefs - # kind_expr = makeIntExpr arity - # var_exprs = [ makeStringExpr ("\""+++v+++"\"") gs_predefs \\ v <- vars] - # (var_list_expr, gs_heaps) = makeListExpr var_exprs gs_predefs gs_heaps - - # (cons_info_exprs, gs_heaps) = mapSt build_app cons_info_def_syms gs_heaps - with - build_app cons_info_def_sym h - //= buildUndefFunApp [] gs_predefs h - = buildFunApp gs_main_dcl_module_n cons_info_def_sym [] h - # (cons_info_list_expr, gs_heaps) = makeListExpr cons_info_exprs gs_predefs gs_heaps - - # (typedefinfo_expr, gs_heaps) = buildPredefConsApp - PD_ConsTypeDefInfo - [ name_expr - , kind_expr - , var_list_expr - , cons_info_list_expr - ] - gs_predefs gs_heaps - = (typedefinfo_expr, {gs & gs_heaps = gs_heaps}) - - build_type_def_app name arity vars cons_info_def_syms arg_exprs gs=:{gs_predefs, gs_heaps} - # (arg_list_expr, gs_heaps) = makeListExpr arg_exprs gs_predefs gs_heaps - # (type_def_expr, gs=:{gs_heaps}) = - build_type_def name arity vars cons_info_def_syms {gs & gs_heaps = gs_heaps} - # (type_app_expr, gs_heaps) = buildPredefConsApp - PD_ConsTypeApp - [ type_def_expr - , arg_list_expr - ] - gs_predefs gs_heaps - - = (type_app_expr, { gs & gs_heaps = gs_heaps}) - - build_type_info {at_type=TA {type_ident,type_arity} ts} gs - # (arg_exprs, gs) = build_type_infos ts gs - = build_type_def_app type_ident.id_name type_arity [] [] arg_exprs gs - - build_type_info {at_type=arg --> res} gs - # (arg_expr, gs) = build_type_info arg gs - # (res_expr, gs) = build_type_info res gs - = build_type_def_app "->" 2 ["a", "b"] [] [arg_expr, res_expr] gs - - build_type_info {at_type=TB t} gs - - # name = case t of - BT_Int -> "Int" - BT_Char -> "Char" - BT_Real -> "Real" - BT_Bool -> "Bool" - BT_Dynamic -> "Dynamic" - BT_File -> "File" - BT_World -> "World" - BT_String _ -> "String" - - = build_type_def_app name 0 [] [] [] gs - - build_type_info {at_type=TV {tv_ident}} gs=:{gs_heaps, gs_predefs} - # name_expr = makeStringExpr ("\"" +++ tv_ident.id_name +++ "\"") gs_predefs - # (expr, gs_heaps) = buildPredefConsApp PD_ConsTypeVar [ name_expr ] gs_predefs gs_heaps - = (expr, {gs & gs_heaps = gs_heaps}) - - build_type_info {at_type} gs=:{gs_heaps, gs_predefs} - # name_expr = makeStringExpr ("\"error\"") gs_predefs - # (expr, gs_heaps) = buildPredefConsApp PD_ConsTypeVar [ name_expr ] gs_predefs gs_heaps - = (expr, {gs & gs_heaps = gs_heaps}) - - build_typedef_info - {td_pos,td_ident, td_args} - type_info_def_sym - group_index - cons_info_def_syms - gs=:{gs_main_dcl_module_n} - - # type_vars = [ atv.atv_variable.tv_ident.id_name \\ atv <- td_args] - # (body_expr, gs) = build_type_def - td_ident.id_name type_info_def_sym.ds_arity type_vars cons_info_def_syms gs - # fun_def = makeFunction type_info_def_sym group_index [] body_expr No [] gs_main_dcl_module_n td_pos - = (fun_def, gs) - -buildIsomapsForTypeDefs :: ![Global Index] !*GenericState - -> (![FunDef], ![Group], !*GenericState) -buildIsomapsForTypeDefs td_indexes gs=:{gs_last_group} - # gs = foldSt fill_function_indexes td_indexes gs - # first_group = gs_last_group - # (funs, gs) = build_isomap_functions td_indexes gs - # (last_group, gs) = gs ! gs_last_group - # groups = createArray (last_group - first_group) [] - //---> ("created " +++ toString (last_group - first_group) +++ " isomap groups") - # groups = collect_groups first_group funs groups - # groups = [ {group_members = fs} \\ fs <-: groups ] - = (map snd funs, groups, gs) -where - - fill_function_indexes :: !(Global Index) !*GenericState -> !*GenericState - fill_function_indexes {glob_module, glob_object} gs - - # (kind, gs) = get_kind glob_module glob_object gs - | kind == KindConst - // types of kind * do not need isomaps - they are identity - = gs - - # (from_fun_index, gs) = newFunIndex gs - # (to_fun_index, gs) = newFunIndex gs - # (rec_fun_index, gs) = newFunIndex gs - - # (gs=:{gs_gtd_infos, gs_modules}) = gs - # (type_def=:{td_ident, td_arity}, gs_modules) = getTypeDef glob_module glob_object gs_modules - # (GTDI_Generic gt, gs_gtd_infos) = gs_gtd_infos ! [glob_module, glob_object] - - # gtd_info = GTDI_Generic {gt & - gtr_isomap_from = { - ds_ident = {id_name="isomap_from_"+++td_ident.id_name, id_info=nilPtr}, - ds_index = from_fun_index, - ds_arity = (td_arity + 1) - }, - gtr_isomap_to = { - ds_ident = {id_name="isomap_to_"+++td_ident.id_name, id_info=nilPtr}, - ds_index = to_fun_index, - ds_arity = (td_arity + 1) - }, - gtr_isomap = { - ds_ident = {id_name="isomap_"+++td_ident.id_name, id_info=nilPtr}, - ds_index = rec_fun_index, - ds_arity = td_arity - } - } - # gs_gtd_infos = {gs_gtd_infos & [glob_module, glob_object] = gtd_info} - = {gs & gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules} - - get_kind module_index type_index gs=:{gs_td_infos} - # (kind, gs_td_infos) = kindOfTypeDef module_index type_index gs_td_infos - = (kind, {gs & gs_td_infos = gs_td_infos}) - - build_isomap_functions :: ![Global Index] !*GenericState - -> (![(Index, FunDef)], !*GenericState) - build_isomap_functions [] gs = ([], gs) - build_isomap_functions [{glob_module, glob_object}:td_indexes] gs - # (funs1, gs) = build_isomap_function glob_module glob_object gs - # (funs2, gs) = build_isomap_functions td_indexes gs - = (funs1 ++ funs2, gs) - - build_isomap_function module_index type_def_index gs - - # (kind, gs) = get_kind module_index type_def_index gs - | kind == KindConst - // types of kind * do not need isomaps - they are identity - = ([], gs) - # (group_index, gs) = get_group module_index type_def_index gs - - # {gs_modules, gs_gtd_infos} = gs - # (type_def=:{td_ident}, gs_modules) = getTypeDef module_index type_def_index gs_modules - - # (GTDI_Generic {gtr_isomap, gtr_isomap_to, gtr_isomap_from}, gs_gtd_infos) - = gs_gtd_infos![module_index, type_def_index] - - # gs = { gs & gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules } - - # (from_fun_def, from_fun_index, gs) = - buildIsomapFromTo IsoFrom gtr_isomap_from group_index module_index type_def_index gs - # (to_fun_def, to_fun_index, gs) = - buildIsomapFromTo IsoTo gtr_isomap_to group_index module_index type_def_index gs - # (rec_fun_def, rec_fun_index, gs) = - buildIsomapForTypeDef gtr_isomap group_index module_index type_def gtr_isomap_from gtr_isomap_to gs - - # funs = [ (from_fun_index, from_fun_def), (to_fun_index, to_fun_def), (rec_fun_index, rec_fun_def) ] - = (funs, gs) - //---> from_fun_def - //---> ("build isomap for", td_ident, module_index, type_def_index) - - collect_groups :: !Index ![(Index, FunDef)] !*{[Index]} -> !*{[Index]} - collect_groups first_group_index [] groups = groups - collect_groups first_group_index [(fun_index, fun=:{fun_ident, fun_info={fi_group_index}}):funs] groups - # (group, groups) = groups ! [fi_group_index - first_group_index] - # groups = {groups & [fi_group_index - first_group_index] = [fun_index:group]} - //---> ("add fun " +++ fun_ident.id_name +++ " "+++ toString fun_index +++ - // " to group " +++ toString fi_group_index) - = collect_groups first_group_index funs groups - - get_group :: !Index !Index !*GenericState - -> (!Index, !*GenericState) - get_group module_index type_def_index gs=:{gs_gtd_infos} - #! (gtd_info,gs_gtd_infos) = gs_gtd_infos![module_index, type_def_index] - #! gt = case gtd_info of - (GTDI_Generic gt) -> gt - _ -> abort "no generic representation for a type\n" - | gt.gtr_isomap_group <> NoIndex // group index already allocated - = (gt.gtr_isomap_group, { gs & gs_gtd_infos = gs_gtd_infos}) - //---> ("group for type already exists", module_index, type_def_index, gt.gtr_isomap_group) - # (group_index, gs=:{gs_td_infos, gs_gtd_infos}) - = newGroupIndex {gs & gs_gtd_infos = gs_gtd_infos} - - #! (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}) - //---> ("type group of type ", module_index, type_def_index, type_def_info.tdi_group_nr) - -// Sjaak ... - update_group :: !Index ![GlobalIndex] !*GenericTypeDefInfos -> !*GenericTypeDefInfos - update_group group_index [] gtd_infos = gtd_infos - update_group group_index [{gi_module, gi_index}:type_def_global_indexes] gtd_infos - #! (gtd_info, gtd_infos) = gtd_infos ! [gi_module, gi_index] - #! gtd_info = case gtd_info of - (GTDI_Generic gt) - | gt.gtr_isomap_group <> NoIndex - -> abort "sanity check: updating already updated group\n" - -> GTDI_Generic {gt & gtr_isomap_group = group_index } - _ -> gtd_info - #! gtd_infos = {gtd_infos & [gi_module, gi_index] = gtd_info} - = update_group group_index type_def_global_indexes gtd_infos - - -buildIsomapsForGenerics :: !*GenericState - -> (![FunDef], ![Group], !*GenericState) -buildIsomapsForGenerics gs - = build_modules 0 gs -where - build_modules module_index gs=:{gs_modules} - #! num_modules = size gs_modules - | module_index == num_modules - = ([], [], gs) - # (common_defs, gs_modules) = gs_modules ! [module_index] - # {com_generic_defs} = common_defs - # com_generic_defs = {g \\ g <-: com_generic_defs} // make unique copy - # (new_funs, new_groups, com_generic_defs, gs) = - build_isomaps module_index 0 com_generic_defs {gs & gs_modules = gs_modules} - # (funs, groups, gs) = build_modules (inc module_index) gs - # {gs_modules} = gs - # gs_modules = { gs_modules & [module_index] = {common_defs & com_generic_defs = com_generic_defs}} - = (new_funs ++ funs, new_groups ++ groups, {gs & gs_modules = gs_modules}) - - build_isomaps module_index generic_index generic_defs gs - #! num_generic_defs = size generic_defs - | generic_index == num_generic_defs - = ([], [], generic_defs, gs) - # (new_funs, new_groups, generic_defs, gs) = build_isomap module_index generic_index generic_defs gs - # (funs, groups, generic_defs, gs) = build_isomaps module_index (inc generic_index) generic_defs gs - = (new_funs ++ funs, new_groups ++ groups, generic_defs, gs) - - build_isomap module_index generic_index generic_defs gs - # (generic_def=:{gen_ident, gen_type}, generic_defs) = generic_defs ! [generic_index] - # (fun_index, group_index, gs) = newFunAndGroupIndex gs - # def_sym = { - ds_ident = {id_name="isomap_"+++gen_ident.id_name, id_info = nilPtr}, - ds_index = fun_index, - ds_arity = gen_type.gt_arity - } - # generic_defs = {generic_defs & [generic_index] = {generic_def & gen_isomap = def_sym}} - # (fun_def, _, gs) = buildIsomapForGeneric def_sym group_index generic_def gs - //# (fun_def, gs) = build_undef_fun def_sym group_index gs - # group = {group_members = [fun_index]} - = ([fun_def], [group], generic_defs, gs) - where - build_undef_fun def_sym group gs=:{gs_heaps, gs_predefs} - # (fun_def, gs_heaps) = buildUndefFunction def_sym group gs_predefs gs_heaps - = (fun_def, {gs & gs_heaps = gs_heaps}) - -// generate instances -buildInstances :: !*GenericState - -> (![FunDef], ![Group], !*GenericState) -buildInstances gs - = build_modules 0 gs -where - build_modules :: !Index !*GenericState - -> (![FunDef], ![Group], !*GenericState) - build_modules module_index gs=:{gs_modules} - #! num_modules = size gs_modules - | module_index == num_modules - = ([], [], gs) - # (common_defs, gs_modules) = gs_modules ! [module_index] - # {com_instance_defs} = common_defs - # com_instance_defs = {i \\ i <-: com_instance_defs} // make unique copy - # (new_funs, new_groups, com_instance_defs, gs) = - build_instances module_index 0 com_instance_defs {gs & gs_modules = gs_modules} - # (funs, groups, gs) = build_modules (inc module_index) gs - # {gs_modules} = gs - # gs_modules = { gs_modules & [module_index] = {common_defs & com_instance_defs = com_instance_defs}} - = (new_funs ++ funs, new_groups ++ groups, {gs & gs_modules = gs_modules}) - - build_instances :: !Index !Index !*{#ClassInstance} !*GenericState - -> (![FunDef], ![Group], !*{#ClassInstance}, !*GenericState) - build_instances module_index instance_index instance_defs gs - #! num_instance_defs = size instance_defs - | instance_index == num_instance_defs - = ([], [], instance_defs, gs) - # (new_funs, new_groups, instance_defs, gs) = build_instance module_index instance_index instance_defs gs - # (funs, groups, instance_defs, gs) = build_instances module_index (inc instance_index) instance_defs gs - = (new_funs ++ funs, new_groups ++ groups, instance_defs, gs) - - build_instance :: !Index !Index !*{#ClassInstance} !*GenericState - -> (![FunDef], ![Group], !*{#ClassInstance}, !*GenericState) - build_instance module_index instance_index instance_defs gs=:{gs_modules} - # (instance_def, instance_defs) = instance_defs ! [instance_index] - | not instance_def.ins_is_generic - = ([], [], instance_defs, gs) - - | instance_def.ins_generate - #! (fun_def, fun_def_sym, gs) = build_instance_fun instance_def gs - #! instance_def = { instance_def & ins_members = {fun_def_sym} } - #! instance_defs = {instance_defs & [instance_index] = instance_def} - # (dcl_fun_index, gs) = get_dcl_member_index instance_index gs - with - get_dcl_member_index icl_instance_index gs=:{gs_main_dcl_module_n} -// # ({dcl_common}, gs_dcl_modules) = gs_dcl_modules![gs_main_dcl_module_n] -// # gs = {gs & gs_dcl_modules = gs_dcl_modules} -// # dcl_index = case dcl_conversions of - # dcl_index = NoIndex -/* - No -> NoIndex - Yes conversion_table - # instance_table = conversion_table.[cInstanceDefs] - # dcl_instance_index = find_dcl_instance_index icl_instance_index 0 instance_table - | dcl_instance_index == NoIndex - -> NoIndex - | otherwise - # dcl_instance = dcl_common.com_instance_defs.[dcl_instance_index] - # dcl_index = dcl_instance.ins_members.[0].ds_index - -> dcl_index -*/ - = (dcl_index, gs) - where - find_dcl_instance_index icl_instance_index index instance_table - | index == size instance_table - = NoIndex - | instance_table.[index] == icl_instance_index - = index - | otherwise - = find_dcl_instance_index icl_instance_index (inc index) instance_table - - # gs = case dcl_fun_index of - NoIndex -> gs - _ -// # gs = update_dcl_icl_conversions dcl_fun_index fun_def_sym.ds_index gs -// # gs = update_dcl_fun_conversions module_index dcl_fun_index fun_def_sym.ds_index gs - -> gs -/* with - update_dcl_icl_conversions dcl_index icl_index gs=:{gs_opt_dcl_icl_conversions=No} - = gs - update_dcl_icl_conversions dcl_index icl_index gs=:{gs_opt_dcl_icl_conversions=Yes cs} - #! (table_size, cs) = usize cs - | dcl_index < table_size - = {gs & gs_opt_dcl_icl_conversions=Yes {cs & [dcl_index] = icl_index}} - //---> ("update dcl-to-icl conversion table", dcl_index, icl_index) - = {gs & gs_opt_dcl_icl_conversions=Yes cs} - //---> ("update dcl-to-icl conversion table: index does not fit", dcl_index, icl_index) - - update_dcl_fun_conversions module_index dcl_index icl_index gs=:{gs_dcl_modules} - # (dcl_module=:{dcl_conversions}, gs_dcl_modules) = gs_dcl_modules ! [module_index] - # dcl_conversions = case dcl_conversions of - No -> No - Yes table - # fun_table = table.[cFunctionDefs] - # (size_fun_table, fun_table) = usize fun_table - | dcl_index < size_fun_table - # fun_table = {x \\ x <-: fun_table} - # fun_table = {fun_table & [dcl_index] = icl_index} - -> Yes {{x\\x<-:table} & [cFunctionDefs] = fun_table} - | otherwise - -> Yes table - # dcl_module = { dcl_module & dcl_conversions = dcl_conversions} - = {gs & gs_dcl_modules = {gs_dcl_modules & [module_index] = dcl_module }} -*/ - = ([fun_def], [{group_members = [fun_def_sym.ds_index]}], instance_defs, gs) - - | supportPartialInstances && instance_def.ins_partial - - #! (fun_def, fun_def_sym, gs) = build_instance_fun instance_def gs - - #! (instance_def, ins_fun_index, ins_fun_def, gs) - = move_instance instance_def gs - #! instance_defs = {instance_defs & [instance_index] = instance_def} - - #! (ins_fun_def, gs) = add_generic_alternative ins_fun_def fun_def_sym gs - - = ( [fun_def, ins_fun_def], - [{group_members = [fun_def_sym.ds_index]}, {group_members = [ins_fun_index]}], - instance_defs, gs) - //---> ("build partial instance", instance_def.ins_ident, instance_def.ins_type) - - | otherwise - = ([], [], instance_defs, gs) - - add_generic_alternative ins_fun_def gen_fun_ds gs=:{gs_heaps, gs_main_dcl_module_n} - # (TransformedBody tb) = ins_fun_def.fun_body - # (Case cas) = tb.tb_rhs - - #! (arg_exprs, new_tb_args, gs_heaps) = buildBoundVarExprs tb.tb_args gs_heaps - - #! (app_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n gen_fun_ds arg_exprs gs_heaps - #! case_expr = Case {cas & case_default = (Yes app_expr)} - - #! ins_fun_def = - { ins_fun_def - & fun_body = TransformedBody {tb & tb_rhs=case_expr, tb_args = new_tb_args} - , fun_info = - { ins_fun_def.fun_info - & fi_calls = - [ FunCall gen_fun_ds.ds_index NotALevel - : ins_fun_def.fun_info.fi_calls ] - } - } - - = (ins_fun_def, {gs & gs_heaps = gs_heaps}) - //---> ("created generic alterntaive for " +++ ins_fun_def.fun_ident.id_name) - - move_instance instance_def=:{ins_members, ins_pos} gs=:{gs_main_dcl_module_n} - # (new_fun_index, new_fun_group, gs=:{gs_fun_defs, gs_predefs, gs_heaps}) - = newFunAndGroupIndex gs - # ins_fun_index = ins_members.[0].ds_index - # (ins_fun_def, gs_fun_defs) = gs_fun_defs ! [ins_fun_index] - - // set new indexes in the function - # new_ins_fun_def = - { ins_fun_def - //& fun_index = new_fun_index - & fun_info = {ins_fun_def.fun_info & fi_group_index = new_fun_group} - } - #! new_member = {ins_members.[0] & ds_index = new_fun_index} - #! instance_def = {instance_def & ins_members = {new_member}} - - // build a dummy function and set it at the old position - #! (undef_expr, gs_heaps) = buildUndefFunApp [] gs_predefs gs_heaps - #! (arg_vars, gs_heaps) = - mapSt buildFreeVar0 ["v" +++ toString i \\ i <- [1..ins_fun_def.fun_arity]] gs_heaps - # {fun_ident, fun_arity, fun_info, fun_type, fun_pos} = ins_fun_def - #! dummy_def_sym = - { ds_ident = fun_ident - , ds_arity = fun_arity - , ds_index = ins_fun_index - } - #! dummy_fun_def = - makeFunction dummy_def_sym fun_info.fi_group_index arg_vars undef_expr fun_type [] gs_main_dcl_module_n fun_pos - #! gs_fun_defs = {gs_fun_defs & [ins_fun_index] = dummy_fun_def} - - = (instance_def, new_fun_index, new_ins_fun_def, {gs & gs_fun_defs = gs_fun_defs, gs_heaps = gs_heaps}) - - build_instance_fun instance_def gs=:{gs_modules} - # {ins_class, ins_generic} = instance_def - # (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules - # (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules - # (generic_def, gs_modules) = getGenericDef ins_generic.glob_module ins_generic.glob_object gs_modules - # (fun_index, group_index, gs) = newFunAndGroupIndex {gs & gs_modules=gs_modules} - # fun_def_sym = { - ds_ident = instance_def.ins_ident, - ds_index = fun_index, - ds_arity = member_def.me_type.st_arity - } - - //# (fun_def, gs) = build_dummy_instance fun_def_sym group_index gs - # (fun_def, gs) = buildInstance fun_def_sym group_index instance_def generic_def gs - = (fun_def, fun_def_sym, gs) - - build_dummy_instance fun_def_sym group_index gs=:{gs_predefs, gs_heaps} - # (fun_def, gs_heaps) = buildUndefFunction fun_def_sym group_index gs_predefs gs_heaps - = (fun_def, {gs & gs_heaps = gs_heaps}) - -// generate kind star instances -buildKindConstInstances :: !*GenericState - -> (![FunDef], ![Group], !*GenericState) -buildKindConstInstances gs - = build_modules 0 gs -where - build_modules :: !Index !*GenericState - -> (![FunDef], ![Group], !*GenericState) - build_modules module_index gs=:{gs_modules, gs_main_dcl_module_n} - - #! num_modules = size gs_modules - | module_index == num_modules - = ([], [], {gs & gs_modules = gs_modules}) - # (new_funs, new_groups, instance_defs, gs) = - build_instances module_index 0 {gs & gs_modules = gs_modules} - # (funs, groups, gs) = build_modules (inc module_index) gs - # {gs_modules} = gs - - // add instances -/* - # (common_defs=:{com_instance_defs}, gs_modules) = gs_modules ! [module_index] - # com_instance_defs = arrayPlusList com_instance_defs instance_defs - # gs_modules = { gs_modules & [module_index] = {common_defs & com_instance_defs = com_instance_defs}} -*/ - # (common_defs=:{com_instance_defs}, gs_modules) = gs_modules ! [gs_main_dcl_module_n] - # com_instance_defs = arrayPlusList com_instance_defs instance_defs - # gs_modules = { gs_modules & [gs_main_dcl_module_n] = {common_defs & com_instance_defs = com_instance_defs}} - - = (new_funs ++ funs, new_groups ++ groups, {gs & gs_modules = gs_modules}) - - build_instances :: !Index !Index !*GenericState - -> (![FunDef], ![Group], ![ClassInstance], !*GenericState) - build_instances module_index instance_index gs=:{gs_modules} - # ({com_instance_defs}, gs_modules) = gs_modules ! [module_index] - #! num_instance_defs = size com_instance_defs - # gs = { gs & gs_modules = gs_modules } - | instance_index == num_instance_defs - = ([], [], [], gs) - - # (new_funs, new_groups, new_instance_defs, gs) = build_instance module_index instance_index gs - # (funs, groups, instance_defs, gs) = build_instances module_index (inc instance_index) gs - = (new_funs ++ funs, new_groups ++ groups, new_instance_defs ++ instance_defs, gs) - build_instance :: !Index !Index !*GenericState - -> (![FunDef], ![Group], ![ClassInstance], !*GenericState) - build_instance module_index instance_index gs=:{gs_modules, gs_td_infos, gs_heaps} - # (instance_def, gs_modules) = getInstanceDef module_index instance_index gs_modules - # { ins_ident, ins_type, ins_pos, - ins_generate, ins_is_generic, ins_generic} = instance_def - - | not (ins_is_generic) - = ([], [], [], {gs & gs_td_infos = gs_td_infos, gs_modules = gs_modules, gs_heaps = gs_heaps}) - - # it_type = hd ins_type.it_types - #! (kind, gs_td_infos) = kindOfType it_type gs_td_infos - | kind == KindConst - = ([], [], [], { gs & gs_td_infos = gs_td_infos, gs_modules = gs_modules, gs_heaps = gs_heaps}) - - # (KindArrow kind_args) = kind - # (generic_def, gs_modules) = getGenericDef ins_generic.glob_module ins_generic.glob_object gs_modules - # (ok, kind_star_class_def_sym) = getGenericClassForKind generic_def KindConst - | not ok - = abort "no class for kind *" - - # (oks, arg_class_def_syms) = unzip (map (getGenericClassForKind generic_def) kind_args) - | not (and oks) - = abort "no class for an agrument kind" - - # (kind_star_class_def, gs_modules) = getClassDef ins_generic.glob_module kind_star_class_def_sym.ds_index gs_modules - # (member_def, gs_modules) = getMemberDef ins_generic.glob_module kind_star_class_def.class_members.[0].ds_index gs_modules - - # glob_kind_star_class_def_sym = {glob_module=ins_generic.glob_module, glob_object=kind_star_class_def_sym} - # glob_arg_class_def_syms = [{glob_module=ins_generic.glob_module, glob_object=c} \\ c <- arg_class_def_syms] - - # (new_ins_type, gs_heaps) = - //build_instance_type ins_type kind {glob_module=ins_generic.glob_module, glob_object=kind_star_class_def_sym} gs_heaps - build_instance_type1 - ins_type - glob_arg_class_def_syms - glob_kind_star_class_def_sym - gs_heaps - - # gs = {gs & gs_modules=gs_modules, gs_td_infos = gs_td_infos, gs_heaps = gs_heaps} - # (fun_index, group_index, gs) = newFunAndGroupIndex gs - # fun_def_sym = { - ds_ident = kind_star_class_def.class_ident, // kind star name - ds_index = fun_index, - ds_arity = member_def.me_type.st_arity - } - - //# (fun_def, gs) = build_dummy_instance fun_def_sym group_index gs - # generic_def_sym = { - ds_ident=generic_def.gen_ident, - ds_index=ins_generic.glob_object, - ds_arity=0 - } - # (fun_def, gs) = - //buildKindConstInstance fun_def_sym group_index ins_generic.glob_module generic_def_sym kind gs - buildKindConstInstance1 fun_def_sym group_index ins_generic.glob_module generic_def_sym kind_args gs - - # new_instance_def = { - ins_class = {glob_module = ins_generic.glob_module, glob_object = kind_star_class_def_sym}, - ins_ident = kind_star_class_def.class_ident, - ins_type = new_ins_type, - ins_members = {fun_def_sym}, - ins_specials = SP_None, - ins_pos = ins_pos, - ins_is_generic = True, - ins_generate = False, - ins_partial = False, - ins_generic = ins_generic - } - //---> fun_def - - = ([fun_def], [{group_members = [fun_index]}], [new_instance_def], gs) - - build_dummy_instance fun_def_sym group_index gs=:{gs_predefs, gs_heaps} - # (fun_def, gs_heaps) = buildUndefFunction fun_def_sym group_index gs_predefs gs_heaps - = (fun_def, {gs & gs_heaps = gs_heaps}) - - build_instance_type ins_type=:{it_vars, it_types, it_context} (KindArrow kinds) class_glob_def_sym heaps - #! type_var_names = ["a" +++ toString i \\ i <- [1 .. (length kinds)]] - #! (type_vars, heaps) = mapSt buildTypeVar type_var_names heaps - #! type_var_types = [TV tv \\ tv <- type_vars] - #! new_type_args = [makeAType t TA_Multi \\ t <- type_var_types] - - #! new_type = fill_type_args (hd it_types) new_type_args - with - fill_type_args (TA type_symb_ident=:{type_arity} type_args) new_type_args - #! type_arity = type_arity + length new_type_args - #! type_args = type_args ++ new_type_args - = TA {type_symb_ident & type_arity = type_arity} type_args - fill_type_args TArrow [arg_type, res_type] - = arg_type --> res_type - fill_type_args (TArrow1 arg_type) [res_type] - = arg_type --> res_type - - #! (new_contexts, heaps) = mapSt (build_type_context class_glob_def_sym) type_var_types heaps - - #! new_ins_type = { ins_type & - it_vars = it_vars ++ type_vars, - it_types = [new_type], - it_context = it_context ++ new_contexts - } - = (new_ins_type, heaps) - //---> new_ins_type - - build_instance_type1 ins_type=:{it_vars, it_types, it_context} arg_class_def_syms class_glob_def_sym heaps - #! type_var_names = ["a" +++ toString i \\ i <- [1 .. (length arg_class_def_syms)]] - #! (type_vars, heaps) = mapSt buildTypeVar type_var_names heaps - #! type_var_types = [TV tv \\ tv <- type_vars] - #! new_type_args = [makeAType t TA_Multi \\ t <- type_var_types] - - #! new_type = fill_type_args (hd it_types) new_type_args - with - fill_type_args (TA type_symb_ident=:{type_arity} type_args) new_type_args - #! type_arity = type_arity + length new_type_args - #! type_args = type_args ++ new_type_args - = TA {type_symb_ident & type_arity = type_arity} type_args - fill_type_args TArrow [arg_type, res_type] - = arg_type --> res_type - fill_type_args (TArrow1 arg_type) [res_type] - = arg_type --> res_type - - #! (new_contexts, heaps) - = mapSt build_type_context1 (zip2 arg_class_def_syms type_var_types) heaps - - #! new_ins_type = { ins_type & - it_vars = it_vars ++ type_vars, - it_types = [new_type], - it_context = it_context ++ new_contexts - } - = (new_ins_type, heaps) - //---> new_ins_type - - build_type_var name heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} - # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars - # type_var = { - tv_ident = {id_name = name, id_info = nilPtr}, - tv_info_ptr = tv_info_ptr - } - = ( type_var, {heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}) - - build_type_context class_glob_def_sym type heaps=:{hp_var_heap} - # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - # type_context = - { tc_class = class_glob_def_sym - , tc_types = [type] - , tc_var = var_info_ptr - } - = (type_context, {heaps & hp_var_heap = hp_var_heap}) - - build_type_context1 (class_def_sym, type) heaps=:{hp_var_heap} - # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - # type_context = - { tc_class = class_def_sym - , tc_types = [type] - , tc_var = var_info_ptr - } - = (type_context, {heaps & hp_var_heap = hp_var_heap}) - - -// for all generic instances determine and set types -// of their functions -determineMemberTypes :: !Index !Index !*GenericState - -> !*GenericState -determineMemberTypes module_index ins_index - gs=:{gs_modules, gs_fun_defs, gs_heaps=gs_heaps=:{hp_var_heap, hp_type_heaps}, gs_dcl_modules, gs_main_dcl_module_n} - #! (num_modules, gs_modules) = usize gs_modules - | module_index == num_modules - = {gs & gs_modules = gs_modules} - #! (common_defs=:{com_instance_defs}, gs_modules) = gs_modules![module_index] - | ins_index == size com_instance_defs - = determineMemberTypes (inc module_index) 0 {gs & gs_modules = gs_modules} - #! (instance_def, com_instance_defs) = com_instance_defs![ins_index] - | not instance_def.ins_is_generic - = determineMemberTypes module_index (inc ins_index) {gs & gs_modules = gs_modules} - - #! gs = determine_member_type module_index ins_index instance_def {gs & gs_modules = gs_modules} - = determineMemberTypes module_index (inc ins_index) gs -where - determine_member_type - module_index - ins_index - {ins_ident, ins_class, ins_type, ins_members} - gs=:{ gs_modules, - gs_fun_defs, - gs_heaps=gs_heaps=:{hp_var_heap, hp_type_heaps}, - gs_dcl_modules, - gs_main_dcl_module_n, - gs_opt_dcl_icl_conversions, - gs_error} - - #! (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules - #! (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules - #! {me_type, me_class_vars} = member_def - - // determine type of the instance function - #! (symbol_type, _, hp_type_heaps, _, gs_error) = - determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None hp_type_heaps No gs_error - #! (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap - #! symbol_type = {symbol_type & st_context = st_context} - - // determine the instance function index (in icl or dcl) - #! fun_index = ins_members.[0].ds_index - | fun_index == NoIndex - = abort "no generic instance function\n" - - // update the instance function - | module_index == gs_main_dcl_module_n // icl module - #! (fun_def, gs_fun_defs) = gs_fun_defs![fun_index] - #! fun_def = { fun_def & fun_type = Yes symbol_type } - #! gs_fun_defs = {gs_fun_defs & [fun_index] = fun_def} - - // update corresponding DCL function type, which is empty at the moment -// #! (gs_dcl_modules) = gs_dcl_modules ! [gs_main_dcl_module_n] - #! (dcl_fun_index, gs_opt_dcl_icl_conversions) - = find_dcl_fun_index fun_index gs_opt_dcl_icl_conversions// XXX - with - find_dcl_fun_index icl_fun_index No - = (NoIndex /*abort "no dcl_icl conversions table\n"*/, No) - find_dcl_fun_index icl_fun_index (Yes table) - #! table1 = {x\\x<-:table} - = find_index 0 icl_fun_index table - find_index i index table - #! (size_table, table) = usize table - | i == size_table - = (NoIndex /*abort ("not found dcl function index " +++ toString index)*/, Yes table) - #! (x, table) = table ! [i] - | x == index - = (i /*abort ("found dcl function index " +++ toString index +++ " " +++ toString i)*/, Yes table) - = find_index (inc i) index table - - - #! gs_dcl_modules = case dcl_fun_index of - NoIndex -> gs_dcl_modules - _ -> update_dcl_fun_type gs_main_dcl_module_n dcl_fun_index symbol_type gs_dcl_modules - - = { gs - & gs_modules = gs_modules - , gs_fun_defs = gs_fun_defs - , gs_dcl_modules = gs_dcl_modules - , gs_opt_dcl_icl_conversions = gs_opt_dcl_icl_conversions - , gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} - , gs_error = gs_error - } - - | otherwise // dcl module - //---> ("update dcl instance function", ins_ident, module_index, ins_index, symbol_type) - #! gs_dcl_modules = update_dcl_fun_type module_index fun_index symbol_type gs_dcl_modules - = { gs - & gs_modules = gs_modules - , gs_dcl_modules = gs_dcl_modules - , gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} - , gs_error = gs_error - } - - update_dcl_fun_type module_index fun_index symbol_type dcl_modules - # (dcl_module=:{dcl_functions}, dcl_modules) = dcl_modules ! [module_index] - # (dcl_fun, dcl_functions) = dcl_functions ! [fun_index] - # dcl_fun = - { dcl_fun - & ft_arity = symbol_type.st_arity - , ft_type = symbol_type - } - # dcl_functions = {{x \\ x <-: dcl_functions} & [fun_index] = dcl_fun} - # dcl_module={dcl_module & dcl_functions = dcl_functions} - = {dcl_modules & [module_index] = dcl_module} - - -kindOfTypeDef :: Index Index !*TypeDefInfos -> (!TypeKind, !*TypeDefInfos) -kindOfTypeDef module_index td_index td_infos - #! ({tdi_kinds}, td_infos) = td_infos![module_index, td_index] - | isEmpty tdi_kinds - = (KindConst, td_infos) - = (KindArrow (tdi_kinds/* ++ [KindConst]*/), td_infos) - -kindOfType :: !Type !*TypeDefInfos -> (!TypeKind, !*TypeDefInfos) -kindOfType (TA type_cons args) td_infos - #! {glob_object,glob_module} = type_cons.type_index - #! ({tdi_kinds}, td_infos) = td_infos![glob_module,glob_object] - #! kinds = drop (length args) tdi_kinds - | isEmpty kinds - = (KindConst, td_infos) - = (KindArrow (kinds/* ++ [KindConst]*/), td_infos) -kindOfType TArrow td_infos - = (KindArrow [KindConst, KindConst/*, KindConst*/], td_infos) -kindOfType (TArrow1 _) td_infos - = (KindArrow [KindConst/*, KindConst*/], td_infos) -kindOfType (TV _) td_infos - = (KindConst, td_infos) -kindOfType (GTV _) td_infos - = (KindConst, td_infos) -kindOfType (TQV _) td_infos - = (KindConst, td_infos) -kindOfType _ td_infos - = (KindConst, td_infos) - -buildClassDef :: !Index !Index !Index !GenericDef !TypeKind !*GenericState - -> (!ClassDef, !MemberDef!, !GenericDef, *GenericState) -buildClassDef module_index class_index member_index generic_def=:{gen_ident, gen_classes} kind gs=:{gs_heaps} - #! ident = makeIdent (gen_ident.id_name +++ ":" +++ (toString kind)) - #! class_ds={ds_ident=ident, ds_index=class_index, ds_arity=0} - #! (class_var, gs_heaps) = build_class_var gs_heaps - #! (member_def, class_contexts, gs_heaps) = build_member module_index class_index member_index class_var class_ds generic_def gs_heaps - #! class_def = build_class module_index class_index member_index class_var kind ident generic_def member_def class_contexts - #! generic_def = { generic_def & gen_classes = [{gci_kind=kind,gci_class=class_ds}:gen_classes]} - = (class_def, member_def, generic_def, {gs & gs_heaps = gs_heaps}) - //---> ("generated class " +++ ident.id_name) -where - - build_class_var heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} - #! (class_var, th_vars) = freshTypeVar (makeIdent "class_var") th_vars - =(class_var, {heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}) - - build_member - module_index class_index member_index - class_var class_ds=:{ds_ident} generic_def=:{gen_type} - heaps=:{hp_var_heap, hp_type_heaps} - #! (type_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - #! (tc_var_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - #! type_context = - { tc_class = {glob_module = module_index, glob_object=class_ds} - , tc_types = [ TV class_var ] - , tc_var = tc_var_ptr - } - #! (member_type, class_contexts, hp_type_heaps, hp_var_heap) = buildMemberType2 generic_def kind class_var hp_type_heaps hp_var_heap - //#! member_type = { member_type & st_context = [type_context : gen_type.gt_type.st_context] } - #! member_type = { member_type & st_context = [type_context : member_type.st_context] } - #! member_def = { - me_ident = ds_ident, // same name as class - me_class = {glob_module = module_index, glob_object = class_index}, - me_offset = 0, - me_type = member_type, - me_type_ptr = type_ptr, // empty - me_class_vars = [class_var], // the same variable as in the class - me_pos = generic_def.gen_pos, - me_priority = NoPrio - } - //---> ("member_type", member_type) - = (member_def, class_contexts, {heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap}) - - build_class - module_index class_index member_index class_var kind ident - generic_def=:{gen_pos} member_def=:{me_type} class_contexts - #! class_member = {ds_ident=ident, ds_index = member_index, ds_arity = me_type.st_arity} - #! class_dictionary = { - ds_ident = ident, - ds_arity = 0, - ds_index = NoIndex/*index in the type def table, filled in later*/ - } - #! class_def = { - class_ident = ident, - class_arity = 1, - class_args = [class_var], - class_context = class_contexts, - class_pos = gen_pos, - class_members = createArray 1 class_member, - class_cons_vars = 0, // dotted class variables - class_dictionary = class_dictionary, - class_arg_kinds = [kind] - } - - = class_def - -currySymbolType1 :: !SymbolType !String !*TypeHeaps - -> (!AType, ![AttributeVar], ![AttrInequality], !*TypeHeaps) -currySymbolType1 {st_args=[], st_result} attr_var_name th - = (st_result, [], [], th) -currySymbolType1 {st_args, st_result} attr_var_name th=:{th_attrs} - // TA_None indicates top-level attribute - #! (at, attr_vars, ais, index, th_attrs) = curry_type st_args st_result TA_None 0 th_attrs - = (at, attr_vars, ais, {th & th_attrs = th_attrs}) -where - curry_type [] type cum_attr index th_attrs - = (type, [], [], index, th_attrs) - curry_type [at=:{at_attribute}] type cum_attr index th_attrs - #! t = makeAType (at --> type) (if (cum_attr == TA_None) TA_Multi cum_attr) - = (t, [], [], index, th_attrs) - curry_type [at=:{at_attribute}:ats] type cum_attr index th_attrs - #! (next_cum_attr, avs1, ais1, index, th_attrs) = combine_attributes at_attribute cum_attr index th_attrs - #! (res_type, avs2, ais2, index, th_attrs) = curry_type ats type next_cum_attr index th_attrs - #! t = makeAType (at --> res_type) cum_attr - = (t, avs1 ++ avs2, ais1 ++ ais2, index, th_attrs) - - combine_attributes TA_Unique cum_attr index th_attrs - = (TA_Unique, [], [], index, th_attrs) - combine_attributes (TA_Var av) (TA_Var cum_av) index th_attrs - #! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++ /*"_"+++*/ toString index)) th_attrs - #! ais = [ - {ai_offered=new_av, ai_demanded=av}, - {ai_offered=new_av, ai_demanded=cum_av}] - = (TA_Var new_av, [new_av], ais, (inc index), th_attrs) - combine_attributes (TA_Var av) TA_None index th_attrs - #! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++ /*"_"+++*/ toString index)) th_attrs - = (TA_Var new_av, [new_av], [{ai_offered=new_av, ai_demanded=av}], (inc index), th_attrs) - combine_attributes (TA_Var _) cum_attr index th_attrs - = (cum_attr, [], [], index, th_attrs) - combine_attributes _ (TA_Var cum_av) index th_attrs - #! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++ /*"_"+++*/ toString index)) th_attrs - = (TA_Var new_av, [new_av], [{ai_offered=new_av, ai_demanded=cum_av}], (inc index), th_attrs) - combine_attributes _ TA_None index th_attrs - #! (new_av, th_attrs) = freshAttrVar (makeIdent (attr_var_name+++ /*"_"+++*/ toString index)) th_attrs - = (TA_Var new_av, [new_av], [], (inc index), th_attrs) - combine_attributes _ cum_attr index th_attrs - = (cum_attr, [], [], index, th_attrs) - - -currySymbolType2 :: !SymbolType !String !*TypeHeaps - -> (!SymbolType, !*TypeHeaps) -currySymbolType2 st attr_var_name th - #! (atype, avs, ais, th) = currySymbolType1 st attr_var_name th - #! st = { st - & st_args = [] - , st_arity = 0 - , st_result = atype - , st_attr_env = st.st_attr_env ++ ais - , st_attr_vars = st.st_attr_vars ++ avs - } - = (st, th) - -buildCurriedType :: ![AType] !AType !TypeAttribute ![AttrInequality] ![AttributeVar] !String !Int !*AttrVarHeap - -> (!AType, ![AttrInequality], ![AttributeVar], !Int, !*AttrVarHeap) -buildCurriedType [] type cum_attr attr_env attr_vars attr_var_name attr_store th_attrs - = (type, attr_env, attr_vars, attr_store, th_attrs) -buildCurriedType [at=:{at_attribute}] type cum_attr attr_env attr_vars attr_var_name attr_store th_attrs - # atype = {at_attribute = cum_attr , at_type = at --> type } - = (atype, attr_env, attr_vars, attr_store, th_attrs) -buildCurriedType [at=:{at_attribute}:ats] type cum_attr attr_env attr_vars attr_var_name attr_store th_attrs - # (next_cum_attr, new_attr_env, attr_vars, attr_store, th_attrs) = combine_attributes at_attribute cum_attr attr_env attr_vars attr_store th_attrs - (res_type, attr_env, attr_vars, attr_store, th_attrs) = buildCurriedType ats type next_cum_attr attr_env attr_vars attr_var_name attr_store th_attrs - # atype = {at_attribute = cum_attr , at_type = at --> res_type } - = (atype, attr_env, attr_vars, attr_store, th_attrs) -where - combine_attributes TA_Unique cum_attr attr_env attr_vars attr_store th_attrs - = (TA_Unique, attr_env, attr_vars, attr_store, th_attrs) - combine_attributes (TA_Var attr_var) (TA_Var cum_attr_var) attr_env attr_vars attr_store th_attrs - #! (new_attr_var, th_attrs) - = freshAttrVar (makeIdent (attr_var_name +++ toString attr_store)) th_attrs - # attr_env = - [ { ai_demanded = cum_attr_var,ai_offered = new_attr_var } - , { ai_demanded = attr_var, ai_offered = new_attr_var } - : attr_env - ] - = ( TA_Var new_attr_var, attr_env, [new_attr_var:attr_vars], inc attr_store, th_attrs) - combine_attributes (TA_Var _) cum_attr attr_env attr_vars attr_store th_attrs - = (cum_attr, attr_env, attr_vars, attr_store, th_attrs) - combine_attributes _ (TA_Var cum_attr_var) attr_env attr_vars attr_store th_attrs - #! (new_attr_var, th_attrs) - = freshAttrVar (makeIdent (attr_var_name +++ toString attr_store)) th_attrs - # attr_env = [ { ai_demanded = cum_attr_var,ai_offered = new_attr_var }: attr_env] - = ( TA_Var new_attr_var, attr_env, [new_attr_var:attr_vars], inc attr_store, th_attrs) - combine_attributes _ cum_attr attr_env attr_vars attr_store th_attrs - = (cum_attr, attr_env, attr_vars, attr_store, th_attrs) - -currySymbolType3 :: !SymbolType !String !*TypeHeaps - -> (!SymbolType, !*TypeHeaps) -currySymbolType3 st=:{st_args, st_result, st_attr_env, st_attr_vars} attr_var_name th=:{th_attrs} - - #! (cum_attr_var, th_attrs) = freshAttrVar (makeIdent (attr_var_name +++ "0")) th_attrs - - #! attr_env = foldSt (build_attr_env cum_attr_var) st_args st_attr_env - - #! (atype, attr_env, attr_vars, attr_store, th_attrs) - = buildCurriedType st_args st_result (TA_Var cum_attr_var) attr_env st_attr_vars attr_var_name 1 th_attrs - - # curried_st = - { st - & st_args = [] - , st_arity = 0 - , st_result = atype - , st_attr_env = attr_env - , st_attr_vars = [cum_attr_var:attr_vars] - } - = (curried_st, {th & th_attrs = th_attrs}) - //---> ("currySymbolType3", st, curried_st) -where - - build_attr_env cum_attr_var {at_attribute=(TA_Var attr_var)} attr_env - = [{ ai_demanded = attr_var, ai_offered = cum_attr_var } : attr_env ] - build_attr_env cum_attr_var _ attr_env - = attr_env - - -currySymbolType4 :: !SymbolType !String !*TypeHeaps - -> (!SymbolType, !*TypeHeaps) -currySymbolType4 st=:{st_args, st_result, st_attr_env, st_attr_vars} attr_var_name th=:{th_attrs} - - #! (atype, attr_env, attr_vars, attr_store, th_attrs) - = buildCurriedType st_args st_result TA_Multi st_attr_env st_attr_vars attr_var_name 1 th_attrs - - # curried_st = - { st - & st_args = [] - , st_arity = 0 - , st_result = atype - , st_attr_env = attr_env - , st_attr_vars = attr_vars - } - = (curried_st, {th & th_attrs = th_attrs}) - //---> ("currySymbolType4", st, curried_st) - - -// specialize generic (kind-indexed) type for a kind -specializeGenericType :: !GenericDef !TypeKind !*TypeHeaps -> (!SymbolType, ![ATypeVar], ![AttributeVar], !*TypeHeaps) -specializeGenericType generic_def=:{gen_ident,gen_type} kind th - - //#! th = th ---> ("specializeSymbolType", kind, gen_type.gt_type) - - #! (gen_type, th) = freshGenericType gen_type th - - #! (agvs, gavs, th) = collect_gtv_attrs gen_type th - - #! (st, _, th) = build_symbol_type gen_type.gt_type agvs kind "" 1 th - - #! st = - { st - & st_vars = removeDup st.st_vars - , st_attr_vars = removeDup st.st_attr_vars - , st_attr_env = removeDup st.st_attr_env - , st_context = removeDup st.st_context - } - - # th = clearSymbolType st th - - = (st, agvs, gavs, th) - //---> ("specializeGenericType result", kind, st) -where - - // collect generic variables and withe attributes - // and generic attribute variables - collect_gtv_attrs :: GenericType !*TypeHeaps -> !(![ATypeVar], ![AttributeVar], !*TypeHeaps) - collect_gtv_attrs {gt_type, gt_vars} th - #! th = clearSymbolType gt_type th - #! th = setTypeVarAttrs gt_type th - #! (attributed_vars, (avs, th)) = mapSt get_attr gt_vars ([], th) - = (attributed_vars, avs, th) - where - get_attr tv=:{tv_info_ptr} (avs, th=:{th_vars}) - #! (TVI_Attribute attr, th_vars) = readPtr tv_info_ptr th_vars - #! avs = case attr of - (TA_Var av) -> [av:avs] - _ -> avs - #! th = {th & th_vars = th_vars} - = ( {atv_attribute=attr, atv_variable=tv}, - (avs, th)) - - - build_symbol_type :: SymbolType ![ATypeVar] !TypeKind !String !Int !*TypeHeaps - -> !(!SymbolType, ![ATypeVar], !*TypeHeaps) - build_symbol_type st agvs KindConst postfix order th - #! st = { st & st_vars = [atv_variable \\ {atv_variable}<- agvs] ++ st.st_vars } - = (st, [], th) - //---> ("build_symbol_type KindConst", st, order) - - build_symbol_type st agvs (KindArrow kinds) postfix order th - - | order > 2 - = abort "kinds of order higher then 2 are not supported" - - //#! th = th ---> ("build_symbol_type for st", (KindArrow kinds, order, postfix), agvs, st) - - #! gvs = [atv_variable \\ {atv_variable} <- agvs] - #! gavs = [av \\ {atv_attribute=TA_Var av} <- agvs] - - #! arity = length kinds - - // build lifting argumnents - #! (args, th) = mapSt (build_arg agvs st postfix order) (zip2 kinds [1..arity]) th - #! (curry_sts, atvss) = unzip args - - #! th = clearSymbolType st th - #! th = foldSt build_gv_subst (zip2 gvs (transpose atvss)) th - #! th = foldSt subst_av_for_self (st.st_attr_vars ++ gavs) th - - #! (new_st, th) = substituteInSymbolType st th - #! th = clearSymbolType st th - #! th = clearSymbolType new_st th - - #! new_st = - { new_st - & st_vars = - foldr (++) (new_st.st_vars ++ gvs) [st_vars \\ {st_vars} <- curry_sts] - , st_attr_vars = - foldr (++) (new_st.st_attr_vars ++ gavs) [st_attr_vars \\ {st_attr_vars} <- curry_sts] - //, st_attr_env = - // foldr (++) new_st.st_attr_env [st_attr_env \\ {st_attr_env} <- curry_sts] - , st_args = - [st_result \\ {st_result} <- curry_sts] ++ new_st.st_args - , st_arity = new_st.st_arity + arity - , st_context = foldr (++) new_st.st_context [st_context \\ {st_context} <- curry_sts] - } - = (new_st, flatten atvss, th) - //---> ("build_symbol_type new st", (KindArrow kinds, order), new_st) - where - build_gv_subst (gv=:{tv_info_ptr}, atvs) th=:{th_vars} - #! type_args = [ makeAType (TV atv_variable) atv_attribute \\ {atv_variable, atv_attribute} <- atvs] - #! type = (CV gv) :@: type_args - #! th_vars = th_vars <:= (tv_info_ptr, TVI_Type type) - = {th & th_vars = th_vars} - - build_arg :: ![ATypeVar] !SymbolType !String !Int !(!TypeKind, !Int) !*TypeHeaps - -> !(!(!SymbolType, ![ATypeVar]), !*TypeHeaps) - build_arg agvs st postfix order (kind, arg_num) th - - //#! th = th ---> ("build_arg for st", (kind, arg_num, order), st) - - #! postfix = toString arg_num - #! gavs = [av \\ {atv_attribute=TA_Var av} <- agvs] - - #! th = clearSymbolType st th - #! th = foldSt subst_av_for_self (st.st_attr_vars ++ gavs) th - #! (fresh_atvs, th) = mapSt (fresh_agv postfix) agvs th - #! (fresh_st, th) = substituteInSymbolType st th - #! th = clearSymbolType st th - #! th = clearSymbolType fresh_st th - - #! fresh_avs = [av \\ {atv_attribute=TA_Var av} <- fresh_atvs] - #! fresh_st = - { fresh_st - & st_attr_vars = fresh_st.st_attr_vars ++ fresh_avs - } - - #! (fresh_st, forall_atvs, th) = build_symbol_type fresh_st fresh_atvs kind postfix (inc order) th - - //#! (curry_st, th) = currySymbolType2 fresh_st ("cur" +++ postfix) th - #! (curry_st, th) = currySymbolType4 fresh_st ("cur" +++ toString order +++ postfix) th - - #! curry_st = case forall_atvs of - [] -> curry_st - forall_atvs - # (atype=:{at_type}) = curry_st.st_result - -> - { curry_st - & st_result = {atype & at_type = TFA forall_atvs at_type} - , st_attr_vars = curry_st.st_attr_vars -- [av \\ {atv_attribute=TA_Var av} <- forall_atvs] - , st_vars = curry_st.st_vars -- [atv_variable \\ {atv_variable} <- forall_atvs] - } - - = ((curry_st, fresh_atvs), th) - //---> ("build_arg curry_st", (kind, arg_num, order), curry_st) - - where - - fresh_agv postfix agv=:{atv_attribute, atv_variable} th=:{th_attrs, th_vars} - #! (tv, th_vars) = fresh_tv atv_variable postfix th_vars - #! (attr, th_attrs) = fresh_attr atv_attribute postfix th_attrs - = ({agv & atv_attribute = attr, atv_variable = tv}, {th & th_vars = th_vars, th_attrs = th_attrs}) - where - fresh_tv {tv_ident, tv_info_ptr} postfix th_vars - #! name = makeIdent (tv_ident.id_name +++ postfix) - #! (tv, th_vars) = freshTypeVar name th_vars - #! th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TV tv)) - = (tv, th_vars) - - fresh_attr (TA_Unique) postfix th_attrs = (TA_Unique, th_attrs) - fresh_attr (TA_Multi) postfix th_attrs = (TA_Multi, th_attrs) - fresh_attr (TA_Var av=:{av_ident, av_info_ptr}) postfix th_attrs - #! (fresh_av, th_attrs) = freshAttrVar (makeIdent (av_ident.id_name+++postfix)) th_attrs - #! attr = TA_Var fresh_av - #! th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr attr) - = (attr, th_attrs) - - subst_av_for_self av=:{av_info_ptr} th=:{th_attrs} - = {th & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var av))} - -buildMemberType2 :: !GenericDef !TypeKind !TypeVar !*TypeHeaps !*VarHeap -> (!SymbolType, ![TypeContext], !*TypeHeaps, !*VarHeap) -buildMemberType2 generic_def=:{gen_ident,gen_type} kind class_var th var_heap - - # (st, agvs, gavs, th) = specializeGenericType generic_def kind th - - #! (st, th) = replace_gvs_with_class_var st agvs class_var kind th - #! (st, th) = adjust_gavs st gavs kind th - #! st = - { st - & st_vars = removeDup st.st_vars - , st_attr_vars = removeDup st.st_attr_vars - , st_attr_env = removeDup st.st_attr_env - , st_context = removeDup st.st_context - } - #! (st_context, class_contexts, var_heap) = adjust_contexts st.st_context class_var kind var_heap - #! st = {st & st_context = st_context} - - # th = clearSymbolType st th - - = (st, class_contexts, th, var_heap) -where - replace_gvs_with_class_var :: !SymbolType ![ATypeVar] !TypeVar !TypeKind !*TypeHeaps - -> (!SymbolType, !*TypeHeaps) - replace_gvs_with_class_var st agvs class_var kind th - - #! gvs = [atv_variable \\ {atv_variable} <- agvs] - - #! th = clearSymbolType st th - #! th = foldSt subst_av_for_self st.st_attr_vars th - #! th = foldSt (build_subst class_var) gvs th - with - build_subst class_var {tv_info_ptr} th=:{th_vars} - #! th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TV class_var)) - = {th & th_vars = th_vars} - #! (new_st, th) = substituteInSymbolType st th - #! (st_vars, th) = remove_gvs new_st.st_vars th - with - remove_gvs [] th = ([], th) - remove_gvs [tv:tvs] th=:{th_vars} - #! (tv_info, th_vars) = readPtr tv.tv_info_ptr th_vars - #! (tvs, th) = remove_gvs tvs {th & th_vars = th_vars} - #! tvs = case tv_info of - TVI_Empty -> [tv:tvs] - (TVI_Type _) -> tvs - _ -> (abort "wrong TVI_?") ---> ("remove_gvs ", tv) - = (tvs, th) - #! new_st = { new_st & st_vars = [class_var : st_vars] } - #! th = clearSymbolType st th - #! th = clearSymbolType new_st th - = (new_st, th) - - adjust_gavs st [gav:gavs] KindConst th - - #! th = clearSymbolType st th - #! th = foldSt subst_av_for_self st.st_attr_vars th - #! th = foldSt (subst_for_av gav) gavs th - with - subst_for_av gav {av_info_ptr} th=:{th_attrs} - = {th & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var gav))} - #! (new_st, th) = substituteInSymbolType st th - #! th = clearSymbolType st th - #! th = clearSymbolType new_st th - - #! th = foldSt mark_av gavs th - with - mark_av {av_info_ptr} th=:{th_attrs} - = {th & th_attrs = th_attrs <:= (av_info_ptr, AVI_Used)} - #! (st_attr_vars, th) = remove_avs new_st.st_attr_vars th - with - remove_avs [] th = ([], th) - remove_avs [av:avs] th=:{th_attrs} - #! (av_info, th_attrs) = readPtr av.av_info_ptr th_attrs - #! (avs, th) = remove_avs avs {th & th_attrs = th_attrs } - #! avs = case av_info of - AVI_Empty -> [av:avs] - AVI_Used -> avs - _ -> (abort "wrong AVI_") ---> ("remove_avs ", av) - = (avs, th) - - #! th = clearSymbolType new_st th - - = (new_st, th) - adjust_gavs st gavs kind th - = (st, th) - - adjust_contexts contexts class_var kind var_heap - #! (contexts, class_contexts, var_heap) = split_contexts contexts var_heap - #! class_contexs = case kind of - KindConst -> class_contexts - _ -> [] // just drop them - = (contexts, class_contexts, var_heap) - where - - // split contexts into involving and not invloving class variables - split_contexts [] var_heap - = ([], [], var_heap) - split_contexts [context:contexts] var_heap - #! (contexts1, class_contexts1, var_heap) = split_context context var_heap - #! (contexts2, class_contexts2, var_heap) = split_contexts contexts var_heap - = (contexts1 ++ contexts2, class_contexts1 ++ class_contexts2, var_heap) - split_context tc=:{tc_class, tc_types, tc_var} var_heap - #! (types, class_types) = split_types tc_types - #! (tc_var, var_heap) = case isNilPtr tc_var of - True -> newPtr VI_Empty var_heap - False -> (tc_var, var_heap) - #! tc = {tc & tc_var = tc_var} - | isEmpty types - = ([], [tc], var_heap) - | isEmpty class_types - = ([tc], [], var_heap) - | otherwise - #! tc = {tc & tc_types = types} - #! (tc_var, var_heap) = newPtr VI_Empty var_heap - #! class_tc = {tc & tc_types = class_types, tc_var = tc_var} - = ([tc], [class_tc], var_heap) - - split_types [] - = ([], []) - split_types [type:types] - # (types1, class_types1) = split_type type - # (types2, class_types2) = split_types types - = (types1 ++ types2, class_types1 ++ class_types2) - split_type type - #! contains_class_var = performOnTypeVars (\attr tv ok -> ok || tv == class_var) type False - | contains_class_var - = ([], [type]) - = ([type], []) - - subst_av_for_self av=:{av_info_ptr} th=:{th_attrs} - = {th & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var av))} - - -buildMemberType :: !GenericDef !TypeKind !TypeVar !*TypeHeaps -> (!SymbolType, !*TypeHeaps) -buildMemberType generic_def=:{gen_ident,gen_type} kind class_var th -// = abort "generics; buildMemberType" - - #! (gen_type, th) = freshGenericType gen_type th - - // Collect attributes of generic variables. - // The attributes are instantiated along with the variables. - #! (gen_vars_with_attrs, generic_avs, th) = collect_generic_var_attrs gen_type th - - // build additional arguments that emerge due to lifting - #! (new_args, atvss, new_avs, attr_inequalities, th) = build_args gen_type gen_vars_with_attrs kind th - - #! atvss = case atvss of - [] -> repeatn gen_type.gt_arity [] - atvss -> transpose atvss - - // substitute generic variables for types - // all non-generic variables must be left intact - #! th = clearSymbolType gen_type.gt_type th - #! th = build_generic_var_substs gen_vars_with_attrs class_var atvss kind th -// #! th = build_attr_var_substs gen_type.gt_type.st_attr_vars generic_avs kind th - #! (avs1, th) = build_attr_var_substs gen_type.gt_type.st_attr_vars generic_avs kind th - #! (st, th) = substituteInSymbolType gen_type.gt_type th - - // update generated fields - #! instantiation_tvs = [atv_variable \\ {atv_variable} <- (flatten atvss)] - #! st = { st & - st_vars = [class_var : instantiation_tvs ++ st.st_vars] - , st_arity = (length new_args) + st.st_arity - , st_args = new_args ++ st.st_args -// , st_attr_vars = st.st_attr_vars ++ new_avs - , st_attr_vars = avs1 ++ new_avs - , st_attr_env = st.st_attr_env ++ attr_inequalities - } - - = (st, th) - //---> ("member type", gen_ident, kind, st) - -where - - collect_generic_var_attrs {gt_type, gt_vars} th - #! th = clearSymbolType gt_type th - #! th = setTypeVarAttrs gt_type th - - #! (attributed_vars, (avs, th)) = mapSt get_attr gt_vars ([], th) - with - get_attr tv=:{tv_info_ptr} (avs, th=:{th_vars}) - #! (TVI_Attribute attr, th_vars) = readPtr tv_info_ptr th_vars - #! avs = (collect_attr_var attr) ++ avs - #! th = {th & th_vars = th_vars} - = ( {atv_attribute=attr, atv_variable=tv}, - (avs, th)) - collect_attr_var (TA_Var av) = [av] - collect_attr_var _ = [] - - = (attributed_vars, avs, th) - -/* - build_attr_var_substs avs generic_avs kind th - = foldSt build_subst (determine_attr_vars kind avs generic_avs) th - where - determine_attr_vars KindConst avs generic_avs - = removeMembers avs generic_avs - determine_attr_vars kind avs generic_avs - = avs - build_subst av=:{av_info_ptr} th=:{th_attrs} - = { th & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var av))} -*/ - build_attr_var_substs avs [] KindConst th - = (avs, foldSt build_attr_var_subst avs th) - build_attr_var_substs avs generic_avs KindConst th - # nongeneric_avs = avs -- generic_avs - - # {th_attrs} = th - # (gen_av, th_attrs) = freshAttrVar (makeIdent "gav") th_attrs - # new_generic_avs = repeatn (length generic_avs) gen_av - - // substitute generic var attributes with single attr var - # th = foldSt build_subst generic_avs {th & th_attrs = th_attrs} - with - build_subst {av_info_ptr} th=:{th_attrs} - = { th & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var gen_av))} - - # th = foldSt build_attr_var_subst nongeneric_avs th - = (nongeneric_avs ++ new_generic_avs, th) - build_attr_var_substs avs generic_avs kind th - = (avs, foldSt build_attr_var_subst avs th) - build_attr_var_subst av=:{av_info_ptr} th=:{th_attrs} - = { th & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var av))} - - build_generic_var_substs [] class_var [] kind th - = th - build_generic_var_substs [gv:gvs] class_var [tvs:tvss] kind th - # th = build_generic_var_subst gv class_var tvs kind th - # th = build_generic_var_substs gvs class_var tvss kind th - = th - - build_generic_var_subst {atv_variable={tv_info_ptr}} class_var [] KindConst th=:{th_vars} - #! th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TV class_var)) - = {th & th_vars = th_vars} - build_generic_var_subst {atv_variable={tv_info_ptr}} class_var atvs (KindArrow ks) th=:{th_vars} - #! arity = length ks - | arity <> length atvs = abort "sanity check: invalid number of type variables" - - #! type_args = [ makeAType (TV atv_variable) atv_attribute \\ {atv_variable, atv_attribute} <- atvs] - #! type = (CV class_var) :@: type_args - #! th_vars = th_vars <:= (tv_info_ptr, TVI_Type type) - = {th & th_vars = th_vars} - - build_args gen_type agvs KindConst th - = ([], [], [], [], th) - build_args gen_type agvs (KindArrow ks) th - #! arity = length ks - #! postfixes = [/*"_" +++*/ toString i \\ i <- [1..arity]] - #! (ats, atvss, new_avs, ais, th) = build_generic_args gen_type agvs postfixes th - = (ats, atvss, new_avs, ais, th) - - build_generic_args :: !GenericType ![ATypeVar] ![String] !*TypeHeaps - -> (![AType], ![[ATypeVar]], ![AttributeVar], ![AttrInequality], !*TypeHeaps) - build_generic_args gen_type agvs [] th - = ([], [], [], [], th) - build_generic_args gen_type agvs [postfix:postfixes] th - #! (at, atvs, new_avs, ais, th) = build_generic_arg gen_type agvs postfix th - #! (ats, atvss, new_avs1, ais1, th) = build_generic_args gen_type agvs postfixes th - = ([at:ats], [atvs:atvss], new_avs ++ new_avs1, ais ++ ais1, th) - - build_generic_arg :: !GenericType ![ATypeVar] !String !*TypeHeaps - -> (!AType, ![ATypeVar], ![AttributeVar], ![AttrInequality], !*TypeHeaps) - build_generic_arg {gt_type, gt_vars, gt_arity} agvs postfix th=:{th_vars, th_attrs} - #! th = clearSymbolType gt_type th - #! {th_vars, th_attrs} = th - - // replace all generic variables with fresh variables - #! (tvs, th_vars) = mapSt build_subst gt_vars th_vars - with - build_subst gv=:{tv_ident,tv_info_ptr} th_vars - #! name = makeIdent (tv_ident.id_name +++ postfix) - #! (tv, th_vars) = freshTypeVar name th_vars - #! th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TV tv)) - = (tv, th_vars) - - // leave all non-generic attribute variables intact - #! th_attrs = foldSt build_subst gt_type.st_attr_vars th_attrs - with - build_subst av=:{av_info_ptr} th_attrs - = th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var av)) - - // all attribute variables at generic arguments must be taken afresh - #! (attrs, (instantiated_avs, th_attrs)) = mapSt build_subst agvs ([], th_attrs) - with - build_subst {atv_attribute=TA_Unique} st = (TA_Unique, st) - build_subst {atv_attribute=TA_Multi} st = (TA_Multi, st) - build_subst {atv_attribute=TA_Var {av_ident, av_info_ptr}} (avs, th_attrs) - #! (fresh_av, th_attrs) = freshAttrVar (makeIdent (av_ident.id_name+++postfix)) th_attrs - #! attr = TA_Var fresh_av - #! th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr attr) - = (attr, ([fresh_av:avs], th_attrs)) - #! (st, th) = substituteInSymbolType gt_type {th & th_vars = th_vars, th_attrs = th_attrs} - - #! atvs = [{atv_attribute=attr, atv_variable=tv} \\ - attr <- attrs & - tv <- tvs] - - #! (at, curry_avs, ais, th) = currySymbolType1 st ("arg"+++postfix) th - #! th = clearSymbolType gt_type th - = (at, atvs, instantiated_avs ++ curry_avs, ais, th) - -buildGenericRepType :: !Index !Index !*GenericState - -> (AType, !*GenericState) -buildGenericRepType module_index td_index gs=:{gs_modules, gs_predefs, gs_error} - # (type_def=:{td_ident}, gs_modules) = getTypeDef module_index td_index gs_modules - # (common_defs, gs_modules) = gs_modules ! [module_index] - # (atype, gs_error) = build_type module_index type_def gs_predefs common_defs gs_error - = (atype, {gs & gs_modules = gs_modules, gs_error = gs_error}) -where - build_type td_module {td_rhs=(AlgType alts)} predefs common_defs error - = (build_sum alts predefs common_defs.com_cons_defs, error) - where - build_sum :: ![DefinedSymbol] !PredefinedSymbols !{#ConsDef} -> !AType - build_sum [] predefs cons_defs = abort "no alternatives in typedef" - build_sum [{ds_index}] predefs cons_defs - # cons_args = cons_defs.[ds_index].cons_type.st_args - # atype = buildProductType cons_args predefs - = case supportCons of - True -> buildATypeCONS atype predefs - False -> atype - build_sum alts predefs cons_defs - # (l,r) = splitAt ((length alts) / 2) alts - = buildATypeEITHER (build_sum l predefs cons_defs) (build_sum r predefs cons_defs) predefs - - build_type td_module {td_rhs=(RecordType {rt_constructor={ds_index}})} predefs common_defs error - #! {cons_type={st_args}} = common_defs . com_cons_defs . [ds_index] - #! atype = buildProductType st_args predefs - #! atype = case supportCons of - True -> buildATypeCONS atype predefs - False -> atype - = (atype, error) - - build_type td_module {td_rhs=(SynType type)} predefs common_defs error - = (type, error) // is that correct ??? - - build_type - td_module td=:{td_rhs=(AbstractType _), td_ident, td_arity, td_args, td_pos} - predefs common_defs error - #! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build generic type repesentation for an abstract type" error - = (makeAType TE TA_None, error) - -buildIsoRecord :: !DefinedSymbol !Int !DefinedSymbol !DefinedSymbol !*GenericState - -> (!FunDef, !*GenericState) -buildIsoRecord - def_sym group_index from_fun to_fun - gs=:{gs_heaps, gs_main_dcl_module_n, gs_predefs} - # (from_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n from_fun [] gs_heaps - # (to_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n to_fun [] gs_heaps - # (iso_expr, gs_heaps) = buildISO to_expr from_expr gs_predefs gs_heaps - # fun_def = makeFunction def_sym group_index [] iso_expr No [] gs_main_dcl_module_n NoPos - = (fun_def, {gs & gs_heaps = gs_heaps}) - -// convert a type to ot's generic representation -buildIsoTo :: !DefinedSymbol !Int !Int !CheckedTypeDef ![DefinedSymbol] !*GenericState - -> (!FunDef, !*GenericState) -buildIsoTo - def_sym group_index type_def_mod - type_def=:{td_rhs, td_ident, td_index, td_pos} - cons_infos - gs=:{gs_heaps,gs_main_dcl_module_n} - # (arg_expr, arg_var, gs_heaps) = buildVarExpr "x" gs_heaps - # (body_expr, free_vars, gs=:{gs_error}) = - build_body type_def_mod td_index td_rhs cons_infos arg_expr {gs&gs_heaps = gs_heaps} - | not gs_error.ea_ok - #! fun_def = makeFunction {def_sym&ds_arity=0} NoIndex [] EE No [] gs_main_dcl_module_n NoPos - = (fun_def, {gs & gs_error = gs_error}) - # fun_def = makeFunction def_sym group_index [arg_var] body_expr No free_vars gs_main_dcl_module_n NoPos - = (fun_def, {gs & gs_error = gs_error}) - //---> fun_def -where - get_cons_infos module_index td_index gs=:{gs_gtd_infos} - # (GTDI_Generic {gtr_cons_infos}, gs_gtd_infos) = gs_gtd_infos ! [module_index, td_index] - = (gtr_cons_infos, {gs & gs_gtd_infos = gs_gtd_infos}) - - build_body :: !Int !Int !TypeRhs ![DefinedSymbol] !Expression !*GenericState - -> (!Expression, ![FreeVar], !*GenericState) - build_body type_def_mod type_def_index (AlgType def_symbols) cons_infos arg_expr gs - = build_body1 type_def_mod type_def_index def_symbols cons_infos arg_expr gs - - build_body type_def_mod type_def_index (RecordType {rt_constructor}) cons_infos arg_expr gs - = build_body1 type_def_mod type_def_index [rt_constructor] cons_infos arg_expr gs - - build_body type_def_mod type_def_index (AbstractType _) cons_infos arg_expr gs=:{gs_error} - #! gs_error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for an abstract type" gs_error - = (EE, [], {gs & gs_error = gs_error}) - build_body type_def_mod type_def_index (SynType _) cons_infos arg_expr gs=:{gs_error} - #! gs_error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for a synonym type" gs_error - = (EE, [], {gs & gs_error = gs_error}) - - build_body1 type_def_mod type_def_index cons_def_syms cons_infos arg_expr gs - # (case_alts, free_vars, gs=:{gs_heaps}) = - build_alts 0 (length cons_def_syms) type_def_mod cons_def_syms cons_infos gs - # case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts - # (case_expr, gs_heaps) = buildCaseExpr arg_expr case_patterns gs_heaps - = (case_expr, free_vars, {gs & gs_heaps = gs_heaps}) - //---> (free_vars, case_expr) - - build_alts :: !Int !Int !Int ![DefinedSymbol] ![DefinedSymbol] !*GenericState - -> ([AlgebraicPattern], [FreeVar], !*GenericState) - build_alts i n type_def_mod [] [] gs = ([], [], gs) - build_alts i n type_def_mod [cons_def_sym:cons_def_syms] cons_infos gs - #! (cons_info, cons_infos) = case supportCons of - True -> (hd cons_infos, tl cons_infos) - False -> (EmptyDefinedSymbol, []) - #! (alt, fvs, gs) = build_alt i n type_def_mod cons_def_sym cons_info gs - #! (alts, free_vars, gs) = build_alts (i+1) n type_def_mod cons_def_syms cons_infos gs - = ([alt:alts], fvs ++ free_vars, gs) - - build_alt :: !Int !Int !Int !DefinedSymbol !DefinedSymbol !*GenericState - -> (AlgebraicPattern, [FreeVar], !*GenericState) - build_alt - i n type_def_mod def_symbol=:{ds_ident, ds_arity} cons_info - gs=:{gs_heaps, gs_predefs, gs_main_dcl_module_n} - #! names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]] - #! (var_exprs, vars, gs_heaps) = buildVarExprs names gs_heaps - #! (expr, gs_heaps) = build_prod var_exprs gs_predefs gs_heaps - #! (expr, gs_heaps) = case supportCons of - True - //# (cons_info_expr, gs_heaps) = buildUndefFunApp [] gs_predefs gs_heaps - # (cons_info_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n cons_info [] gs_heaps - -> buildCONS cons_info_expr expr gs_predefs gs_heaps - False - -> (expr, gs_heaps) - #! (expr, gs_heaps) = build_sum i n expr gs_predefs gs_heaps - - #! alg_pattern = { - ap_symbol = {glob_module = type_def_mod, glob_object = def_symbol}, - ap_vars = vars, - ap_expr = expr, - ap_position = NoPos - } - = (alg_pattern, vars, {gs & gs_heaps = gs_heaps}) - - build_sum :: !Int !Int !Expression !PredefinedSymbols !*Heaps -> (!Expression, !*Heaps) - build_sum i n expr predefs heaps - | n == 0 = abort "build sum of zero elements\n" - | i >= n = abort "error building sum" - | n == 1 = (expr, heaps) - | i < (n/2) - # (expr, heaps) = build_sum i (n/2) expr predefs heaps - = buildLEFT expr predefs heaps - | otherwise - # (expr, heaps) = build_sum (i - (n/2)) (n - (n/2)) expr predefs heaps - = buildRIGHT expr predefs heaps - - build_prod :: ![Expression] !PredefinedSymbols !*Heaps -> (!Expression, !*Heaps) - build_prod [] predefs heaps = buildUNIT predefs heaps - build_prod [expr] predefs heaps = (expr, heaps) - build_prod exprs predefs heaps - # (lexprs, rexprs) = splitAt ((length exprs)/2) exprs - # (lexpr, heaps) = build_prod lexprs predefs heaps - # (rexpr, heaps) = build_prod rexprs predefs heaps - = buildPAIR lexpr rexpr predefs heaps - -// convert from generic representation to type -buildIsoFrom :: !DefinedSymbol !Int !Int !CheckedTypeDef !*GenericState - -> (!FunDef, !*GenericState) -buildIsoFrom - def_sym group_index type_def_mod - type_def=:{td_rhs, td_ident, td_index, td_pos} - gs=:{gs_predefs, gs_heaps, gs_error,gs_main_dcl_module_n} - #! (body_expr, free_vars, gs_heaps, gs_error) = build_body type_def_mod td_rhs gs_predefs gs_heaps gs_error - | not gs_error.ea_ok - #! fun_def = makeFunction {def_sym&ds_arity=0} NoIndex [] EE No [] gs_main_dcl_module_n td_pos - = (fun_def, {gs & gs_heaps = gs_heaps, gs_error = gs_error} ) - #! fun_def = makeFunction def_sym group_index [hd free_vars] body_expr No (tl free_vars) gs_main_dcl_module_n td_pos - = (fun_def, {gs & gs_heaps = gs_heaps, gs_error = gs_error} ) - //---> fun_def -where - build_body :: !Int !TypeRhs !PredefinedSymbols !*Heaps !*ErrorAdmin - -> (!Expression, ![FreeVar], !*Heaps, !*ErrorAdmin) - build_body type_def_mod (AlgType def_symbols) predefs heaps error - = build_sum type_def_mod def_symbols predefs heaps error - build_body type_def_mod (RecordType {rt_constructor}) predefs heaps error - = build_sum type_def_mod [rt_constructor] predefs heaps error - build_body type_def_mod (AbstractType _) predefs heaps error - #! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for an abstract type" error - = (EE, [], heaps, error) - build_body type_def_mod (SynType _) predefs heaps error - #! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for a synonym type" error - = (EE, [], heaps, error) - - build_sum :: !Index [DefinedSymbol] !PredefinedSymbols !*Heaps !*ErrorAdmin - -> (!Expression, ![FreeVar], !*Heaps, !*ErrorAdmin) - build_sum type_def_mod [] predefs heaps error - = abort "algebraic type with no constructors!\n" - build_sum type_def_mod [def_symbol] predefs heaps error - #! (cons_app_expr, cons_args, heaps) = build_cons_app type_def_mod def_symbol heaps - #! (alt_expr, free_vars, heaps) = build_prod cons_app_expr cons_args predefs heaps - = case supportCons of - True - #! (var_expr, var, heaps) = buildVarExpr "c" heaps - #! (info_var, heaps) = buildFreeVar0 "i" heaps - #! (alt_expr, heaps) = buildCaseCONSExpr var_expr info_var (hd free_vars) alt_expr predefs heaps - -> (alt_expr, [var, info_var : free_vars], heaps, error) - False - -> (alt_expr, free_vars, heaps, error) - - build_sum type_def_mod def_symbols predefs heaps error - #! (var_expr, var, heaps) = buildVarExpr "e" heaps - #! (left_def_syms, right_def_syms) = splitAt ((length def_symbols) /2) def_symbols - - #! (left_expr, left_vars, heaps, error) = build_sum type_def_mod left_def_syms predefs heaps error - #! (right_expr, right_vars, heaps, error) = build_sum type_def_mod right_def_syms predefs heaps error - - #! (case_expr, heaps) = - buildCaseEITHERExpr var_expr (hd left_vars, left_expr) (hd right_vars, right_expr) predefs heaps - #! vars = [var : left_vars ++ right_vars] - = (case_expr, vars, heaps, error) - - build_prod :: !Expression ![FreeVar] !PredefinedSymbols !*Heaps - -> (!Expression, ![FreeVar], !*Heaps) - build_prod expr [] predefs heaps - #! (var_expr, var, heaps) = buildVarExpr "x" heaps - #! (case_expr, heaps) = buildCaseUNITExpr var_expr expr predefs heaps - = (case_expr, [var], heaps) - build_prod expr [cons_arg_var] predefs heaps - = (expr, [cons_arg_var], heaps) - build_prod expr cons_arg_vars predefs heaps - #! (var_expr, var, heaps) = buildVarExpr "p" heaps - #! (left_vars, right_vars) = splitAt ((length cons_arg_vars) /2) cons_arg_vars - - #! (expr, left_vars, heaps) = build_prod expr left_vars predefs heaps - #! (expr, right_vars, heaps) = build_prod expr right_vars predefs heaps - - #! (case_expr, heaps) = buildCasePAIRExpr var_expr (hd left_vars) (hd right_vars) expr predefs heaps - - #! vars = [var : left_vars ++ right_vars] - = (case_expr, vars, heaps) - - build_cons_app :: !Index !DefinedSymbol !*Heaps - -> (!Expression, [FreeVar], !*Heaps) - build_cons_app cons_mod def_symbol=:{ds_arity} heaps - #! names = ["x" +++ toString k \\ k <- [1..ds_arity]] - #! (var_exprs, vars, heaps) = buildVarExprs names heaps - #! (expr, heaps) = buildConsApp cons_mod def_symbol var_exprs heaps - = (expr, vars, heaps) - -buildIsomapFromTo :: !IsoDirection !DefinedSymbol !Int !Int !Int !*GenericState - -> (!FunDef, !Index, !*GenericState) -buildIsomapFromTo - iso_dir def_sym group_index type_def_mod type_def_index - gs=:{gs_heaps, gs_modules,gs_main_dcl_module_n} - #! (type_def=:{td_ident, td_index, td_arity, td_pos}, gs_modules) - = getTypeDef type_def_mod type_def_index gs_modules - #! arg_names = [ "i" +++ toString n \\ n <- [1 .. td_arity]] - #! (isomap_arg_vars, gs_heaps) = buildFreeVars arg_names gs_heaps - #! (arg_expr, arg_var, gs_heaps) = buildVarExpr "x" gs_heaps - #! gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules} - #! (body_expr, free_vars, gs) = - build_body iso_dir type_def_mod td_index type_def arg_expr isomap_arg_vars gs - - #! (fun_type, gs) = build_type1 iso_dir type_def_mod type_def_index gs - #! fun_def = makeFunction def_sym group_index (isomap_arg_vars ++ [arg_var]) body_expr (Yes fun_type) free_vars gs_main_dcl_module_n td_pos - = (fun_def, def_sym.ds_index, gs) - //---> ("isomap from/to", td_ident, fun_def) -where - build_body :: !IsoDirection !Int !Int !CheckedTypeDef !Expression ![FreeVar] !*GenericState - -> (Expression, [FreeVar], !*GenericState) - build_body iso_dir type_def_mod type_def_index type_def=:{td_rhs=(AlgType def_symbols)} arg_expr isomap_arg_vars gs - = build_body1 iso_dir type_def_mod type_def_index type_def def_symbols arg_expr isomap_arg_vars gs - - build_body iso_dir type_def_mod type_def_index type_def=:{td_rhs=(RecordType {rt_constructor})} arg_expr isomap_arg_vars gs - = build_body1 iso_dir type_def_mod type_def_index type_def [rt_constructor] arg_expr isomap_arg_vars gs - - build_body - iso_dir type_def_mod type_def_index - type_def=:{td_rhs=(AbstractType _),td_ident, td_pos} arg_expr isomap_arg_vars gs=:{gs_error} - #! gs_error = checkErrorWithIdentPos - (newPosition td_ident td_pos) - "cannot build map function for an abstract type" - gs_error - = (EE, [], {gs & gs_error = gs_error}) - - build_body - iso_dir type_def_mod type_def_index - type_def=:{td_rhs=(SynType _), td_ident, td_pos} arg_expr isomap_arg_vars gs=:{gs_error} - #! gs_error = checkErrorWithIdentPos - (newPosition td_ident td_pos) - "cannot build map function for a synonym type" - gs_error - = (EE, [], {gs & gs_error = gs_error}) - - build_body1 iso_dir type_def_mod type_def_index type_def def_symbols arg_expr isomap_arg_vars gs - #! (case_alts, free_vars, gs=:{gs_heaps}) = - build_alts iso_dir 0 (length def_symbols) type_def_mod def_symbols isomap_arg_vars type_def gs - #! case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts - #! (case_expr, gs_heaps) = buildCaseExpr arg_expr case_patterns gs_heaps - = (case_expr, free_vars, {gs & gs_heaps = gs_heaps}) - - build_alts :: !IsoDirection !Int !Int !Int ![DefinedSymbol] ![FreeVar] !CheckedTypeDef !*GenericState - -> ([AlgebraicPattern], [FreeVar], !*GenericState) - build_alts iso_dir i n type_def_mod [] arg_vars type_def gs - = ([], [], gs) - build_alts iso_dir i n type_def_mod [def_symbol:def_symbols] arg_vars type_def gs - #! (alt, fvs, gs) = build_alt iso_dir i n type_def_mod def_symbol arg_vars type_def gs - #! (alts, free_vars, gs) = build_alts iso_dir (i+1) n type_def_mod def_symbols arg_vars type_def gs - = ([alt:alts], fvs ++ free_vars, gs) - - build_alt :: !IsoDirection !Int !Int !Int !DefinedSymbol ![FreeVar] !CheckedTypeDef !*GenericState - -> (AlgebraicPattern, [FreeVar], !*GenericState) - build_alt - iso_dir i n type_def_mod def_symbol=:{ds_ident, ds_arity, ds_index} - fun_arg_vars type_def gs=:{gs_heaps, gs_modules} - #! names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]] - #! (cons_arg_vars, gs_heaps) = buildFreeVars names gs_heaps - #! (cons_def=:{cons_type}, gs_modules) = getConsDef type_def_mod ds_index gs_modules - #! gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules} - - #! (cons_arg_exprs, gs=:{gs_heaps}) = - build_cons_args iso_dir cons_type.st_args cons_arg_vars fun_arg_vars type_def gs - #! (expr, gs_heaps) = buildConsApp type_def_mod def_symbol cons_arg_exprs gs_heaps - #! alg_pattern = { - ap_symbol = {glob_module = type_def_mod, glob_object = def_symbol}, - ap_vars = cons_arg_vars, - ap_expr = expr, - ap_position = NoPos - } - = (alg_pattern, cons_arg_vars, {gs & gs_heaps = gs_heaps}) - - build_cons_args :: !IsoDirection ![AType] ![FreeVar] ![FreeVar] !CheckedTypeDef !*GenericState - -> ([Expression], !*GenericState) - build_cons_args iso_dir [] [] fun_arg_vars type_def gs = ([], gs) - build_cons_args iso_dir [arg_type:arg_types] [cons_arg_var:cons_arg_vars] fun_arg_vars type_def gs - #! (arg_expr, gs) = build_cons_arg iso_dir arg_type cons_arg_var fun_arg_vars type_def gs - #! (arg_exprs, gs) = build_cons_args iso_dir arg_types cons_arg_vars fun_arg_vars type_def gs - = ([arg_expr : arg_exprs], gs) - - build_cons_arg :: !IsoDirection !AType !FreeVar ![FreeVar] !CheckedTypeDef !*GenericState - -> (!Expression, !*GenericState) - build_cons_arg iso_dir type cons_arg_var fun_vars type_def=:{td_args, td_ident, td_pos} gs - #! type_def_args = [atv_variable \\ {atv_variable} <- td_args] - #! (iso_expr, gs) = buildIsomapExpr type type_def_args fun_vars td_ident td_pos gs - #! {gs_heaps, gs_predefs} = gs - #! sel_expr = case iso_dir of - IsoTo -> buildIsoToSelectionExpr iso_expr gs_predefs - IsoFrom -> buildIsoFromSelectionExpr iso_expr gs_predefs - #! (cons_var_expr, _, gs_heaps) = buildBoundVarExpr cons_arg_var gs_heaps - = (sel_expr @ [cons_var_expr], {gs & gs_heaps = gs_heaps}) - - build_type1 :: !IsoDirection !Int !Int !*GenericState -> (!SymbolType, !*GenericState) - build_type1 iso_dir module_index type_def_index gs=:{gs_heaps, gs_modules, gs_predefs} - - #! (st=:{st_result, st_args, st_arity}, gs) = buildIsomapType module_index type_def_index gs - - # (type1, type2) = case st_result.at_type of - (TA _ [type1, type2]) -> (type1, type2) - _ -> abort "Must be ISO application" - - #! (argtype, restype) = case iso_dir of - IsoTo -> (type1, type2) - IsoFrom -> (type2, type1) - - #! st = - { st - & st_args = st_args ++ [argtype] - , st_arity = inc st_arity - , st_result = restype - } - - = (st, gs) - - build_type :: !IsoDirection !Int !Int !*GenericState - -> (!SymbolType, !*GenericState) - build_type - iso_dir module_index type_def_index - gs=:{gs_heaps, gs_modules, gs_predefs} - - #! ({td_arity, td_ident}, gs_modules) = getTypeDef module_index type_def_index gs_modules - - #! (tvs1, gs_heaps) = mapSt (\n->build_type_var ("a"+++toString n)) [1..td_arity] gs_heaps - #! (tvs2, gs_heaps) = mapSt (\n->build_type_var ("b"+++toString n)) [1..td_arity] gs_heaps - #! (iso_args) = [buildATypeISO t1 t2 gs_predefs \\ t1 <- tvs1 & t2 <- tvs2] - - #! type_symb_ident = { - type_ident = td_ident, - type_index = { glob_module = module_index, glob_object = type_def_index }, - type_arity = td_arity, - type_prop = { - tsp_sign = {sc_pos_vect=cAllBitsClear, sc_neg_vect=cAllBitsClear}, - tsp_propagation = cAllBitsClear, - tsp_coercible = False - } - } - - #! (av1, gs_heaps) = buildAttrVar "u1" gs_heaps - #! (av2, gs_heaps) = buildAttrVar "u2" gs_heaps - #! type1 = makeAType (TA type_symb_ident tvs1) (TA_Var av1) - #! type2 = makeAType (TA type_symb_ident tvs2) (TA_Var av2) - #! (arg_type, res_type) = case iso_dir of - IsoTo -> (type1, type2) - IsoFrom -> (type2, type1) - - #! symbol_type = { - st_vars = - [tv \\ {at_type=(TV tv)} <- tvs1] ++ - [tv \\ {at_type=(TV tv)} <- tvs2], - st_args = iso_args ++ [arg_type], - st_args_strictness = NotStrict, - st_arity = td_arity + 1, - st_result = res_type, - st_context = [], - st_attr_vars = - [av \\ {at_attribute=(TA_Var av)} <- tvs1] ++ - [av \\ {at_attribute=(TA_Var av)} <- tvs2] ++ - [av1, av2], - st_attr_env = [] - } - #! gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules} - = (symbol_type, gs) - //---> ("isomap to/from type", td_ident, symbol_type) - - build_type_var name heaps - #! (av, heaps) = buildAttrVar name heaps - #! (tv, heaps) = buildTypeVar name heaps - = (makeAType (TV tv) (TA_Var av), heaps) - -buildIsomapForTypeDef :: !DefinedSymbol !Int !Int !CheckedTypeDef !DefinedSymbol !DefinedSymbol !*GenericState - -> (!FunDef, !Index, !*GenericState) -buildIsomapForTypeDef - fun_def_sym group_index type_def_mod - type_def=:{td_ident, td_index, td_arity, td_pos} - from_fun to_fun - gs=:{gs_main_dcl_module_n, gs_heaps, gs_predefs} - #! arg_names = [ "iso" +++ toString n \\ n <- [1 .. td_arity]] - #! (arg_exprs, arg_vars, gs_heaps) = buildVarExprs arg_names gs_heaps - - #! (from_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n from_fun arg_exprs gs_heaps - #! (to_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n to_fun arg_exprs gs_heaps - #! (iso_expr, gs_heaps) = buildISO to_expr from_expr gs_predefs gs_heaps - #! gs = {gs & gs_heaps = gs_heaps} - #! (fun_type, gs) = buildIsomapType type_def_mod td_index gs - #! fun_def = makeFunction fun_def_sym group_index arg_vars iso_expr (Yes fun_type) [] gs_main_dcl_module_n td_pos - = (fun_def, fun_def_sym.ds_index, gs) - -buildIsomapType :: !Int !Int !*GenericState -> (!SymbolType, !*GenericState) -buildIsomapType module_index type_def_index - gs=:{gs_heaps, gs_modules, gs_predefs, gs_td_infos} - - #! ({td_arity, td_ident, td_pos}, gs_modules) = getTypeDef module_index type_def_index gs_modules - # ({tdi_kinds}, gs_td_infos) = gs_td_infos ! [module_index, type_def_index] - # kind = case tdi_kinds of - [] -> KindConst - ks -> KindArrow (ks /*++ [KindConst]*/) - - // build generic type for isomap - # (t1, tv1, av1, gs_heaps) = build_type_var1 "a" gs_heaps - # (t2, tv2, av2, gs_heaps) = build_type_var1 "b" gs_heaps - # generic_type = - { gt_type = - { st_vars = [] - , st_args_strictness=NotStrict - , st_args = [] - , st_arity = 0 - , st_result = buildATypeISO t1 t2 gs_predefs - , st_context = [] - , st_attr_vars = [av1, av2] - , st_attr_env = [] - } - , gt_vars = [tv1, tv2] - , gt_arity = 2 - } - # dummy_generic_def = - { gen_ident = td_ident - , gen_member_ident = td_ident - , gen_type = generic_type - , gen_pos = td_pos - , gen_kinds_ptr = nilPtr - , gen_cons_ptr = nilPtr - , gen_classes = [] - , gen_isomap = EmptyDefinedSymbol - } - - # (st, agvs, gavs, hp_type_heaps) = specializeGenericType dummy_generic_def kind gs_heaps.hp_type_heaps - - // substitute generic variables with the type - #! type_symb = { - type_ident = td_ident, - type_index = { glob_module = module_index, glob_object = type_def_index }, - type_arity = td_arity, - type_prop = { - tsp_sign = {sc_pos_vect=cAllBitsClear, sc_neg_vect=cAllBitsClear}, - tsp_propagation = cAllBitsClear, - tsp_coercible = False - } - } - - # hp_type_heaps = foldSt subst_av_for_self st.st_attr_vars hp_type_heaps - with - subst_av_for_self av=:{av_info_ptr} th=:{th_attrs} - = {th & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr (TA_Var av))} - - # hp_type_heaps = foldSt subst_with_the_type agvs hp_type_heaps - with - subst_with_the_type {atv_variable={tv_info_ptr}} th=:{th_vars} - = {th & th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TA type_symb []))} - - # (ok, (st_args, st_result), hp_type_heaps) = substitute (st.st_args, st.st_result) hp_type_heaps - - - # symbol_type = - { st - & st_args = st_args - , st_result = st_result - , st_vars = st.st_vars -- [atv_variable \\ {atv_variable} <- agvs] - } - - #! gs_heaps = { gs_heaps & hp_type_heaps = hp_type_heaps } - #! gs = {gs & gs_heaps = gs_heaps, gs_modules = gs_modules, gs_td_infos = gs_td_infos} - = (symbol_type, gs) - //---> ("isomap to/from type", td_ident, symbol_type) -where - build_type_var1 name heaps - #! (av, heaps) = buildAttrVar name heaps - #! (tv, heaps) = buildTypeVar name heaps - = (makeAType (TV tv) (TA_Var av), tv, av, heaps) - - -buildIsomapForGeneric :: !DefinedSymbol !Int !GenericDef !*GenericState - -> (!FunDef, !Index, !*GenericState) -buildIsomapForGeneric def_sym group_index {gen_type, gen_ident, gen_pos} gs=:{gs_heaps,gs_main_dcl_module_n} - #! arg_names = [ "iso" +++ toString n \\ n <- [1 .. gen_type.gt_arity]] - #! (arg_vars, gs_heaps) = buildFreeVars arg_names gs_heaps - #! curried_gt_type = curry_symbol_type gen_type.gt_type - #! gs = {gs & gs_heaps = gs_heaps } - #! (body_expr, gs) = buildIsomapExpr curried_gt_type gen_type.gt_vars arg_vars gen_ident gen_pos gs - #! fun_def = makeFunction def_sym group_index arg_vars body_expr No [] gs_main_dcl_module_n gen_pos - = (fun_def, def_sym.ds_index, gs) -where - // no uniqueness stuff is needed to build the - // expression using the type - curry_symbol_type {st_args, st_result} - = foldr (\x y -> makeAType (x --> y) TA_Multi) st_result st_args - -// expression that does mapping of a type -buildIsomapExpr :: - !AType // type to build mapping expression for - ![TypeVar] // type variables of the type - ![FreeVar] // function arguments corresponding to the type variables - !Ident !Position - !*GenericState - -> (!Expression, !*GenericState) -buildIsomapExpr {at_type} arg_type_vars arg_vars name pos gs - = build_expr at_type arg_type_vars arg_vars name pos gs -where - - build_expr :: !Type ![TypeVar] ![FreeVar] !Ident !Position !*GenericState - -> (!Expression, !*GenericState) - build_expr (TA {type_arity=0} _) arg_type_vars arg_vars name pos gs=:{gs_predefs, gs_heaps} - // isomap for types with no arguments is identity - # (expr, gs_heaps) = buildIsomapIdApp gs_predefs gs_heaps - = (expr, {gs & gs_heaps = gs_heaps}) - - build_expr (TA {type_index, type_ident} args) arg_type_vars arg_vars name pos gs - # (arg_exprs, gs) = build_exprs args arg_type_vars arg_vars name pos gs - # {gs_heaps, gs_main_dcl_module_n, gs_gtd_infos} = gs - # (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [type_index.glob_module, type_index.glob_object] - # gt = case gtd_info of - (GTDI_Generic gt) -> gt - _ -> abort ("(generic.icl) type " +++ type_ident.id_name +++ " does not have generic representation\n") - # (expr, gs_heaps) = buildFunApp gs_main_dcl_module_n gt.gtr_isomap arg_exprs gs_heaps - = (expr, {gs & gs_heaps = gs_heaps, gs_gtd_infos = gs_gtd_infos}) - - build_expr (arg_type --> res_type) arg_type_vars arg_vars name pos gs - # (arg_expr, gs) = buildIsomapExpr arg_type arg_type_vars arg_vars name pos gs - # (res_expr, gs) = buildIsomapExpr res_type arg_type_vars arg_vars name pos gs - # {gs_heaps, gs_main_dcl_module_n, gs_predefs} = gs - # (expr, gs_heaps) = buildIsomapArrowApp arg_expr res_expr gs_predefs gs_heaps - = (expr, {gs & gs_heaps = gs_heaps}) - - build_expr ((CV type_var) :@: args) arg_type_vars arg_vars name pos gs=:{gs_error} - - #! (arg_exprs, gs) = build_exprs args arg_type_vars arg_vars name pos gs - #! (cons_var_expr, gs) = build_expr_for_type_var type_var arg_type_vars arg_vars gs - = (cons_var_expr @ arg_exprs, gs) - -/* - #! gs_error = reportError name pos "type constructor variables are not yet supported in generic types" gs_error - = (EE, {gs & gs_error = gs_error}) -*/ - build_expr (TB baric_type) arg_type_vars arg_vars name pos gs=:{gs_predefs, gs_heaps} - # (expr, gs_heaps) = buildIsomapIdApp gs_predefs gs_heaps - = (expr, {gs & gs_heaps = gs_heaps}) - - build_expr (TV type_var) arg_type_vars arg_vars name pos gs - = build_expr_for_type_var type_var arg_type_vars arg_vars gs - build_expr (GTV type_var) arg_type_vars arg_vars name pos gs - = build_expr_for_type_var type_var arg_type_vars arg_vars gs - build_expr (TQV type_var) arg_type_vars arg_vars name pos gs - = build_expr_for_type_var type_var arg_type_vars arg_vars gs - build_expr (TLifted type_var) arg_type_vars arg_vars name pos gs - = build_expr_for_type_var type_var arg_type_vars arg_vars gs - build_expr _ arg_type_vars arg_vars name pos gs=:{gs_error} - #! gs_error = reportError name pos "cannot build mapping for the type" gs_error - = (EE, {gs & gs_error = gs_error}) - - build_exprs [] arg_type_vars arg_vars name pos gs - = ([], gs) - build_exprs [type:types] arg_type_vars arg_vars name pos gs - # (expr, gs) = buildIsomapExpr type arg_type_vars arg_vars name pos gs - # (exprs, gs) = build_exprs types arg_type_vars arg_vars name pos gs - = ([expr:exprs], gs) - - build_expr_for_type_var type_var arg_type_vars arg_vars gs=:{gs_predefs, gs_heaps} - # (var_expr, gs_heaps) = buildExprForTypeVar type_var arg_type_vars arg_vars gs_predefs gs_heaps - = (var_expr, {gs & gs_heaps = gs_heaps}) - -buildInstance :: !DefinedSymbol !Int !ClassInstance !GenericDef !*GenericState - -> (!FunDef, !*GenericState) -buildInstance - def_sym group_index - instance_def=:{ins_type, ins_generic, ins_pos, ins_ident} - generic_def=:{gen_ident, gen_type, gen_isomap} - gs=:{gs_heaps,gs_main_dcl_module_n} - - #! original_arity = gen_type.gt_type.st_arity - #! generated_arity = def_sym.ds_arity - original_arity // arity of kind - - #! generated_arg_names = [ "f" +++ toString n \\ n <- [1 .. generated_arity]] - #! (generated_arg_vars, gs_heaps) = buildFreeVars generated_arg_names gs_heaps - #! original_arg_names = [ "x" +++ toString n \\ n <- [1 .. original_arity]] - #! (original_arg_exprs, original_arg_vars, gs_heaps) = buildVarExprs original_arg_names gs_heaps - #! arg_vars = generated_arg_vars ++ original_arg_vars - - #! (gt=:{gtr_type, gtr_type_args, gtr_cons_infos}, gs) = get_generic_type ins_type {gs & gs_heaps = gs_heaps } - #! gen_glob_def_sym = { - glob_module = ins_generic.glob_module, - glob_object = { - ds_ident = gen_ident, - ds_index = ins_generic.glob_object, - ds_arity = 0 - } - } - - #! (adaptor_expr, gs) = build_adaptor_expr gt gen_isomap gs - //---> ("generic type", gtr_type) - - #! (instance_expr, cons_infos, gs) = build_instance_expr gtr_type gtr_cons_infos gtr_type_args generated_arg_vars gen_glob_def_sym gs - //---> ("build_instance_expr", gtr_type_args, generated_arg_vars) - - | supportConsInfo && (not (isEmpty cons_infos)) - = abort "not all cons infos consumed" - - #! body_expr = if (isEmpty original_arg_exprs) - (adaptor_expr @ [instance_expr]) - ((adaptor_expr @ [instance_expr]) @ original_arg_exprs) - - #! fun_def = makeFunction def_sym group_index arg_vars body_expr No [] gs_main_dcl_module_n ins_pos - = (fun_def, gs) - //---> ("buildInstance", fun_def) -where - get_generic_type :: !InstanceType !*GenericState - -> (GenericTypeRep, !*GenericState) - get_generic_type ins_type gs=:{gs_modules, gs_gtd_infos, gs_error} - # instance_type = hd ins_type.it_types - # {type_index} = case instance_type of - TA type_symb_ident _ -> type_symb_ident - _ -> abort ("instance type is not a type application") - //---> ("get_generic_type", instance_type) - # (gtd_info, gs_gtd_infos) = gs_gtd_infos ! [type_index.glob_module, type_index.glob_object] - # (GTDI_Generic gt) = gtd_info - = (gt, {gs & gs_gtd_infos = gs_gtd_infos, gs_modules = gs_modules, gs_error=gs_error}) - - build_adaptor_expr {gtr_iso, gtr_type} gen_isomap gs=:{gs_heaps, gs_main_dcl_module_n, gs_predefs} - // create n iso applications - # (iso_exprs, gs_heaps) = build_iso_exprs gen_isomap.ds_arity gtr_iso gs_main_dcl_module_n gs_heaps - # (isomap_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n gen_isomap iso_exprs gs_heaps - # sel_expr = buildIsoFromSelectionExpr isomap_expr gs_predefs - = (sel_expr, {gs & gs_heaps = gs_heaps}) - - build_iso_exprs n iso gs_main_dcl_module_n gs_heaps - | n == 0 = ([], gs_heaps) - # (expr, gs_heaps) = buildFunApp gs_main_dcl_module_n iso [] gs_heaps - # (exprs, gs_heaps) = build_iso_exprs (n - 1) iso gs_main_dcl_module_n gs_heaps - = ([expr:exprs], gs_heaps) - - // e.g. for eq on lists: - // eqEITHER eqUNIT (eqPAIR eqElt (eqList eqElt)) - // with cons info: - // eqEITHER - // (eqCONS info_Nil eqUNIT) - // (eqCONS info_Cons (eqPAIR eqElt (eqList eqElt))) - build_instance_expr :: !AType ![DefinedSymbol] ![TypeVar] ![FreeVar] !(Global DefinedSymbol) !*GenericState - -> (Expression, ![DefinedSymbol], !*GenericState) - build_instance_expr {at_type} cons_infos type_vars vars gen_sym gs - = build_instance_expr1 at_type cons_infos type_vars vars gen_sym gs - - build_instance_expr1 (TA {type_ident, type_index, type_arity} type_args) cons_infos type_vars vars gen_sym gs - # (arg_exprs, cons_infos, gs=:{gs_heaps}) = build_args type_args cons_infos gs - with - build_args [] cons_infos gs = ([], cons_infos, gs) - build_args [t:ts] cons_infos gs - # (e, cons_infos, gs) = build_instance_expr t cons_infos type_vars vars gen_sym gs - # (es, cons_infos, gs) = build_args ts cons_infos gs - = ([e:es], cons_infos, gs) - - # (is_cons, gs) = is_cons_instance type_index gs - | supportConsInfo && is_cons - = build_cons_fun_app gen_sym arg_exprs cons_infos gs - - | otherwise - # (kind, gs) = get_kind_of_type_def type_index gs - = build_generic_app gen_sym kind arg_exprs cons_infos gs - - build_instance_expr1 (arg_type --> res_type) cons_infos type_vars vars gen_sym gs - #! (arg_expr, cons_infos, gs) = build_instance_expr arg_type cons_infos type_vars vars gen_sym gs - #! (res_expr, cons_infos, gs) = build_instance_expr res_type cons_infos type_vars vars gen_sym gs - = build_generic_app gen_sym (KindArrow [KindConst,KindConst/*,KindConst*/]) [arg_expr, res_expr] cons_infos gs - build_instance_expr1 ((CV type_var) :@: type_args) cons_infos type_vars vars gen_sym gs=:{gs_error} -/* - # gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "application of type constructor variable is not yet supported in generic types" gs_error - = (EE, cons_infos, {gs & gs_error = gs_error}) -*/ - # (arg_exprs, cons_infos, gs=:{gs_heaps}) = build_args type_args cons_infos gs - with - build_args [] cons_infos gs = ([], cons_infos, gs) - build_args [t:ts] cons_infos gs - # (e, cons_infos, gs) = build_instance_expr t cons_infos type_vars vars gen_sym gs - # (es, cons_infos, gs) = build_args ts cons_infos gs - = ([e:es], cons_infos, gs) - - # (var_expr, cons_infos, gs) = build_expr_for_type_var type_var type_vars vars cons_infos gs - - = (var_expr @ arg_exprs, cons_infos, gs) - - build_instance_expr1 (TB basic_type) cons_infos type_vars vars gen_sym gs - = build_generic_app gen_sym KindConst [] cons_infos gs - build_instance_expr1 (TV type_var) cons_infos type_vars vars gen_sym gs - = build_expr_for_type_var type_var type_vars vars cons_infos gs - build_instance_expr1 (GTV type_var) cons_infos type_vars vars gen_sym gs - = build_expr_for_type_var type_var type_vars vars cons_infos gs - build_instance_expr1 (TQV type_var) cons_infos type_vars vars gen_sym gs - = build_expr_for_type_var type_var type_vars vars cons_infos gs - build_instance_expr1 _ cons_infos _ _ _ gs=:{gs_error} - # gs_error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) "can not build instance for the type" gs_error - = (EE, cons_infos, {gs & gs_error = gs_error}) - - build_expr_for_type_var type_var type_vars vars cons_infos gs=:{gs_predefs, gs_heaps} - # (var_expr, gs_heaps) = buildExprForTypeVar type_var type_vars vars gs_predefs gs_heaps - = (var_expr, cons_infos, {gs & gs_heaps = gs_heaps}) - - build_generic_app {glob_module, glob_object} kind arg_exprs cons_infos gs=:{gs_heaps} - # (expr, gs_heaps) = buildGenericApp glob_module glob_object kind arg_exprs gs_heaps - = (expr, cons_infos, {gs & gs_heaps = gs_heaps}) - - get_kind_of_type_def {glob_module, glob_object} gs=:{gs_td_infos} - # (td_info, gs_td_infos) = gs_td_infos ! [glob_module, glob_object] - = (make_kind td_info.tdi_kinds, {gs & gs_td_infos = gs_td_infos}) - where - make_kind [] = KindConst - make_kind ks = KindArrow (ks /*++ [KindConst]*/) - - is_cons_instance {glob_module, glob_object} gs=:{gs_predefs} - # {pds_def, pds_module} = gs_predefs.[PD_TypeCONS] - = (pds_module == glob_module && pds_def == glob_object, gs) - - build_cons_fun_app - gen=:{glob_module, glob_object} - arg_exprs - [cons_info:cons_infos] - gs=:{ gs_heaps=gs_heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}, - gs_main_dcl_module_n, - gs_modules, - gs_error} - - #! (generic_def=:{gen_ident, gen_pos, gen_cons_ptr}, gs_modules) - = getGenericDef glob_module glob_object.ds_index gs_modules - #! (info, th_vars) = readPtr gen_cons_ptr th_vars - #! gs_heaps = { gs_heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars }} - - # (cons_info_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n cons_info [] gs_heaps - - #! (fun_def_sym, gs_error) = case info of - TVI_ConsInstance fun_def_sym - -> (fun_def_sym, gs_error) - TVI_Empty - -> (EmptyDefinedSymbol, reportError gen_ident gen_pos "no CONS instance provided" gs_error) - - #! (app_expr, gs_heaps) = buildFunApp gs_main_dcl_module_n fun_def_sym [cons_info_expr:arg_exprs] gs_heaps - = (app_expr, cons_infos, {gs & gs_heaps = gs_heaps, gs_modules = gs_modules, gs_error = gs_error}) - //---> ("build_cons_app", cons_info.ds_ident, fun_def_sym.ds_ident) - -buildExprForTypeVar :: - TypeVar // type variable to build exspression for - [TypeVar] // generic type variables - [FreeVar] // function arguments corresponding to the type variables - !PredefinedSymbols !*Heaps - -> (!Expression, !*Heaps) -buildExprForTypeVar type_var type_vars vars predefs heaps - | length type_vars <> length vars - = abort "buildExprForTypeVar: inconsistent arguments\n" - # tv_info_ptrs = {tv_info_ptr \\ {tv_info_ptr} <- type_vars} - - // find whether type_var is contained in the array of generic variables. - # index = find_in_array 0 tv_info_ptrs type_var.tv_info_ptr - | index == (-1) - // If not, it is a non-generic variable. - // For non-generic variables the isomorphism is identity - = buildIsomapIdApp predefs heaps - // This is a generic variable, - // use corresponding function argument variable - # (expr, var, heaps) = buildBoundVarExpr (vars !! index) heaps - = (expr, heaps) - -where - find_in_array :: !Int !{#TypeVarInfoPtr} !TypeVarInfoPtr -> !Int - find_in_array index array el - | index == size array = -1 - | array.[index] == el = index - = find_in_array (inc index) array el - - -buildKindConstInstance :: !DefinedSymbol !Int !Index !DefinedSymbol !TypeKind !GenericState - -> (!FunDef, !*GenericState) -buildKindConstInstance - def_sym group_index - generic_module generic_def_sym kind=:(KindArrow kinds) - gs=:{gs_heaps,gs_main_dcl_module_n} - #! arg_names = ["x" +++ toString i \\ i <- [1 .. def_sym.ds_arity]] - #! (arg_exprs, arg_vars, gs_heaps) = buildVarExprs arg_names gs_heaps - - # (gen_exprs, gs_heaps) = mapSt build_gen_expr [1 .. (length kinds)/* - 1*/] gs_heaps - - #! (body_expr, gs_heaps) = buildGenericApp generic_module generic_def_sym kind (gen_exprs ++ arg_exprs) gs_heaps - #! fun_def = makeFunction def_sym group_index arg_vars body_expr No [] gs_main_dcl_module_n NoPos - = (fun_def, {gs & gs_heaps = gs_heaps}) -where - build_gen_expr _ heaps - = buildGenericApp generic_module generic_def_sym KindConst [] heaps - -buildKindConstInstance1 :: !DefinedSymbol !Int !Index !DefinedSymbol ![TypeKind] !GenericState - -> (!FunDef, !*GenericState) -buildKindConstInstance1 - def_sym group_index - generic_module generic_def_sym arg_kinds - gs=:{gs_heaps,gs_main_dcl_module_n} - #! arg_names = ["x" +++ toString i \\ i <- [1 .. def_sym.ds_arity]] - #! (arg_exprs, arg_vars, gs_heaps) = buildVarExprs arg_names gs_heaps - - # (gen_exprs, gs_heaps) = mapSt build_gen_expr arg_kinds gs_heaps - - #! (body_expr, gs_heaps) - = buildGenericApp generic_module generic_def_sym (KindArrow arg_kinds) (gen_exprs ++ arg_exprs) gs_heaps - #! fun_def = makeFunction def_sym group_index arg_vars body_expr No [] gs_main_dcl_module_n NoPos - = (fun_def, {gs & gs_heaps = gs_heaps}) -where - build_gen_expr kind heaps - = buildGenericApp generic_module generic_def_sym kind [] heaps - - -//=========================================== -// access to common definitions -//=========================================== - - -getTypeDef :: !Index !Index !u:{#CommonDefs} -> (!CheckedTypeDef, !u:{#CommonDefs}) -getTypeDef mod_index type_index modules - # (common_defs=:{com_type_defs}, modules) = modules![mod_index] - # type_def = com_type_defs.[type_index] - = (type_def, modules) - -getConsDef :: !Index !Index !u:{#CommonDefs} -> (!ConsDef, !u:{#CommonDefs}) -getConsDef mod_index type_index modules - # (common_defs=:{com_cons_defs}, modules) = modules![mod_index] - # cons_def = com_cons_defs.[type_index] - = (cons_def, modules) - -getSelectorDef :: !Index !Index !u:{#CommonDefs} -> (!SelectorDef, !u:{#CommonDefs}) -getSelectorDef mod_index type_index modules - # (common_defs=:{com_selector_defs}, modules) = modules![mod_index] - # sel_def = com_selector_defs.[type_index] - = (sel_def, modules) - - -getInstanceDef :: !Index !Index !u:{#CommonDefs} -> (!ClassInstance, !u:{#CommonDefs}) -getInstanceDef mod_index ins_index modules - # (common_defs=:{com_instance_defs}, modules) = modules![mod_index] - # instance_def = com_instance_defs.[ins_index] - = (instance_def, modules) - -getGenericDef :: !Index !Index !u:{#CommonDefs} -> (!GenericDef, !u:{#CommonDefs}) -getGenericDef module_index generic_index modules - # (common_defs=:{com_generic_defs}, modules) = modules![module_index] - # generic_def = com_generic_defs.[generic_index] - = (generic_def, modules) - -getClassDef :: !Index !Index !u:{#CommonDefs} -> (!ClassDef, !u:{#CommonDefs}) -getClassDef module_index class_index modules - #! (common_defs=:{com_class_defs}, modules) = modules![module_index] - #! class_def = com_class_defs.[class_index] - = (class_def, modules) - -getMemberDef :: !Index !Index !u:{#CommonDefs} -> (!MemberDef, !u:{#CommonDefs}) -getMemberDef module_index member_index modules - # (common_defs=:{com_member_defs}, modules) = modules![module_index] - # member_def = com_member_defs.[member_index] - = (member_def, modules) - -getGenericMember :: !(Global Index) !TypeKind !{#CommonDefs} -> (Bool, Global Index) -getGenericMember {glob_module, glob_object} kind modules - # (generic_def, modules) = getGenericDef glob_module glob_object modules - # (ok, def_sym) = getGenericClassForKind generic_def kind - | 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 -//=================================== - -makeAType :: !Type !TypeAttribute -> !AType -makeAType type attr = - { at_attribute = attr - , at_type = type - } - -buildTypeVar name heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}} - # (tv, th_vars) = freshTypeVar {id_name=name,id_info=nilPtr} th_vars - = ( tv, {heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}) - -buildAttrVar name heaps=:{hp_type_heaps=hp_type_heaps=:{th_attrs}} - # (av, th_attrs) = freshAttrVar {id_name=name,id_info=nilPtr} th_attrs - = ( av, {heaps & hp_type_heaps = {hp_type_heaps & th_attrs = th_attrs}}) - -freshTypeVar :: !Ident !*TypeVarHeap -> (!TypeVar, !*TypeVarHeap) -freshTypeVar name th_vars - # (info_ptr, th_vars) = newPtr TVI_Empty th_vars - = ({tv_ident = name, tv_info_ptr = info_ptr}, th_vars) - -freshAttrVar :: !Ident !*AttrVarHeap -> (!AttributeVar, !*AttrVarHeap) -freshAttrVar name th_attrs - # (info_ptr, th_attrs) = newPtr AVI_Empty th_attrs - = ({av_ident = name, av_info_ptr = info_ptr}, th_attrs) - -freshSymbolType :: String !SymbolType !*TypeHeaps -> (!SymbolType, !*TypeHeaps) -freshSymbolType postfix st type_heaps - # {st_vars, st_args, st_result, st_context, st_attr_vars, st_attr_env} = st - # (new_st_vars, type_heaps) = subst_type_vars postfix st_vars type_heaps - # (new_st_attr_vars, type_heaps) = subst_attr_vars postfix st_attr_vars type_heaps - - # (_, new_st_args, type_heaps) = substitute st_args type_heaps - # (_, new_st_result, type_heaps) = substitute st_result type_heaps - # (_, new_st_context, type_heaps) = substitute st_context type_heaps - # (_, new_st_attr_env, type_heaps) = substitute st_attr_env type_heaps - - # new_st = { st & - st_vars = new_st_vars - , st_args = new_st_args - , st_result = new_st_result - , st_context = new_st_context - , st_attr_vars = new_st_attr_vars - , st_attr_env = new_st_attr_env - } - = (new_st, type_heaps) - -where - subst_type_var postfix tv=:{tv_ident={id_name}, tv_info_ptr} th_vars - # (tv, th_vars) = freshTypeVar {id_name=id_name+++postfix, id_info=nilPtr} th_vars - = (tv, writePtr tv_info_ptr (TVI_Type (TV tv)) th_vars) - subst_type_vars postfix tvs type_heaps=:{th_vars} - # (tvs, th_vars) = mapSt (subst_type_var postfix) tvs th_vars - = (tvs, {type_heaps & th_vars = th_vars}) - - subst_attr_var postfix av=:{av_ident={id_name}, av_info_ptr} th_attrs - # (av, th_attrs) = freshAttrVar {id_name=id_name+++postfix, id_info=nilPtr} th_attrs - = (av, writePtr av_info_ptr (AVI_Attr (TA_Var av)) th_attrs) - subst_attr_vars postfix avs type_heaps=:{th_attrs} - # (avs, th_attrs) = mapSt (subst_attr_var postfix) avs th_attrs - = (avs, {type_heaps & th_attrs = th_attrs}) - -// all variables are taken afresh -freshGenericType :: !GenericType !*TypeHeaps - -> (!GenericType, !*TypeHeaps) -freshGenericType gen_type=:{gt_type, gt_vars, gt_arity} type_heaps - // set variables that have to be taken fresh, i.e. - // both generic variables and non-variables - # {st_vars} = gt_type - # symbol_type = { gt_type & st_vars = gt_vars ++ st_vars } - # (fresh_symbol_type, type_heaps) = freshSymbolType "" symbol_type type_heaps - - // split fresh variables into generic and non-generic variables - # (fresh_gt_vars, st_vars) = splitAt gt_arity fresh_symbol_type.st_vars - # fresh_gen_type = { gen_type & - gt_vars = fresh_gt_vars, gt_type = {fresh_symbol_type & st_vars = st_vars}} - = (fresh_gen_type, type_heaps) - -// Only generic variables are taken afresh -// Non generic variables are supposed to be shared by -// generic subtypes of a type -freshGenericSubtype :: !String !GenericType !*TypeHeaps - -> (!GenericType, !*TypeHeaps) -freshGenericSubtype postfix gen_type=:{gt_vars, gt_type, gt_arity} type_heaps - // set variables that have to be taken afresh, i.e. generic variables - #! {st_vars} = gt_type - #! symbol_type = {gt_type & st_vars = gt_vars} - - #! (fresh_symbol_type, type_heaps) = freshSymbolType postfix symbol_type type_heaps - - // restore non-generic variables - #! fresh_gt_vars = fresh_symbol_type.st_vars - #! fresh_gen_type = { gen_type & - gt_vars = fresh_gt_vars, gt_type = {fresh_symbol_type & st_vars = st_vars}} - = (fresh_gen_type, type_heaps) - -clearType :: Type !*TypeHeaps -> !*TypeHeaps -clearType type th=:{th_vars} - = {th & th_vars = performOnTypeVars initializeToTVI_Empty type th_vars} - -clearAType :: !AType !*TypeHeaps -> !*TypeHeaps -clearAType type th=:{th_vars, th_attrs} - #! th_vars = performOnTypeVars initializeToTVI_Empty type th_vars - #! th_attrs = performOnAttrVars initializeToAVI_Empty type th_attrs - = {th & th_vars = th_vars, th_attrs = th_attrs} - -clearSymbolType :: !SymbolType !*TypeHeaps -> !*TypeHeaps -clearSymbolType {st_args, st_context, st_result} th - #! th = foldSt clearAType st_args th - #! th = foldSt clearType (flatten [tc_types \\ {tc_types} <- st_context]) th - #! th = clearAType st_result th - = th - -substituteInSymbolType :: !SymbolType !*TypeHeaps -> (!SymbolType, !*TypeHeaps) -substituteInSymbolType st=:{st_args, st_result, st_attr_env, st_context} th - #! (_, st_args, th) = substitute st.st_args th - #! (_, st_result, th) = substitute st.st_result th - #! (_, st_context, th) = substitute st.st_context th - #! (_, st_attr_env, th) = substitute st.st_attr_env th - #! st = { st & - st_args = st_args, - st_result = st_result, - st_context = st_context, - st_attr_env = st_attr_env - } - = (st, th) - -// sets ATV_Attribute in all variables -setTypeVarAttrs :: !SymbolType !*TypeHeaps -> !*TypeHeaps -setTypeVarAttrs {st_args, st_result} th=:{th_vars} - #! th_vars = foldSt set_in_atype st_args th_vars - #! th_vars = set_in_atype st_result th_vars - = {th & th_vars = th_vars} -where - set_in_atype at th_vars - = performOnTypeVars on_type_var at th_vars - on_type_var ta tv=:{tv_info_ptr} th_vars - = writePtr tv_info_ptr (TVI_Attribute ta) th_vars - -buildTypeApp :: !Index !CheckedTypeDef [AType] -> AType -buildTypeApp td_module {td_ident, td_arity, td_index} args - # global_index = {glob_module = td_module, glob_object = td_index} - # type_symb = MakeTypeSymbIdent global_index td_ident (length args) - = makeAType (TA type_symb args) TA_Multi - -buildPredefTypeApp :: !Int [AType] !PredefinedSymbols -> !AType -buildPredefTypeApp predef_index args predefs - # {pds_module, pds_def} = predefs.[predef_index] - # pds_ident = predefined_idents.[predef_index] - # global_index = {glob_module = pds_module, glob_object = pds_def} - # type_symb = MakeTypeSymbIdent global_index pds_ident (length args) - = makeAType (TA type_symb args) TA_Multi - -buildATypeISO x y predefs = buildPredefTypeApp PD_TypeISO [x, y] predefs -buildATypeUNIT predefs = buildPredefTypeApp PD_TypeUNIT [] predefs -buildATypePAIR x y predefs = buildPredefTypeApp PD_TypePAIR [x, y] predefs -buildATypeEITHER x y predefs = buildPredefTypeApp PD_TypeEITHER [x, y] predefs -buildATypeARROW x y predefs = buildPredefTypeApp PD_TypeARROW [x, y] predefs -buildATypeCONS x predefs = buildPredefTypeApp PD_TypeCONS [x] predefs - -buildProductType :: ![AType] !PredefinedSymbols -> !AType -buildProductType [] predefs = buildATypeUNIT predefs -buildProductType [type] predefs = type -buildProductType types predefs - # (l,r) = splitAt ((length types) / 2) types - = buildATypePAIR (buildProductType l predefs) (buildProductType r predefs) predefs - -//=================================== -// Functions -//=================================== - -makeFunction :: !DefinedSymbol !Index ![FreeVar] !Expression !(Optional SymbolType) ![FreeVar] !Index !Position - -> FunDef -makeFunction {ds_index, ds_arity, ds_ident} group_index arg_vars body_expr opt_sym_type local_vars main_dcl_module_n fun_pos - | length arg_vars <> ds_arity - = abort "length arg_vars <> ds_arity\n" - = { - fun_ident = ds_ident, - fun_arity = ds_arity, - fun_priority = NoPrio, - fun_body = TransformedBody { - tb_args = arg_vars, - tb_rhs = body_expr - }, - fun_type = opt_sym_type, - fun_pos = fun_pos, - fun_kind = FK_Function cNameNotLocationDependent, - fun_lifted = 0, - fun_info = { - fi_calls = [FunCall ind NotALevel \\ ind <- collectCalls main_dcl_module_n body_expr], - fi_group_index = group_index, - fi_def_level = NotALevel, - fi_free_vars = [], - fi_local_vars = local_vars, - fi_dynamics = [], - fi_properties = 0 - } - } - -newGroupIndex gs=:{gs_last_group} = (gs_last_group, {gs & gs_last_group = gs_last_group + 1}) -newFunIndex gs=:{gs_last_fun} = (gs_last_fun, {gs & gs_last_fun = gs_last_fun + 1}) -newFunAndGroupIndex gs=:{gs_last_fun, gs_last_group} - = (gs_last_fun, gs_last_group, {gs & gs_last_fun = gs_last_fun + 1, gs_last_group = gs_last_group + 1}) - -addFunsAndGroups :: ![FunDef] ![Group] (!*GenericState) -> !*GenericState -addFunsAndGroups new_fun_defs new_groups - gs=:{gs_fun_defs, gs_groups, gs_first_fun, gs_last_fun, gs_first_group, gs_last_group,gs_main_dcl_module_n} - # gs_fun_defs = add_funs new_fun_defs gs_fun_defs gs_first_fun gs_last_fun - # gs_groups = add_groups new_groups gs_groups gs_first_group gs_last_group - # (gs_groups, gs_fun_defs) = check_groups gs_first_group gs_groups gs_fun_defs - = {gs & gs_fun_defs = gs_fun_defs, gs_groups = gs_groups} -where - add_funs new_fun_defs gs_fun_defs gs_first_fun gs_last_fun - # n_gs_fun_defs = size gs_fun_defs - # n_new_fun_defs = length new_fun_defs - | n_new_fun_defs <> gs_last_fun - gs_first_fun - = abort "error in number of fun_defs" - # fun_defs = createArray (n_new_fun_defs + n_gs_fun_defs) - (makeFunction EmptyDefinedSymbol NoIndex [] EE No [] gs_main_dcl_module_n NoPos) - #! fun_defs = { fun_defs & [i] = gs_fun_defs . [i] \\ i <- [0..(n_gs_fun_defs - 1)]} - #! fun_defs = { fun_defs & [i] = check_fun fun_def i \\ - i <- [n_gs_fun_defs .. (n_gs_fun_defs + n_new_fun_defs - 1)] & - fun_def <- new_fun_defs } - = fun_defs - - add_groups new_groups gs_groups gs_first_group gs_last_group - # n_gs_groups = size gs_groups - # n_new_groups = length new_groups - | n_new_groups <> gs_last_group - gs_first_group - = abort "error in number of groups" - # groups = createArray (n_gs_groups + n_new_groups) {group_members = []} - #! groups = { groups & [i] = gs_groups . [i] \\ i <- [0..(n_gs_groups - 1)]} - #! groups = { groups & [i] = group \\ - i <- [n_gs_groups .. (n_gs_groups + n_new_groups - 1)] & - group <- new_groups } - = groups - - check_fun fun_def index - = fun_def -/* - | fun_def.fun_index == index - = fun_def - = abort ("conflicting fun_indexes of " +++ fun_def.fun_ident.id_name +++ - toString fun_def.fun_index +++ " and " +++ toString index) -*/ - - check_groups group_index groups funs - | group_index == size groups = (groups, funs) - # (group, groups) = groups ! [group_index] - //---> ("check group " +++ toString group_index) - # funs = check_group group_index group.group_members funs - = check_groups (group_index + 1) groups funs - - 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 +++ ": " +++ - toString fun_index +++ " and " +++ toString fun.fun_info.fi_group_index) - -buildIdFunction :: !DefinedSymbol Int !Ident !PredefinedSymbols !Index !*Heaps-> (!FunDef, !*Heaps) -buildIdFunction def_sym group_index name predefs gs_main_dcl_module_n heaps - # (arg_expr, arg_var, heaps) = buildVarExpr "x" heaps - # fun_def = makeFunction def_sym group_index [arg_var] arg_expr No [] gs_main_dcl_module_n NoPos - = (fun_def, heaps) - -buildUndefFunction :: !DefinedSymbol !Int !PredefinedSymbols !Index !*Heaps-> (!FunDef, !*Heaps) -buildUndefFunction def_sym group_index predefs gs_main_dcl_module_n heaps - # names = [ "x" +++ toString i \\ i <- [1 .. def_sym.ds_arity]] - # (arg_vars, heaps) = mapSt build_free_var names heaps - # (body_expr, heaps) = buildUndefFunApp [] predefs heaps - //# (body_expr, heaps) = buildUNIT predefs heaps - # fun_def = makeFunction def_sym group_index arg_vars body_expr No [] gs_main_dcl_module_n NoPos - = (fun_def, heaps) -where - build_free_var :: !String !*Heaps -> (!FreeVar, !*Heaps) - build_free_var name heaps=:{hp_var_heap} - # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - # var_ident = { id_name = name, id_info = nilPtr } - # free_var = { fv_def_level = NotALevel, fv_count = 0, fv_info_ptr = var_info_ptr, fv_ident = var_ident} - = (free_var, {heaps & hp_var_heap = hp_var_heap}) - -//=================================== -// Case patterns -//=================================== - -buildPredefConsPattern :: !Int ![FreeVar] !Expression !PredefinedSymbols - -> AlgebraicPattern -buildPredefConsPattern predef_index vars expr predefs - # {pds_module, pds_def} = predefs.[predef_index] - # pds_ident = predefined_idents.[predef_index] - # cons_def_symbol = { - ds_ident = pds_ident, - ds_arity = length vars, - ds_index = pds_def - } - # pattern = { - ap_symbol = {glob_module = pds_module, glob_object = cons_def_symbol}, - ap_vars = vars, - ap_expr = expr, - ap_position = NoPos - } - = pattern - -buildUNITPattern expr predefs :== buildPredefConsPattern PD_ConsUNIT [] expr predefs -buildLEFTPattern var expr predefs :== buildPredefConsPattern PD_ConsLEFT [var] expr predefs -buildRIGHTPattern var expr predefs :== buildPredefConsPattern PD_ConsRIGHT [var] expr predefs -buildPAIRPattern var1 var2 expr predefs :== buildPredefConsPattern PD_ConsPAIR [var1, var2] expr predefs -buildCONSPattern cons_info_var cons_arg_var expr predefs :== buildPredefConsPattern PD_ConsCONS [cons_info_var, cons_arg_var] expr predefs - -//=================================== -// Expressions -//=================================== - -buildConsApp :: !Index DefinedSymbol ![Expression] !*Heaps - -> (!Expression, !*Heaps) -buildConsApp cons_mod {ds_ident, ds_index, ds_arity} arg_exprs heaps=:{hp_expression_heap} - # (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap - # cons_glob = {glob_module = cons_mod, glob_object = ds_index} - # expr = App { - app_symb = { - symb_ident = ds_ident, - symb_kind = SK_Constructor cons_glob - }, - app_args = arg_exprs, - app_info_ptr = expr_info_ptr} - # heaps = { heaps & hp_expression_heap = hp_expression_heap } - = (expr, heaps) - -buildFunApp :: !Index DefinedSymbol ![Expression] !*Heaps - -> (!Expression, !*Heaps) -buildFunApp fun_mod {ds_ident, ds_index, ds_arity} arg_exprs heaps=:{hp_expression_heap} - # (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap - # fun_glob = {glob_module = fun_mod, glob_object = ds_index} - # expr = App { - app_symb = { - symb_ident = ds_ident, - symb_kind = SK_Function fun_glob - }, - app_args = arg_exprs, - app_info_ptr = expr_info_ptr} - # heaps = { heaps & hp_expression_heap = hp_expression_heap } - = (expr, heaps) - -buildGenericApp :: !Index !DefinedSymbol !TypeKind ![Expression] !*Heaps - -> (!Expression, !*Heaps) -buildGenericApp module_index {ds_ident, ds_index} kind arg_exprs heaps=:{hp_expression_heap} - # (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap - # glob_index = {glob_module = module_index, glob_object = ds_index} - # expr = App { - app_symb = { - symb_ident = ds_ident, - symb_kind = SK_Generic glob_index kind - }, - app_args = arg_exprs, - app_info_ptr = expr_info_ptr} - # heaps = { heaps & hp_expression_heap = hp_expression_heap } - = (expr, heaps) - -buildCaseExpr :: Expression CasePatterns !*Heaps - -> (!Expression, !*Heaps) -buildCaseExpr case_arg case_alts heaps=:{hp_expression_heap} - # (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap - # expr = Case { - case_expr = case_arg, - case_guards = case_alts, - case_default = No, - case_ident = No, - case_info_ptr = expr_info_ptr, -// RWS ... - case_explicit = False, -// ... RWS - case_default_pos = NoPos - } - # heaps = { heaps & hp_expression_heap = hp_expression_heap} - = (expr, heaps) - -buildCaseUNITExpr :: !Expression !Expression !PredefinedSymbols !*Heaps - -> (!Expression, !*Heaps) -buildCaseUNITExpr arg_expr body_expr predefs heaps - # unit_pat = buildUNITPattern body_expr predefs - # {pds_module, pds_def} = predefs.[PD_TypeUNIT] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [unit_pat] - = buildCaseExpr arg_expr case_patterns heaps - -buildCaseEITHERExpr :: !Expression (!FreeVar, !Expression) (!FreeVar, !Expression) !PredefinedSymbols !*Heaps - -> (!Expression, !*Heaps) -buildCaseEITHERExpr arg_expr (left_var, left_expr) (right_var, right_expr) predefs heaps - # left_pat = buildLEFTPattern left_var left_expr predefs - # right_pat = buildRIGHTPattern right_var right_expr predefs - # {pds_module, pds_def} = predefs.[PD_TypeEITHER] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [left_pat, right_pat] - = buildCaseExpr arg_expr case_patterns heaps - -buildCasePAIRExpr :: !Expression !FreeVar !FreeVar !Expression !PredefinedSymbols !*Heaps - -> (!Expression, !*Heaps) -buildCasePAIRExpr arg_expr var1 var2 body_expr predefs heaps - # pair_pat = buildPAIRPattern var1 var2 body_expr predefs - # {pds_module, pds_def} = predefs.[PD_TypePAIR] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pair_pat] - = buildCaseExpr arg_expr case_patterns heaps - -buildCaseCONSExpr :: !Expression !FreeVar !FreeVar !Expression !PredefinedSymbols !*Heaps - -> (!Expression, !*Heaps) -buildCaseCONSExpr arg_expr cons_info_var arg_var body_expr predefs heaps - # cons_pat = buildCONSPattern cons_info_var arg_var body_expr predefs - # {pds_module, pds_def} = predefs.[PD_TypeCONS] - # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [cons_pat] - = buildCaseExpr arg_expr case_patterns heaps - - - -buildPredefConsApp :: !Int [Expression] !PredefinedSymbols !*Heaps - -> (!Expression, !*Heaps) -buildPredefConsApp predef_index args predefs heaps=:{hp_expression_heap} - # {pds_module, pds_def} = predefs.[predef_index] - # pds_ident = predefined_idents.[predef_index] - # global_index = {glob_module = pds_module, glob_object = pds_def} - # symb_ident = { - symb_ident = pds_ident, - symb_kind = SK_Constructor global_index - } - # (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap - # app = App {app_symb = symb_ident, app_args = args, app_info_ptr = expr_info_ptr} - = (app, {heaps & hp_expression_heap = hp_expression_heap}) - -buildISO to_expr from_expr predefs heaps :== buildPredefConsApp PD_ConsISO [to_expr, from_expr] predefs heaps -buildUNIT predefs heaps :== buildPredefConsApp PD_ConsUNIT [] predefs heaps -buildPAIR x y predefs heaps :== buildPredefConsApp PD_ConsPAIR [x, y] predefs heaps -buildLEFT x predefs heaps :== buildPredefConsApp PD_ConsLEFT [x] predefs heaps -buildRIGHT x predefs heaps :== buildPredefConsApp PD_ConsRIGHT [x] predefs heaps -buildARROW x y predefs heaps :== buildPredefConsApp PD_ConsARROW [x, y] predefs heaps -buildCONS cons_info arg predefs heaps :== buildPredefConsApp PD_ConsCONS [cons_info, arg] predefs heaps - -buildPredefFunApp :: !Int [Expression] !PredefinedSymbols !*Heaps - -> (!Expression, !*Heaps) -buildPredefFunApp predef_index args predefs heaps=:{hp_expression_heap} - # {pds_module, pds_def} = predefs.[predef_index] - # pds_ident = predefined_idents.[predef_index] - # global_index = {glob_module = pds_module, glob_object = pds_def} - # symb_ident = { - symb_ident = pds_ident, - symb_kind = SK_Function global_index - } - # (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap - # app = App {app_symb = symb_ident, app_args = args, app_info_ptr = expr_info_ptr} - = (app, {heaps & hp_expression_heap = hp_expression_heap}) - -buildUndefFunApp args predefs heaps :== buildPredefFunApp PD_undef args predefs heaps -buildIsomapArrowApp x y predefs heaps :== buildPredefFunApp PD_isomap_ARROW_ [x,y] predefs heaps -buildIsomapIdApp predefs heaps :== buildPredefFunApp PD_isomap_ID [] predefs heaps - -buildIsoToSelectionExpr :: !Expression !PredefinedSymbols -> Expression -buildIsoToSelectionExpr record_expr predefs - # {pds_module, pds_def} = predefs . [PD_iso_to] - # pds_ident = predefined_idents . [PD_iso_to] - # selector = { - glob_module = pds_module, - glob_object = {ds_ident = pds_ident, ds_index = pds_def, ds_arity = 1}} - = Selection NormalSelector record_expr [RecordSelection selector 0] - -buildIsoFromSelectionExpr :: !Expression !PredefinedSymbols -> Expression -buildIsoFromSelectionExpr record_expr predefs - # {pds_module, pds_def} = predefs . [PD_iso_from] - # pds_ident = predefined_idents . [PD_iso_from] - # selector = { - glob_module = pds_module, - glob_object = {ds_ident = pds_ident, ds_index = pds_def, ds_arity = 1}} - = Selection NormalSelector record_expr [RecordSelection selector 1] - -buildVarExpr :: !String !*Heaps -> (!Expression, !FreeVar, !*Heaps) -buildVarExpr name heaps=:{hp_var_heap, hp_expression_heap} - # (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap - # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - # var_ident = { id_name = name, id_info = nilPtr } - # fv = { fv_def_level = NotALevel, fv_count = 1, fv_info_ptr = var_info_ptr, fv_ident = var_ident} - # var = Var {var_ident = var_ident, var_expr_ptr = expr_info_ptr, var_info_ptr = var_info_ptr } - # hp_var_heap = writePtr var_info_ptr (VI_Expression var) hp_var_heap - # heaps = { heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap } - = (var, fv, heaps) - -buildVarExprs :: ![String] !*Heaps -> (![Expression], [FreeVar], !*Heaps) -buildVarExprs [] heaps = ([], [], heaps) -buildVarExprs [name:names] heaps - # (expr, var, heaps) = buildVarExpr name heaps - # (exprs, vars, heaps) = buildVarExprs names heaps - = ([expr:exprs], [var:vars], heaps) - -buildFreeVar :: !String !*Heaps -> (!FreeVar, !*Heaps) -buildFreeVar name heaps=:{hp_var_heap} - # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - # var_ident = { id_name = name, id_info = nilPtr } - # var = { fv_def_level = NotALevel, fv_count = 1, fv_info_ptr = var_info_ptr, fv_ident = var_ident} - = (var, {heaps & hp_var_heap = hp_var_heap}) - - -buildFreeVar0 :: !String !*Heaps -> (!FreeVar, !*Heaps) -buildFreeVar0 name heaps=:{hp_var_heap} - # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - # var_ident = { id_name = name, id_info = nilPtr } - # var = { fv_def_level = NotALevel, fv_count = 0, fv_info_ptr = var_info_ptr, fv_ident = var_ident} - = (var, {heaps & hp_var_heap = hp_var_heap}) - - - -buildFreeVars :: ![String] !*Heaps -> (![FreeVar], !*Heaps) -buildFreeVars names heaps = mapSt buildFreeVar names heaps - -// create expression from a variable -buildBoundVarExpr :: !FreeVar !*Heaps -> (!Expression, !FreeVar, !*Heaps) -buildBoundVarExpr free_var=:{fv_info_ptr, fv_ident, fv_count} heaps=:{hp_expression_heap, hp_var_heap} - # (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap - # expr = Var {var_ident = fv_ident, var_expr_ptr = expr_info_ptr, var_info_ptr = fv_info_ptr } - # hp_var_heap = writePtr fv_info_ptr (VI_Expression expr) hp_var_heap - # heaps = { heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap } - = (expr, {free_var & fv_count = fv_count + 1}, heaps) - -buildBoundVarExprs :: ![FreeVar] !*Heaps -> (![Expression], ![FreeVar], !*Heaps) -buildBoundVarExprs [] heaps = ([], [], heaps) -buildBoundVarExprs [free_var:free_vars] heaps - # (expr, free_var, heaps) = buildBoundVarExpr free_var heaps - # (exprs, free_vars, heaps) = buildBoundVarExprs free_vars heaps - = ([expr:exprs], [free_var:free_vars], heaps) - - -copyVar :: FreeVar !*Heaps -> (!FreeVar, !*Heaps) -copyVar var heaps=:{hp_var_heap} - # (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap - = ({var & fv_info_ptr = var_info_ptr}, {heaps & hp_var_heap = hp_var_heap}) - //---> ("copyVar", var, ptrToInt var_info_ptr) -copyVars vars heaps = mapSt copyVar vars heaps - -setVarInfo var=:{fv_info_ptr} var_info heaps=:{hp_var_heap} - # hp_var_heap = writePtr fv_info_ptr var_info hp_var_heap - = {heaps & hp_var_heap = hp_var_heap} -setVarInfos vars var_infos heaps - = fold2St setVarInfo vars var_infos heaps -clearVarInfos vars heaps - = setVarInfos vars (repeatn (length vars) VI_Empty) heaps - -copyExpr :: !Expression !*Heaps -> (!Expression, !*Heaps) -copyExpr expr heaps=:{hp_var_heap, hp_expression_heap} - #! state = - { us_var_heap = hp_var_heap - , us_symbol_heap = hp_expression_heap - , us_opt_type_heaps = No - , us_cleanup_info = [] - , us_local_macro_functions = No - } - #! info = - { ui_handle_aci_free_vars = LeaveThem - , ui_convert_module_n = -1 - , ui_conversion_table = No - } - #! (expr, {us_var_heap, us_symbol_heap}) = unfold expr info state - = (expr, {heaps & hp_var_heap = us_var_heap, hp_expression_heap = us_symbol_heap}) - //---> ("copy Expr") - -mapExprSt :: !(Expression -> w:st -> u:(Expression, w:st)) !Expression w:st -> v:(Expression, w:st), [v<=w,u<=v] -mapExprSt f (App app=:{app_args}) st - # (app_args, st) = mapSt (mapExprSt f) app_args st - = f (App { app & app_args = app_args }) st - -mapExprSt f (Let lad=:{let_lazy_binds, let_strict_binds, let_expr}) st - # (let_lazy_binds, st) = mapSt map_bind let_lazy_binds st - # (let_strict_binds, st) = mapSt map_bind let_strict_binds st - # (let_expr, st) = mapExprSt f let_expr st - # lad = - { lad - & let_expr = let_expr - , let_lazy_binds = let_lazy_binds - , let_strict_binds = let_strict_binds - } - = f (Let lad) st -where - map_bind b=:{lb_src} st - # (lb_src, st) = mapExprSt f lb_src st - = ({b & lb_src = lb_src}, st) - -mapExprSt f (Selection a expr b) st - # (expr, st) = mapExprSt f expr st - = f (Selection a expr b) st - -mapExprSt f (Update e1 x e2) st - # (e1, st) = mapExprSt f e1 st - # (e2, st) = mapExprSt f e2 st - = f (Update e1 x e2) st - -mapExprSt f (RecordUpdate x expr binds) st - # (expr, st) = mapExprSt f expr st - # (binds, st) = mapSt map_bind binds st - = f (RecordUpdate x expr binds) st -where - map_bind b=:{bind_src} st - # (bind_dst, st) = mapExprSt f bind_src st - = ({b & bind_src = bind_src}, st) - -mapExprSt f (TupleSelect x y expr) st - # (expr, st) = mapExprSt f expr st - = f (TupleSelect x y expr) st - -mapExprSt f (Conditional cond=:{if_cond, if_then, if_else}) st - # (if_cond, st) = mapExprSt f if_cond st - # (if_then, st) = mapExprSt f if_then st - # (if_else, st) = case if_else of - (Yes x) - # (x, st) = mapExprSt f x st - -> (Yes x, st) - No -> (No, st) - = f (Conditional {cond & if_cond = if_cond, if_then = if_then, if_else = if_else}) st - -mapExprSt f (MatchExpr y expr) st - # (expr, st) = mapExprSt f expr st - = f (MatchExpr y expr) st - -mapExprSt f (DynamicExpr dyn=:{dyn_expr}) st - # (dyn_expr, st) = mapExprSt f dyn_expr st - = f (DynamicExpr {dyn& dyn_expr = dyn_expr}) st - -mapExprSt f (Case c=:{case_expr, case_guards, case_default=case_default}) st - # (case_expr, st) = mapExprSt f case_expr st - # (case_guards, st) = map_patterns case_guards st - # (case_default, st) = case case_default of - (Yes x) - # (x, st) = mapExprSt f x st - -> (Yes x, st) - No -> (No, st) - # new_case = {c & case_expr=case_expr, case_guards=case_guards, case_default=case_default} - = f (Case new_case) st -where - map_patterns (AlgebraicPatterns index pats) st - # (pats, st) = mapSt map_alg_pattern pats st - = (AlgebraicPatterns index pats, st) - map_patterns (BasicPatterns bt pats) st - # (pats, st) = mapSt map_basic_pattern pats st - = (BasicPatterns bt pats, st) - map_patterns (DynamicPatterns pats) st - # (pats, st) = mapSt map_dyn_pattern pats st - = (DynamicPatterns pats, st) - - map_alg_pattern pat=:{ap_expr} st - # (ap_expr, st) = mapExprSt f ap_expr st - = ({pat & ap_expr = ap_expr}, st) - map_basic_pattern pat=:{bp_expr} st - # (bp_expr, st) = mapExprSt f bp_expr st - = ({pat & bp_expr = bp_expr}, st) - map_dyn_pattern pat=:{dp_rhs} st - # (dp_rhs, st) = mapExprSt f dp_rhs st - = ({pat & dp_rhs = dp_rhs}, st) - -mapExprSt f expr st = f expr st - - -copyFunDef :: !FunDef !Index !Index !*Heaps -> (!FunDef, !*Heaps) -copyFunDef fun_def=:{fun_ident,fun_arity,fun_body,fun_info} fun_index group_index gs_heaps - # (TransformedBody {tb_args, tb_rhs}) = fun_body - - # (fresh_arg_vars, gs_heaps) = copy_vars tb_args gs_heaps - # (copied_rhs, gs_heaps) = copyExpr tb_rhs gs_heaps - - # (copied_rhs, fresh_arg_vars, fresh_local_vars, gs_heaps) = - collect_local_vars copied_rhs fresh_arg_vars gs_heaps - - # gs_heaps = clearVarInfos tb_args gs_heaps - - # fun_def = - { fun_def - // & fun_index = fun_index - //, fun_ident = makeIdent "zzzzzzzzzzzz" - & fun_body = TransformedBody { tb_args = fresh_arg_vars, tb_rhs = copied_rhs } - , fun_info = - { fun_info - & fi_group_index = group_index - , fi_local_vars = fresh_local_vars - } - } - = (fun_def, gs_heaps) -where - copy_vars vars heaps - # (fresh_vars, heaps) = copyVars vars heaps - # infos = [VI_Variable fv_ident fv_info_ptr\\ {fv_ident,fv_info_ptr} <- fresh_vars] - # heaps = setVarInfos vars infos heaps - = (fresh_vars, heaps) - - collect_local_vars body_expr fun_arg_vars heaps=:{hp_var_heap, hp_expression_heap} - # dummy_pds = {pds_module=NoIndex,pds_def=NoIndex} - #! cs = - { cos_error = {ea_file = stderr, ea_ok = True, ea_loc=[]} - , cos_var_heap = hp_var_heap - , cos_symbol_heap = hp_expression_heap - , cos_predef_symbols_for_transform = { predef_alias_dummy=dummy_pds, predef_and=dummy_pds, predef_or=dummy_pds } - } - # (body_expr, fun_arg_vars, local_vars, {cos_symbol_heap, cos_var_heap}) = - determineVariablesAndRefCounts fun_arg_vars body_expr cs - # heaps = { heaps & hp_var_heap = cos_var_heap, hp_expression_heap = cos_symbol_heap } - = (body_expr, fun_arg_vars, local_vars, heaps) - -// collect functions called in an expression -collectCalls :: !Index !Expression -> [Index] -collectCalls current_module expr - # symbidents = collect_expr_calls expr [] - = removeDup - [glob_object \\ - {symb_kind=SK_Function {glob_module,glob_object}} <- symbidents - | glob_module == current_module] -where - - collect_expr_calls (App app) rest = [app.app_symb:foldr collect_expr_calls rest app.app_args] - collect_expr_calls (expr@exprs) rest = collect_expr_calls expr (foldr collect_expr_calls rest exprs) - collect_expr_calls (Let li) rest = collect_expr_calls li.let_expr (foldr collect_letbind_calls (foldr collect_letbind_calls rest li.let_lazy_binds) li.let_strict_binds) - collect_expr_calls (Case ci) rest = collect_expr_calls ci.case_expr (collect_casepatterns_calls ci.case_guards (foldOptional id collect_expr_calls ci.case_default rest)) - collect_expr_calls (Selection optgd expr sels) rest = collect_expr_calls expr (foldr collect_sel_calls rest sels) - collect_expr_calls (Update expr1 sels expr2) rest = collect_expr_calls expr1 (foldr collect_sel_calls (collect_expr_calls expr2 rest) sels) - collect_expr_calls (RecordUpdate gds expr binds) rest = collect_expr_calls expr (foldr collect_bind_calls rest binds) - collect_expr_calls (TupleSelect ds i expr) rest = collect_expr_calls expr rest - //collect_expr_calls (Lambda fvs expr) rest = collect_expr_calls expr rest - collect_expr_calls (Conditional cond) rest = collect_expr_calls cond.if_cond (collect_expr_calls cond.if_then (foldOptional id collect_expr_calls cond.if_else rest)) - collect_expr_calls (MatchExpr gds expr) rest = collect_expr_calls expr rest - collect_expr_calls (DynamicExpr dyn) rest = collect_expr_calls dyn.dyn_expr (collect_tce_calls dyn.dyn_type_code rest) - //collect_expr_calls (TypeCase tc) rest = collect_expr_calls tc.type_case_dynamic (foldr collect_dp_calls (foldOptional id collect_expr_calls rest) tc.type_case_patterns) - collect_expr_calls (TypeCodeExpression tce) rest = collect_tce_calls tce rest - collect_expr_calls _ rest = rest - - collect_letbind_calls lb rest = collect_expr_calls lb.lb_src rest - - collect_casepatterns_calls (AlgebraicPatterns gi aps) rest = foldr collect_ap_calls rest aps - collect_casepatterns_calls (BasicPatterns gi bps) rest = foldr collect_bp_calls rest bps - collect_casepatterns_calls (DynamicPatterns dps) rest = foldr collect_dp_calls rest dps - collect_casepatterns_calls NoPattern rest = rest - - collect_ap_calls ap rest = collect_expr_calls ap.ap_expr rest - collect_bp_calls bp rest = collect_expr_calls bp.bp_expr rest - collect_dp_calls dp rest = collect_tce_calls dp.dp_type_code (collect_expr_calls dp.dp_rhs rest) - - collect_sel_calls (RecordSelection gds i) rest = rest - collect_sel_calls (ArraySelection gds eip expr) rest = collect_expr_calls expr rest - collect_sel_calls (DictionarySelection bv sels sip expr) rest = foldr collect_sel_calls (collect_expr_calls expr rest) sels - - collect_bind_calls b rest = collect_expr_calls b.bind_src rest - - collect_tce_calls (TCE_Constructor i tces) rest = foldr collect_tce_calls rest tces - collect_tce_calls (TCE_Selector sels vip) rest = foldr collect_sel_calls rest sels - collect_tce_calls _ rest = rest - - -makeIdent :: String -> Ident -makeIdent str = {id_name = str, id_info = nilPtr} - -makeIntExpr :: Int -> Expression -makeIntExpr value = BasicExpr (BVI (toString value)) - -makeStringExpr :: String !PredefinedSymbols -> Expression -makeStringExpr str predefs - #! {pds_module, pds_def} = predefs.[PD_StringType] - #! pds_ident = predefined_idents.[PD_StringType] - #! type_symb = MakeTypeSymbIdent { glob_module = pds_module, glob_object = pds_def } pds_ident 0 - = BasicExpr (BVS str) - -makeListExpr :: [Expression] !PredefinedSymbols !*Heaps -> (Expression, !*Heaps) -makeListExpr [] predefs heaps - = buildPredefConsApp PD_NilSymbol [] predefs heaps -makeListExpr [expr:exprs] predefs heaps - # (list_expr, heaps) = makeListExpr exprs predefs heaps - = buildPredefConsApp PD_ConsSymbol [expr, list_expr] predefs heaps - -foldOptional no yes No = no -foldOptional no yes (Yes x) = yes x - -transpose [] = [] -transpose [[] : xss] = transpose xss -transpose [[x:xs] : xss] = - [[x : [hd l \\ l <- xss]] : transpose [xs : [ tl l \\ l <- xss]]] - -unzip3 [] = ([], [], []) -unzip3 [(x1,x2,x3):xs] - # (x1s, x2s, x3s) = unzip3 xs - = ([x1:x1s], [x2:x2s], [x3:x3s]) - -reportError name pos msg error - = checkErrorWithIdentPos (newPosition name pos) msg error - -(--) infixl 5 :: u:[a] .[a] -> u:[a] | Eq a -(--) x y = removeMembers x y |