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)
This diff is collapsed.
......@@ -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