Commit 72c24161 authored by John van Groningen's avatar John van Groningen
Browse files

add type constraints in constructors and function arguments with universal...

add type constraints in constructors and function arguments with universal quantifier (from iTask branch)
parent 1b4837a1
......@@ -1410,6 +1410,8 @@ convertTypeNode TE
= beNormalTypeNode beDontCareDefinitionSymbol beNoTypeArgs
convertTypeNode (TFA vars type)
= beAddForAllTypeVariables (convertTypeVars vars) (convertTypeNode type)
convertTypeNode (TFAC vars type contexts)
= beAddForAllTypeVariables (convertTypeVars vars) (convertTypeNode type)
convertTypeNode (TGenericFunctionInDictionary gds type_kind generic_dict=:{gi_module,gi_index})
= beNormalTypeNode (beTypeSymbol gi_index gi_module) beNoTypeArgs
convertTypeNode typeNode
......
......@@ -315,6 +315,8 @@ signClassOfType (arg_type --> res_type) sign use_top_sign group_nr ci scs
signClassOfType (TFA vars type) sign use_top_sign group_nr ci scs
= signClassOfType type sign use_top_sign group_nr ci scs
signClassOfType (TFAC vars type _) sign use_top_sign group_nr ci scs
= signClassOfType type sign use_top_sign group_nr ci scs
signClassOfType type _ _ _ _ scs
= (BottomSignClass, BottomSignClass, scs)
......@@ -580,6 +582,8 @@ where
propClassOfType (TFA vars type) group_nr ci pcs
= propClassOfType type group_nr ci pcs
propClassOfType (TFAC vars type _) group_nr ci pcs
= propClassOfType type group_nr ci pcs
propClassOfType _ _ _ pcs
= (NoPropClass, NoPropClass, pcs)
......
......@@ -383,6 +383,10 @@ where
# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
(_, new_at, type_heaps) = substitute {at & at_type = type} type_heaps
= ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok, type_heaps))
substitue_arg_type at=:{at_type = TFAC type_vars type type_contexts} (was_ok, type_heaps)
# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
(_, new_at, type_heaps) = substitute {at & at_type = type} type_heaps
= ({ new_at & at_type = TFAC fresh_type_vars new_at.at_type type_contexts}, (was_ok, type_heaps))
substitue_arg_type type (was_ok, type_heaps)
# (_, type, type_heaps) = substitute type type_heaps
= (type, (was_ok, type_heaps))
......@@ -877,7 +881,7 @@ checkDclMacros :: !Index !Level !Index !Index !*ExpressionInfo !*Heaps !*CheckSt
-> (!*ExpressionInfo,!*Heaps,!*CheckState)
checkDclMacros mod_index level fun_index to_index e_info heaps cs
| fun_index == to_index
= ( e_info, heaps, cs)
= (e_info, heaps, cs)
# (macro_def,e_info) = e_info!ef_macro_defs.[mod_index,fun_index]
# (macro_def,_, e_info, heaps, cs) = checkFunction macro_def mod_index (DclMacroIndex mod_index fun_index) level 0 {} e_info heaps cs
# e_info = { e_info & ef_macro_defs.[mod_index,fun_index] = macro_def }
......@@ -997,11 +1001,11 @@ array_plus_list a l = arrayPlusList a l
checkCommonDefinitions :: !(Optional (CopiedDefinitions, Int)) !Index !*CommonDefs !*{# DclModule} !*Heaps !*CheckState
-> (!DictionaryInfo,!*CommonDefs,!*{# DclModule},!*Heaps, !*CheckState)
checkCommonDefinitions opt_icl_info module_index common modules heaps cs
# (com_type_defs, com_cons_defs, com_selector_defs, modules, heaps, cs)
# (com_type_defs, com_cons_defs, com_selector_defs, com_class_defs, modules, heaps, cs)
= checkTypeDefs module_index opt_icl_info
common.com_type_defs common.com_cons_defs common.com_selector_defs modules heaps cs
common.com_type_defs common.com_cons_defs common.com_selector_defs common.com_class_defs modules heaps cs
(com_class_defs, com_member_defs, com_type_defs, modules, heaps, cs)
= checkTypeClasses module_index opt_icl_info common.com_class_defs common.com_member_defs com_type_defs modules heaps cs
= checkTypeClasses module_index opt_icl_info com_class_defs common.com_member_defs com_type_defs modules heaps cs
(com_member_defs, com_type_defs, com_class_defs, modules, heaps, cs)
= checkMemberTypes module_index opt_icl_info com_member_defs com_type_defs com_class_defs modules heaps cs
(com_instance_defs, com_type_defs, com_class_defs, com_member_defs, modules, heaps, cs)
......
......@@ -1073,6 +1073,7 @@ transform_pattern (AP_Algebraic cons_symbol global_type_index args opt_var) patt
# glob_object = {glob_object & ds_index=pds_def,ds_ident=pds_ident}
= ({pattern & ap_symbol.glob_object=glob_object},cs)
= abort "replace_overloaded_symbol_in_pattern"
transform_pattern (AP_Basic basic_val opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs
# pattern = { bp_value = basic_val, bp_expr = result_expr, bp_position = pos}
pattern_variables = cons_optional opt_var pattern_variables
......@@ -1309,6 +1310,10 @@ where
SK_Constructor _
# app_expr = App {app_symb = symbol, app_args = [], app_info_ptr = nilPtr}
-> (app_expr, free_vars, e_state, e_info, cs)
SK_OverloadedConstructor cons_index
# (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap
app_expr = App {app_symb = {symbol & symb_kind=SK_Constructor cons_index}, app_args = [], app_info_ptr = new_info_ptr}
-> (app_expr, free_vars, {e_state & es_expr_heap = es_expr_heap}, e_info, cs)
SK_NewTypeConstructor _
# cs = { cs & cs_error = checkError id "argument missing (for newtype constructor)" cs.cs_error}
# app_expr = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr }
......@@ -1372,18 +1377,22 @@ where
# {me_type={st_arity},me_priority} = com_member_defs.[def_index]
= (SK_OverloadedFunction { glob_object = def_index, glob_module = mod_index }, st_arity, me_priority)
ste_kind_to_symbol_kind STE_Constructor def_index mod_index {dcl_common={com_cons_defs}}
# {cons_type={st_arity},cons_priority,cons_number} = com_cons_defs.[def_index]
# {cons_type={st_arity,st_args,st_context},cons_priority,cons_number} = com_cons_defs.[def_index]
| cons_number <> -2
= (SK_Constructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority)
| isEmpty st_context && no_TFAC_argument st_args
= (SK_Constructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority)
= (SK_OverloadedConstructor {glob_object = def_index, glob_module = mod_index}, st_arity, cons_priority)
= (SK_NewTypeConstructor {gi_index = def_index, gi_module = mod_index}, st_arity, cons_priority)
determine_info_of_symbol {ste_kind=STE_Member, ste_index} _ e_input=:{ei_mod_index} e_state e_info=:{ef_member_defs} cs
# ({me_type={st_arity},me_priority}, ef_member_defs) = ef_member_defs![ste_index]
= (SK_OverloadedFunction { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, me_priority,
e_state, { e_info & ef_member_defs = ef_member_defs }, cs)
determine_info_of_symbol {ste_kind=STE_Constructor, ste_index} _ e_input=:{ei_mod_index} e_state e_info cs
# ({cons_type={st_arity},cons_priority,cons_number}, e_info) = e_info!ef_cons_defs.[ste_index]
# ({cons_type={st_arity,st_args,st_context},cons_priority,cons_number}, e_info) = e_info!ef_cons_defs.[ste_index]
| cons_number <> -2
= (SK_Constructor {glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
| isEmpty st_context && no_TFAC_argument st_args
= (SK_Constructor {glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
= (SK_OverloadedConstructor {glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
= (SK_NewTypeConstructor {gi_index = ste_index, gi_module = ei_mod_index}, st_arity, cons_priority, e_state, e_info, cs)
determine_info_of_symbol {ste_kind=STE_DclFunction, ste_index} _ e_input=:{ei_mod_index} e_state=:{es_calls} e_info=:{ef_is_macro_fun} cs
# ({ft_type={st_arity},ft_priority}, e_info) = e_info!ef_modules.[ei_mod_index].dcl_functions.[ste_index]
......@@ -1402,6 +1411,10 @@ where
= SK_LocalMacroFunction index.glob_object
= SK_Function index
no_TFAC_argument [{at_type=TFAC _ _ _}:_] = False
no_TFAC_argument [_:args] = no_TFAC_argument args
no_TFAC_argument [] = True
checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_input=:{ei_fun_index,ei_mod_index} e_state e_info cs
# (found,{decl_kind,decl_ident,decl_index},cs) = search_qualified_ident module_id ident_name ExpressionNameSpaceN cs
| not found
......@@ -1417,12 +1430,15 @@ checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_inpu
# e_state = { e_state & es_calls = [DclFunCall mod_index decl_index : e_state.es_calls ]}
-> (app_expr, free_vars, e_state, e_info, cs)
STE_Imported STE_Constructor mod_index
# ({cons_type={st_arity},cons_priority,cons_number}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index]
# ({cons_type={st_arity,st_context},cons_priority,cons_number}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index]
| cons_number <> -2
# kind = SK_Constructor { glob_object = decl_index, glob_module = mod_index }
symbol = { symb_ident = decl_ident, symb_kind = kind }
# app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority
-> (app_expr, free_vars, e_state, e_info, cs)
| isEmpty st_context
# (app_expr,e_state) = build_application_or_constant_for_function symbol st_arity cons_priority e_state
-> (app_expr, free_vars, e_state, e_info, cs)
# app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority
-> (app_expr, free_vars, e_state, e_info, cs)
# kind = SK_NewTypeConstructor { gi_index = decl_index, gi_module = mod_index }
# symbol = { symb_ident = decl_ident, symb_kind = kind }
# app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority
......@@ -2663,6 +2679,13 @@ buildApplication symbol=:{symb_kind=SK_Constructor _} form_arity act_arity args
| act_arity > form_arity
= (app, e_state, checkError symbol.symb_ident "used with too many arguments" error)
= (app, e_state, error)
buildApplication symbol=:{symb_kind=SK_OverloadedConstructor cons_index} form_arity act_arity args e_state error
# (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap
e_state = {e_state & es_expr_heap=es_expr_heap}
app = App {app_symb = {symbol & symb_kind=SK_Constructor cons_index}, app_args = args, app_info_ptr = new_info_ptr}
| act_arity > form_arity
= (app, e_state, checkError symbol.symb_ident "used with too many arguments" error)
= (app, e_state, error)
buildApplication symbol=:{symb_kind=SK_NewTypeConstructor _} form_arity act_arity args e_state error
# app = App { app_symb = symbol , app_args = args, app_info_ptr = nilPtr }
| act_arity == form_arity
......@@ -2682,6 +2705,10 @@ buildApplicationWithoutArguments :: !SymbIdent !*ExpressionState !*ErrorAdmin ->
buildApplicationWithoutArguments symbol=:{symb_kind=SK_Constructor _} e_state error
# app = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr }
= (app, e_state, error)
buildApplicationWithoutArguments symbol=:{symb_kind=SK_OverloadedConstructor cons_index} e_state error
# (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap
app = App {app_symb = {symbol & symb_kind=SK_Constructor cons_index}, app_args = [], app_info_ptr = new_info_ptr}
= (app, {e_state & es_expr_heap = es_expr_heap}, error)
buildApplicationWithoutArguments symbol=:{symb_kind=SK_NewTypeConstructor _} e_state error
# app = App { app_symb = symbol , app_args = [], app_info_ptr = nilPtr }
= (app, e_state, checkError symbol.symb_ident "argument missing (for newtype constructor)" error)
......
......@@ -3,8 +3,8 @@ definition module checktypes
import checksupport
checkTypeDefs :: !Index !(Optional (CopiedDefinitions, Int))
!*{#CheckedTypeDef} !*{#ConsDef} !*{#SelectorDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#CheckedTypeDef},!*{#ConsDef},!*{#SelectorDef},!*{#DclModule},!*Heaps,!*CheckState)
!*{#CheckedTypeDef} !*{#ConsDef} !*{#SelectorDef} !v:{#ClassDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#CheckedTypeDef},!*{#ConsDef},!*{#SelectorDef},!v:{#ClassDef},!*{#DclModule},!*Heaps,!*CheckState)
checkFunctionType :: !Index !SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType,!FunSpecials,!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*CheckState)
......
This diff is collapsed.
......@@ -483,6 +483,16 @@ instance consumerRequirements Expression where
= (CPassive, False, ai)
consumerRequirements (FailExpr _) _ ai
= (CPassive, False, ai)
consumerRequirements (DictionariesFunction dictionaries expr expr_type) common_defs ai
# (new_next_var,new_next_var_of_fun,ai_var_heap) = init_variables dictionaries ai.ai_next_var ai.ai_next_var_of_fun ai.ai_var_heap
# ai = {ai & ai_next_var=new_next_var,ai_next_var_of_fun=new_next_var_of_fun,ai_var_heap=ai_var_heap}
= consumerRequirements expr common_defs ai
where
init_variables [({fv_info_ptr},_):dictionaries] ai_next_var ai_next_var_of_fun ai_var_heap
# ai_var_heap = writePtr fv_info_ptr (VI_AccVar ai_next_var ai_next_var_of_fun) ai_var_heap
= init_variables dictionaries (inc ai_next_var) (inc ai_next_var_of_fun) ai_var_heap
init_variables [] ai_next_var ai_next_var_of_fun ai_var_heap
= (ai_next_var,ai_next_var_of_fun,ai_var_heap)
consumerRequirements expr _ ai
= abort ("consumerRequirements [Expression]" ---> expr)
......@@ -685,7 +695,7 @@ instance consumerRequirements Case where
_ -> False
inspect_patterns :: !{#CommonDefs} !Bool !CasePatterns ![(Int,Bool)] -> (!Bool,!Bool)
inspect_patterns common_defs has_default (AlgebraicPatterns {gi_index,gi_module} algebraic_patterns) constructors_and_unsafe_bits
inspect_patterns common_defs has_default (AlgebraicPatterns {gi_index,gi_module} _) constructors_and_unsafe_bits
# type_def = common_defs.[gi_module].com_type_defs.[gi_index]
defined_symbols = case type_def.td_rhs of
AlgType defined_symbols -> defined_symbols
......@@ -1473,6 +1483,13 @@ count_locals EE n
count_locals (FailExpr _) n = n
count_locals (NoBind _) n
= n
count_locals (DictionariesFunction dictionaries expr expr_type) n
= count_locals expr (foldSt count_local_dictionary dictionaries n)
where
count_local_dictionary ({fv_count},_) n
| fv_count > 0
= n+1
= n
count_optional_locals (Yes e) n
= count_locals e n
......@@ -1781,6 +1798,8 @@ instance producerRequirements Expression where
= (True,prs)
producerRequirements (FailExpr _) prs
= (True,prs)
producerRequirements (DictionariesFunction dictionaries expr expr_type) prs
= producerRequirements expr prs
producerRequirements expr prs
= abort ("producerRequirements " ---> expr)
......
......@@ -110,9 +110,14 @@ where
comp_type_var_heap = initialyseATypeVars dcl_cons_def.cons_exi_vars icl_cons_def.cons_exi_vars comp_type_var_heap
comp_st = { comp_st & comp_type_var_heap = comp_type_var_heap }
(ok, comp_st) = compare (dcl_cons_type.st_args,dcl_cons_type.st_args_strictness) (icl_cons_type.st_args,icl_cons_type.st_args_strictness) comp_st
| ok && do_compare_result_types
= compare dcl_cons_type.st_result icl_cons_type.st_result comp_st
= (ok, comp_st)
| not ok
= (False,comp_st)
| do_compare_result_types
# (ok,comp_st) = compare dcl_cons_type.st_result icl_cons_type.st_result comp_st
| ok
= compare dcl_cons_type.st_context icl_cons_type.st_context comp_st
= (False,comp_st)
= compare dcl_cons_type.st_context icl_cons_type.st_context comp_st
compareClassDefs :: !{#Int} {#Bool} !{# ClassDef} !{# MemberDef} !u:{# ClassDef} !v:{# MemberDef} !*CompareState
-> (!u:{# ClassDef}, !v:{# MemberDef}, !*CompareState)
......@@ -298,6 +303,12 @@ where
type_heaps = clear_type_vars dclvars (comp_st.comp_type_var_heap, comp_st.comp_attr_var_heap)
(comp_type_var_heap, comp_attr_var_heap) = clear_type_vars iclvars type_heaps
= (ok, {comp_st & comp_type_var_heap = comp_type_var_heap, comp_attr_var_heap = comp_attr_var_heap})
compare (TFAC dclvars dcltype dcl_contexts) (TFAC iclvars icltype icl_contexts) comp_st=:{comp_type_var_heap}
# comp_type_var_heap = initialyseATypeVars dclvars iclvars comp_type_var_heap
(ok, comp_st) = compare (dcltype,dcl_contexts) (icltype,icl_contexts) {comp_st & comp_type_var_heap = comp_type_var_heap}
type_heaps = clear_type_vars dclvars (comp_st.comp_type_var_heap, comp_st.comp_attr_var_heap)
(comp_type_var_heap, comp_attr_var_heap) = clear_type_vars iclvars type_heaps
= (ok, {comp_st & comp_type_var_heap = comp_type_var_heap, comp_attr_var_heap = comp_attr_var_heap})
compare _ _ comp_st
= (False, comp_st)
......@@ -940,6 +951,10 @@ instance t_corresponds Type where
t_corresponds (TFA dclVars dclType) (TFA iclVars iclType)
= do (init_atype_vars dclVars iclVars)
&&& t_corresponds dclType iclType
t_corresponds (TFAC dclVars dclType dclContexts) (TFAC iclVars iclType iclContexts)
= do (init_atype_vars dclVars iclVars)
&&& t_corresponds dclType iclType
&&& t_corresponds dclContexts iclContexts
t_corresponds _ _
= return False
......@@ -1084,9 +1099,9 @@ instance e_corresponds FunctionBody where
// both bodies are either CheckedBodies or TransformedBodies
e_corresponds dclDef iclDef
= e_corresponds (from_body dclDef) (from_body iclDef)
where
from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs])
from_body (CheckedBody {cb_args, cb_rhs}) = (cb_args, [ca_rhs \\ {ca_rhs} <- cb_rhs])
from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs])
from_body (CheckedBody {cb_args, cb_rhs}) = (cb_args, [ca_rhs \\ {ca_rhs} <- cb_rhs])
instance e_corresponds FreeVar where
e_corresponds dclVar iclVar
......@@ -1387,31 +1402,3 @@ do_nothing ec_state
give_error s ec_state
= { ec_state & ec_error_admin = checkError s ErrorMessage ec_state.ec_error_admin }
/*
instance <<< Priority
where
(<<<) file NoPrio = file <<< "NoPrio"
(<<<) file (Prio LeftAssoc i) = file <<< "Prio LeftAssoc " <<< i
(<<<) file (Prio RightAssoc i) = file <<< "Prio RightAssoc " <<< i
(<<<) file (Prio NoAssoc i) = file <<< "Prio NoAssoc " <<< i
Trace_array a
= trace_array 0
where
trace_array i
| i<size a
= Trace_tn i && Trace_tn a.[i] && trace_array (i+1)
= True;
Trace_tn d
= file_to_true (stderr <<< d <<< '\n')
file_to_true :: !File -> Bool;
file_to_true file = code {
.inline file_to_true
pop_b 2
pushB TRUE
.end
};
*/
\ No newline at end of file
......@@ -301,6 +301,9 @@ instance convertDynamics Expression where
= (EE, ci)
convertDynamics cinp expr=:(NoBind _) ci
= (expr,ci)
convertDynamics cinp (DictionariesFunction dictionaries expr expr_type) ci
# (expr,ci) = convertDynamics cinp expr ci
= (DictionariesFunction dictionaries expr expr_type,ci)
instance convertDynamics App where
convertDynamics cinp app=:{app_args} ci
......@@ -561,6 +564,7 @@ where
# type_fun
= App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr}
= (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [type_fun], app_info_ptr = nilPtr}, ci)
typeConstructor (GTT_Basic basic_type) ci
#! predefined_TC_basic_type
= case basic_type of
......@@ -737,7 +741,6 @@ create_dynamic_and_selector_idents common_defs predefined_symbols
// otherwise
# ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_Dyn_DynamicTemp]
# {td_rhs=RecordType {rt_constructor}} = common_defs.[pds_module1].com_type_defs.[pds_def1]
# dynamic_defined_symbol
= {glob_module = pds_module1, glob_object = rt_constructor}
# dynamic_type = {gi_module = pds_module1, gi_index = pds_def1}
......
......@@ -259,6 +259,8 @@ where
= rs
weightedRefCount rci (NoBind ptr) rs
= rs
weightedRefCount rci (DictionariesFunction _ expr _) rs
= weightedRefCount rci expr rs
weightedRefCount rci (FailExpr _) rs
= rs
weightedRefCount rci expr rs
......@@ -582,6 +584,9 @@ where
= (NoBind ptr, ds)
distributeLets _ (FailExpr id) ds
= (FailExpr id, ds)
distributeLets di (DictionariesFunction dictionaries expr expr_type) ds
# (expr,ds) = distributeLets di expr ds
= (DictionariesFunction dictionaries expr expr_type,ds)
instance distributeLets Case
where
......@@ -1641,6 +1646,33 @@ where
# (failExpr, cs)
= convertNonRootFail ci ident cs
= (failExpr, cs)
convertCases ci (DictionariesFunction dictionaries expr expr_type) cs
# (expr,cs) = convertRootCases {ci & ci_case_level=CaseLevelRoot,ci_bound_vars=dictionaries++ci.ci_bound_vars} expr cs
(old_fv_info_ptr_values,var_heap) = store_VI_FreeVar_in_dictionary_vars_and_save_old_values dictionaries [] cs.cs_var_heap
(old_fv_info_ptr_values,var_heap) = store_VI_BoundVar_in_bound_vars_and_save_old_values ci.ci_bound_vars old_fv_info_ptr_values var_heap
(expr, {cp_free_vars,cp_var_heap,cp_local_vars}) = copy expr {cp_free_vars=[], cp_var_heap=var_heap, cp_local_vars=[]}
(bound_vars, free_typed_vars, var_heap) = retrieve_variables cp_free_vars cp_var_heap
(free_typed_dictinary_vars, var_heap) = retrieve_dictionary_variables dictionaries var_heap
cs = {cs & cs_var_heap = var_heap}
(fun_ident,cs) = new_case_function No expr_type expr (free_typed_vars++free_typed_dictinary_vars) cp_local_vars ci.ci_group_index cs
cs_var_heap = restore_old_fv_info_ptr_values old_fv_info_ptr_values (dictionaries++ci.ci_bound_vars) cs.cs_var_heap
= (App {app_symb=fun_ident, app_args=bound_vars, app_info_ptr=nilPtr}, {cs & cs_var_heap=cs_var_heap})
where
store_VI_FreeVar_in_dictionary_vars_and_save_old_values [({fv_info_ptr,fv_ident},type):bound_vars] old_fv_info_ptr_values var_heap
# (old_fv_info_ptr_value,var_heap) = readPtr fv_info_ptr var_heap
(new_info_ptr,var_heap) = newPtr (VI_Labelled_Empty "convertCases [FreeVar]") var_heap
var_heap = writePtr fv_info_ptr (VI_FreeVar fv_ident new_info_ptr 0 type) var_heap
(old_fv_info_ptr_values,var_heap) = store_VI_FreeVar_in_dictionary_vars_and_save_old_values bound_vars old_fv_info_ptr_values var_heap
= ([old_fv_info_ptr_value:old_fv_info_ptr_values],var_heap)
store_VI_FreeVar_in_dictionary_vars_and_save_old_values [] old_fv_info_ptr_values var_heap
= (old_fv_info_ptr_values,var_heap)
retrieve_dictionary_variables cp_free_vars cp_var_heap
= foldSt retrieve_dictionary_variable cp_free_vars ([], cp_var_heap)
where
retrieve_dictionary_variable ({fv_info_ptr}, type) (free_typed_vars, var_heap)
# (VI_FreeVar name new_ptr count type, var_heap) = readPtr fv_info_ptr var_heap
= ([({fv_def_level = NotALevel, fv_ident = name, fv_info_ptr = new_ptr, fv_count = count}, type) : free_typed_vars], var_heap)
convertCases ci expr cs
= (expr, cs)
......
......@@ -158,6 +158,11 @@ where
| changed
= (True,TFA vars type, ets)
= (False,tfa_type, ets)
expandSynTypes rem_annots common_defs tfac_type=:(TFAC vars type type_context) ets
# (changed,type, ets) = expandSynTypes rem_annots common_defs type ets
| changed
= (True,TFAC vars type type_context, ets)
= (False,tfac_type, ets)
expandSynTypes rem_annots common_defs type ets
= (False,type, ets)
......
/*
module owner: Ronny Wichers Schreur
*/
implementation module frontend
import scanner, parse, postparse, check, type, trans, partition, convertcases, overloading, utilities, convertDynamics,
......@@ -347,17 +344,42 @@ showMacrosInModule dcl_index (macro_defs,file)
# (macro,macro_defs) = macro_defs![dcl_index,macro_index]
= (macro_defs, file <<< macro_index <<< macro <<< '\n')
showComponents :: !u:{! Group} !Int !Bool !*{# FunDef} !*File -> (!u:{! Group}, !*{# FunDef},!*File)
showGroups :: !u:{! Group} !Int !Bool !*{# FunDef} !*File -> (!u:{! Group}, !*{# FunDef},!*File)
showGroups comps comp_index show_types fun_defs file
| comp_index >= size comps
= (comps, fun_defs, file)
# (comp, comps) = comps![comp_index]
# (fun_defs, file) = show_group comp.group_members show_types fun_defs (file <<< "component " <<< comp_index <<< '\n')
= showGroups comps (inc comp_index) show_types fun_defs file
show_group [] show_types fun_defs file
= (fun_defs, file <<< '\n')
show_group [fun:funs] show_types fun_defs file
# (fun_def, fun_defs) = fun_defs![fun]
# file=file<<<fun<<<'\n'
| show_types
= show_group funs show_types fun_defs (file <<< fun_def.fun_type <<< '\n' <<< fun_def)
= show_group funs show_types fun_defs (file <<< fun_def)
// = show_group funs show_types fun_defs (file <<< fun_def.fun_ident)
showComponents :: !u:{!Component} !Int !Bool !*{# FunDef} !*File -> (!u:{!Component}, !*{# FunDef},!*File)
showComponents comps comp_index show_types fun_defs file
| comp_index >= size comps
= (comps, fun_defs, file)
# (comp, comps) = comps![comp_index]
# (fun_defs, file) = show_component comp.group_members show_types fun_defs (file <<< "component " <<< comp_index <<< '\n')
# (fun_defs, file) = show_component comp.component_members show_types fun_defs (file <<< "component " <<< comp_index <<< '\n')
= showComponents comps (inc comp_index) show_types fun_defs file
show_component [] show_types fun_defs file
show_component NoComponentMembers show_types fun_defs file
= (fun_defs, file <<< '\n')
show_component [fun:funs] show_types fun_defs file
show_component (ComponentMember fun funs) show_types fun_defs file
# (fun_def, fun_defs) = fun_defs![fun]
# file=file<<<fun<<<'\n'
| show_types
= show_component funs show_types fun_defs (file <<< fun_def.fun_type <<< '\n' <<< fun_def)
= show_component funs show_types fun_defs (file <<< fun_def)
// = show_component funs show_types fun_defs (file <<< fun_def.fun_ident)
show_component (GeneratedComponentMember fun _ funs) show_types fun_defs file
# (fun_def, fun_defs) = fun_defs![fun]
# file=file<<<fun<<<'\n'
| show_types
......
/*
module owner: Ronny Wichers Schreur
*/
implementation module mergecases
import syntax, transform, compare_types, utilities
......@@ -147,7 +144,7 @@ where
has_no_default No = True
has_no_default (Yes _) = False
skip_alias var_info_ptr var_heap
= case sreadPtr var_info_ptr var_heap of
VI_Alias bv
......@@ -209,7 +206,7 @@ where
new_variable fv=:{fv_ident, fv_info_ptr} var_heap
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
= ({fv & fv_info_ptr = new_info_ptr}, var_heap <:= (fv_info_ptr, VI_Variable fv_ident new_info_ptr))
rebuild_let_expression lad expr var_heap expr_heap
# (rev_let_lazy_binds, var_heap) = foldSt renew_let_var lad.let_lazy_binds ([], var_heap)
(let_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
......@@ -373,14 +370,14 @@ where
= ([ pattern : patterns ], var_heap, symbol_heap, error)
merge_basic_pattern_with_patterns new_pattern [] var_heap symbol_heap error
= ([new_pattern], var_heap, symbol_heap, error)
replace_variables vars expr ap_vars var_heap symbol_heap
# var_heap = build_aliases vars ap_vars var_heap
# us = { us_var_heap = var_heap, us_symbol_heap = symbol_heap, us_local_macro_functions = No }
(expr, us) = unfold expr us
= (expr, us.us_var_heap, us.us_symbol_heap)
where
build_aliases [var1 : vars1] [ {fv_ident,fv_info_ptr} : vars2 ] var_heap
build_aliases [var1 : vars1] [{fv_ident,fv_info_ptr} : vars2] var_heap
= build_aliases vars1 vars2 (writePtr var1.fv_info_ptr (VI_Variable fv_ident fv_info_ptr) var_heap)
build_aliases [] [] var_heap
= var_heap
......
This diff is collapsed.
......@@ -425,7 +425,7 @@ where
| ~(isGlobalContext parseContext)
= (False,abort "no def(3)",parseError "definition" No "imports only at the global level" pState)
# (imp, pState) = wantFromImports pState
= (True, PD_Import [imp], pState) -->> imp
= (True, PD_Import [imp], pState)
try_definition parseContext ClassToken pos pState
| ~(isGlobalContext parseContext)
= (False,abort "no def(2)",parseError "definition" No "class definitions are only at the global level" pState)
......@@ -1131,7 +1131,7 @@ where
(file_name, line_nr, pState)
= getFileAndLineNr pState
(rhs_exp, pState) = wantExpression pState
pState = wantEndRootExpression pState -->> ("#",lhs_exp,"=",rhs_exp)
pState = wantEndRootExpression pState // -->> ("#",lhs_exp,"=",rhs_exp)
(locals , pState) = optionalLocals WithToken localsExpected pState
= ( True
, { ndwl_strict = strict
......@@ -1536,6 +1536,13 @@ optionalContext pState
= want_contexts pState
= ([], tokenBack pState)
optional_constructor_context :: !ParseState -> ([TypeContext],ParseState)
optional_constructor_context pState
# (token, pState) = nextToken TypeContext pState
| token == AndToken
= want_contexts pState
= ([], tokenBack pState)
want_contexts :: ParseState -> ([TypeContext],ParseState)
want_contexts pState
# (contexts, pState) = want_context pState
......@@ -1926,8 +1933,9 @@ where
# token = basic_type_to_constructor token
# (pc_cons_ident, pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState
(pc_arg_types, pState) = parseList tryBrackSAType pState
(pc_context,pState) = optional_constructor_context pState
cons = { pc_cons_ident = pc_cons_ident, pc_arg_types = atypes_from_satypes pc_arg_types, pc_args_strictness=strictness_from_satypes pc_arg_types,
pc_cons_arity = length pc_arg_types, pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos}
pc_context = pc_context, pc_cons_arity = length pc_arg_types, pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos}
= (cons,pState)
want_newtype_constructor :: ![ATypeVar] !Token !ParseState -> (.ParsedConstructor,!ParseState)
......@@ -1936,7 +1944,7 @@ where
(pc_cons_ident, pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState
(succ, pc_arg_type, pState) = trySimpleType TA_Anonymous pState