Skip to content
GitLab
Commit 6fd027e3 authored by John van Groningen's avatar John van Groningen
Browse files

implement newtype

parent f736c783
Expand all Hide whitespace changes
Inline Side-by-side
frontend/analtypes.icl
View file @ 6fd027e3
This diff is collapsed.
frontend/analunitypes.icl
View file @ 6fd027e3
......@@ -193,7 +193,9 @@ where
# (sign_class, _, scs) = signClassOfType at_type PositiveSign DontUSeTopSign group_nr ci scs
= (sign_class, scs)
sign_class_of_type_def module_index (RecordType {rt_constructor}) group_nr ci scs
= sign_class_of_type_conses module_index [rt_constructor] group_nr ci BottomSignClass scs
= sign_class_of_type_cons module_index rt_constructor group_nr ci BottomSignClass scs
sign_class_of_type_def module_index (NewType constructor) group_nr ci scs
= sign_class_of_type_cons module_index constructor group_nr ci BottomSignClass scs
sign_class_of_type_def _ (AbstractType properties) _ _ scs
| properties bitand cIsNonCoercible == 0
= (PostiveSignClass, scs)
......@@ -202,6 +204,7 @@ where
| properties bitand cIsNonCoercible == 0
= (PostiveSignClass, scs)
= (TopSignClass, scs)
sign_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_sign_class scs
#! cons_def = ci.[module_index].com_cons_defs.[ds_index]
# (cumm_sign_class, scs) = sign_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_sign_class scs
......@@ -209,6 +212,10 @@ where
sign_class_of_type_conses module_index [] _ _ cumm_sign_class scs
= (cumm_sign_class, scs)
sign_class_of_type_cons module_index {ds_index} group_nr ci cumm_sign_class scs
#! cons_def = ci.[module_index].com_cons_defs.[ds_index]
= sign_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_sign_class scs
sign_class_of_type_of_list [] _ _ cumm_sign_class scs
= (cumm_sign_class, scs)
sign_class_of_type_of_list [{at_type} : types] group_nr ci cumm_sign_class scs
......@@ -468,7 +475,9 @@ where
# (prop_class, _, pcs) = propClassOfType at_type group_nr ci pcs
= (prop_class, pcs)
prop_class_of_type_def module_index (RecordType {rt_constructor}) group_nr ci pcs
= prop_class_of_type_conses module_index [rt_constructor] group_nr ci NoPropClass pcs
= prop_class_of_type_cons module_index rt_constructor group_nr ci NoPropClass pcs
prop_class_of_type_def module_index (NewType constructor) group_nr ci pcs
= prop_class_of_type_cons module_index constructor group_nr ci NoPropClass pcs
prop_class_of_type_def _ (AbstractType properties) _ _ pcs
= (PropClass, pcs)
prop_class_of_type_def _ (AbstractSynType properties _) _ _ pcs
......@@ -481,6 +490,10 @@ where
prop_class_of_type_conses module_index [] _ _ cumm_prop_class pcs
= (cumm_prop_class, pcs)
prop_class_of_type_cons module_index {ds_index} group_nr ci cumm_prop_class pcs
#! cons_def = ci.[module_index].com_cons_defs.[ds_index]
= prop_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_prop_class pcs
prop_class_of_type_of_list [] _ _ cumm_prop_class pcs
= (cumm_prop_class, pcs)
prop_class_of_type_of_list [{at_type} : types] group_nr ci cumm_prop_class pcs
......
frontend/check.icl
View file @ 6fd027e3
......@@ -1455,6 +1455,8 @@ renumber_icl_definitions_as_dcl_definitions (Yes icl_to_dcl_index_table) icl_siz
# rt_constructor = {rt_constructor & ds_index=icl_to_dcl_index_table.[cConstructorDefs,rt_constructor.ds_index]}
# rt_fields = {{field & fs_index=icl_to_dcl_index_table.[cSelectorDefs,field.fs_index]} \\ field <-: rt_fields}
= {td & td_rhs=RecordType {rt_constructor=rt_constructor,rt_fields=rt_fields,rt_is_boxed_record=rt_is_boxed_record}}
renumber_type_def td=:{td_rhs = NewType cons}
= { td & td_rhs = NewType {cons & ds_index=icl_to_dcl_index_table.[cConstructorDefs,cons.ds_index]} }
renumber_type_def td
= td
renumber_icl_decl_symbol (Declaration icl_decl_symbol=:{decl_kind = STE_Constructor, decl_index}) cdefs
......@@ -1639,6 +1641,10 @@ where
# new_cons_defs = if (dcl_cons_index==(-1)) new_cons_defs [ com_cons_defs.[dcl_cons_index] : new_cons_defs ]
# (rt_fields, cs) = redirect_field_symbols td_pos rt_fields cs
= ([ { td & td_rhs = RecordType { rt & rt_constructor = rt_constructor, rt_fields = rt_fields }} : new_type_defs ],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
add_type_def td=:{td_pos, td_rhs = NewType cons} new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs
# (dcl_cons_index,cons,(conversion_table,icl_sizes,icl_decl_symbols,cs)) = copy_and_redirect_symbol STE_Constructor td_pos cons (conversion_table,icl_sizes,icl_decl_symbols,cs)
# new_cons_defs = if (dcl_cons_index==(-1)) new_cons_defs [ com_cons_defs.[dcl_cons_index] : new_cons_defs ]
= ([ { td & td_rhs = NewType cons} : new_type_defs ],new_cons_defs,new_selector_defs,conversion_table,icl_sizes,icl_decl_symbols,cs)
add_type_def td=:{td_ident, td_pos, td_rhs = AbstractType _} new_type_defs new_cons_defs new_selector_defs conversion_table icl_sizes icl_decl_symbols cs
# cs_error = checkError "abstract type not defined in implementation module" ""
(setErrorAdmin (newPosition td_ident td_pos) cs.cs_error)
......@@ -2703,7 +2709,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
solved_imports = { si_explicit=[], si_qualified_explicit=[], si_implicit=[] }
imports_ikh = ikhInsert` False cPredefinedModuleIndex solved_imports ikhEmpty
(deferred_stuff, (_, modules, macro_and_fun_defs, macro_defs, heaps, cs))
= checkDclModule EndNumbers [] imports_ikh cUndef False cDummyArray support_dynamics mod ste_index cDummyArray modules macro_and_fun_defs macro_defs heaps cs
= checkPredefinedDclModule EndNumbers [] imports_ikh cUndef False cDummyArray support_dynamics mod ste_index cDummyArray modules macro_and_fun_defs macro_defs heaps cs
(modules, heaps, cs)
= checkInstancesOfDclModule cPredefinedModuleIndex deferred_stuff (modules, heaps, cs)
({dcl_declared={dcls_import,dcls_local,dcls_local_for_import}}, modules) = modules![ste_index]
......@@ -3392,10 +3398,10 @@ checkInstancesOfDclModule mod_index (nr_of_dcl_functions_and_instances, nr_of_dc
(Yes symbol_type) = inst_def.ft_type
= { instance_defs & [ds_index] = { inst_def & ft_type = makeElemTypeOfArrayFunctionStrict inst_def.ft_type ins_offset offset_table } }
checkDclModule :: !NumberSet ![Int] !(IntKeyHashtable SolvedImports) !Int !Bool !LargeBitvect !Bool
!(Module (CollectedDefinitions ClassInstance IndexRange)) !Index !*ExplImpInfos !*{#DclModule} !*{#FunDef} !*{#*{#FunDef}} !*Heaps !*CheckState
-> (!(!Int,!Index,![FunType]), !(!*ExplImpInfos, !*{#DclModule}, !*{#FunDef},!*{#*{#FunDef}},!*Heaps, !*CheckState))
checkDclModule dcl_imported_module_numbers components_importing_module imports_ikh component_nr is_on_cycle modules_in_component_set support_dynamics
checkPredefinedDclModule :: !NumberSet ![Int] !(IntKeyHashtable SolvedImports) !Int !Bool !LargeBitvect !Bool
!(Module (CollectedDefinitions ClassInstance IndexRange)) !Index !*ExplImpInfos !*{#DclModule} !*{#FunDef} !*{#*{#FunDef}} !*Heaps !*CheckState
-> (!(!Int,!Index,![FunType]), !(!*ExplImpInfos, !*{#DclModule}, !*{#FunDef},!*{#*{#FunDef}},!*Heaps, !*CheckState))
checkPredefinedDclModule dcl_imported_module_numbers components_importing_module imports_ikh component_nr is_on_cycle modules_in_component_set support_dynamics
mod=:{mod_ident,mod_defs=mod_defs=:{def_macro_indices,def_funtypes}} mod_index expl_imp_info modules icl_functions macro_defs heaps cs
# dcl_common = createCommonDefinitions mod_defs
#! first_type_index = size dcl_common.com_type_defs
......
frontend/checkFunctionBodies.icl
View file @ 6fd027e3
This diff is collapsed.
frontend/checktypes.icl
View file @ 6fd027e3
......@@ -341,10 +341,15 @@ where
= [av : attr_vars]
add_attr_var attr attr_vars
= attr_vars
check_rhs_of_TypeDef {td_rhs = SynType type} _ cti ts_ti_cs
# (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs
= (SynType type, ts_ti_cs)
check_rhs_of_TypeDef {td_ident,td_arity,td_args,td_rhs = td_rhs=:NewType cons} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs
# type_lhs = { at_attribute = cti_lhs_attribute,
at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_ident td_arity)
[{at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]}
ts_ti_cs = bind_types_of_constructor cti -2 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs cons ts_ti_cs
= (td_rhs, ts_ti_cs)
check_rhs_of_TypeDef {td_rhs = AbstractSynType properties type} _ cti ts_ti_cs
# (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs
= (AbstractSynType properties type, ts_ti_cs)
......@@ -380,7 +385,7 @@ where
= ({ ts & ts_cons_defs.[ds_index] = cons_def}, { ti & ti_var_heap = ti_var_heap }, { cs & cs_symbol_table=symbol_table })
where
bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState)
-> (![AType], ![[ATypeVar]], ![AttrInequality], !(!*TypeSymbols, !*TypeInfo, !*CheckState))
-> (![AType], ![[ATypeVar]], ![AttrInequality],!(!*TypeSymbols, !*TypeInfo, !*CheckState))
bind_types_of_cons [] cti free_vars attr_env ts_ti_cs
= ([], [], attr_env, ts_ti_cs)
bind_types_of_cons [type : types] cti free_vars attr_env ts_ti_cs
......@@ -529,7 +534,7 @@ checkArityOfType act_arity form_arity (SynType _)
checkArityOfType act_arity form_arity _
= form_arity >= act_arity
checkAbstractType type_index(AbstractType _) = type_index <> cPredefinedModuleIndex
checkAbstractType type_index (AbstractType _) = type_index <> cPredefinedModuleIndex
checkAbstractType type_index (AbstractSynType _ _) = type_index <> cPredefinedModuleIndex
checkAbstractType _ _ = False
......
frontend/comparedefimp.icl
View file @ 6fd027e3
......@@ -73,7 +73,15 @@ where
= True
# field_nr = dec field_nr
= dcl_fields.[field_nr].fs_index == icl_fields.[field_nr].fs_index && compare_fields field_nr dcl_fields icl_fields
compare_rhs_of_types (NewType dclConstructor) (NewType iclConstructor) dcl_cons_defs icl_cons_defs comp_st
| dclConstructor.ds_index<>iclConstructor.ds_index
= (False, icl_cons_defs, comp_st)
# dcl_cons_def = dcl_cons_defs.[dclConstructor.ds_index]
(icl_cons_def, icl_cons_defs) = icl_cons_defs![iclConstructor.ds_index]
# (ok, comp_st) = compare_cons_def_types True icl_cons_def dcl_cons_def comp_st
= (ok, icl_cons_defs, comp_st)
compare_rhs_of_types (AbstractType _) (NewType _) dcl_cons_defs icl_cons_defs comp_st
= (False, icl_cons_defs, comp_st)
compare_rhs_of_types (AbstractType _) icl_type dcl_cons_defs icl_cons_defs comp_st
= (True, icl_cons_defs, comp_st)
compare_rhs_of_types (AbstractSynType _ dclType) (SynType iclType) dcl_cons_defs icl_cons_defs comp_st
......@@ -81,11 +89,15 @@ where
= (ok, icl_cons_defs, comp_st)
compare_rhs_of_types dcl_type icl_type dcl_cons_defs icl_cons_defs comp_st
= (False, icl_cons_defs, comp_st)
compare_constructors do_compare_result_types cons_index dcl_cons_defs icl_cons_defs comp_st=:{comp_type_var_heap}
compare_constructors do_compare_result_types cons_index dcl_cons_defs icl_cons_defs comp_st
# dcl_cons_def = dcl_cons_defs.[cons_index]
(icl_cons_def, icl_cons_defs) = icl_cons_defs![cons_index]
dcl_cons_type = dcl_cons_def.cons_type
(ok, comp_st) = compare_cons_def_types do_compare_result_types icl_cons_def dcl_cons_def comp_st
= (ok, icl_cons_defs, comp_st)
compare_cons_def_types do_compare_result_types icl_cons_def dcl_cons_def comp_st=:{comp_type_var_heap}
# dcl_cons_type = dcl_cons_def.cons_type
icl_cons_type = icl_cons_def.cons_type
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 }
......@@ -93,10 +105,9 @@ where
| dcl_cons_def.cons_priority == icl_cons_def.cons_priority
| ok && do_compare_result_types
# (ok, comp_st) = compare dcl_cons_type.st_result icl_cons_type.st_result comp_st
= (ok, icl_cons_defs, comp_st)
= (ok, icl_cons_defs, comp_st)
= (False, icl_cons_defs, comp_st)
= (ok, comp_st)
= (ok, comp_st)
= (False, comp_st)
compareClassDefs :: !{#Int} {#Bool} !{# ClassDef} !{# MemberDef} !u:{# ClassDef} !v:{# MemberDef} !*CompareState
-> (!u:{# ClassDef}, !v:{# MemberDef}, !*CompareState)
......@@ -857,10 +868,14 @@ instance t_corresponds TypeRhs where
= t_corresponds dclType iclType
t_corresponds (RecordType dclRecord) (RecordType iclRecord)
= t_corresponds dclRecord iclRecord
t_corresponds (AbstractType _) (NewType _)
= return False
t_corresponds (AbstractType _) _
= return True
t_corresponds (AbstractSynType _ dclType) (SynType iclType)
= t_corresponds dclType iclType
t_corresponds (NewType dclConstructor) (NewType iclConstructor)
= t_corresponds dclConstructor iclConstructor
// sanity check ...
t_corresponds UnknownType _
......
frontend/mergecases.icl
View file @ 6fd027e3
......@@ -5,14 +5,6 @@ implementation module mergecases
import syntax, check, StdCompare, utilities
/*
cContainsFreeVars :== True
cContainsNoFreeVars :== False
cMacroIsCalled :== True
cNoMacroIsCalled :== False
*/
class GetSetPatternRhs a
where
get_pattern_rhs :: !a -> Expression
......@@ -41,7 +33,7 @@ mergeCases expr_and_pos [] var_heap symbol_heap error
mergeCases (Let lad=:{let_expr}, pos) exprs var_heap symbol_heap error
# ((let_expr, _), var_heap, symbol_heap, error) = mergeCases (let_expr, NoPos) exprs var_heap symbol_heap error
= ((Let {lad & let_expr = let_expr}, pos), var_heap,symbol_heap, error)
mergeCases (case_expr=:(Case first_case=:{case_expr = Var {var_info_ptr}, case_default = No, case_explicit}), case_pos)
mergeCases (Case first_case=:{case_expr = Var {var_info_ptr}, case_default = No, case_explicit}, case_pos)
[(expr, expr_pos) : exprs] var_heap symbol_heap error
| not case_explicit
# (split_result, var_heap, symbol_heap) = split_case var_info_ptr expr var_heap symbol_heap
......@@ -71,7 +63,7 @@ where
-> (Yes cees, var_heap, symbol_heap)
-> (No, var_heap, symbol_heap)
No
-> (No, var_heap, symbol_heap)
-> (No, var_heap, symbol_heap)
BasicPatterns type [basic_pattern]
# (split_result, var_heap, symbol_heap) = split_case split_var_info_ptr basic_pattern.bp_expr var_heap symbol_heap
-> case split_result of
......@@ -95,7 +87,19 @@ where
-> (Yes cees, var_heap, symbol_heap)
-> (No, var_heap, symbol_heap)
No
-> (No, var_heap, symbol_heap)
-> (No, var_heap, symbol_heap)
NewTypePatterns type [newtype_pattern]
# (split_result, var_heap, symbol_heap) = split_case split_var_info_ptr newtype_pattern.ap_expr var_heap symbol_heap
-> case split_result of
Yes split_case
| not split_case.case_explicit
# (cees,symbol_heap) = push_expression_into_guards_and_default
( \ guard_expr -> { this_case & case_guards = NewTypePatterns type [{ newtype_pattern & ap_expr = guard_expr }] } )
split_case symbol_heap
-> (Yes cees, var_heap, symbol_heap)
-> (No, var_heap, symbol_heap)
No
-> (No, var_heap, symbol_heap)
DynamicPatterns [dynamic_pattern]
/* Don't merge dynamic cases, as a work around for the following case
apply :: Dynamic Dynamic -> Int
......@@ -175,6 +179,9 @@ where
push_expression_into_guards split_case=:{case_guards=OverloadedListPatterns type decons_expr patterns} symbol_heap
# (new_patterns,symbol_heap) = push_expression_into_patterns patterns symbol_heap
= ({split_case & case_guards=OverloadedListPatterns type decons_expr new_patterns},symbol_heap)
push_expression_into_guards split_case=:{case_guards=NewTypePatterns type patterns} symbol_heap
# (new_patterns,symbol_heap) = push_expression_into_patterns patterns symbol_heap
= ({split_case & case_guards=NewTypePatterns type new_patterns},symbol_heap)
push_expression_into_guards split_case=:{case_guards=DynamicPatterns patterns} symbol_heap
# (new_patterns,symbol_heap) = push_expression_into_patterns patterns symbol_heap
= ({split_case & case_guards=DynamicPatterns new_patterns},symbol_heap)
......@@ -236,6 +243,9 @@ where
push_let_expression_into_guards lad (OverloadedListPatterns type decons_expr patterns) var_heap expr_heap
# (patterns, var_heap, expr_heap) = push_let_expression_into_algebraic_pattern lad patterns var_heap expr_heap
= (OverloadedListPatterns type decons_expr patterns, var_heap, expr_heap)
push_let_expression_into_guards lad (NewTypePatterns type patterns) var_heap expr_heap
# (patterns, var_heap, expr_heap) = push_let_expression_into_algebraic_pattern lad patterns var_heap expr_heap
= (NewTypePatterns type patterns, var_heap, expr_heap)
push_let_expression_into_guards lad (DynamicPatterns patterns) var_heap expr_heap
# (patterns, var_heap, expr_heap) = push_let_expression_into_dynamic_pattern lad patterns var_heap expr_heap
= (DynamicPatterns patterns, var_heap, expr_heap)
......@@ -281,6 +291,11 @@ where
-> merge_overloaded_list_patterns type1 decons_expr1 patterns1 patterns2 var_heap symbol_heap error
_
-> (guards, var_heap, symbol_heap, incompatible_patterns_in_case_error error)
merge_guards guards=:(NewTypePatterns type1 patterns1) (NewTypePatterns type2 patterns2) var_heap symbol_heap error
| type1 == type2
# (merged_patterns, var_heap, symbol_heap, error) = merge_algebraic_or_overloaded_list_patterns patterns1 patterns2 var_heap symbol_heap error
= (NewTypePatterns type1 merged_patterns, var_heap, symbol_heap, error)
= (guards, var_heap, symbol_heap, incompatible_patterns_in_case_error error)
merge_guards guards=:(DynamicPatterns patterns1) (DynamicPatterns patterns2) var_heap symbol_heap error
# (merged_patterns, var_heap, symbol_heap, error) = merge_dynamic_patterns patterns1 patterns2 var_heap symbol_heap error
= (DynamicPatterns merged_patterns, var_heap, symbol_heap, error)
......@@ -401,7 +416,7 @@ where
incompatible_patterns_in_case_error error
= checkError "" "incompatible patterns in case" error
mergeCases (case_expr=:(Case first_case=:{case_default, case_default_pos, case_explicit}), case_pos) [expr : exprs] var_heap symbol_heap error
mergeCases (Case first_case=:{case_default, case_default_pos, case_explicit}, case_pos) [expr : exprs] var_heap symbol_heap error
| not case_explicit
= case case_default of
Yes default_expr
......@@ -412,7 +427,7 @@ mergeCases (case_expr=:(Case first_case=:{case_default, case_default_pos, case_e
# ((default_expr, pos), var_heap, symbol_heap, error) = mergeCases expr exprs var_heap symbol_heap error
-> ((Case { first_case & case_default = Yes default_expr, case_default_pos = pos }, case_pos),
var_heap, symbol_heap, error)
mergeCases expr_and_pos _ var_heap symbol_heap error
mergeCases expr_and_pos=:(_,pos) _ var_heap symbol_heap error
= (expr_and_pos, var_heap, symbol_heap, checkWarning "" " alternative will never match" error)
isOverloaded (OverloadedList _ _ _ _)
......
frontend/overloading.icl
View file @ 6fd027e3
......@@ -72,6 +72,9 @@ typeCodeInDynamicError err=:{ea_ok}
err = {err & ea_ok=ea_ok}
= { err & ea_file = err.ea_file <<< "TC context not allowed in dynamic" <<< '\n' }
cycleAfterRemovingNewTypeConstructorsError ident err
# err = errorHeading "Error" err
= { err & ea_file = err.ea_file <<< (" cycle in definition of '" +++ toString ident +++ "' after removing newtype constructors") <<< '\n' }
/*
As soon as all overloaded variables in an type context are instantiated, context reduction is carried out.
......@@ -1363,6 +1366,8 @@ class updateExpression e :: !Index !e !*UpdateInfo -> (!e, !*UpdateInfo)
instance updateExpression Expression
where
updateExpression group_index (App {app_symb={symb_kind=SK_NewTypeConstructor _},app_args=[arg]}) ui
= updateExpression group_index arg ui
updateExpression group_index (App app=:{app_symb=symb=:{symb_kind,symb_ident},app_args,app_info_ptr}) ui
# (app_args, ui) = updateExpression group_index app_args ui
| isNilPtr app_info_ptr
......@@ -1481,10 +1486,13 @@ where
# ((expr, exprs), ui) = updateExpression group_index (expr, exprs) ui
= (expr @ exprs, ui)
updateExpression group_index (Let lad=:{let_lazy_binds, let_strict_binds, let_expr}) ui
# ui = set_aliases_for_binds_that_will_become_aliases let_lazy_binds ui
# (let_lazy_binds, ui) = updateExpression group_index let_lazy_binds ui
# (let_strict_binds, ui) = updateExpression group_index let_strict_binds ui
# (let_expr, ui) = updateExpression group_index let_expr ui
= (Let {lad & let_lazy_binds = let_lazy_binds, let_strict_binds = let_strict_binds, let_expr = let_expr}, ui)
updateExpression group_index case_expr=:(Case {case_guards=NewTypePatterns _ _}) ui
= remove_NewTypePatterns_case_and_update_expression case_expr group_index ui
updateExpression group_index (Case kees=:{case_expr,case_guards,case_default}) ui
# ((case_expr,(case_guards,case_default)), ui) = updateExpression group_index (case_expr,(case_guards,case_default)) ui
= (Case { kees & case_expr = case_expr, case_guards = case_guards, case_default = case_default }, ui)
......@@ -1515,17 +1523,98 @@ where
(EI_TypeOfDynamic type_code, ui_symbol_heap) = readPtr dyn_info_ptr ui.ui_symbol_heap
ui = { ui & ui_symbol_heap = ui_symbol_heap }
= (DynamicExpr { dyn & dyn_expr = dyn_expr, dyn_type_code = type_code }, ui)
updateExpression group_index (MatchExpr cons_symbol expr) ui
# (expr, ui) = updateExpression group_index expr ui
= (MatchExpr cons_symbol expr, ui)
updateExpression group_index (MatchExpr cons_symbol=:{glob_object={ds_arity}} expr) ui
| ds_arity <> -2
# (expr, ui) = updateExpression group_index expr ui
= (MatchExpr cons_symbol expr, ui)
// newtype constructor
= updateExpression group_index expr ui
updateExpression group_index (TupleSelect symbol argn_nr expr) ui
# (expr, ui) = updateExpression group_index expr ui
= (TupleSelect symbol argn_nr expr, ui)
updateExpression group_index (TypeSignature _ expr) ui
= updateExpression group_index expr ui
updateExpression group_index expr=:(Var {var_info_ptr}) ui
# (var_info,var_heap) = readPtr var_info_ptr ui.ui_var_heap
# ui = { ui & ui_var_heap = var_heap }
= case var_info of
VI_Alias var2
# (var_info2,var_heap) = readPtr var2.var_info_ptr ui.ui_var_heap
# ui = { ui & ui_var_heap = var_heap }
-> skip_aliases var_info2 var2 var_info_ptr ui
_
-> (expr,ui)
where
skip_aliases var_info2=:(VI_Alias var3) var2 var_info_ptr1 ui=:{ui_var_heap}
# ui = set_alias_and_detect_cycle var_info_ptr1 var3 ui
| var3.var_info_ptr==var_info_ptr1
= (Var var2,ui)
# (var_info3,var_heap) = readPtr var3.var_info_ptr ui.ui_var_heap
# ui = { ui & ui_var_heap = var_heap }
= skip_aliases var_info3 var3 var2.var_info_ptr ui
skip_aliases var_info2 var2 var_info ui
= (Var var2,ui)
updateExpression group_index expr ui
= (expr, ui)
set_alias_and_detect_cycle info_ptr var ui
| info_ptr<>var.var_info_ptr
= { ui & ui_var_heap = writePtr info_ptr (VI_Alias var) ui.ui_var_heap }
# (var_info,var_heap) = readPtr info_ptr ui.ui_var_heap
# ui = { ui & ui_var_heap = var_heap }
= case var_info of
VI_Alias var
| var.var_info_ptr==info_ptr // to prevent repeating cycle error
-> ui
_
# ui = { ui & ui_var_heap = writePtr info_ptr (VI_Alias var) ui.ui_var_heap }
-> {ui & ui_error = cycleAfterRemovingNewTypeConstructorsError var.var_ident ui.ui_error}
remove_NewTypePatterns_case_and_update_expression :: !Expression !Index !*UpdateInfo -> (!Expression,!*UpdateInfo)
remove_NewTypePatterns_case_and_update_expression (Case {case_guards=NewTypePatterns type [{ap_symbol,ap_vars=[ap_var=:{fv_info_ptr}],ap_expr,ap_position}],
case_expr, case_default, case_explicit, case_info_ptr}) group_index ui
# ap_expr = add_case_default ap_expr case_default
# ap_expr = if case_explicit
(mark_case_explicit ap_expr)
ap_expr
# (case_expr,ui) = updateExpression group_index case_expr ui
= case case_expr of
Var var
# ui = set_alias_and_detect_cycle fv_info_ptr var ui
-> updateExpression group_index ap_expr ui
case_expr
# (ap_expr,ui) = updateExpression group_index ap_expr ui
# let_bind = {lb_dst = ap_var, lb_src = case_expr, lb_position = ap_position}
# (EI_CaseType {ct_pattern_type}, ui_symbol_heap) = readPtr case_info_ptr ui.ui_symbol_heap
// # (let_info_ptr, ui_symbol_heap) = newPtr (EI_LetType [ct_pattern_type]) ui_symbol_heap
# let_info_ptr = case_info_ptr
# ui_symbol_heap = writePtr case_info_ptr (EI_LetType [ct_pattern_type]) ui_symbol_heap
# ui = { ui & ui_symbol_heap = ui_symbol_heap }
# let_expr = Let { let_strict_binds = [], let_lazy_binds = [let_bind], let_expr = ap_expr,
let_info_ptr = let_info_ptr, let_expr_position = ap_position }
-> (let_expr,ui)
where
mark_case_explicit (Case case_=:{case_explicit})
= Case {case_ & case_explicit=True}
mark_case_explicit (Let let_=:{let_expr})
= Let {let_ & let_expr=mark_case_explicit let_expr}
mark_case_explicit expr
= expr
add_case_default expr No
= expr
add_case_default expr (Yes default_expr)
= add_default expr default_expr
where
add_default (Case kees=:{case_default=No,case_explicit=False}) default_expr
= Case { kees & case_default = Yes default_expr }
add_default (Case kees=:{case_default=Yes case_default_expr,case_explicit=False}) default_expr
= Case { kees & case_default = Yes (add_default case_default_expr default_expr)}
add_default (Let lad=:{let_expr}) default_expr
= Let { lad & let_expr = add_default let_expr default_expr }
add_default expr _
= expr
instance updateExpression LetBind
where
updateExpression group_index bind=:{lb_src} ui
......@@ -1607,6 +1696,50 @@ where
updateExpression group_index l ui
= mapSt (updateExpression group_index) l ui
set_aliases_for_binds_that_will_become_aliases :: ![LetBind] !*UpdateInfo -> *UpdateInfo
set_aliases_for_binds_that_will_become_aliases [] ui
= ui
set_aliases_for_binds_that_will_become_aliases [{lb_dst={fv_info_ptr},lb_src}:let_binds] ui
# ui = make_alias_if_expression_will_become_var lb_src fv_info_ptr ui
= set_aliases_for_binds_that_will_become_aliases let_binds ui
where
make_alias_if_expression_will_become_var (Var var) fv_info_ptr ui
= set_alias_and_detect_cycle fv_info_ptr var ui
make_alias_if_expression_will_become_var (App {app_symb={symb_kind=SK_NewTypeConstructor _},app_args=[arg]}) fv_info_ptr ui
= skip_newtypes_and_make_alias_if_var arg fv_info_ptr ui
make_alias_if_expression_will_become_var (MatchExpr {glob_object={ds_arity = -2}} expr) fv_info_ptr ui
= skip_newtypes_and_make_alias_if_var expr fv_info_ptr ui
make_alias_if_expression_will_become_var expr=:(Case {case_guards=NewTypePatterns _ _}) fv_info_ptr ui
= skip_newtypes_and_make_alias_if_var expr fv_info_ptr ui
make_alias_if_expression_will_become_var _ fv_info_ptr ui
= ui
skip_newtypes_and_make_alias_if_var expr fv_info_ptr ui
= case skip_newtypes expr of
Var var
-> set_alias_and_detect_cycle fv_info_ptr var ui
_
-> ui
where
skip_newtypes (App {app_symb={symb_kind=SK_NewTypeConstructor _},app_args=[arg]})
= skip_newtypes arg
skip_newtypes (MatchExpr {glob_object={ds_arity = -2}} expr)
= skip_newtypes expr
skip_newtypes expr=:(Case {case_guards=NewTypePatterns type [{ap_symbol,ap_vars=[ap_var=:{fv_info_ptr}],ap_expr}],case_expr})
= case skip_newtypes case_expr of
Var case_var
-> case skip_newtypes ap_expr of
Var rhs_var
| rhs_var.var_info_ptr==fv_info_ptr
-> case_expr
-> ap_expr
_
-> expr
_
-> expr
skip_newtypes expr
= expr
adjustClassExpressions symb_ident exprs tail_exprs ui
= mapAppendSt (adjustClassExpression symb_ident) exprs tail_exprs ui
where
......
frontend/parse.icl
View file @ 6fd027e3
......@@ -1651,7 +1651,7 @@ wantTypeDef :: !ParseContext !Position !ParseState -> (ParsedDefinition, !Parse
wantTypeDef parseContext pos pState
# (type_lhs, annot, pState) = want_type_lhs pos pState
(token, pState) = nextToken TypeContext pState
(def, pState) = want_type_rhs parseContext type_lhs token annot pState
(def, pState) = want_type_rhs token parseContext type_lhs annot pState
pState = wantEndOfDefinition "type definition (6)" pState
= (def, pState)
where
......@@ -1664,8 +1664,8 @@ where
(contexts, pState) = optionalContext pState
= (MakeTypeDef ident args (ConsList []) attr contexts pos, annot, pState)
want_type_rhs :: !ParseContext !ParsedTypeDef !Token !Annotation !ParseState -> (ParsedDefinition, !ParseState)
want_type_rhs parseContext td=:{td_ident,td_attribute} EqualToken annot pState
want_type_rhs :: !Token !ParseContext !ParsedTypeDef !Annotation !ParseState -> (ParsedDefinition, !ParseState)
want_type_rhs EqualToken parseContext td=:{td_ident,td_attribute} annot pState
# name = td_ident.id_name
pState = verify_annot_attr annot td_attribute name pState
(exi_vars, pState) = optionalExistentialQuantifiedVariables pState
......@@ -1695,7 +1695,7 @@ where
(rec_cons_ident, pState) = stringToIdent ("_" + name) IC_Expression pState
= (PD_Type { td & td_rhs = SelectorList rec_cons_ident exi_vars is_boxed_record fields }, pState)
want_type_rhs parseContext td=:{td_attribute} ColonDefinesToken annot pState // type Macro
want_type_rhs ColonDefinesToken parseContext td=:{td_attribute} annot pState // type synonym
# name = td.td_ident.id_name
pState = verify_annot_attr annot td_attribute name pState
(atype, pState) = want pState // Atype
......@@ -1704,7 +1704,18 @@ where
= (PD_Type td, pState)
= (PD_Type td, parseError "Type synonym" No ("No lhs strictness annotation for the type synonym "+name) pState)
want_type_rhs parseContext td=:{td_attribute} token=:OpenToken annot pState
want_type_rhs DefinesColonToken parseContext td=:{td_ident,td_attribute} annot pState
# name = td_ident.id_name
pState = verify_annot_attr annot td_attribute name pState
(exi_vars, pState) = optionalExistentialQuantifiedVariables pState
(token, pState) = nextToken GeneralContext pState
(condef, pState) = want_newtype_constructor exi_vars token pState
td = { td & td_rhs = NewTypeCons condef }
| annot == AN_None
= (PD_Type td, pState)
= (PD_Type td, parseError "New type" No ("No lhs strictness annotation for the new type "+name) pState)
want_type_rhs token=:OpenToken parseContext td=:{td_attribute} annot pState
| isIclContext parseContext
= (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState)
# pState = wantToken TypeContext "Abstract type synonym" ColonDefinesToken pState
......@@ -1717,7 +1728,7 @@ where
= (PD_Type td, pState)
= (PD_Type td, parseError "abstract type" No ("type attribute "+toString td_attribute+" for abstract type "+name+" is not") (tokenBack pState))
want_type_rhs parseContext td=:{td_attribute} token annot pState
want_type_rhs token parseContext td=:{td_attribute} annot pState
| isIclContext parseContext
= (PD_Erroneous, parseError "type RHS" (Yes token) "type definition" pState)
| td_attribute == TA_Anonymous || td_attribute == TA_Unique || td_attribute == TA_None
......@@ -1747,11 +1758,7 @@ where
want_constructor_list :: ![ATypeVar] !Token !ParseState -> (.[ParsedConstructor],ParseState)
want_constructor_list exi_vars token pState
# 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
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}
# (cons,pState) = want_constructor exi_vars token pState
(token, pState) = nextToken TypeContext pState
| token == BarToken
# (exi_vars, pState) = optionalExistentialQuantifiedVariables pState
......@@ -1760,31 +1767,51 @@ where
= ([cons : cons_list], pState)
// otherwise