Commit 12f93c22 authored by John van Groningen's avatar John van Groningen

add preliminary implementation of deriving instances using generics for testing purposes

parent d1bf6f73
......@@ -5,7 +5,7 @@ import StdEnv, compare_types
import syntax, expand_types, parse, checksupport, utilities, checktypes, transform, predef
import explicitimports, comparedefimp, checkFunctionBodies, containers, typesupport
import typereify
from checkgenerics import checkGenericDefs,checkGenericCaseDefs,convert_generic_instances,create_gencase_funtypes
from checkgenerics import checkGenericDefs,checkGenericCaseDefs,convert_generic_instances,create_gencase_funtypes,get_generic_index
cUndef :== (-1)
cDummyArray :== {}
......@@ -310,6 +310,21 @@ where
= check_icl_instance_members (class_member_n+1) instance_member_n member_mod_index ins_members class_members class_ident ins_pos ins_type
instance_types n_icl_functions new_instance_members member_defs type_defs icl_functions modules var_heap type_heaps cs
| ins_member.cim_ident == class_member.ds_ident
| icl_functions.[ins_member.cim_index].fun_body=:GenerateInstanceBody _
# ({fun_body=GenerateInstanceBody generic_ident},icl_functions) = icl_functions![ins_member.cim_index]
#! main_module_n = cs.cs_x.x_main_dcl_module_n
# (generic_index,cs) = get_generic_index generic_ident main_module_n cs
# ({me_type,me_class_vars,me_priority}, member_defs, modules)
= getMemberDef member_mod_index class_member.ds_index x_main_dcl_module_n member_defs modules
(fun,icl_functions) = icl_functions![ins_member.cim_index];
fun & fun_body = GenerateInstanceBodyChecked generic_ident generic_index, fun_arity = class_member.ds_arity, fun_priority = me_priority
icl_functions & [ins_member.cim_index] = fun
(instance_type,type_defs,modules,var_heap,type_heaps,cs)
= make_class_member_instance_type ins_type me_type me_class_vars type_defs modules var_heap type_heaps cs
instance_types = [(ins_member.cim_index, instance_type) : instance_types]
= check_icl_instance_members (class_member_n+1) (instance_member_n+1) member_mod_index ins_members class_members class_ident ins_pos ins_type
instance_types n_icl_functions new_instance_members member_defs type_defs icl_functions modules var_heap type_heaps cs
#! instance_member_arity=icl_functions.[ins_member.cim_index].fun_arity
| instance_member_arity <> class_member.ds_arity
# cs & cs_error = checkError class_member.ds_ident ("defined with wrong arity ("+++toString instance_member_arity+++" instead of "+++toString class_member.ds_arity+++")") cs.cs_error
......@@ -2376,16 +2391,16 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
| icl_mem_index < size icl_members
# icl_member = icl_members.[icl_mem_index]
| icl_member.cim_ident.id_name==dcl_member.cim_ident.id_name
# new_table = {new_table & [dcl_member.cim_index] = icl_member.cim_index}
# new_table & [dcl_member.cim_index] = icl_member.cim_index
= build_conversion_table_for_instances_of_members_with_default_instances (dcl_mem_index+1) (icl_mem_index+1) dcl_members icl_members new_table n_icl_functions icl_instance error
| icl_member.cim_ident.id_name<dcl_member.cim_ident.id_name
# error = checkErrorWithPosition icl_instance.ins_ident icl_instance.ins_pos (icl_member.cim_ident.id_name+++" is not a member of this class") error
= build_conversion_table_for_instances_of_members_with_default_instances dcl_mem_index (icl_mem_index+1) dcl_members icl_members new_table n_icl_functions icl_instance error
# icl_members = add_possible_default_instance dcl_member icl_mem_index n_icl_functions icl_members
# new_table = {new_table & [dcl_member.cim_index] = n_icl_functions}
# new_table & [dcl_member.cim_index] = n_icl_functions
= build_conversion_table_for_instances_of_members_with_default_instances (dcl_mem_index+1) (icl_mem_index+1) dcl_members icl_members new_table (n_icl_functions+1) icl_instance error
# icl_members = add_possible_default_instance dcl_member icl_mem_index n_icl_functions icl_members
# new_table = {new_table & [dcl_member.cim_index] = n_icl_functions}
# new_table & [dcl_member.cim_index] = n_icl_functions
= build_conversion_table_for_instances_of_members_with_default_instances (dcl_mem_index+1) (icl_mem_index+1) dcl_members icl_members new_table (n_icl_functions+1) icl_instance error
| icl_mem_index < size icl_members
# error = checkErrorWithPosition icl_instance.ins_ident icl_instance.ins_pos (icl_members.[icl_mem_index].cim_ident.id_name+++" is not a member of this class") error
......@@ -2406,7 +2421,7 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
| mem_index < size dcl_members
# dcl_member = dcl_members.[mem_index]
# icl_member = icl_members.[mem_index]
# new_table = {new_table & [dcl_member.cim_index] = icl_member.cim_index}
# new_table & [dcl_member.cim_index] = icl_member.cim_index
= build_conversion_table_for_instances_of_members (inc mem_index) dcl_members icl_members new_table
= new_table
......
......@@ -365,9 +365,13 @@ where
# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, result_expr, expr_heap)
checkFunctionBodies GeneratedBody function_ident_for_errors e_input e_state e_info cs
checkFunctionBodies GeneratedBody function_ident_for_errors e_input e_state e_info cs
= (GeneratedBody, [], e_state, e_info, cs)
//---> ("checkFunctionBodies: function to derive ", function_ident_for_errors)
checkFunctionBodies (GenerateInstanceBodyChecked generic_ident generic_index) function_ident_for_errors e_input e_state e_info cs
= (GenerateInstanceBodyChecked generic_ident generic_index, [], e_state, e_info, cs)
checkFunctionBodies (GenerateInstanceBody generic_ident) function_ident_for_errors e_input e_state e_info cs
= (GenerateInstanceBody generic_ident, [], e_state, e_info, cs)
checkFunctionBodies _ function_ident_for_errors e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_var_heap, es_fun_defs} e_info cs
= abort ("checkFunctionBodies " +++ toString function_ident_for_errors +++ "\n")
......
......@@ -15,3 +15,5 @@ convert_generic_instances :: !Int !Int !*{#GenericCaseDef} !*{#ClassDef} !*Symbo
create_gencase_funtypes :: !Index !*{#GenericCaseDef} !*Heaps
-> (!Index,![FunType],!*{#GenericCaseDef},!*Heaps)
get_generic_index :: !Ident !Index !*CheckState -> (!GlobalIndex, !*CheckState)
......@@ -17,6 +17,7 @@ import genericsupport,transform,utilities
= GTSAppCons TypeKind [GenTypeStruct]
| GTSAppVar TypeVar [GenTypeStruct]
| GTSVar TypeVar
| GTSArrow GenTypeStruct GenTypeStruct
| GTSCons !DefinedSymbol !GlobalIndex !DefinedSymbol !DefinedSymbol !GenTypeStruct
| GTSRecord !DefinedSymbol !GlobalIndex !DefinedSymbol !DefinedSymbol !GenTypeStruct
| GTSField !DefinedSymbol !GlobalIndex !DefinedSymbol !GenTypeStruct
......@@ -24,7 +25,7 @@ import genericsupport,transform,utilities
| GTSEither !GenTypeStruct !GenTypeStruct
| GTSPair !GenTypeStruct !GenTypeStruct
| GTSUnit
| GTSArrow GenTypeStruct GenTypeStruct
| GTSMemberCall !SymbIdent
| GTSE
:: BimapGenTypeStruct
......@@ -251,13 +252,46 @@ where
// generic type representation
build_generic_representations_for_derived_instances :: !Int !{#ClassInstance} !FunsAndGroups !*GenericState -> *(!FunsAndGroups,!*GenericState)
build_generic_representations_for_derived_instances instance_i instance_defs funs_and_groups gs
| instance_i<size instance_defs
# {ins_members,ins_type,ins_class_ident,ins_pos} = instance_defs.[instance_i]
| instance_has_derived_member 0 ins_members gs.gs_funs
# class_name = case ins_class_ident.ci_ident of
Ident {id_name} -> id_name
QualifiedIdent _ id_name -> id_name
= case ins_type.it_types of
[TA {type_index={glob_module,glob_object}} _]
# (funs_and_groups,gs)
= build_generic_type_rep glob_module glob_object True False class_name ins_pos funs_and_groups gs
-> build_generic_representations_for_derived_instances (instance_i+1) instance_defs funs_and_groups gs
[_]
# gs & gs_error
= reportError class_name ins_pos "cannot derive an instance for this type" gs.gs_error
-> build_generic_representations_for_derived_instances (instance_i+1) instance_defs funs_and_groups gs
_
# gs & gs_error
= reportError class_name ins_pos "cannot derive an instance for a multiparameter type class" gs.gs_error
-> build_generic_representations_for_derived_instances (instance_i+1) instance_defs funs_and_groups gs
= build_generic_representations_for_derived_instances (instance_i+1) instance_defs funs_and_groups gs
= (funs_and_groups, gs)
instance_has_derived_member :: !Int !{#ClassInstanceMember} !{#FunDef} -> Bool
instance_has_derived_member member_i ins_members gs_funs
| member_i<size ins_members
# {cim_index} = ins_members.[member_i]
| cim_index>=0 && gs_funs.[cim_index].fun_body=:GenerateInstanceBodyChecked _ _
= True
= instance_has_derived_member (member_i+1) ins_members gs_funs
= False
// generic representation is built for each type argument of
// generic cases of the current module
buildGenericRepresentations :: !*GenericState -> (!BimapFunctions,!*GenericState)
buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups}
#! size_funs = size gs_funs
#! size_groups = size gs_groups
#! ({com_gencase_defs}, gs) = gs!gs_modules.[gs_main_module]
#! ({com_gencase_defs,com_instance_defs}, gs) = gs!gs_modules.[gs_main_module]
# undefined_function_and_ident = {fii_index = -1,fii_ident = undef}
bimap_functions = {
......@@ -270,6 +304,8 @@ buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups}
#! (funs_and_groups, gs)
= foldArraySt build_generic_representation com_gencase_defs (funs_and_groups, gs)
# (funs_and_groups, gs) = build_generic_representations_for_derived_instances 0 com_instance_defs funs_and_groups gs
# {fg_funs=new_funs,fg_groups=new_groups,fg_bimap_functions} = funs_and_groups
# {gs_funs, gs_groups} = gs
#! gs_funs = arrayPlusRevList gs_funs new_funs
......@@ -777,7 +813,8 @@ where
# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
= case tv_info of
TVI_Empty = writePtr tv_info_ptr TVI_Used th_vars
_ = abort "type var is not empty"
TVI_Used = abort "type var is not empty"
_ = writePtr tv_info_ptr TVI_Used th_vars
clear_type_var {tv_info_ptr} th_vars
= writePtr tv_info_ptr TVI_Empty th_vars
......@@ -2032,6 +2069,88 @@ getGenericTypeRep (GenericTypeRep gen_type_rep) = gen_type_rep
getGenericTypeRep (GenericTypeRepAndBimapTypeRep gen_type_rep _) = gen_type_rep
getGenericTypeRep _ = abort "getGenericTypeRep: no generic representation\n"
generate_derived_instances :: !Int !{#ClassInstance} !Int PredefinedSymbolsData !*SpecializeState -> *SpecializeState
generate_derived_instances instance_i instance_defs main_module_n predefs ss
| instance_i<size instance_defs
# {ins_members,ins_type,ins_class_ident,ins_pos,ins_class_index} = instance_defs.[instance_i]
# ss = generate_derived_instance 0 ins_members ins_type ins_pos ins_class_index main_module_n predefs ss
= generate_derived_instances (instance_i+1) instance_defs main_module_n predefs ss
= ss
generate_derived_instance :: !Int !{#ClassInstanceMember} InstanceType Position GlobalIndex Int PredefinedSymbolsData !*SpecializeState -> *SpecializeState
generate_derived_instance member_i ins_members ins_type ins_pos ins_class_index main_module_n predefs ss
| member_i<size ins_members
# {cim_index,cim_ident} = ins_members.[member_i]
| cim_index>=0 && ss.ss_funs.[cim_index].fun_body=:GenerateInstanceBodyChecked _ _
# (GenerateInstanceBodyChecked generic_ident generic_index,ss) = ss!ss_funs.[cim_index].fun_body
# ({gen_type,gen_deps},ss) = ss!ss_modules.[generic_index.gi_module].com_generic_defs.[generic_index.gi_index]
| ss.ss_funs.[cim_index].fun_arity<>gen_type.st_arity
# ss & ss_error = reportError generic_ident.id_name ins_pos "arity of generic function and member not equal" ss.ss_error
= generate_derived_instance (member_i+1) ins_members ins_type ins_pos ins_class_index main_module_n predefs ss
| not gen_deps=:[]
# ss & ss_error = reportError generic_ident.id_name ins_pos "deriving instances from generic with dependencies not implemented" ss.ss_error
= generate_derived_instance (member_i+1) ins_members ins_type ins_pos ins_class_index main_module_n predefs ss
= case ins_type.it_types of
[TA {type_index} _]
# ({tdi_gen_rep},ss) = ss!ss_td_infos.[type_index.glob_module, type_index.glob_object]
# gen_type_rep = getGenericTypeRep tdi_gen_rep
# ({class_ident,class_members},ss) = ss!ss_modules.[ins_class_index.gi_module].com_class_defs.[ins_class_index.gi_index]
# {ds_ident,ds_index} = class_members.[member_i]
# member_symb_ident = {symb_ident=ds_ident,
symb_kind=SK_OverloadedFunction {glob_module=ins_class_index.gi_module,glob_object=ds_index}}
# gen_type_rep & gtr_type = add_instance_calls_to_GenTypeStruct gen_type_rep.gtr_type member_symb_ident
# (TransformedBody {tb_args, tb_rhs}, ss)
= buildDerivedInstanceCaseBody gen_type_rep main_module_n ins_pos type_index generic_ident generic_index predefs ss
#! (arg_vars, local_vars, free_vars) = collectVars tb_rhs tb_args
| not free_vars=:[]
-> abort "generate_derived_instance: free_vars is not empty\n"
# (fun=:{fun_info},ss) = ss!ss_funs.[cim_index]
# fun &
fun_arity = length arg_vars,
fun_body = TransformedBody {tb_args=arg_vars, tb_rhs=tb_rhs},
fun_info = {fun_info &
fi_calls = collectCalls main_module_n tb_rhs,
fi_free_vars = [],
fi_local_vars = local_vars,
fi_properties = fun_info.fi_properties bitor FI_GenericFun
}
(ss_funs_and_groups,ss) = ss!ss_funs_and_groups
group = {group_members = [cim_index]}
ss_funs_and_groups & fg_group_index=ss_funs_and_groups.fg_group_index+1,
fg_groups=[group:ss_funs_and_groups.fg_groups]
ss & ss_funs.[cim_index] = fun, ss_funs_and_groups = ss_funs_and_groups
-> generate_derived_instance (member_i+1) ins_members ins_type ins_pos ins_class_index main_module_n predefs ss
_
-> generate_derived_instance (member_i+1) ins_members ins_type ins_pos ins_class_index main_module_n predefs ss
= generate_derived_instance (member_i+1) ins_members ins_type ins_pos ins_class_index main_module_n predefs ss
= ss
add_instance_calls_to_GenTypeStruct :: !GenTypeStruct SymbIdent -> GenTypeStruct
add_instance_calls_to_GenTypeStruct (GTSPair gts1 gts2) member_symb_ident
= GTSPair (add_instance_calls_to_GenTypeStruct gts1 member_symb_ident) (add_instance_calls_to_GenTypeStruct gts2 member_symb_ident)
add_instance_calls_to_GenTypeStruct (GTSCons a1 a2 a3 a4 gts) member_symb_ident
= GTSCons a1 a2 a3 a4 (add_instance_calls_to_GenTypeStruct gts member_symb_ident)
add_instance_calls_to_GenTypeStruct (GTSField a1 a2 a3 gts) member_symb_ident
= GTSField a1 a2 a3 (add_instance_calls_to_GenTypeStruct gts member_symb_ident)
add_instance_calls_to_GenTypeStruct (GTSEither gts1 gts2) member_symb_ident
= GTSEither (add_instance_calls_to_GenTypeStruct gts1 member_symb_ident) (add_instance_calls_to_GenTypeStruct gts2 member_symb_ident)
add_instance_calls_to_GenTypeStruct (GTSRecord a1 a2 a3 a4 gts) member_symb_ident
= GTSRecord a1 a2 a3 a4 (add_instance_calls_to_GenTypeStruct gts member_symb_ident)
add_instance_calls_to_GenTypeStruct (GTSObject a1 a2 a3 gts) member_symb_ident
= GTSObject a1 a2 a3 (add_instance_calls_to_GenTypeStruct gts member_symb_ident)
add_instance_calls_to_GenTypeStruct GTSUnit member_symb_ident
= GTSUnit
add_instance_calls_to_GenTypeStruct _ member_symb_ident
= GTSMemberCall member_symb_ident
convertGenericCases :: !BimapFunctions !*DclMacros !*GenericState -> (!*DclMacros, !*GenericState)
convertGenericCases bimap_functions dcl_macros
gs=:{gs_main_module, gs_used_modules, gs_predefs, gs_funs, gs_groups, gs_modules, gs_dcl_modules, gs_td_infos,
......@@ -2181,7 +2300,8 @@ where
!*{#DclModule} !(!Index, ![ClassInstance]) !*SpecializeState
-> (!*{#DclModule},!(!Index, ![ClassInstance]), !*SpecializeState)
build_main_instances_in_main_module gs_main_module dcl_modules st1 st2
#! (com_gencase_defs,st2) = st2!ss_modules.[gs_main_module].com_gencase_defs
#! ({com_gencase_defs,com_instance_defs},st2) = st2!ss_modules.[gs_main_module]
# st2 = generate_derived_instances 0 com_instance_defs gs_main_module gs_predefs st2
| size com_gencase_defs==0
= (dcl_modules,st1,st2)
#! (dcl_functions,dcl_modules) = dcl_modules![gs_main_module].dcl_functions
......@@ -2829,6 +2949,41 @@ buildGenericBimapCaseBody main_module_index gc_pos type_index gc_ident generic_i
= (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, st)
buildDerivedInstanceCaseBody ::
!GenericTypeRep
!Index // current icl module
!Position !(Global Index) !Ident !GlobalIndex
!PredefinedSymbolsData
!*SpecializeState
-> (!FunctionBody,!*SpecializeState)
buildDerivedInstanceCaseBody gen_type_rep=:{gtr_type} main_module_index gc_pos type_index gc_ident gcf_generic predefs
st=:{ss_modules=modules,ss_heaps=heaps}
#! (gen_def, modules) = modules![gcf_generic.gi_module].com_generic_defs.[gcf_generic.gi_index]
#! (type_def=:{td_args,td_arity,td_rhs}, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object]
# (original_arg_exprs, arg_vars, heaps) = build_original_arg_vars gen_def heaps
# st & ss_modules=modules,ss_heaps=heaps
#! (specialized_expr, st)
= build_specialized_expr gc_pos gc_ident gcf_generic gen_def.gen_deps gen_def.gen_vars gtr_type td_args gen_def.gen_info_ptr st
# {ss_modules=modules,ss_td_infos=td_infos,ss_funs_and_groups=funs_and_groups,ss_heaps=heaps,ss_error=error} = st
#! (body_expr,funs_and_groups,modules,td_infos,heaps,error)
= adapt_specialized_expr gc_pos gen_def gen_type_rep original_arg_exprs specialized_expr main_module_index predefs
funs_and_groups modules td_infos heaps error
# st & ss_modules=modules,ss_td_infos=td_infos,ss_funs_and_groups=funs_and_groups,ss_heaps=heaps,ss_error=error
= (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, st)
where
// generic function specialized to the generic representation of the type
build_specialized_expr :: Position Ident GlobalIndex [GenericDependency] [a] GenTypeStruct [ATypeVar] GenericInfoPtr *SpecializeState -> *(Expression,*SpecializeState)
build_specialized_expr gc_pos gc_ident gcf_generic gen_deps gen_vars gtr_type td_args gen_info_ptr st=:{ss_heaps}
# g_nums = [i \\ _<-gen_vars & i<-[0..]]
spec_env = []
({gen_rep_conses},generic_heap) = readPtr gen_info_ptr ss_heaps.hp_generic_heap
st & ss_heaps = {ss_heaps & hp_generic_heap=generic_heap}
= specializeGeneric gcf_generic gtr_type spec_env gc_ident gc_pos gen_deps gen_rep_conses gen_info_ptr g_nums main_module_index predefs st
buildGenericCaseBody_ ::
!GenericTypeRep
!Index // current icl module
......@@ -2881,24 +3036,30 @@ where
st & ss_heaps = {heaps & hp_generic_heap=generic_heap}
= specializeGeneric gcf_generic gtr_type spec_env gc_ident gc_pos gen_deps gen_rep_conses gen_info_ptr g_nums main_module_index predefs st
build_arg_vars :: GenericDef GlobalIndex [ATypeVar] *Heaps -> (![[Expression]],![Expression],![FreeVar],!*Heaps)
build_arg_vars {gen_ident, gen_vars, gen_type, gen_deps} gcf_generic td_args heaps
build_original_arg_vars :: GenericDef *Heaps -> (![Expression],![FreeVar],!*Heaps)
build_original_arg_vars {gen_type} heaps
= buildVarExprs [ "x" +++ toString n \\ n <- [1 .. gen_type.st_arity]] heaps
build_generic_arg_vars :: GenericDef GlobalIndex [ATypeVar] *Heaps -> (![[Expression]],![FreeVar],!*Heaps)
build_generic_arg_vars {gen_ident, gen_vars, gen_deps} gcf_generic td_args heaps
# dep_names = [(gen_ident, gen_vars, gcf_generic) : [(ident, gd_vars, gd_index) \\ {gd_ident=Ident ident, gd_vars, gd_index} <- gen_deps]]
#! (generated_arg_exprss, generated_arg_vars, heaps)
#! (generic_arg_exprss, generic_vars, heaps)
= mapY2St buildVarExprs
[[mkDepName dep_name atv_variable \\ dep_name <- dep_names] \\ {atv_variable} <- td_args]
heaps
#! (original_arg_exprs, original_arg_vars, heaps)
= buildVarExprs
[ "x" +++ toString n \\ n <- [1 .. gen_type.st_arity]]
heaps
= (generated_arg_exprss, original_arg_exprs, flatten generated_arg_vars ++ original_arg_vars, heaps)
= (generic_arg_exprss, flatten generic_vars, heaps)
where
mkDepName (ident, gvars, index) atv
# gvarsName = foldl (\vs v -> vs +++ "_" +++ v.tv_ident.id_name) "" gvars
# indexName = "_" +++ toString index.gi_module +++ "-" +++ toString index.gi_index
= ident.id_name +++ gvarsName +++ indexName +++ "_" +++ atv.tv_ident.id_name
build_arg_vars :: GenericDef GlobalIndex [ATypeVar] *Heaps -> (![[Expression]],![Expression],![FreeVar],!*Heaps)
build_arg_vars gen_def gcf_generic td_args heaps
# (original_arg_exprs, original_arg_vars, heaps) = build_original_arg_vars gen_def heaps
# (generic_arg_exprss, generic_arg_vars, heaps) = build_generic_arg_vars gen_def gcf_generic td_args heaps
= (generic_arg_exprss, original_arg_exprs, generic_arg_vars ++ original_arg_vars, heaps)
// adaptor that converts a function for the generic representation into a function for the type itself
adapt_specialized_expr :: Position GenericDef GenericTypeRep [Expression] Expression Index PredefinedSymbolsData
!FunsAndGroups !*Modules !*TypeDefInfos !*Heaps !*ErrorAdmin
......@@ -3451,6 +3612,12 @@ where
#! (expr, heaps)
= buildFunApp2 fun_module_index fun_index grc_ident arg_exprs st.ss_heaps
= (expr, {st & ss_heaps=heaps})
specialize (GTSMemberCall symb_ident) gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr g_nums st
# heaps=:{hp_expression_heap}=st.ss_heaps
# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty hp_expression_heap
# expr = App {app_symb = symb_ident, app_args = []/*arg_exprs*/, app_info_ptr = expr_info_ptr}
# heaps & hp_expression_heap = hp_expression_heap
= (expr, {st & ss_heaps=heaps})
specialize type gen_index gen_ident gen_deps gen_rep_conses gen_info_ptr g_nums st
#! error = reportError gen_ident.id_name gen_pos "cannot specialize " st.ss_error
= (EE, {st & ss_error=error})
......
......@@ -453,10 +453,13 @@ where
# (gendef, pState) = wantGenericDefinition parseContext pos pState
= (True, gendef, pState)
try_definition parseContext DeriveToken pos pState
| ~(isGlobalContext parseContext)
| isGlobalContext parseContext
# (gendef, pState) = wantDeriveDefinition parseContext pos pState
= (True, gendef, pState)
| isInstanceDefsContext parseContext
# (derive_instance_def, pState) = wantDeriveInstanceDefinition parseContext pos pState
= (True, derive_instance_def, pState)
= (False,abort "no def(2)",parseError "definition" No "derive declarations are only at the global level" pState)
# (gendef, pState) = wantDeriveDefinition parseContext pos pState
= (True, gendef, pState)
try_definition parseContext InstanceToken pos pState
| ~(isGlobalContext parseContext)
= (False,abort "no def(2)",parseError "definition" No "instance declarations are only at the global level" pState)
......@@ -1676,10 +1679,22 @@ wantInstanceDeclaration parseContext pi_pos pState
| isIclContext parseContext
# (begin_members, pState) = begin_member_group token pState
| not begin_members
# pi = {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_specials = SP_None, pi_pos = pi_pos}
| token=:DeriveToken
# (token, pState) = nextToken FunctionContext pState
= case token of
IdentToken generic_function_name
# (member_ident, pState) = stringToIdent class_name IC_Expression pState
# (generic_ident, pState) = stringToIdent generic_function_name IC_Generic pState
# pState = wantEndOfDefinition "derive instance" pState
-> (PD_Instance {pim_pi = pi, pim_members = [PD_DeriveInstanceMember pi_pos member_ident generic_ident]}, pState)
_
# pState = parseError "derive instance member" (Yes token) "generic function name" pState
-> (PD_Instance {pim_pi = pi, pim_members = []}, pState)
# pState = wantEndOfDefinition "instance declaration" (tokenBack pState)
= (PD_Instance {pim_pi = {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
pi_specials = SP_None, pi_pos = pi_pos},
pim_members = []}, pState)
= (PD_Instance {pim_pi = pi, pim_members = []}, pState)
# (pi_members, pState) = wantDefinitions (SetInstanceDefsContext parseContext) pState
pState = wantEndGroup "instance" pState
= (PD_Instance {pim_pi = {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context,
......@@ -2196,6 +2211,25 @@ get_type_cons type pState
# pState = parseError "generic type" No "type constructor" pState
= (abort "no TypeCons", pState)
wantDeriveInstanceDefinition :: !ParseContext !Position !*ParseState -> (!ParsedDefinition, !*ParseState)
wantDeriveInstanceDefinition parseContext pos pState
# (token, pState) = nextToken FunctionContext pState
= case token of
IdentToken member_name
# (member_ident, pState) = stringToIdent member_name IC_Expression pState
# (token, pState) = nextToken FunctionContext pState
-> case token of
IdentToken generic_function_name
# (generic_ident, pState) = stringToIdent generic_function_name IC_Generic pState
# pState = wantEndOfDefinition "derive instance" pState
-> (PD_DeriveInstanceMember pos member_ident generic_ident,pState)
_
# pState = parseError "derive instance member" (Yes token) "generic function name" pState
-> (PD_Erroneous,pState)
_
# pState = parseError "derive instance member" (Yes token) "member name" pState
-> (PD_Erroneous,pState)
/*
Type definitions
*/
......@@ -4481,8 +4515,6 @@ where
= (False, abort "no case alt", pState)
= (False, abort "no case alt", tokenBack pState)
// caseSeperator t = t == EqualToken || t == ArrowToken // to enable Clean 1.3.x case expressions
// FIXME: it would be better if this would use (tryExpression cIsNotPattern)
// but there's no function tryExpression available yet
try_pattern :: !Token !ParseState -> (!Bool, ParsedExpr, !ParseState)
......
......@@ -376,6 +376,8 @@ instance collectFunctions FunDef where
collectFunctions fun_def=:{fun_body = ParsedBody bodies} icl_module ca
# (bodies, ca) = collectFunctions bodies icl_module ca
= ({fun_def & fun_body = ParsedBody bodies}, ca)
collectFunctions fun_def=:{fun_body = GenerateInstanceBody _} icl_module ca
= (fun_def, ca)
instance collectFunctions ParsedBody where
collectFunctions pb=:{pb_rhs} icl_module ca
......@@ -1658,6 +1660,12 @@ where
-> ([ fun : fun_defs ], ca)
_
-> collect_member_instances defs (postParseError fun_pos "function body expected" ca)
collect_member_instances [PD_DeriveInstanceMember pos member_ident generic_ident : defs] ca
# fun_body = GenerateInstanceBody generic_ident
fun_def = {fun_ident = member_ident, fun_arity = 0, fun_priority = NoPrio, fun_type = No, fun_kind = (FK_Function False),
fun_body = fun_body, fun_pos = pos, fun_lifted = 0, fun_info = EmptyFunInfo }
(fun_defs, ca) = collect_member_instances defs ca
= ([fun_def : fun_defs], ca)
collect_member_instances [] ca
= ([], ca)
......
......@@ -271,6 +271,7 @@ cIsNotAFunction :== False
| PD_Generic GenericDef
| PD_GenericCase GenericCaseDef Ident
| PD_Derive [GenericCaseDef]
| PD_DeriveInstanceMember Position Ident Ident
| PD_Erroneous
:: FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_NodeDefOrFunction | FK_Unknown
......@@ -719,6 +720,8 @@ FI_FusedMember :== 512 // used in module trans to mark fused versions of insta
| TransformedBody !TransformedBody
| Expanding ![FreeVar] // the parameters of the newly generated function
| GeneratedBody // the body will be generated automatically - for generics
| GenerateInstanceBody !Ident
| GenerateInstanceBodyChecked !Ident !GlobalIndex
| NoBody
:: FunDef =
......@@ -1004,7 +1007,7 @@ cNotVarNumber :== -1
, ct_result_type :: !AType
, ct_cons_types :: ![[AType]]
}
:: SymbIdent =
{ symb_ident :: !Ident
, symb_kind :: !SymbKind
......
......@@ -1291,7 +1291,10 @@ partitionate_function mod_index max_fun_nr fun_index pi ps
)
-> (max_fun_nr, ps)
GeneratedBody
// do not allocate a group, it will be allocated during generic phase
// do not allocate a group, it will be allocated during the generic phase
-> (max_fun_nr, ps)
GenerateInstanceBodyChecked _ _
// do not allocate a group, it will be allocated during the generic phase
-> (max_fun_nr, ps)
partitionate_called_function :: Int Int !Int PartitioningInfo !*PartitioningState -> (!Int,!*PartitioningState)
......@@ -1322,7 +1325,10 @@ partitionate_called_function mod_index max_fun_nr fun_index pi ps
)
-> (max_fun_nr, ps)
GeneratedBody
// do not allocate a group, it will be allocated during generic phase
// do not allocate a group, it will be allocated during the generic phase
-> (max_fun_nr, ps)
GenerateInstanceBodyChecked _ _
// do not allocate a group, it will be allocated during the generic phase
-> (max_fun_nr, ps)
index_in_ranges index [!{ir_from, ir_to}:ranges!]
......
Markdown is supported
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