Commit 1c4690a3 authored by John van Groningen's avatar John van Groningen
Browse files

pass Ident name instead of Ident to functions to create generic idents

in genericsupport
parent 18536944
......@@ -2419,7 +2419,7 @@ check_module1 cdefs icl_global_function_range fun_defs optional_dcl_mod optional
convert_generic_instances [gc=:{gc_ident,gc_pos, gc_type_cons, gc_body=GCB_None} : gcs] next_fun_index
# (fun_defs, gcs) = convert_generic_instances gcs (inc next_fun_index)
# fun_def =
{ fun_ident = genericIdentToFunIdent gc_ident gc_type_cons
{ fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
, fun_arity = 0
, fun_priority = NoPrio
, fun_body = GeneratedBody
......@@ -3333,7 +3333,7 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
# gencase_def = { gencase_def & gc_body = GCB_FunIndex fun_index }
# gencase_defs = {gencase_defs & [gc_index] = gencase_def}
#! fun_ident = genericIdentToFunIdent gc_ident gc_type_cons
#! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
#! (var_info_ptr, hp_var_heap) = newPtr VI_Empty hp_var_heap
#! fun =
{ ft_ident = fun_ident
......
......@@ -1003,7 +1003,7 @@ where
# clazz =
{ glob_module = -1
, glob_object =
{ ds_ident = genericIdentToClassIdent gen_ident gtc_kind
{ ds_ident = genericIdentToClassIdent gen_ident.id_name gtc_kind
, ds_arity = 1
, ds_index = -1
}
......@@ -1605,7 +1605,7 @@ where
// FIXME: We do not know the type before the generic phase.
// The generic phase currently does not update the type.
# field_type = makeAttributedType TA_Multi TE
# class_ident = genericIdentToClassIdent gtc_generic.glob_object.ds_ident gtc_kind
# class_ident = genericIdentToClassIdent gtc_generic.glob_object.ds_ident.id_name gtc_kind
# (field, var_heap, symbol_table) = build_field field_nr class_ident.id_name rec_type_index rec_type field_type next_selector_index var_heap symbol_table
= build_context_fields mod_index (inc field_nr) tcs rec_type rec_type_index (inc next_selector_index) [ field : rev_fields ]
[field_type : rev_field_types] class_defs modules var_heap symbol_table
......
......@@ -1517,8 +1517,8 @@ buildClassAndMember
//---> ("buildClassAndMember", gen_def.gen_ident, kind)
where
class_ident = genericIdentToClassIdent gen_def.gen_ident kind
member_ident = genericIdentToMemberIdent gen_def.gen_ident kind
class_ident = genericIdentToClassIdent gen_def.gen_ident.id_name kind
member_ident = genericIdentToMemberIdent gen_def.gen_ident.id_name kind
class_ds = {ds_index = class_index, ds_ident = class_ident, ds_arity = 1}
build_class_member class_var gs=:{gs_varh}
......@@ -1773,7 +1773,7 @@ where
{ tc_class = TCClass
{ glob_module=gci_module // the same as icl module
, glob_object =
{ ds_ident = genericIdentToClassIdent gc_ident gci_kind
{ ds_ident = genericIdentToClassIdent gc_ident.id_name gci_kind
, ds_index = gci_class
, ds_arity = 1
}
......@@ -1789,7 +1789,7 @@ where
#! (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty heaps.hp_expression_heap
#! heaps = {heaps & hp_expression_heap = hp_expression_heap}
#! fun_name = genericIdentToMemberIdent gc_ident this_kind
#! fun_name = genericIdentToMemberIdent gc_ident.id_name this_kind
# (gen_exprs, heaps) = mapSt (build_generic_app gc_generic gc_ident) class_infos heaps
......@@ -1821,7 +1821,7 @@ where
# {gc_pos, gc_ident, gc_kind} = gencase
#! class_ident = genericIdentToClassIdent gc_ident this_kind
#! class_ident = genericIdentToClassIdent gc_ident.id_name this_kind
#! class_ds = {ds_index = class_index, ds_arity=1, ds_ident=class_ident}
#! ins =
{ ins_class = {glob_module=gs_main_module, glob_object=class_ds}
......@@ -1864,7 +1864,7 @@ where
| fun_index < size dcl_functions
#! (symbol_type, heaps) = fresh_symbol_type symbol_type heaps
#! (fun, dcl_functions) = dcl_functions ! [fun_index]
#! fun = { fun & ft_ident = genericIdentToFunIdent gc_ident gc_type_cons
#! fun = { fun & ft_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
, ft_type = symbol_type
, ft_arity = symbol_type.st_arity }
#! dcl_functions = { dcl_functions & [fun_index] = fun}
......@@ -1887,7 +1887,7 @@ where
update_icl_function fun_index gencase=:{gc_ident, gc_type_cons, gc_pos} st funs_and_groups fun_defs td_infos modules heaps error
#! (st, heaps) = fresh_symbol_type st heaps
#! (fun=:{fun_body, fun_arity}, fun_defs) = fun_defs ! [fun_index]
#! fun_ident = genericIdentToFunIdent gc_ident gc_type_cons
#! fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
= case fun_body of
TransformedBody tb // user defined case
| fun_arity <> st.st_arity
......@@ -1928,7 +1928,7 @@ where
#! (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty heaps.hp_expression_heap
#! heaps = {heaps & hp_expression_heap = hp_expression_heap}
#! fun_name = genericIdentToFunIdent gc_ident gc_type_cons
#! fun_name = genericIdentToFunIdent gc_ident.id_name gc_type_cons
#! expr = App
{ app_symb =
{ symb_ident=fun_name
......@@ -1940,7 +1940,7 @@ where
#! (st, heaps) = fresh_symbol_type st heaps
#! memfun_name = genericIdentToMemberIdent gc_ident gc_kind
#! memfun_name = genericIdentToMemberIdent gc_ident.id_name gc_kind
#! (fun_ds, fun_info)
= buildFunAndGroup memfun_name arg_vars expr (Yes st) gs_main_module gc_pos fun_info
= (fun_ds, fun_info, heaps)
......@@ -1949,7 +1949,7 @@ where
# {gc_pos, gc_ident, gc_kind} = gencase
#! class_ident = genericIdentToClassIdent gc_ident gc_kind
#! class_ident = genericIdentToClassIdent gc_ident.id_name gc_kind
#! class_ds = {ds_index = class_index, ds_arity=1, ds_ident=class_ident}
#! ins =
{ ins_class = {glob_module=gs_main_module, glob_object=class_ds}
......@@ -2269,7 +2269,7 @@ where
# clazz =
{ glob_module = class_info.gci_module
, glob_object =
{ ds_ident = genericIdentToClassIdent gtc_generic.glob_object.ds_ident gtc_kind
{ ds_ident = genericIdentToClassIdent gtc_generic.glob_object.ds_ident.id_name gtc_kind
, ds_arity = 1
, ds_index = class_info.gci_class
}
......@@ -3151,11 +3151,11 @@ where
// generic type var is replaced with a fresh one
subst_gtv {tv_info_ptr, tv_ident} th_vars
# (tv, th_vars) = freshTypeVar (postfixIdent tv_ident postfix) th_vars
# (tv, th_vars) = freshTypeVar (postfixIdent tv_ident.id_name postfix) th_vars
= (tv, writePtr tv_info_ptr (TVI_Type (TV tv)) th_vars)
subst_attr (TA_Var {av_ident, av_info_ptr}) th_attrs
# (av, th_attrs) = freshAttrVar (postfixIdent av_ident postfix) th_attrs
# (av, th_attrs) = freshAttrVar (postfixIdent av_ident.id_name postfix) th_attrs
= (TA_Var av, writePtr av_info_ptr (AVI_Attr (TA_Var av)) th_attrs)
//---> ("(2) writePtr av_info_ptr", ptrToInt av_info_ptr, av)
subst_attr TA_Multi th = (TA_Multi, th)
......
......@@ -46,7 +46,7 @@ getGenericClass ::
// Ident Helpers
//****************************************************************************************
makeIdent :: !String -> Ident
postfixIdent :: !Ident !String -> Ident
genericIdentToClassIdent :: !Ident !TypeKind -> Ident
genericIdentToMemberIdent :: !Ident !TypeKind -> Ident
genericIdentToFunIdent :: !Ident !TypeCons -> Ident
postfixIdent :: !String !String -> Ident
genericIdentToClassIdent :: !String !TypeKind -> Ident
genericIdentToMemberIdent :: !String !TypeKind -> Ident
genericIdentToFunIdent :: !String !TypeCons -> Ident
......@@ -79,12 +79,12 @@ addGenericClassInfo class_info=:{gci_kind} class_infos
makeIdent :: !String -> Ident
makeIdent str = {id_name = str, id_info = nilPtr}
postfixIdent :: !Ident !String -> Ident
postfixIdent {id_name} postfix = makeIdent (id_name +++ postfix)
postfixIdent :: !String !String -> Ident
postfixIdent id_name postfix = makeIdent (id_name +++ postfix)
genericIdentToClassIdent :: !Ident !TypeKind -> Ident
genericIdentToClassIdent gen_ident kind
= postfixIdent gen_ident ("_" +++ kind_to_str kind)
genericIdentToClassIdent :: !String !TypeKind -> Ident
genericIdentToClassIdent id_name kind
= postfixIdent id_name ("_" +++ kind_to_str kind)
where
kind_to_str KindConst = "s"
kind_to_str (KindArrow kinds)
......@@ -93,13 +93,13 @@ where
kinds_to_str [KindConst:ks] = "s" +++ kinds_to_str ks
kinds_to_str [k:ks] = "o" +++ (kind_to_str k) +++ "c" +++ kinds_to_str ks
genericIdentToMemberIdent :: !Ident !TypeKind -> Ident
genericIdentToMemberIdent gen_ident kind
= genericIdentToClassIdent gen_ident kind
genericIdentToMemberIdent :: !String !TypeKind -> Ident
genericIdentToMemberIdent id_name kind
= genericIdentToClassIdent id_name kind
genericIdentToFunIdent :: !Ident !TypeCons -> Ident
genericIdentToFunIdent gen_ident type_cons
= postfixIdent gen_ident ("_" +++ type_cons_to_str type_cons)
genericIdentToFunIdent :: !String !TypeCons -> Ident
genericIdentToFunIdent id_name type_cons
= postfixIdent id_name ("_" +++ type_cons_to_str type_cons)
where
type_cons_to_str (TypeConsSymb {type_ident}) = toString type_ident
type_cons_to_str (TypeConsBasic bt) = toString bt
......
......@@ -1440,7 +1440,7 @@ reorganiseDefinitions icl_module [PD_GenericCase gc : defs] cons_count sel_count
, pb_position = gc.gc_pos
}
#! bodies = [body : bodies ]
#! fun_name = genericIdentToFunIdent gc.gc_ident gc.gc_type_cons
#! fun_name = genericIdentToFunIdent gc.gc_ident.id_name gc.gc_type_cons
#! fun = MakeNewImpOrDefFunction fun_name gc.gc_arity bodies (FK_Function cNameNotLocationDependent) NoPrio No gc.gc_pos
#! inst = { gc & gc_body = GCB_FunDef fun }
#! c_defs = {c_defs & def_generic_cases = [inst : c_defs.def_generic_cases]}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment