diff options
39 files changed, 1485 insertions, 1278 deletions
diff --git a/frontend/Heap.dcl b/frontend/Heap.dcl index bf855d9..c23381b 100644 --- a/frontend/Heap.dcl +++ b/frontend/Heap.dcl @@ -28,4 +28,4 @@ ptrToInt :: !(Ptr w) -> Int where (ptr, val) = ptr_and_val -instance == Ptr a +instance == (Ptr a) diff --git a/frontend/Heap.icl b/frontend/Heap.icl index 3a99c89..a8312ab 100644 --- a/frontend/Heap.icl +++ b/frontend/Heap.icl @@ -131,7 +131,7 @@ ptrToInt2 p = code { rtn }; -instance == Ptr a +instance == (Ptr a) where { (==) p1 p2 = code { push_r_args_b 1 1 1 1 1 diff --git a/frontend/StdCompare.dcl b/frontend/StdCompare.dcl index a46ee4d..c4a94e2 100644 --- a/frontend/StdCompare.dcl +++ b/frontend/StdCompare.dcl @@ -9,14 +9,12 @@ Equal :== 0 class (=<) infix 4 a :: !a !a -> CompareValue -instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, Global a | =< a +instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, (Global a) | =< a instance =< Type instance == BasicType, TypeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue, - FunKind, Global a | == a, Priority, Assoc - -export == Int + FunKind, (Global a) | == a, Priority, Assoc instance < MemberDef diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl index c9159c3..b9785ca 100644 --- a/frontend/StdCompare.icl +++ b/frontend/StdCompare.icl @@ -11,7 +11,7 @@ instance == FunKind where (==) fk1 fk2 = equal_constructor fk1 fk2 -instance == Global a | == a +instance == (Global a) | == a where (==) g1 g2 = g1.glob_module == g2.glob_module && g1.glob_object == g2.glob_object @@ -188,7 +188,7 @@ where (=<) id1 id2 = id1.id_name =< id2.id_name -instance =< Global a | =< a +instance =< (Global a) | =< a where (=<) g1 g2 = (g1.glob_module,g1.glob_object) =< (g2.glob_module,g2.glob_object) diff --git a/frontend/_aconcat.dcl b/frontend/_aconcat.dcl index 3647358..38c3da8 100644 --- a/frontend/_aconcat.dcl +++ b/frontend/_aconcat.dcl @@ -1,12 +1,13 @@ system module _aconcat -import _SystemArray,StdInt,StdEnum,StdList +import StdArray,StdInt,StdEnum,StdList arrayConcat a1 a2 :==r2 where r2={r1 & [i+s1]=a2.[i] \\ i<-[0..s2-1]} r1={r0 & [i]=a1.[i] \\ i<-[0..s1-1]} +// r0=_createArray (s1+s2) // 2.0 r0=_createArrayc (s1+s2) s1=size a1 s2=size a2 @@ -16,6 +17,7 @@ arrayPlusList a l where r2={r1 & [i+s1]=e \\ i<-[0..s2-1] & e<-l} r1={r0 & [i]=a.[i] \\ i<-[0..s1-1]} +// r0=_createArray (s1+s2) // 2.0 r0=_createArrayc (s1+s2) s1=size a s2=length l @@ -26,6 +28,7 @@ arrayPlusRevList a l where r2={r1 & [sr-i]=e \\ i<-[1..s2] & e<-l} r1={r0 & [i]=a.[i] \\ i<-[0..s1-1]} +// r0=_createArray sr // 2.0 r0=_createArrayc sr sr=s1+s2 s2=length l diff --git a/frontend/_aconcat.icl b/frontend/_aconcat.icl index 67caf59..b0c4d95 100644 --- a/frontend/_aconcat.icl +++ b/frontend/_aconcat.icl @@ -1,12 +1,13 @@ implementation module _aconcat -import _SystemArray,StdInt,StdEnum, StdList +import StdArray,StdInt,StdEnum, StdList arrayConcat a1 a2 :==r2 where r2={r1 & [i+s1]=a2.[i] \\ i<-[0..s2-1]} r1={r0 & [i]=a1.[i] \\ i<-[0..s1-1]} +// r0=_createArray (s1+s2) // 2.0 r0=_createArrayc (s1+s2) s1=size a1 s2=size a2 @@ -16,22 +17,17 @@ arrayPlusList a l where r2={r1 & [i+s1]=e \\ i<-[0..s2-1] & e <- l} r1={r0 & [i]=a.[i] \\ i<-[0..s1-1]} +// r0=_createArray (s1+s2) // 2.0 r0=_createArrayc (s1+s2) s1=size a s2=length l -/* - :== case l of - [] - -> a - _ - -> arrayConcat a { x \\ x <- l } -*/ arrayPlusRevList a l :==r2 where r2={r1 & [sr-i]=e \\ i<-[1..s2] & e<-l} r1={r0 & [i]=a.[i] \\ i<-[0..s1-1]} +// r0=_createArray sr // 2.0 r0=_createArrayc sr sr=s1+s2 s1=size a diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 692e317..19de6f5 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -340,9 +340,9 @@ where | (ldep == cMAXINT || ldep == my_mark) # (as_deps, as_check_marks, group) = close_group type_module type_index as_deps as_check_marks [] (kinds, (type_properties, as_kind_heap, as_td_infos)) = determine_kinds_and_properties_of_group group as_kind_heap as_td_infos - kind_heap = unify_var_binds con_var_binds as_kind_heap + as_kind_heap = unify_var_binds con_var_binds as_kind_heap (normalized_top_vars, (kind_var_store, as_kind_heap)) = normalize_top_vars con_top_var_binds 0 as_kind_heap - (as_kind_heap, as_td_infos) = update_type_group_info group kinds type_properties normalized_top_vars group as_next_group_num kind_var_store as_kind_heap as_td_infos + (as_kind_heap, as_td_infos) = update_type_group_info group kinds type_properties normalized_top_vars group as_next_group_num 0 kind_var_store as_kind_heap as_td_infos = (cMAXINT, ({con_top_var_binds = [], con_var_binds = [] }, { as & as_check_marks = as_check_marks, as_deps = as_deps, as_kind_heap = as_kind_heap, as_td_infos = as_td_infos, as_next_group_num = inc as_next_group_num })) @@ -363,7 +363,7 @@ where = (kinds, (combineTypeProperties type_properties tdi_properties, kind_heap, as_td_infos)) retrieve_kind (KindVar kind_info_ptr) kind_heap - #! kind_info = sreadPtr kind_info_ptr kind_heap + # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap = (determine_kind kind_info, kind_heap) where determine_kind (KI_Indirection kind) @@ -379,12 +379,12 @@ where unify_var_bind :: !VarBind !*KindHeap -> *KindHeap unify_var_bind {vb_var, vb_vars} kind_heap - #! kind_info = sreadPtr vb_var kind_heap + # (kind_info, kind_heap) = readPtr vb_var kind_heap # (vb_var, kind_heap) = determine_var_bind vb_var kind_info kind_heap = redirect_vars vb_var vb_vars kind_heap where redirect_vars kind_info_ptr [var_info_ptr : var_info_ptrs] kind_heap - #! kind_info = sreadPtr var_info_ptr kind_heap + # (kind_info, kind_heap) = readPtr var_info_ptr kind_heap # (var_info_ptr, kind_heap) = determine_var_bind var_info_ptr kind_info kind_heap | kind_info_ptr == var_info_ptr = redirect_vars kind_info_ptr var_info_ptrs kind_heap @@ -393,14 +393,14 @@ where = kind_heap determine_var_bind _ (KI_VarBind kind_info_ptr) kind_heap - #! kind_info = sreadPtr kind_info_ptr kind_heap + # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap = determine_var_bind kind_info_ptr kind_info kind_heap determine_var_bind kind_info_ptr kind_info kind_heap = (kind_info_ptr, kind_heap) nomalize_var :: !KindInfoPtr !KindInfo !(!Int,!*KindHeap) -> (!Int,!(!Int,!*KindHeap)) nomalize_var orig_kind_info (KI_VarBind kind_info_ptr) (kind_store, kind_heap) - #! kind_info = sreadPtr kind_info_ptr kind_heap + # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) nomalize_var kind_info_ptr (KI_NormVar var_number) (kind_store, kind_heap) = (var_number, (kind_store, kind_heap)) @@ -412,23 +412,23 @@ where where normalize_top_var :: !KindInfoPtr !(!Int,!*KindHeap) -> (!Int,!(!Int,!*KindHeap)) normalize_top_var kind_info_ptr (kind_store, kind_heap) - #! kind_info = sreadPtr kind_info_ptr kind_heap + # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) -// update_type_group_info :: ![Index] ![[TypeKind]] !TypeProperties ![Int] ![Int] !Int !*KindHeap !*{# CheckedTypeDef} -> (!*KindHeap,!*{# CheckedTypeDef}) - update_type_group_info [td:tds] [td_kinds : tds_kinds] type_properties top_vars group group_nr kind_store kind_heap td_infos - # (kind_store, kind_heap, td_infos) = update_type_def_info td td_kinds type_properties top_vars group group_nr kind_store kind_heap td_infos - = update_type_group_info tds tds_kinds type_properties top_vars group group_nr kind_store kind_heap td_infos - update_type_group_info [] [] type_properties top_vars group group_nr kind_store kind_heap td_infos +// update_type_group_info :: ![Index] ![[TypeKind]] !TypeProperties ![Int] ![Int] !Index !Int !*KindHeap !*{# CheckedTypeDef} -> (!*KindHeap,!*{# CheckedTypeDef}) + update_type_group_info [td:tds] [td_kinds : tds_kinds] type_properties top_vars group group_nr loc_type_index kind_store kind_heap td_infos + # (kind_store, kind_heap, td_infos) = update_type_def_info td td_kinds type_properties top_vars group group_nr loc_type_index kind_store kind_heap td_infos + = update_type_group_info tds tds_kinds type_properties top_vars group group_nr (inc loc_type_index) kind_store kind_heap td_infos + update_type_group_info [] [] type_properties top_vars group group_nr loc_type_index kind_store kind_heap td_infos = (kind_heap, td_infos) -// update_type_def_info :: !Int ![TypeKind] !TypeProperties ![Int] ![Int] !Int !*KindHeap !*{# CheckedTypeDef} -> (!Int,!*KindHeap,!*{# CheckedTypeDef}) - update_type_def_info {glob_module,glob_object} td_kinds type_properties top_vars group group_nr kind_store kind_heap td_infos +// update_type_def_info :: !Int ![TypeKind] !TypeProperties ![Int] ![Int] !Int !Index !Int !*KindHeap !*{# CheckedTypeDef} -> (!Int,!*KindHeap,!*{# CheckedTypeDef}) + update_type_def_info {glob_module,glob_object} td_kinds type_properties top_vars group group_nr loc_type_index kind_store kind_heap td_infos # (td_info=:{tdi_kinds}, td_infos) = td_infos![glob_module].[glob_object] # (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info tdi_kinds td_kinds top_vars kind_store kind_heap = (kind_store, kind_heap, { td_infos & [glob_module].[glob_object] = {td_info & tdi_properties = type_properties, tdi_kinds = td_kinds, tdi_group = group, - tdi_group_vars = group_vars, tdi_cons_vars = cons_vars, tdi_group_nr = group_nr } }) + tdi_group_vars = group_vars, tdi_cons_vars = cons_vars, tdi_group_nr = group_nr, tdi_tmp_index = loc_type_index } }) // ---> ("update_type_def_info", glob_module, glob_object, group_nr) where determine_type_def_info [ KindVar kind_info_ptr : kind_vars ] [ kind : kinds ] top_vars kind_store kind_heap diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl index 746fbbc..05e8994 100644 --- a/frontend/analunitypes.icl +++ b/frontend/analunitypes.icl @@ -30,15 +30,18 @@ typeProperties type_index module_index hio_signs hio_props defs type_var_heap td (tsp_propagation, type_var_heap, td_infos) = determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos tsp_coercible = (td_info.tdi_properties bitand cIsNonCoercible) == 0 = ({tsp_sign = tsp_sign, tsp_propagation = tsp_propagation, tsp_coercible = tsp_coercible }, type_var_heap, td_infos) -// ---> ("typeProperties", td_name, tsp_sign, tsp_propagation) + ---> ("typeProperties", (td_name, type_index, module_index), tsp_sign, tsp_propagation) signClassification :: !Index !Index ![SignClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos -> (!SignClassification, !*TypeVarHeap, !*TypeDefInfos) signClassification type_index module_index hio_signs defs type_var_heap td_infos # {td_name,td_args} = defs.[module_index].com_type_defs.[type_index] (td_info, td_infos) = td_infos![module_index].[type_index] - = determineSignClassOfTypeDef type_index module_index td_args td_info hio_signs defs type_var_heap td_infos + (sign_class, type_var_heap, td_infos) = determineSignClassOfTypeDef type_index module_index td_args td_info hio_signs defs type_var_heap td_infos + = (sign_class, type_var_heap, td_infos) // ---> ("signClassification", td_name) + + removeTopClasses [cv : cvs] [tc : tcs] | isATopConsVar cv = removeTopClasses cvs tcs @@ -46,8 +49,19 @@ removeTopClasses [cv : cvs] [tc : tcs] removeTopClasses _ _ = [] +:: RecTypeApplication classification = + { rta_index :: !Int + , rta_classification :: !classification + } + +:: SignClassState = + { scs_type_var_heap :: !.TypeVarHeap + , scs_type_def_infos :: !.TypeDefInfos + , scs_rec_appls :: ![RecTypeApplication (Sign, [SignClassification])] + } + determineSignClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![SignClassification] {# CommonDefs} !*TypeVarHeap !*TypeDefInfos - -> (!SignClassification, !*TypeVarHeap, !*TypeDefInfos) + -> (!SignClassification, !*TypeVarHeap,!*TypeDefInfos) determineSignClassOfTypeDef type_index module_index td_args {tdi_classification,tdi_cons_vars,tdi_group_vars,tdi_group,tdi_group_nr} hio_signs ci type_var_heap td_infos # hio_signs = removeTopClasses tdi_cons_vars hio_signs @@ -55,178 +69,234 @@ determineSignClassOfTypeDef type_index module_index td_args {tdi_classification, = case result of Yes {ts_type_sign} -> (ts_type_sign, type_var_heap, td_infos) -// ---> ("determineSignClassOfTypeDef1", ts_type_sign) - No - # type_var_heap = bind_type_vars_to_signs td_args tdi_group_vars tdi_cons_vars hio_signs type_var_heap - (sign_class, type_var_heap, td_infos) - = newSignClassOfTypeDefGroup tdi_group_nr { glob_module = module_index, glob_object = type_index} - tdi_group hio_signs ci type_var_heap td_infos - -> (sign_class, foldSt restore_binds_of_type_var td_args type_var_heap, td_infos) -// ---> ("determineSignClassOfTypeDef2", sign_class) + # signs_of_group_vars = foldSt (determine_signs_of_group_var tdi_cons_vars hio_signs) tdi_group_vars [] + -> newSignClassOfTypeDefGroup tdi_group_nr { glob_module = module_index, glob_object = type_index} + tdi_group signs_of_group_vars ci type_var_heap td_infos where - bind_type_vars_to_signs [{atv_variable={tv_info_ptr}}: tvs] [gv : gvs] cons_vars hio_signs type_var_heap - # sign = determine_classification gv cons_vars hio_signs BottomSignClass - # (var_info, type_var_heap) = readPtr tv_info_ptr type_var_heap - = bind_type_vars_to_signs tvs gvs cons_vars hio_signs (type_var_heap <:= (tv_info_ptr, TVI_SignClass gv sign var_info)) - bind_type_vars_to_signs [] group_vars cons_vars hio_signs type_var_heap - = type_var_heap - - determine_classification gv [cv : cvs] hio_signs=:[tc : tcs] cumm_sign_class - | isATopConsVar cv - | gv == decodeTopConsVar cv - = TopSignClass + determine_signs_of_group_var cons_vars cons_var_signs gv signs_of_group_vars + | sign_determined gv signs_of_group_vars + = signs_of_group_vars + # sign = determine_classification gv cons_vars cons_var_signs BottomSignClass + = [(gv, sign) : signs_of_group_vars] + where + sign_determined this_gv [] + = False + sign_determined this_gv [(gv,_) : signs] + = this_gv == gv || sign_determined this_gv signs + + determine_classification gv [cv : cvs] sigs=:[tc : tcs] cumm_sign_class + | isATopConsVar cv + | gv == decodeTopConsVar cv + = TopSignClass + = determine_classification gv cvs sigs cumm_sign_class + | gv == cv + = determine_classification gv cvs tcs (tc + cumm_sign_class) = determine_classification gv cvs tcs cumm_sign_class - | gv == cv - = determine_classification gv cvs tcs (tc + cumm_sign_class) - = determine_classification gv cvs tcs cumm_sign_class - determine_classification gv cons_vars [] cumm_sign_class - = cumm_sign_class + determine_classification gv cons_vars [] cumm_sign_class + = cumm_sign_class + +:: SignRequirements = + { sr_classification :: !SignClassification + , sr_hio_signs :: ![SignClassification] + , sr_type_applications :: ![RecTypeApplication (Sign, [SignClassification])] + } + +newGroupSigns :: !Int -> *{# SignRequirements} +newGroupSigns group_size = createArray group_size { sr_hio_signs = [], sr_classification = BottomSignClass, sr_type_applications = [] } + +newSignClassOfTypeDefGroup :: !Int !(Global Int) ![Global Int] ![(Int, SignClassification)] !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos + -> *(!SignClassification, !*TypeVarHeap, !*TypeDefInfos) +newSignClassOfTypeDefGroup group_nr {glob_module,glob_object} group signs_of_group_vars ci type_var_heap td_infos + # (group_signs, type_var_heap, td_infos) = collect_sign_class_of_type_defs group_nr group signs_of_group_vars ci + (newGroupSigns (length group)) type_var_heap td_infos + group_signs = determine_fixed_point group_signs + td_infos = update_sign_class_of_group group group_signs td_infos + (tdi=:{tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] + = (group_signs.[tdi_tmp_index].sr_classification, type_var_heap, td_infos) +where + update_sign_class_of_group group group_signs td_infos + = foldSt (update_sign_class_of_type_def group_signs) group td_infos + where + update_sign_class_of_type_def group_signs {glob_module,glob_object} td_infos + # (tdi=:{tdi_classification,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] + {sr_hio_signs, sr_classification} = group_signs.[tdi_tmp_index] + tdi_classification = addSignClassification sr_hio_signs sr_classification tdi_classification + = { td_infos & [glob_module].[glob_object] = { tdi & tdi_classification = tdi_classification }} + + + collect_sign_class_of_type_defs group_nr group signs_of_group_vars ci sign_requirements type_var_heap td_infos + = foldSt (collect_sign_class_of_type_def group_nr signs_of_group_vars ci) group (sign_requirements, type_var_heap, td_infos) + where + collect_sign_class_of_type_def group_nr signs_of_group_vars ci {glob_module,glob_object} (sign_requirements, type_var_heap, td_infos) + # ({tdi_group_vars,tdi_kinds,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] + {td_name,td_args,td_rhs} = ci.[glob_module].com_type_defs.[glob_object] + (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args tdi_group_vars tdi_kinds signs_of_group_vars ([], type_var_heap) + (sign_env, scs) = sign_class_of_type_def glob_module td_rhs group_nr ci + {scs_type_var_heap = type_var_heap, scs_type_def_infos = td_infos, scs_rec_appls = [] } + type_var_heap = foldSt restore_binds_of_type_var td_args scs.scs_type_var_heap + = ({sign_requirements & [tdi_tmp_index] = { sr_hio_signs = reverse rev_hio_signs, sr_classification = sign_env, + sr_type_applications = scs.scs_rec_appls }}, type_var_heap, scs.scs_type_def_infos) + + determine_fixed_point sign_requirements + #! group_size = size sign_requirements + # (go_on, sign_requirements) = iFoldSt next_sign_classification 0 group_size (False, sign_requirements) + | go_on + = determine_fixed_point sign_requirements + = sign_requirements + + next_sign_classification type_index (changed, sign_requirements) + # ({sr_classification,sr_type_applications}, sign_requirements) = sign_requirements![type_index] + (new_sr_classification, sign_requirements) = foldSt examine_type_application sr_type_applications (sr_classification, sign_requirements) + | sr_classification == new_sr_classification + = (changed, sign_requirements) + = (True, { sign_requirements & [type_index].sr_classification = new_sr_classification }) + + examine_type_application {rta_index, rta_classification = (sign, arg_classes)} (cumm_class, sign_requirements) + # (sr_classification, sign_requirements) = sign_requirements![rta_index].sr_classification + cumm_class = determine_cummulative_sign sign sr_classification arg_classes 0 cumm_class + = (cumm_class, sign_requirements) + where + determine_cummulative_sign sign sign_class [arg_class : arg_classes] type_index cumm_class + # this_sign = sign_class_to_sign sign_class type_index + = determine_cummulative_sign sign sign_class arg_classes (inc type_index) ((sign * this_sign) *+ arg_class + cumm_class) + determine_cummulative_sign sign sign_class [] type_index cumm_class + = cumm_class + + bind_type_vars_to_signs [] group_vars kinds signs_of_group_vars (rev_hio_signs, type_var_heap) + = (rev_hio_signs, type_var_heap) + bind_type_vars_to_signs [{atv_variable={tv_info_ptr}}: tvs] [gv : gvs] [tk : tks] signs_of_group_vars (rev_hio_signs, type_var_heap) + # sign = retrieve_sign gv signs_of_group_vars + (var_info, type_var_heap) = readPtr tv_info_ptr type_var_heap + | IsArrowKind tk + = bind_type_vars_to_signs tvs gvs tks signs_of_group_vars ([sign:rev_hio_signs], type_var_heap <:= (tv_info_ptr, TVI_SignClass gv sign var_info)) + = bind_type_vars_to_signs tvs gvs tks signs_of_group_vars (rev_hio_signs, type_var_heap <:= (tv_info_ptr, TVI_SignClass gv sign var_info)) + where + retrieve_sign this_gv [(gv,sign) : signs ] + | this_gv == gv + = sign + = retrieve_sign this_gv signs restore_binds_of_type_var {atv_variable={tv_info_ptr}} type_var_heap # (TVI_SignClass _ _ old_info, type_var_heap) = readPtr tv_info_ptr type_var_heap = type_var_heap <:= (tv_info_ptr, old_info) -newSignClassOfTypeDefGroup :: !Int !(Global Int) ![Global Int] ![SignClassification] !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos - -> *(!SignClassification,!*TypeVarHeap,!*TypeDefInfos) -newSignClassOfTypeDefGroup group_nr this_type group hio_signs ci type_var_heap td_infos - # (cumm_sign_env, type_var_heap, td_infos) = collect_sign_class_of_type_defs group_nr group ci BottomSignClass type_var_heap td_infos - (sign_class, td_infos) = update_sign_class_of_group this_type group cumm_sign_env hio_signs td_infos - = (sign_class, type_var_heap, td_infos) -where - update_sign_class_of_group my_index [] cumm_sign_env hio_signs td_infos - = (BottomSignClass, td_infos) - update_sign_class_of_group my_index [{glob_module,glob_object} : group] cumm_sign_env hio_signs td_infos - # (tdi=:{tdi_classification, tdi_group_vars},td_infos) = td_infos![glob_module].[glob_object] - sign_class = determine_sign_class tdi_group_vars cumm_sign_env BottomSignClass 0 - tdi_classification = addSignClassification hio_signs sign_class tdi_classification - td_infos = { td_infos & [glob_module].[glob_object] = { tdi & tdi_classification = tdi_classification }} - (my_sign_class, td_infos) = update_sign_class_of_group my_index group cumm_sign_env hio_signs td_infos - = (if (my_index.glob_module == glob_module && my_index.glob_object == glob_object) sign_class my_sign_class, td_infos) - - determine_sign_class [gv : gvs] cumm_sign_env sign_class var_index - # sign_class = set_sign_in_sign_class (sign_class_to_sign cumm_sign_env gv) var_index sign_class - = determine_sign_class gvs cumm_sign_env sign_class (inc var_index) - determine_sign_class [] cumm_sign_env sign_class var_index - = sign_class - - collect_sign_class_of_type_defs group_nr [] ci cumm_sign_env type_var_heap td_infos - = (cumm_sign_env, type_var_heap, td_infos) - collect_sign_class_of_type_defs group_nr [{glob_module,glob_object} : group] ci cumm_sign_env type_var_heap td_infos - # {td_rhs} = ci.[glob_module].com_type_defs.[glob_object] - # (cumm_sign_env, type_var_heap, td_infos) = sign_class_of_type_def glob_module td_rhs group_nr ci cumm_sign_env type_var_heap td_infos - = collect_sign_class_of_type_defs group_nr group ci cumm_sign_env type_var_heap td_infos - - sign_class_of_type_def :: !Int !TypeRhs !Int !{#CommonDefs} !SignClassification !*TypeVarHeap *TypeDefInfos - -> (!SignClassification,!*TypeVarHeap,!*TypeDefInfos) - sign_class_of_type_def module_index (AlgType conses) group_nr ci cumm_sign_env type_var_heap td_infos - = sign_class_of_type_conses module_index conses group_nr ci cumm_sign_env type_var_heap td_infos - sign_class_of_type_def _ (SynType {at_type}) group_nr ci cumm_sign_env type_var_heap td_infos - # (sign_class, _, type_var_heap, td_infos) = signClassOfType at_type group_nr ci type_var_heap td_infos - = (cumm_sign_env + sign_class, type_var_heap, td_infos) - sign_class_of_type_def module_index (RecordType {rt_constructor}) group_nr ci cumm_sign_env type_var_heap td_infos - = sign_class_of_type_conses module_index [rt_constructor] group_nr ci cumm_sign_env type_var_heap td_infos - sign_class_of_type_def _ (AbstractType properties) _ _ _ type_var_heap td_infos + sign_class_of_type_def :: !Int !TypeRhs !Int !{#CommonDefs} !*SignClassState + -> (!SignClassification,!*SignClassState) + sign_class_of_type_def module_index (AlgType conses) group_nr ci scs + = sign_class_of_type_conses module_index conses group_nr ci BottomSignClass scs + sign_class_of_type_def _ (SynType {at_type}) group_nr ci scs + # (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_def _ (AbstractType properties) _ _ scs | properties bitand cIsNonCoercible == 0 - = (PosSignClass, type_var_heap, td_infos) - = (TopSignClass, type_var_heap, td_infos) + = (PostiveSignClass, scs) + = (TopSignClass, scs) - sign_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_sign_class type_var_heap td_infos + 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, type_var_heap, td_infos) = sign_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_sign_class type_var_heap td_infos - = sign_class_of_type_conses module_index conses group_nr ci cumm_sign_class type_var_heap td_infos - sign_class_of_type_conses module_index [] _ _ cumm_sign_class type_var_heap td_infos - = (cumm_sign_class, type_var_heap, td_infos) - - sign_class_of_type_of_list [{at_type} : types] group_nr ci cumm_sign_class type_var_heap td_infos - # (sign_class, _, type_var_heap, td_infos) = signClassOfType at_type group_nr ci type_var_heap td_infos - = sign_class_of_type_of_list types group_nr ci (cumm_sign_class + sign_class) type_var_heap td_infos - sign_class_of_type_of_list [] _ _ cumm_sign_class type_var_heap td_infos - = (cumm_sign_class, type_var_heap, td_infos) - + # (cumm_sign_class, scs) = sign_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_sign_class scs + = sign_class_of_type_conses module_index conses group_nr ci cumm_sign_class scs + sign_class_of_type_conses module_index [] _ _ cumm_sign_class scs + = (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 + # (sign_class, _, scs) = signClassOfType at_type PositiveSign DontUSeTopSign group_nr ci scs + = sign_class_of_type_of_list types group_nr ci (cumm_sign_class + sign_class) scs + IsAHioType :== True IsNotAHioType :== False IsArrowKind (KindArrow _) = True IsArrowKind _ = False -signClassOfTypeVariable :: !TypeVar !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos - -> *(!SignClassification,!SignClassification,!*TypeVarHeap,!*TypeDefInfos); -signClassOfTypeVariable {tv_info_ptr} ci type_var_heap td_infos - #! var_info = sreadPtr tv_info_ptr type_var_heap +signClassOfTypeVariable :: !TypeVar !{#CommonDefs} !*SignClassState -> (!SignClassification,!SignClassification,!*SignClassState) +signClassOfTypeVariable {tv_name,tv_info_ptr} ci scs=:{scs_type_var_heap} + # (var_info, scs_type_var_heap) = readPtr tv_info_ptr scs_type_var_heap + scs = { scs & scs_type_var_heap = scs_type_var_heap } = case var_info of TVI_SignClass group_var_index var_class _ - -> (var_index_to_sign_class group_var_index, var_class, type_var_heap, td_infos) + -> (var_index_to_sign_class group_var_index, var_class, scs) _ - -> (BottomSignClass, TopSignClass, type_var_heap, td_infos) + -> (BottomSignClass, TopSignClass, scs) where var_index_to_sign_class :: !Int -> SignClassification var_index_to_sign_class var_index = { sc_pos_vect = 1 << var_index, sc_neg_vect = 0} +UseTopSign :== True +DontUSeTopSign :== False -signClassOfType :: !Type !Int !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos -> *(!SignClassification,!SignClassification,!*TypeVarHeap,!*TypeDefInfos); -signClassOfType (TV tv) _ ci type_var_heap td_infos - = signClassOfTypeVariable tv ci type_var_heap td_infos +signClassOfType :: !Type !Sign !Bool !Int !{#CommonDefs} !*SignClassState -> (!SignClassification,!SignClassification,!*SignClassState) +signClassOfType (TV tv) sign use_top_sign group_nr ci scs + # (sign_class, type_class, scs) = signClassOfTypeVariable tv ci scs + = (sign *+ sign_class, type_class, scs) -signClassOfType (TA {type_index = {glob_module, glob_object}} types) group_nr ci type_var_heap td_infos - # ({tdi_group_nr,tdi_kinds}, td_infos) = td_infos![glob_module].[glob_object] +signClassOfType (TA {type_index = {glob_module, glob_object}} types) sign use_top_sign group_nr ci scs + # (td_info=:{tdi_group_nr,tdi_tmp_index,tdi_kinds}, scs) = scs!scs_type_def_infos.[glob_module].[glob_object] | tdi_group_nr == group_nr - = sign_class_of_type_list_of_rec_type types BottomSignClass ci type_var_heap td_infos + = sign_class_of_type_list_of_rec_type types sign use_top_sign tdi_tmp_index ci [] scs # {td_args,td_arity} = ci.[glob_module].com_type_defs.[glob_object] - (td_info, td_infos) = td_infos![glob_module].[glob_object] - (sign_classes, hio_signs, type_var_heap, td_infos) = collect_sign_classes_of_type_list types tdi_kinds ci type_var_heap td_infos - (type_class, type_var_heap, td_infos) = determineSignClassOfTypeDef glob_object glob_module td_args td_info hio_signs ci type_var_heap td_infos - sign_class = determine_cummulative_sign sign_classes type_class 0 BottomSignClass - = (sign_class, adjust_sign_class type_class td_arity, type_var_heap, td_infos) + (sign_classes, hio_signs, scs) = collect_sign_classes_of_type_list types tdi_kinds group_nr ci scs + (type_class, scs_type_var_heap, scs_type_def_infos) + = determineSignClassOfTypeDef glob_object glob_module td_args td_info hio_signs ci scs.scs_type_var_heap scs.scs_type_def_infos + (sign_class, scs) = determine_cummulative_sign types tdi_kinds sign use_top_sign type_class sign_classes 0 ci BottomSignClass + { scs & scs_type_var_heap = scs_type_var_heap, scs_type_def_infos = scs_type_def_infos } + = (sign_class, adjust_sign_class type_class td_arity, scs) where - - sign_class_of_type_list_of_rec_type [t : ts] cumm_sign_class ci type_var_heap td_infos - # (sign_class, type_class, type_var_heap, td_infos) = signClassOfType t.at_type group_nr ci type_var_heap td_infos - cumm_sign_class = { cumm_sign_class & sc_neg_vect = cumm_sign_class.sc_neg_vect bitor sign_class.sc_neg_vect } - = sign_class_of_type_list_of_rec_type ts cumm_sign_class ci type_var_heap td_infos - sign_class_of_type_list_of_rec_type [] cumm_sign_class ci type_var_heap td_infos - = (cumm_sign_class, TopSignClass, type_var_heap, td_infos) - - collect_sign_classes_of_type_list [t : ts] [tk : tks] ci type_var_heap td_infos - # (sign_class, type_class, type_var_heap, td_infos) = signClassOfType t.at_type group_nr ci type_var_heap td_infos - (sign_classes, hio_signs, type_var_heap, td_infos) = collect_sign_classes_of_type_list ts tks ci type_var_heap td_infos - sign_classes = [sign_class : sign_classes] + sign_class_of_type_list_of_rec_type [t : ts] sign use_top_sign tmp_type_index ci rev_sign_classes scs + # (sign_class, type_class, scs) = signClassOfType t.at_type PositiveSign UseTopSign group_nr ci scs + = sign_class_of_type_list_of_rec_type ts sign use_top_sign tmp_type_index ci [ sign_class : rev_sign_classes ] scs + sign_class_of_type_list_of_rec_type [] sign use_top_sign tmp_type_index ci rev_sign_classes scs=:{scs_rec_appls} + # rta = { rta_index = tmp_type_index, rta_classification = (if use_top_sign TopSign sign, reverse rev_sign_classes) } + = (BottomSignClass, TopSignClass, { scs & scs_rec_appls = [ rta : scs_rec_appls ] }) + + collect_sign_classes_of_type_list [t : ts] [tk : tks] group_nr ci scs + | IsArrowKind tk + # (sign_class, type_class, scs) = signClassOfType t.at_type PositiveSign UseTopSign group_nr ci scs + (sign_classes, hio_signs, scs) = collect_sign_classes_of_type_list ts tks group_nr ci scs + = ([sign_class : sign_classes], [type_class:hio_signs], scs) + = collect_sign_classes_of_type_list ts tks group_nr ci scs + collect_sign_classes_of_type_list [] _ _ ci scs + = ([], [], scs) + + determine_cummulative_sign [t : ts] [tk : tks] sign use_top_sign sign_class sign_classes type_index ci cumm_class scs | IsArrowKind tk - = (sign_classes, [type_class:hio_signs], type_var_heap, td_infos) - = (sign_classes, hio_signs, type_var_heap, td_infos) - collect_sign_classes_of_type_list [] _ ci type_var_heap td_infos - = ([], [], type_var_heap, td_infos) - - determine_cummulative_sign [sc : scs] sign_class type_index cumm_class - # cumm_class = sign_class_to_sign sign_class type_index *+ sc + cumm_class - = determine_cummulative_sign scs sign_class (inc type_index) cumm_class - determine_cummulative_sign [] _ _ cumm_class - = cumm_class + # [sc : sign_classes] = sign_classes + = determine_cummulative_sign ts tks sign use_top_sign sign_class sign_classes (inc type_index) ci (sc + cumm_class) scs + # this_sign = sign_class_to_sign sign_class type_index + (sign_class, type_class, scs) = signClassOfType t.at_type this_sign use_top_sign group_nr ci scs + = determine_cummulative_sign ts tks sign use_top_sign sign_class sign_classes (inc type_index) ci (sign *+ sign_class + cumm_class) scs + determine_cummulative_sign [] _ sign use_top_sign sign_class sign_classes type_index ci cumm_class scs + = (cumm_class, scs) adjust_sign_class {sc_pos_vect,sc_neg_vect} arity = { sc_pos_vect = sc_pos_vect >> arity, sc_neg_vect = sc_neg_vect >> arity } -signClassOfType (CV tv :@: types) group_nr ci type_var_heap td_infos - # (sign_class, type_class, type_var_heap, td_infos) = signClassOfTypeVariable tv ci type_var_heap td_infos - (sign_class, type_var_heap, td_infos) = sign_class_of_type_list types group_nr type_class 0 sign_class ci type_var_heap td_infos - = (sign_class, BottomSignClass, type_var_heap, td_infos) +signClassOfType (CV tv :@: types) sign use_top_sign group_nr ci scs + # (sign_class, type_class, scs) = signClassOfTypeVariable tv ci scs + (sign_class, scs) = sign_class_of_type_list types sign use_top_sign group_nr type_class 0 sign_class ci scs + = (sign_class, BottomSignClass, scs) where - sign_class_of_type_list [{at_type} : ts] group_nr cv_sign_class type_index cumm_class ci type_var_heap td_infos - # (sign_class, _, type_var_heap, td_infos) = signClassOfType at_type group_nr ci type_var_heap td_infos - cumm_class = (sign_class_to_sign cv_sign_class type_index *+ sign_class) + cumm_class - = sign_class_of_type_list ts group_nr sign_class (inc type_index) cumm_class ci type_var_heap td_infos - sign_class_of_type_list [] _ _ _ cumm_class ci type_var_heap td_infos - = (cumm_class, type_var_heap, td_infos) + sign_class_of_type_list [{at_type} : ts] sign use_top_sign group_nr cv_sign_class type_index cumm_class ci scs + # (sign_class, _, scs) = signClassOfType at_type (sign_class_to_sign cv_sign_class type_index) use_top_sign group_nr ci scs + cumm_class = (sign *+ sign_class) + cumm_class + = sign_class_of_type_list ts sign use_top_sign group_nr sign_class (inc type_index) cumm_class ci scs + sign_class_of_type_list [] sign use_top_sign group_nr cv_sign_class type_index cumm_class ci scs + = (cumm_class, scs) -signClassOfType (arg_type --> res_type) group_nr ci type_var_heap td_infos - # (arg_class, _, type_var_heap, td_infos) = signClassOfType arg_type.at_type group_nr ci type_var_heap td_infos - (res_class, _, type_var_heap, td_infos) = signClassOfType res_type.at_type group_nr ci type_var_heap td_infos - = (NegativeSign *+ arg_class + PositiveSign *+ res_class, BottomSignClass, type_var_heap, td_infos) +signClassOfType (arg_type --> res_type) sign use_top_sign group_nr ci scs + # (arg_class, _, scs) = signClassOfType arg_type.at_type NegativeSign use_top_sign group_nr ci scs + (res_class, _, scs) = signClassOfType res_type.at_type PositiveSign use_top_sign group_nr ci scs + = (sign *+ (arg_class + res_class), BottomSignClass, scs) -signClassOfType type _ _ type_var_heap td_infos - = (BottomSignClass, BottomSignClass, type_var_heap, td_infos) +signClassOfType type _ _ _ _ scs + = (BottomSignClass, BottomSignClass, scs) propClassification :: !Index !Index ![PropClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos -> (!PropClassification, !*TypeVarHeap, !*TypeDefInfos) @@ -235,172 +305,236 @@ propClassification type_index module_index hio_props defs type_var_heap td_infos (td_info, td_infos) = td_infos![module_index].[type_index] = determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos + determinePropClassOfTypeDef :: !Int !Int ![ATypeVar] !TypeDefInfo ![PropClassification] {# CommonDefs} !*TypeVarHeap !*TypeDefInfos -> (!PropClassification,!*TypeVarHeap, !*TypeDefInfos) determinePropClassOfTypeDef type_index module_index td_args {tdi_classification, tdi_kinds, tdi_group, tdi_group_vars, tdi_cons_vars, tdi_group_nr} hio_props ci type_var_heap td_infos # hio_props = removeTopClasses tdi_cons_vars hio_props result = retrievePropClassification hio_props tdi_classification -// ---> (td_args, tdi_kinds, tdi_group_vars) = case result of Yes {ts_type_prop} -> (ts_type_prop, type_var_heap, td_infos) + No - # type_var_heap = bind_type_vars_to_props td_args tdi_group_vars tdi_cons_vars hio_props type_var_heap - (ts_type_prop, type_var_heap, td_infos) = newPropClassOfTypeDefGroup type_index module_index tdi_group hio_props - tdi_group_nr ci type_var_heap td_infos - -> (ts_type_prop, foldSt restore_binds_of_type_var td_args type_var_heap, td_infos) -// ---> ("determinePropClassOfTypeDef", ci.[module_index].com_type_defs.[type_index].td_name, ts_type_prop, hio_props) + # props_of_group_vars = foldSt (determine_props_of_group_var tdi_cons_vars hio_props) tdi_group_vars [] + -> newPropClassOfTypeDefGroup tdi_group_nr { glob_module = module_index, glob_object = type_index} + tdi_group props_of_group_vars ci type_var_heap td_infos + where - bind_type_vars_to_props [{atv_variable={tv_info_ptr}} : tvs] [gv : gvs] cons_vars hio_props type_var_heap - #! old_info = sreadPtr tv_info_ptr type_var_heap - # sign = determine_classification gv cons_vars hio_props NoPropClass - = bind_type_vars_to_props tvs gvs cons_vars hio_props (writePtr tv_info_ptr (TVI_PropClass gv sign old_info) type_var_heap) - bind_type_vars_to_props [] group_vars cons_vars hio_props type_var_heap - = type_var_heap - - determine_classification gv [cv : cvs] hio_props=:[tc : tcs] cumm_prop_class - | isATopConsVar cv - | gv == decodeTopConsVar cv - = PropClass + determine_props_of_group_var cons_vars cons_var_signs gv props_of_group_vars + | prop_determined gv props_of_group_vars + = props_of_group_vars + # prop = determine_classification gv cons_vars cons_var_signs NoPropClass + = [(gv, prop) : props_of_group_vars] + where + prop_determined this_gv [] + = False + prop_determined this_gv [(gv,_) : props] + = this_gv == gv || prop_determined this_gv props + + determine_classification gv [cv : cvs] hio_props=:[tc : tcs] cumm_prop_class + | isATopConsVar cv + | gv == decodeTopConsVar cv + = PropClass + = determine_classification gv cvs tcs cumm_prop_class + | gv == cv + = determine_classification gv cvs tcs (tc bitor cumm_prop_class) = determine_classification gv cvs tcs cumm_prop_class - | gv == cv - = determine_classification gv cvs tcs (tc bitor cumm_prop_class) - = determine_classification gv cvs tcs cumm_prop_class - determine_classification gv cons_vars [] cumm_prop_class - = cumm_prop_class + determine_classification gv cons_vars [] cumm_prop_class + = cumm_prop_class + +:: PropRequirements = + { pr_classification :: !PropClassification + , pr_hio_signs :: ![PropClassification] + , pr_type_applications :: ![RecTypeApplication [PropClassification]] + } + +:: PropClassState = + { pcs_type_var_heap :: !.TypeVarHeap + , pcs_type_def_infos :: !.TypeDefInfos + , pcs_rec_appls :: ![RecTypeApplication [PropClassification]] + } + +newGroupProps :: !Int -> *{# PropRequirements} +newGroupProps group_size = createArray group_size { pr_hio_signs = [], pr_classification = NoPropClass, pr_type_applications = [] } + +newPropClassOfTypeDefGroup :: !Int !(Global Int) ![Global Int] ![(Int, PropClassification)] !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos + -> *(!PropClassification, !*TypeVarHeap, !*TypeDefInfos) +newPropClassOfTypeDefGroup group_nr {glob_module,glob_object} group props_of_group_vars ci type_var_heap td_infos + # (group_props, type_var_heap, td_infos) = collect_prop_class_of_type_defs group_nr group props_of_group_vars ci + (newGroupProps (length group)) type_var_heap td_infos + group_props = determine_fixed_point group_props + td_infos = update_prop_class_of_group group group_props td_infos + (tdi=:{tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] + = (group_props.[tdi_tmp_index].pr_classification, type_var_heap, td_infos) +where + update_prop_class_of_group group group_props td_infos + = foldSt (update_prop_class_of_type_def group_props) group td_infos + where + update_prop_class_of_type_def group_props {glob_module,glob_object} td_infos + # (tdi=:{tdi_classification,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] + {pr_hio_signs, pr_classification} = group_props.[tdi_tmp_index] + tdi_classification = addPropClassification pr_hio_signs pr_classification tdi_classification + = { td_infos & [glob_module].[glob_object] = { tdi & tdi_classification = tdi_classification }} + + collect_prop_class_of_type_defs group_nr group props_of_group_vars ci prop_requirements type_var_heap td_infos + = foldSt (collect_sign_class_of_type_def group_nr props_of_group_vars ci) group (prop_requirements, type_var_heap, td_infos) + where + collect_sign_class_of_type_def group_nr props_of_group_vars ci {glob_module,glob_object} (prop_requirements, type_var_heap, td_infos) + # ({tdi_group_vars,tdi_kinds,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] + {td_name,td_args,td_rhs} = ci.[glob_module].com_type_defs.[glob_object] + (rev_hio_props, type_var_heap) = bind_type_vars_to_props td_args tdi_group_vars tdi_kinds props_of_group_vars ([], type_var_heap) + (prop_env, pcs) = prop_class_of_type_def glob_module td_rhs group_nr ci + {pcs_type_var_heap = type_var_heap, pcs_type_def_infos = td_infos, pcs_rec_appls = [] } + type_var_heap = foldSt restore_binds_of_type_var td_args pcs.pcs_type_var_heap + = ({prop_requirements & [tdi_tmp_index] = { pr_hio_signs = reverse rev_hio_props, pr_classification = prop_env, + pr_type_applications = pcs.pcs_rec_appls }}, type_var_heap, pcs.pcs_type_def_infos) + + determine_fixed_point sign_requirements + #! group_size = size sign_requirements + # (go_on, sign_requirements) = iFoldSt next_prop_classification 0 group_size (False, sign_requirements) + | go_on + = determine_fixed_point sign_requirements + = sign_requirements + + next_prop_classification type_index (changed, prop_requirements) + # ({pr_classification,pr_type_applications}, prop_requirements) = prop_requirements![type_index] + (new_pr_classification, prop_requirements) = foldSt examine_type_application pr_type_applications (pr_classification, prop_requirements) + | pr_classification == new_pr_classification + = (changed, prop_requirements) + = (True, { prop_requirements & [type_index].pr_classification = new_pr_classification }) + + examine_type_application {rta_index, rta_classification = arg_classes} (cumm_class, prop_requirements) + # (pr_classification, prop_requirements) = prop_requirements![rta_index].pr_classification + cumm_class = determine_cummulative_prop pr_classification arg_classes 0 cumm_class + = (cumm_class, prop_requirements) + where + determine_cummulative_prop prop_class [arg_class : arg_classes] type_index cumm_class + | IsPropagating prop_class type_index + = determine_cummulative_prop prop_class arg_classes (inc type_index) (arg_class bitor cumm_class) + = determine_cummulative_prop prop_class arg_classes (inc type_index) cumm_class + determine_cummulative_prop prop_class [] type_index cumm_class + = cumm_class + + bind_type_vars_to_props [] group_vars kinds props_of_group_vars (rev_hio_props, type_var_heap) + = (rev_hio_props, type_var_heap) + bind_type_vars_to_props [{atv_variable={tv_info_ptr}}: tvs] [gv : gvs] [tk : tks] props_of_group_vars (rev_hio_props, type_var_heap) + # prop = retrieve_prop gv props_of_group_vars + (var_info, type_var_heap) = readPtr tv_info_ptr type_var_heap + | IsArrowKind tk + = bind_type_vars_to_props tvs gvs tks props_of_group_vars ([prop:rev_hio_props], type_var_heap <:= (tv_info_ptr, TVI_PropClass gv prop var_info)) + = bind_type_vars_to_props tvs gvs tks props_of_group_vars (rev_hio_props, type_var_heap <:= (tv_info_ptr, TVI_PropClass gv prop var_info)) + where + retrieve_prop this_gv [(gv,prop) : signs ] + | this_gv == gv + = prop + = retrieve_prop this_gv signs restore_binds_of_type_var {atv_variable={tv_info_ptr}} type_var_heap # (TVI_PropClass _ _ old_info, type_var_heap) = readPtr tv_info_ptr type_var_heap = type_var_heap <:= (tv_info_ptr, old_info) -newPropClassOfTypeDefGroup :: !Int !Int ![Global Int] ![PropClassification] !Int !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos - -> *(!PropClassification, !*TypeVarHeap, !*TypeDefInfos) -newPropClassOfTypeDefGroup type_index module_index group hio_props group_nr ci type_var_heap td_infos - # (cumm_prop_env, type_var_heap, td_infos) = collect_prop_class_of_type_defs group group_nr ci NoPropClass type_var_heap td_infos - (prop_class, td_infos) = update_prop_class_of_group type_index module_index group cumm_prop_env hio_props ci td_infos -// ---> ("newPropClassOfTypeDefGroup", (type_index, module_index), cumm_prop_env) - = (prop_class, type_var_heap, td_infos) -where - update_prop_class_of_group my_index module_index [] cumm_prop_env hio_props ci td_infos - = (NoPropClass, td_infos) - update_prop_class_of_group my_index module_index [{glob_module,glob_object} : group] cumm_prop_env hio_props ci td_infos - # (tdi=:{tdi_group_vars,tdi_classification},td_infos) = td_infos![glob_module].[glob_object] - prop_class = determine_prop_class tdi_group_vars cumm_prop_env NoPropClass 0 - tdi_classification = addPropClassification hio_props prop_class tdi_classification - td_infos = { td_infos & [glob_module].[glob_object] = { tdi & tdi_classification = tdi_classification }} - (my_prop_class, td_infos) = update_prop_class_of_group my_index module_index group cumm_prop_env hio_props ci td_infos - | glob_module == module_index && my_index == glob_object -// ---> ("update_prop_class_of_group", (my_index, module_index), (glob_object, glob_module), prop_class) - = (prop_class, td_infos) - = (my_prop_class, td_infos) - - determine_prop_class [gv : gvs] cumm_prop_env prop_class var_index - | IsPropagating cumm_prop_env gv - = determine_prop_class gvs cumm_prop_env (prop_class bitor (IndexToPropClass var_index)) (inc var_index) - = determine_prop_class gvs cumm_prop_env prop_class (inc var_index) - determine_prop_class [] cumm_prop_env prop_class var_index - = prop_class - - collect_prop_class_of_type_defs [] group_nr ci cumm_prop_env type_var_heap td_infos - = (cumm_prop_env, type_var_heap, td_infos) - collect_prop_class_of_type_defs [{glob_module,glob_object} : group] group_nr ci cumm_prop_env type_var_heap td_infos - # {td_rhs} = ci.[glob_module].com_type_defs.[glob_object] - # (cumm_prop_env, type_var_heap, td_infos) = prop_class_of_type_def glob_module td_rhs group_nr ci cumm_prop_env type_var_heap td_infos - = collect_prop_class_of_type_defs group group_nr ci cumm_prop_env type_var_heap td_infos - - prop_class_of_type_def :: !Int !TypeRhs !Int !{#CommonDefs} !PropClassification !*TypeVarHeap *TypeDefInfos - -> (!PropClassification, !*TypeVarHeap, !*TypeDefInfos) - prop_class_of_type_def module_index (AlgType conses) group_nr ci cumm_prop_env type_var_heap td_infos - = prop_class_of_type_conses module_index conses group_nr ci cumm_prop_env type_var_heap td_infos - prop_class_of_type_def module_index (SynType {at_type}) group_nr ci cumm_prop_env type_var_heap td_infos - # (prop_class, _, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos - = (cumm_prop_env bitor prop_class, type_var_heap, td_infos) - prop_class_of_type_def module_index (RecordType {rt_constructor}) group_nr ci cumm_prop_env type_var_heap td_infos - = prop_class_of_type_conses module_index [rt_constructor] group_nr ci cumm_prop_env type_var_heap td_infos - prop_class_of_type_def module_index (AbstractType _) _ _ _ type_var_heap td_infos - = (PropClass, type_var_heap, td_infos) - - prop_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_prop_class type_var_heap td_infos + + prop_class_of_type_def :: !Int !TypeRhs !Int !{#CommonDefs} !*PropClassState -> (!PropClassification,!*PropClassState) + prop_class_of_type_def module_index (AlgType conses) group_nr ci pcs + = prop_class_of_type_conses module_index conses group_nr ci NoPropClass pcs + prop_class_of_type_def _ (SynType {at_type}) group_nr ci pcs + # (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_def _ (AbstractType properties) _ _ pcs + = (PropClass, pcs) + + prop_class_of_type_conses module_index [{ds_index}:conses] group_nr ci cumm_prop_class pcs #! cons_def = ci.[module_index].com_cons_defs.[ds_index] - # (cumm_prop_class, type_var_heap, td_infos) = prop_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_prop_class type_var_heap td_infos - = prop_class_of_type_conses module_index conses group_nr ci cumm_prop_class type_var_heap td_infos - prop_class_of_type_conses module_index [] _ _ cumm_prop_class type_var_heap td_infos - = (cumm_prop_class, type_var_heap, td_infos) + # (cumm_prop_class, pcs) = prop_class_of_type_of_list cons_def.cons_type.st_args group_nr ci cumm_prop_class pcs + = prop_class_of_type_conses module_index conses group_nr ci cumm_prop_class pcs + prop_class_of_type_conses module_index [] _ _ cumm_prop_class pcs + = (cumm_prop_class, pcs) - prop_class_of_type_of_list [{at_type} : types] group_nr ci cumm_prop_class type_var_heap td_infos - # (prop_class, _, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos - = prop_class_of_type_of_list types group_nr ci (cumm_prop_class bitor prop_class) type_var_heap td_infos - prop_class_of_type_of_list [] _ _ cumm_prop_class type_var_heap td_infos - = (cumm_prop_class, type_var_heap, td_infos) + 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 + # (prop_class, _, pcs) = propClassOfType at_type group_nr ci pcs + = prop_class_of_type_of_list types group_nr ci (cumm_prop_class bitor prop_class) pcs IndexToPropClass index :== 1 << index IsPropagating prop_class_of_type type_index :== prop_class_of_type == (prop_class_of_type bitor IndexToPropClass type_index) AdjustPropClass prop_class arity :== prop_class >> arity - -propClassOfTypeVariable :: !TypeVar !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos - -> *(!PropClassification,!PropClassification, !*TypeVarHeap, !*TypeDefInfos) -propClassOfTypeVariable {tv_info_ptr} ci type_var_heap td_infos - #! var_info = sreadPtr tv_info_ptr type_var_heap +propClassOfTypeVariable :: !TypeVar !{#CommonDefs} !*PropClassState -> (!PropClassification, !PropClassification, !*PropClassState) +propClassOfTypeVariable {tv_info_ptr} ci pcs=:{pcs_type_var_heap} + # (var_info, pcs_type_var_heap) = readPtr tv_info_ptr pcs_type_var_heap + pcs = { pcs & pcs_type_var_heap = pcs_type_var_heap } = case var_info of TVI_PropClass group_var_index var_class _ - -> (IndexToPropClass group_var_index, var_class, type_var_heap, td_infos) + -> (IndexToPropClass group_var_index, var_class, pcs) _ - -> (NoPropClass, PropClass, type_var_heap, td_infos) + -> (NoPropClass, PropClass, pcs) -propClassOfType :: !Type !Int !{#CommonDefs} !*TypeVarHeap !*TypeDefInfos -> *(!PropClassification,!PropClassification, !*TypeVarHeap, !*TypeDefInfos) -propClassOfType (TV tv) _ ci type_var_heap td_infos - = propClassOfTypeVariable tv ci type_var_heap td_infos +propClassOfType :: !Type !Int !{#CommonDefs} !*PropClassState -> (!PropClassification, !PropClassification, !*PropClassState) +propClassOfType (TV tv) _ ci pcs + = propClassOfTypeVariable tv ci pcs -propClassOfType (TA {type_name,type_index = {glob_module, glob_object}} types) group_nr ci type_var_heap td_infos - # ({tdi_group_nr,tdi_kinds}, td_infos) = td_infos![glob_module].[glob_object] +propClassOfType (TA {type_name,type_index = {glob_module, glob_object}} types) group_nr ci pcs + # (td_info=:{tdi_group_nr,tdi_tmp_index,tdi_kinds}, pcs) = pcs!pcs_type_def_infos.[glob_module].[glob_object] | tdi_group_nr == group_nr - = (NoPropClass, PropClass, type_var_heap, td_infos ) + = prop_class_of_type_list_of_rec_type types tdi_tmp_index ci [] pcs # {td_args,td_arity} = ci.[glob_module].com_type_defs.[glob_object] - (td_info, td_infos) = td_infos![glob_module].[glob_object] - (prop_classes, hio_signs, type_var_heap, td_infos) = collect_prop_classes_of_hio_types types tdi_kinds group_nr ci type_var_heap td_infos - (type_class, type_var_heap, td_infos) = determinePropClassOfTypeDef glob_object glob_module td_args td_info hio_signs ci type_var_heap td_infos - (prop_class, type_var_heap, td_infos) = prop_classes_of_type_list types tdi_kinds prop_classes type_class 0 group_nr ci NoPropClass type_var_heap td_infos - = (prop_class, AdjustPropClass type_class td_arity, type_var_heap, td_infos) -// ---> ("propClassOfType (TA ...)", type_name, prop_class) - + (prop_classes, hio_props, pcs) = collect_prop_classes_of_type_list types tdi_kinds group_nr ci pcs + (type_class, pcs_type_var_heap, pcs_type_def_infos) + = determinePropClassOfTypeDef glob_object glob_module td_args td_info hio_props ci pcs.pcs_type_var_heap pcs.pcs_type_def_infos + (prop_class, pcs) = determine_cummulative_prop types tdi_kinds type_class prop_classes 0 group_nr ci NoPropClass + { pcs & pcs_type_var_heap = pcs_type_var_heap, pcs_type_def_infos = pcs_type_def_infos } + = (prop_class, AdjustPropClass type_class td_arity, pcs) where - collect_prop_classes_of_hio_types [{at_type} : types] [ KindArrow _ : tks ] group_nr ci type_var_heap td_infos - # (prop_class, type_class, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos - (prop_classes, hio_signs, type_var_heap, td_infos) = collect_prop_classes_of_hio_types types tks group_nr ci type_var_heap td_infos - = ([prop_class : prop_classes], [type_class : hio_signs], type_var_heap, td_infos) - collect_prop_classes_of_hio_types [_ : types] [ _ : tks ] _ _ type_var_heap td_infos - = ([], [], type_var_heap, td_infos) - collect_prop_classes_of_hio_types [] _ _ _ type_var_heap td_infos - = ([], [], type_var_heap, td_infos) - - prop_classes_of_type_list [ _ : types ] [ KindArrow _ : tks] [pc : pcs] prop_class_of_type type_index group_nr ci cumm_class type_var_heap td_infos - | IsPropagating prop_class_of_type type_index - = prop_classes_of_type_list types tks pcs prop_class_of_type (inc type_index) group_nr ci (cumm_class bitor pc) type_var_heap td_infos - = prop_classes_of_type_list types tks pcs prop_class_of_type (inc type_index) group_nr ci cumm_class type_var_heap td_infos - prop_classes_of_type_list [ {at_type} : types] [ _ : tks] pcs prop_class_of_type type_index group_nr ci cumm_class type_var_heap td_infos - | IsPropagating prop_class_of_type type_index - # (pc, _, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos - = prop_classes_of_type_list types tks pcs prop_class_of_type (inc type_index) group_nr ci (cumm_class bitor pc) type_var_heap td_infos - = prop_classes_of_type_list types tks pcs prop_class_of_type (inc type_index) group_nr ci cumm_class type_var_heap td_infos - prop_classes_of_type_list [] _ _ _ _ _ _ cumm_class type_var_heap td_infos - = (cumm_class, type_var_heap, td_infos) - -propClassOfType (CV tv :@: types) group_nr ci type_var_heap td_infos - # (prop_class, type_class, type_var_heap, td_infos) = propClassOfTypeVariable tv ci type_var_heap td_infos - (prop_class, type_var_heap, td_infos) = prop_class_of_type_list types type_class 0 group_nr ci prop_class type_var_heap td_infos - = (prop_class, NoPropClass, type_var_heap, td_infos) + + prop_class_of_type_list_of_rec_type [t : ts] tmp_type_index ci rev_prop_classes pcs + # (prop_class, type_class, pcs) = propClassOfType t.at_type group_nr ci pcs + = prop_class_of_type_list_of_rec_type ts tmp_type_index ci [ prop_class : rev_prop_classes ] pcs + prop_class_of_type_list_of_rec_type [] tmp_type_index ci rev_prop_classes pcs=:{pcs_rec_appls} + # rta = { rta_index = tmp_type_index, rta_classification = reverse rev_prop_classes } + = (NoPropClass, PropClass, { pcs & pcs_rec_appls = [ rta : pcs_rec_appls ] }) + + collect_prop_classes_of_type_list [t : ts] [tk : tks] group_nr ci pcs + | IsArrowKind tk + # (prop_class, type_class, pcs) = propClassOfType t.at_type group_nr ci pcs + (prop_classes, hio_props, pcs) = collect_prop_classes_of_type_list ts tks group_nr ci pcs + = ([prop_class : prop_classes], [type_class : hio_props], pcs) + = collect_prop_classes_of_type_list ts tks group_nr ci pcs + collect_prop_classes_of_type_list [] _ _ ci pcs + = ([], [], pcs) + + determine_cummulative_prop [t : ts] [tk : tks] prop_class hio_prop_classes type_index group_nr ci cumm_class pcs + | IsArrowKind tk + # [pc : hio_prop_classes] = hio_prop_classes + = determine_cummulative_prop ts tks prop_class hio_prop_classes (inc type_index) group_nr ci (pc bitor cumm_class) pcs + | IsPropagating prop_class type_index + # (pc, _, pcs) = propClassOfType t.at_type group_nr ci pcs + = determine_cummulative_prop ts tks prop_class hio_prop_classes (inc type_index) group_nr ci (pc bitor cumm_class) pcs + = determine_cummulative_prop ts tks prop_class hio_prop_classes (inc type_index) group_nr ci cumm_class pcs + determine_cummulative_prop [] _ prop_class hio_prop_classes type_index group_nr ci cumm_class pcs + = (cumm_class, pcs) + +propClassOfType (CV tv :@: types) group_nr ci pcs + # (prop_class, type_class, pcs) = propClassOfTypeVariable tv ci pcs + (prop_class, pcs) = prop_class_of_type_list types type_class 0 group_nr ci prop_class pcs + = (prop_class, NoPropClass, pcs) where - prop_class_of_type_list [{at_type} : types] cv_prop_class type_index group_nr ci cumm_class type_var_heap td_infos + prop_class_of_type_list [{at_type} : types] cv_prop_class type_index group_nr ci cumm_class pcs | IsPropagating cv_prop_class type_index - # (pc, _, type_var_heap, td_infos) = propClassOfType at_type group_nr ci type_var_heap td_infos - = prop_class_of_type_list types cv_prop_class (inc type_index) group_nr ci (cumm_class bitor pc) type_var_heap td_infos - = prop_class_of_type_list types cv_prop_class (inc type_index) group_nr ci cumm_class type_var_heap td_infos - prop_class_of_type_list [] _ _ _ _ cumm_class type_var_heap td_infos - = (cumm_class, type_var_heap, td_infos) + # (pc, _, pcs) = propClassOfType at_type group_nr ci pcs + = prop_class_of_type_list types cv_prop_class (inc type_index) group_nr ci (cumm_class bitor pc) pcs + = prop_class_of_type_list types cv_prop_class (inc type_index) group_nr ci cumm_class pcs + prop_class_of_type_list [] _ _ _ _ cumm_class pcs + = (cumm_class, pcs) -propClassOfType _ _ _ type_var_heap td_infos - = (NoPropClass, NoPropClass, type_var_heap, td_infos) +propClassOfType _ _ _ pcs + = (NoPropClass, NoPropClass, pcs) +instance == SignClassification +where + == sc1 sc2 = sc1.sc_pos_vect == sc2.sc_pos_vect && sc1.sc_neg_vect == sc2.sc_neg_vect diff --git a/frontend/check.icl b/frontend/check.icl index 480b3f0..cf25ab2 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -2,7 +2,7 @@ implementation module check import StdEnv -import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug +import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef//, RWSDebug import explicitimports, comparedefimp cPredefinedModuleIndex :== 1 @@ -13,20 +13,24 @@ convertIndex index table_index (Yes tables) convertIndex index table_index No = index +getPredefinedGlobalSymbol :: !Index !Index !STE_Kind !Int !*CheckState -> (!Global DefinedSymbol, !*CheckState) getPredefinedGlobalSymbol symb_index module_index req_ste_kind arity cs=:{cs_predef_symbols,cs_symbol_table} - #! pre_def_mod = cs_predef_symbols.[module_index] - # mod_id = pre_def_mod.pds_ident - #! mod_entry = sreadPtr mod_id.id_info cs_symbol_table + # (pre_def_mod, cs_predef_symbols) = cs_predef_symbols![module_index] + # mod_id = pre_def_mod.pds_ident + # (mod_entry, cs_symbol_table) = readPtr mod_id.id_info cs_symbol_table | mod_entry.ste_kind == STE_ClosedModule - # (glob_object, cs) = get_predefined_symbol symb_index req_ste_kind arity mod_entry.ste_index cs + # (glob_object, cs) = get_predefined_symbol symb_index req_ste_kind arity mod_entry.ste_index + { cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table} = ({ glob_object = glob_object, glob_module = mod_entry.ste_index }, cs) = ({ glob_object = { ds_ident = { id_name = "** ERRONEOUS **", id_info = nilPtr }, ds_index = NoIndex, ds_arity = arity }, glob_module = NoIndex}, - { cs & cs_error = checkError mod_id "not imported" cs.cs_error}) + { cs & cs_error = checkError mod_id "not imported" cs.cs_error, cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table }) where + get_predefined_symbol :: !Index !STE_Kind !Int !Index !*CheckState -> (!DefinedSymbol,!*CheckState) get_predefined_symbol symb_index req_ste_kind arity mod_index cs=:{cs_predef_symbols,cs_symbol_table,cs_error} - #! pre_def_symb = cs_predef_symbols.[symb_index] - # symb_id = pre_def_symb.pds_ident - #! symb_entry = sreadPtr symb_id.id_info cs_symbol_table + # (pre_def_symb, cs_predef_symbols) = cs_predef_symbols![symb_index] + symb_id = pre_def_symb.pds_ident + (symb_entry, cs_symbol_table) = readPtr symb_id.id_info cs_symbol_table + cs = { cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table } | symb_entry.ste_kind == req_ste_kind = ({ ds_ident = symb_id, ds_index = symb_entry.ste_index, ds_arity = arity }, cs) = case symb_entry.ste_kind of @@ -41,8 +45,7 @@ checkTypeClasses :: !Index !Index !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDe checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps=:{th_vars} cs=:{cs_symbol_table,cs_error} | class_index == size class_defs = (class_defs, member_defs, type_defs, modules, type_heaps, cs) - #! class_def = class_defs.[class_index] - # {class_name,class_pos,class_args,class_context,class_members} = class_def + # (class_def=:{class_name,class_pos,class_args,class_context,class_members}, class_defs) = class_defs![class_index] position = newPosition class_name class_pos cs_error = setErrorAdmin position cs_error (rev_class_args, cs_symbol_table, th_vars, cs_error) @@ -60,15 +63,16 @@ where add_variables_to_symbol_table level [] rev_class_args symbol_table th_vars error = (rev_class_args, symbol_table, th_vars, error) add_variables_to_symbol_table level [var=:{tv_name={id_name,id_info}} : vars] rev_class_args symbol_table th_vars error - #! entry = sreadPtr id_info symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table | entry.ste_kind == STE_Empty || entry.ste_def_level < level # (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars # symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex level entry = add_variables_to_symbol_table level vars [{ var & tv_info_ptr = new_var_ptr} : rev_class_args] symbol_table th_vars error = add_variables_to_symbol_table level vars rev_class_args symbol_table th_vars (checkError id_name "(variable) already defined" error) + retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable) retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table - #! entry = sreadPtr id_info symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table = retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous)) retrieve_variables_from_symbol_table [] class_args symbol_table = (class_args, symbol_table) @@ -77,7 +81,7 @@ where | mem_offset == size class_members = member_defs # {ds_index} = class_members.[mem_offset] - #! member_def = member_defs.[ds_index] + # (member_def, member_defs) = member_defs![ds_index] = set_classes_in_member_defs (inc mem_offset) class_members glob_class_index { member_defs & [ds_index] = { member_def & me_class = glob_class_index }} @@ -98,11 +102,13 @@ where = ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars, st_context = st_context, st_attr_env = st_attr_env }, type_heaps) -checkDclFunctions :: !Index !Index ![FunType] !v:{#CheckedTypeDef} !x:{#ClassDef} !u:{#.DclModule} !*Heaps !*CheckState - -> (!Index, ![FunType], ![FunType], !z:{#CheckedTypeDef}, !y:{#ClassDef}, !w:{#DclModule}, !.Heaps, !.CheckState), [u v <= w, x <= y, u v <= z] +checkDclFunctions :: !Index !Index ![FunType] !v:{#CheckedTypeDef} !x:{#ClassDef} !v:{#.DclModule} !*Heaps !*CheckState + -> (!Index, ![FunType], ![FunType], !v:{#CheckedTypeDef}, !x:{#ClassDef}, !v:{#DclModule}, !*Heaps, !*CheckState) checkDclFunctions module_index first_inst_index fun_types type_defs class_defs modules heaps cs = check_dcl_functions module_index fun_types 0 first_inst_index [] [] type_defs class_defs modules heaps cs where + check_dcl_functions :: !Index ![FunType] !Index !Index ![FunType] ![FunType] !v:{#CheckedTypeDef} !x:{#ClassDef} !v:{#DclModule} !*Heaps !*CheckState + -> (!Index, ![FunType], ![FunType],!v:{#CheckedTypeDef}, !x:{#ClassDef}, !v:{#DclModule}, !*Heaps, !*CheckState) check_dcl_functions module_index [] fun_index next_inst_index collected_funtypes collected_instances type_defs class_defs modules heaps cs = (next_inst_index, collected_funtypes, collected_instances, type_defs, class_defs, modules, heaps, cs) check_dcl_functions module_index [fun_type=:{ft_symb,ft_type,ft_pos,ft_specials} : fun_types] fun_index @@ -144,13 +150,15 @@ checkSpecialsOfInstances mod_index first_mem_index [class_inst=:{ins_members,ins -> checkSpecialsOfInstances mod_index first_mem_index class_insts next_inst_index [class_inst : all_class_instances] all_specials new_inst_defs all_spec_types heaps error where + check_and_build_members :: !Index !Index !Int {# DefinedSymbol} !Int !Index ![DefinedSymbol] ![FunType] !{#FunType} !*{! [Special]} !*Heaps !*ErrorAdmin + -> (!Index, ![DefinedSymbol], ![FunType], !*{! [Special]}, !*Heaps, !*ErrorAdmin) check_and_build_members mod_index first_mem_index member_offset ins_members type_offset next_inst_index rev_mem_specials all_specials inst_spec_defs all_spec_types heaps error | member_offset < size ins_members # member = ins_members.[member_offset] member_index = member.ds_index spec_member_index = member_index - first_mem_index - #! spec_types = all_spec_types.[spec_member_index] + # (spec_types, all_spec_types) = all_spec_types![spec_member_index] # mem_inst = inst_spec_defs.[spec_member_index] (SP_Substitutions specials) = mem_inst.ft_specials env = specials !! type_offset @@ -200,8 +208,8 @@ where -> (!*{# ClassInstance},!u:InstanceSymbols,!*TypeHeaps,!*CheckState) check_instance_defs inst_index mod_index instance_defs is type_heaps cs | inst_index < size instance_defs - #! instance_def = instance_defs.[inst_index] - # (instance_def, is, type_heaps, cs) = check_instance mod_index instance_def is type_heaps cs + # (instance_def, instance_defs) = instance_defs![inst_index] + (instance_def, is, type_heaps, cs) = check_instance mod_index instance_def is type_heaps cs = check_instance_defs (inc inst_index) mod_index { instance_defs & [inst_index] = instance_def } is type_heaps cs = (instance_defs, is, type_heaps, cs) @@ -209,10 +217,10 @@ where check_instance module_index ins=:{ins_members,ins_class={glob_object = class_name =: {ds_ident = {id_name,id_info},ds_arity}},ins_type,ins_specials,ins_pos,ins_ident} is=:{is_class_defs,is_modules} type_heaps cs=:{cs_symbol_table} - #! entry = sreadPtr id_info cs_symbol_table + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table # (class_index, class_mod_index, class_def, is_class_defs, is_modules) = get_class_def entry module_index is_class_defs is_modules is = { is & is_class_defs = is_class_defs, is_modules = is_modules } - cs = pushErrorAdmin (newPosition ins_ident ins_pos) cs + cs = pushErrorAdmin (newPosition ins_ident ins_pos) { cs & cs_symbol_table = cs_symbol_table } | class_index <> NotFound | class_def.class_arity == ds_arity # (ins_type, ins_specials, is_type_defs, is_class_defs, is_modules, type_heaps, cs) = checkInstanceType module_index ins_type ins_specials @@ -229,11 +237,11 @@ where get_class_def :: !SymbolTableEntry !Index v:{# ClassDef} u:{# DclModule} -> (!Index,!Index,ClassDef,!v:{# ClassDef},!u:{# DclModule}) get_class_def {ste_kind = STE_Class, ste_index} mod_index class_defs modules - #! class_def = class_defs.[ste_index] + # (class_def, class_defs) = class_defs![ste_index] = (ste_index, mod_index, class_def, class_defs, modules) get_class_def {ste_kind = STE_Imported STE_Class dcl_index, ste_index, ste_def_level} mod_index class_defs modules - #! dcl_mod = modules.[dcl_index] - # class_def = dcl_mod.dcl_common.com_class_defs.[ste_index] + # (dcl_mod, modules) = modules![dcl_index] + # class_def = dcl_mod.dcl_common.com_class_defs.[ste_index] = (ste_index, dcl_index, class_def, class_defs, modules) get_class_def _ mod_index class_defs modules = (NotFound, cIclModIndex, abort "no class definition", class_defs, modules) @@ -253,7 +261,7 @@ where -> (![(Index,SymbolType)], !x:{# ClassInstance}, !w:{# ClassDef}, !v:{# MemberDef}, !u:{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState) check_instances inst_index mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps cs | inst_index < size instance_defs - #! {ins_class,ins_members,ins_type} = instance_defs.[inst_index] + # ({ins_class,ins_members,ins_type}, instance_defs) = instance_defs![inst_index] # ({class_members,class_name}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules class_size = size class_members | class_size == size ins_members @@ -263,12 +271,10 @@ where = check_instances (inc inst_index) mod_index instance_types instance_defs class_defs member_defs modules var_heap type_heaps { cs & cs_error = checkError class_name "different number of members specified" cs.cs_error } = (instance_types, instance_defs, class_defs, member_defs, modules, var_heap, type_heaps, cs) -/* - check_member_instances :: !Index !Index ![DefinedSymbol] ![DefinedSymbol] !InstanceType ![TypeVar] ![(Index,SymbolType)] !v:{# MemberDef} !u:{# DclModule} !*TypeHeaps !*CheckState - -> (![(Index,SymbolType)], !v:{# MemberDef},!u:{# DclModule},!*TypeHeaps,!*CheckState) - -*/ + check_member_instances :: !Index !Index !Int !Int !{#DefinedSymbol} !{#DefinedSymbol} !InstanceType ![(Index,SymbolType)] + !v:{# MemberDef} !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState + -> (![(Index,SymbolType)], !v:{# MemberDef}, !u:{# DclModule},!*VarHeap, !*TypeHeaps, !*CheckState) check_member_instances module_index member_mod_index mem_offset class_size ins_members class_members ins_type instance_types member_defs modules var_heap type_heaps cs | mem_offset == class_size @@ -292,17 +298,17 @@ where getClassDef :: !(Global DefinedSymbol) !Int !u:{#ClassDef} !v:{#DclModule} -> (!ClassDef,!u:{#ClassDef},!v:{#DclModule}) getClassDef {glob_module, glob_object={ds_ident, ds_index}} mod_index class_defs modules | glob_module == mod_index - #! class_def = class_defs.[ds_index] + # (class_def, class_defs) = class_defs![ds_index] = (class_def, class_defs, modules) - #! dcl_mod = modules.[glob_module] + # (dcl_mod, modules) = modules![glob_module] = (dcl_mod.dcl_common.com_class_defs.[ds_index], class_defs, modules) getMemberDef :: !Int Int !Int !u:{#MemberDef} !v:{#DclModule} -> (!MemberDef,!u:{#MemberDef},!v:{#DclModule}) getMemberDef mem_mod mem_index mod_index member_defs modules | mem_mod == mod_index - #! member_def = member_defs.[mem_index] + # (member_def,member_defs) = member_defs![mem_index] = (member_def, member_defs, modules) - #! dcl_mod = modules.[mem_mod] + # (dcl_mod,modules) = modules![mem_mod] = (dcl_mod.dcl_common.com_member_defs.[mem_index], member_defs, modules) instantiateTypes :: ![TypeVar] ![AttributeVar] !types ![TypeContext] ![AttrInequality] !SpecialSubstitution ![SpecialSubstitution] !*TypeHeaps @@ -412,7 +418,7 @@ where determine_types_of_instances inst_index next_class_inst_index next_mem_inst_index mod_index all_class_specials class_defs member_defs modules instance_defs type_heaps var_heap error | inst_index < size instance_defs - #! instance_def = instance_defs.[inst_index] + # (instance_def, instance_defs) = instance_defs![inst_index] # {ins_class,ins_pos,ins_type,ins_specials} = instance_def ({class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules class_size = size class_members @@ -512,11 +518,11 @@ checkFields mod_index field_ass opt_type e_info=:{ef_selector_defs,ef_type_defs, where check_fields [ bind=:{bind_dst} : field_ass ] cs=:{cs_symbol_table,cs_error} - #! entry = sreadPtr bind_dst.id_info cs_symbol_table + # (entry, cs_symbol_table) = readPtr bind_dst.id_info cs_symbol_table # fields = retrieveSelectorIndexes mod_index entry | isEmpty fields - = (False, [], { cs & cs_error = checkError bind_dst "not defined as a record field" cs_error }) - # (ok, field_ass, cs) = check_fields field_ass cs + = (False, [], { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError bind_dst "not defined as a record field" cs_error }) + # (ok, field_ass, cs) = check_fields field_ass { cs & cs_symbol_table = cs_symbol_table } = (ok, [{bind & bind_dst = (bind_dst, fields)} : field_ass], cs) check_fields [] cs = (True, [], cs) @@ -529,26 +535,26 @@ where = try_to_get_unique_field fields determine_record_type mod_index (Yes type_id=:{id_info}) _ selector_defs type_defs modules cs=:{cs_symbol_table, cs_error} - #! entry = sreadPtr id_info cs_symbol_table - # (type_index, type_mod_index) = retrieveGlobalDefinition entry STE_Type mod_index + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + # (type_index, type_mod_index) = retrieveGlobalDefinition entry STE_Type mod_index | type_index <> NotFound | mod_index == type_mod_index - #! type_def = type_defs.[type_index] - = (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, cs) + # (type_def, type_defs) = type_defs![type_index] + = (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, { cs & cs_symbol_table = cs_symbol_table }) # (type_def, modules) = modules![type_mod_index].dcl_common.com_type_defs.[type_index] - = (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, cs) - = (No, selector_defs, type_defs, modules, { cs & cs_error = checkError type_id " not defined" cs_error}) + = (Yes (type_def, type_mod_index), selector_defs, type_defs, modules, { cs & cs_symbol_table = cs_symbol_table }) + = (No, selector_defs, type_defs, modules, { cs & cs_error = checkError type_id " not defined" cs_error, cs_symbol_table = cs_symbol_table}) determine_record_type mod_index No fields selector_defs type_defs modules cs=:{cs_error} # succ = try_to_get_unique_field fields = case succ of Yes {glob_module, glob_object} | glob_module == mod_index - #! selector_def = selector_defs.[glob_object] - type_def = type_defs.[selector_def.sd_type_index] + # (selector_def, selector_defs) = selector_defs![glob_object] + (type_def, type_defs) = type_defs![selector_def.sd_type_index] -> (Yes (type_def, glob_module), selector_defs, type_defs, modules, cs) - #! {dcl_common={com_selector_defs,com_type_defs}} = modules.[glob_module] - #! selector_def = com_selector_defs.[glob_object] - type_def = com_type_defs.[selector_def.sd_type_index] + # ({dcl_common={com_selector_defs,com_type_defs}}, modules) = modules![glob_module] + # selector_def = com_selector_defs.[glob_object] + type_def = com_type_defs.[selector_def.sd_type_index] -> (Yes (type_def,glob_module), selector_defs, type_defs, modules, cs) No -> (No, selector_defs, type_defs, modules, { cs & cs_error = checkError "" " could not determine the type of this record" cs.cs_error }) @@ -657,19 +663,17 @@ where = (AP_Algebraic cons_symbol cons_def.cons_type_index patterns opt_var, ums) = (AP_Empty cons_def.cons_symb, { ums & ums_cons_defs = ums_cons_defs, ums_modules = ums_modules, ums_error = checkError cons_def.cons_symb " missing argument(s)" ums_error }) -/* SSS .... */ get_cons_def mod_index cons_mod cons_index cons_defs modules | mod_index == cons_mod # (cons_def, cons_defs) = cons_defs![cons_index] = (cons_def, cons_index, cons_defs, modules) - #! {dcl_common,dcl_conversions} = modules.[cons_mod] - #! cons_def = dcl_common.com_cons_defs.[cons_index] + # ({dcl_common,dcl_conversions}, modules) = modules![cons_mod] + cons_def = dcl_common.com_cons_defs.[cons_index] = (cons_def, convertIndex cons_index (toInt STE_Constructor) dcl_conversions, cons_defs, modules) -/* .... SSS */ get_cons_def mod_index cons_mod cons_index cons_defs modules - #! {dcl_common,dcl_conversions} = modules.[cons_mod] - #! cons_def = dcl_common.com_cons_defs.[cons_index] + # ({dcl_common,dcl_conversions}, modules) = modules![cons_mod] + cons_def = dcl_common.com_cons_defs.[cons_index] = (cons_def, convertIndex cons_index (toInt STE_Constructor) dcl_conversions, cons_defs, modules) unfold_pattern_macro mod_index macro_ident opt_var (BasicExpr bv bt) ums @@ -716,13 +720,11 @@ checkPatternConstructor mod_index is_expr_list {ste_index, ste_kind} cons_symb o = (AP_Algebraic cons_symbol cons_type_index [] opt_var, ps, e_info, { cs & cs_error = checkError cons_symb " constructor arguments are missing" cs_error }) where determine_pattern_symbol mod_index id_index STE_Constructor id_name cons_defs modules error - #! cons_def = cons_defs.[id_index] - # {cons_type={st_arity},cons_priority, cons_type_index} = cons_def + # ({cons_type={st_arity},cons_priority, cons_type_index}, cons_defs) = cons_defs![id_index] = (id_index, mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) determine_pattern_symbol mod_index id_index (STE_Imported STE_Constructor import_mod_index) id_name cons_defs modules error - #! {dcl_common,dcl_conversions} = modules.[import_mod_index] - #! cons_def = dcl_common.com_cons_defs.[id_index] - # {cons_type={st_arity},cons_priority, cons_type_index} = cons_def + # ({dcl_common,dcl_conversions},modules) = modules![import_mod_index] + {cons_type={st_arity},cons_priority, cons_type_index} = dcl_common.com_cons_defs.[id_index] id_index = convertIndex id_index (toInt STE_Constructor) dcl_conversions = (id_index, import_mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error) determine_pattern_symbol mod_index id_index id_kind id_name cons_defs modules error @@ -733,12 +735,12 @@ checkIdentPattern :: !Bool !Ident !(Optional (Bind Ident VarInfoPtr)) !PatternIn -> (!AuxiliaryPattern, !(![Ident], ![ArrayPattern]), !*PatternState, !*ExpressionInfo, !*CheckState) checkIdentPattern is_expr_list id=:{id_name,id_info} opt_var {pi_def_level, pi_mod_index} accus=:(var_env, array_patterns) ps e_info cs=:{cs_symbol_table} - #! entry = sreadPtr id_info cs_symbol_table + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table | isLowerCaseName id_name # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap - cs = checkPatternVariable pi_def_level entry id new_info_ptr cs + cs = checkPatternVariable pi_def_level entry id new_info_ptr { cs & cs_symbol_table = cs_symbol_table } = (AP_Variable id new_info_ptr opt_var, ([ id : var_env ], array_patterns), { ps & ps_var_heap = ps_var_heap}, e_info, cs) - # (pattern, ps, e_info, cs) = checkPatternConstructor pi_mod_index is_expr_list entry id opt_var ps e_info cs + # (pattern, ps, e_info, cs) = checkPatternConstructor pi_mod_index is_expr_list entry id opt_var ps e_info { cs & cs_symbol_table = cs_symbol_table } = (pattern, accus, ps, e_info, cs) :: PatternState = @@ -898,7 +900,7 @@ checkPattern (PE_Basic basic_value) opt_var p_input accus ps e_info cs checkPattern (PE_Tuple tuple_args) opt_var p_input accus ps e_info cs # (patterns, arity, accus, ps, e_info, cs) = check_tuple_patterns tuple_args p_input accus ps e_info cs (tuple_symbol, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex arity) PD_PredefinedModule STE_Constructor arity cs - #! {cons_type_index} = e_info.ef_modules.[tuple_symbol.glob_module].dcl_common.com_cons_defs.[tuple_symbol.glob_object.ds_index] + # ({cons_type_index}, e_info) = e_info!ef_modules.[tuple_symbol.glob_module].dcl_common.com_cons_defs.[tuple_symbol.glob_object.ds_index] = (AP_Algebraic tuple_symbol cons_type_index patterns opt_var, accus, ps, e_info, cs) where check_tuple_patterns [] p_input accus ps e_info cs @@ -920,9 +922,9 @@ where check_field_pattern p_input=:{pi_def_level} {bind_src = PE_Empty, bind_dst = {glob_object={fs_var}}} (var_env, array_patterns, ps, e_info, cs) - #! entry = sreadPtr fs_var.id_info cs.cs_symbol_table + # (entry, cs_symbol_table) = readPtr fs_var.id_info cs.cs_symbol_table # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap - cs = checkPatternVariable pi_def_level entry fs_var new_info_ptr cs + cs = checkPatternVariable pi_def_level entry fs_var new_info_ptr { cs & cs_symbol_table = cs_symbol_table } = (AP_Variable fs_var new_info_ptr No, ([ fs_var : var_env ], array_patterns, { ps & ps_var_heap = ps_var_heap }, e_info, cs)) check_field_pattern p_input {bind_src = PE_WildCard, bind_dst={glob_object={fs_var}}} (var_env, array_patterns, ps, e_info, cs) # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap @@ -938,9 +940,9 @@ where add_bound_variable (AP_Basic bas_val No) {bind_dst = {glob_object={fs_var}}} ps_var_heap # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap = (AP_Basic bas_val (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap) - add_bound_variable (AP_Dynamic dynamic dynamic_type No) {bind_dst = {glob_object={fs_var}}} ps_var_heap + add_bound_variable (AP_Dynamic dynamic_pattern dynamic_type No) {bind_dst = {glob_object={fs_var}}} ps_var_heap # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps_var_heap - = (AP_Dynamic dynamic dynamic_type (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap) + = (AP_Dynamic dynamic_pattern dynamic_type (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), ps_var_heap) add_bound_variable pattern _ ps_var_heap = (pattern, ps_var_heap) @@ -960,7 +962,11 @@ where checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patterns) ps e_info cs # (var_env, ap_selections, ps_var_heap, cs) = foldSt (check_array_selection p_input.pi_def_level) selections (var_env, [], ps.ps_var_heap, cs) - array_var_ident = case opt_var of {Yes {bind_src} -> bind_src; _ -> { id_name = "_a", id_info = nilPtr }} + array_var_ident = case opt_var of + Yes {bind_src} + -> bind_src + No + -> { id_name = "_a", id_info = nilPtr } (array_var, ps_var_heap) = allocate_free_var array_var_ident ps_var_heap = (AP_Variable array_var_ident array_var.fv_info_ptr No, (var_env, [{ ap_opt_var = opt_var, ap_array_var = array_var, ap_selections = ap_selections } :array_patterns]), @@ -980,9 +986,9 @@ checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patter check_rhs def_level {bind_src=PE_Ident ident, bind_dst} (var_env, ap_selections, var_heap, cs) | isLowerCaseName ident.id_name - #! entry = sreadPtr ident.id_info cs.cs_symbol_table + # (entry,cs_symbol_table) = readPtr ident.id_info cs.cs_symbol_table # (rhs_var, var_heap) = allocate_free_var ident var_heap - cs = checkPatternVariable def_level entry ident rhs_var.fv_info_ptr cs + cs = checkPatternVariable def_level entry ident rhs_var.fv_info_ptr { cs & cs_symbol_table = cs_symbol_table } = ([ident : var_env], [ { bind_src = rhs_var, bind_dst = bind_dst } : ap_selections], var_heap, cs) // further with next alternative check_rhs _ _ (var_env, ap_selections, var_heap, cs) @@ -1001,9 +1007,9 @@ checkPattern expr opt_var p_input accus ps e_info cs checkBoundPattern {bind_src,bind_dst} opt_var p_input (var_env, array_patterns) ps e_info cs=:{cs_symbol_table} | isLowerCaseName bind_dst.id_name - #! entry = sreadPtr bind_dst.id_info cs_symbol_table + # (entry, cs_symbol_table) = readPtr bind_dst.id_info cs_symbol_table # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap - cs = checkPatternVariable p_input.pi_def_level entry bind_dst new_info_ptr cs + cs = checkPatternVariable p_input.pi_def_level entry bind_dst new_info_ptr { cs & cs_symbol_table = cs_symbol_table } ps = { ps & ps_var_heap = ps_var_heap } new_var_env = [ bind_dst : var_env ] = case opt_var of @@ -1056,8 +1062,8 @@ buildApplication symbol form_arity act_arity is_fun args e_state=:{es_expr_heap} checkIdentExpression :: !Bool ![FreeVar] !Ident !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState -> (!Expression, ![FreeVar], !*ExpressionState, !u:ExpressionInfo, !*CheckState) checkIdentExpression is_expr_list free_vars id=:{id_info} e_input e_state e_info cs=:{cs_symbol_table} - #! entry = sreadPtr id_info cs_symbol_table - = check_id_expression entry is_expr_list free_vars id e_input e_state e_info cs + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + = check_id_expression entry is_expr_list free_vars id e_input e_state e_info { cs & cs_symbol_table = cs_symbol_table } where check_id_expression :: !SymbolTableEntry !Bool ![FreeVar] !Ident !ExpressionInput !*ExpressionState !u:ExpressionInfo !*CheckState -> (!Expression, ![FreeVar], !*ExpressionState, !u:ExpressionInfo, !*CheckState) @@ -1083,17 +1089,15 @@ where -> (!SymbKind, !Int, !Priority, !Bool, !*ExpressionState, !u:ExpressionInfo,!*CheckState) determine_info_of_symbol entry=:{ste_kind=STE_FunctionOrMacro calls,ste_index,ste_def_level} symb_info e_input=:{ei_fun_index, ei_mod_index} e_state=:{es_fun_defs,es_calls} e_info cs=:{cs_symbol_table} - #! {fun_symb,fun_arity,fun_kind,fun_priority} = es_fun_defs.[ste_index] + # ({fun_symb,fun_arity,fun_kind,fun_priority}, es_fun_defs) = es_fun_defs![ste_index] # index = { glob_object = ste_index, glob_module = cIclModIndex } | is_called_before ei_fun_index calls | fun_kind == FK_Macro -// = (SK_Macro index, fun_arity, fun_priority, cIsNotAFunction, e_state, e_info, cs) - = (SK_Macro index, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) - = (SK_Function index, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) + = (SK_Macro index, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) + = (SK_Function index, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) # cs = { cs & cs_symbol_table = cs_symbol_table <:= (symb_info, { entry & ste_kind = STE_FunctionOrMacro [ ei_fun_index : calls ]})} - e_state = { e_state & es_calls = [{ fc_index = ste_index, fc_level = ste_def_level} : es_calls ]} + e_state = { e_state & es_fun_defs = es_fun_defs, es_calls = [{ fc_index = ste_index, fc_level = ste_def_level} : es_calls ]} = (if (fun_kind == FK_Macro) (SK_Macro index) (SK_Function index), fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) -// ---> ("determine_info_of_symbol", ei_fun_index, fun_symb, ptrToInt symb_info, ste_index) where is_called_before caller_index [] = False @@ -1101,35 +1105,38 @@ where = caller_index == called_index || is_called_before caller_index calls determine_info_of_symbol entry=:{ste_kind=STE_Imported kind mod_index,ste_index} symb_index e_input e_state e_info=:{ef_modules} cs - #! mod_def = ef_modules.[mod_index] + # (mod_def, ef_modules) = ef_modules![mod_index] # (kind, arity, priotity, is_fun) = ste_kind_to_symbol_kind kind ste_index mod_index mod_def - = (kind, arity, priotity, is_fun, e_state, e_info, cs) + = (kind, arity, priotity, is_fun, e_state, { e_info & ef_modules = ef_modules }, cs) where ste_kind_to_symbol_kind :: !STE_Kind !Index !Index !DclModule -> (!SymbKind, !Int, !Priority, !Bool); ste_kind_to_symbol_kind STE_DclFunction def_index mod_index {dcl_functions,dcl_conversions} - #! {ft_type={st_arity},ft_priority} = dcl_functions.[def_index] + # {ft_type={st_arity},ft_priority} = dcl_functions.[def_index] # def_index = convertIndex def_index (toInt STE_DclFunction) dcl_conversions = (SK_Function { glob_object = def_index, glob_module = mod_index }, st_arity, ft_priority, cIsAFunction) ste_kind_to_symbol_kind STE_Member def_index mod_index {dcl_common={com_member_defs},dcl_conversions} - #! {me_type={st_arity},me_priority} = com_member_defs.[def_index] + # {me_type={st_arity},me_priority} = com_member_defs.[def_index] # def_index = convertIndex def_index (toInt STE_Member) dcl_conversions = (SK_OverloadedFunction { glob_object = def_index, glob_module = mod_index }, st_arity, me_priority, cIsAFunction) ste_kind_to_symbol_kind STE_Constructor def_index mod_index {dcl_common={com_cons_defs},dcl_conversions} - #! {cons_type={st_arity},cons_priority} = com_cons_defs.[def_index] + # {cons_type={st_arity},cons_priority} = com_cons_defs.[def_index] # def_index = convertIndex def_index (toInt STE_Constructor) dcl_conversions = (SK_Constructor { glob_object = def_index, glob_module = mod_index }, st_arity, cons_priority, cIsNotAFunction) - + 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.[ste_index] - = (SK_OverloadedFunction { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, me_priority, cIsAFunction, e_state, e_info, 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, cIsAFunction, + 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=:{ef_cons_defs} cs - #! {cons_type={st_arity},cons_priority} = ef_cons_defs.[ste_index] - = (SK_Constructor { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, cIsNotAFunction, e_state, e_info, cs) + # ({cons_type={st_arity},cons_priority}, ef_cons_defs) = ef_cons_defs![ste_index] + = (SK_Constructor { glob_object = ste_index, glob_module = ei_mod_index}, st_arity, cons_priority, cIsNotAFunction, + e_state, { e_info & ef_cons_defs = ef_cons_defs }, cs) determine_info_of_symbol {ste_kind=STE_DclFunction, ste_index} _ e_input=:{ei_mod_index} e_state e_info=:{ef_modules} cs - #! mod_def = ef_modules.[ei_mod_index] + # (mod_def, ef_modules) = ef_modules![ei_mod_index] # {ft_type={st_arity},ft_priority} = mod_def.dcl_functions.[ste_index] def_index = convertIndex ste_index (toInt STE_DclFunction) mod_def.dcl_conversions - = (SK_Function { glob_object = def_index, glob_module = ei_mod_index}, st_arity, ft_priority, cIsAFunction, e_state, e_info, cs) + = (SK_Function { glob_object = def_index, glob_module = ei_mod_index}, st_arity, ft_priority, cIsAFunction, + e_state, { e_info & ef_modules = ef_modules }, cs) :: RecordKind = RK_Constructor | RK_Update | RK_UpdateToConstructor ![AuxiliaryPattern] @@ -1299,7 +1306,9 @@ where = case pattern_scheme of AlgebraicPatterns alg_type _ | type_symbol == alg_type - # alg_patterns = case patterns of {AlgebraicPatterns _ alg_patterns -> alg_patterns; NoPattern -> [] } + # alg_patterns = case patterns of + AlgebraicPatterns _ alg_patterns -> alg_patterns + NoPattern -> [] -> (AlgebraicPatterns type_symbol [pattern : alg_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError cons_symbol.glob_object.ds_ident "incompatible types of patterns" cs.cs_error }) @@ -1315,7 +1324,11 @@ where = case pattern_scheme of BasicPatterns basic_type _ | type_symbol == basic_type - # basic_patterns = case patterns of { BasicPatterns _ basic_patterns -> basic_patterns; NoPattern -> [] } + # basic_patterns = case patterns of + BasicPatterns _ basic_patterns + -> basic_patterns + NoPattern + -> [] -> (BasicPatterns basic_type [pattern : basic_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError basic_val "incompatible types of patterns" cs.cs_error }) @@ -1331,7 +1344,11 @@ where pattern_variables = cons_optional opt_var pattern_variables = case pattern_scheme of DynamicPatterns _ - # dyn_patterns = case patterns of { DynamicPatterns dyn_patterns -> dyn_patterns; NoPattern -> [] } + # dyn_patterns = case patterns of + DynamicPatterns dyn_patterns + -> dyn_patterns + NoPattern + -> [] -> (DynamicPatterns [pattern : dyn_patterns], pattern_scheme, pattern_variables, defaul, var_store, expr_heap, [dynamic_info_ptr], cs) NoPattern -> (DynamicPatterns [pattern], DynamicPatterns [], pattern_variables, defaul, var_store, expr_heap, [dynamic_info_ptr], cs) @@ -1517,9 +1534,10 @@ where = checkIdentExpression cIsNotInExpressionList free_vars fs_var e_input e_state e_info cs = ({ field & bind_src = expr }, free_vars, e_state, e_info, cs) check_field_expr free_vars field=:{bind_src = PE_WildCard, bind_dst={glob_object=fs_name}} field_nr RK_Constructor e_input e_state e_info cs - = ({ field & bind_src = EE }, free_vars, e_state, e_info, { cs & cs_error = checkError fs_name "field not specified" cs.cs_error }) - check_field_expr free_vars field=:{bind_src = PE_WildCard} field_nr RK_Update e_input e_state e_info cs - = ({ field & bind_src = EE }, free_vars, e_state, e_info, cs) + = ({ field & bind_src = NoBind nilPtr }, free_vars, e_state, e_info, { cs & cs_error = checkError fs_name "field not specified" cs.cs_error }) + check_field_expr free_vars field=:{bind_src = PE_WildCard} field_nr RK_Update e_input e_state=:{es_expr_heap} e_info cs + # (bind_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap + = ({ field & bind_src = NoBind bind_expr_ptr }, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs) check_field_expr free_vars field=:{bind_src = PE_WildCard} field_nr (RK_UpdateToConstructor fields) e_input e_state=:{es_expr_heap} e_info cs # (var_name, var_info_ptr) = get_field_var (fields !! field_nr) (var_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap @@ -1579,10 +1597,9 @@ where check_out_parameter expr_level bind=:{ bind_src, bind_dst } (e_state, cs) | isLowerCaseName bind_dst.id_name - #! entry = sreadPtr bind_dst.id_info cs.cs_symbol_table + # (entry, cs_symbol_table) = readPtr bind_dst.id_info cs.cs_symbol_table # (new_info_ptr, es_var_heap) = newPtr VI_Empty e_state.es_var_heap - cs = checkPatternVariable expr_level entry bind_dst new_info_ptr cs - + cs = checkPatternVariable expr_level entry bind_dst new_info_ptr { cs & cs_symbol_table = cs_symbol_table } = ( { bind & bind_dst = { fv_def_level = expr_level, fv_name = bind_dst, fv_info_ptr = new_info_ptr, fv_count = 0 }}, ( { e_state & es_var_heap = es_var_heap }, cs)) = ( { bind & bind_dst = { fv_def_level = expr_level, fv_name = bind_dst, fv_info_ptr = nilPtr, fv_count = 0 }}, @@ -1608,10 +1625,10 @@ checkSelectors end_with_update free_vars [ selector : selectors ] e_input e_stat where check_selector _ free_vars (PS_Record selector=:{id_info,id_name} opt_type) e_input=:{ei_mod_index} e_state e_info=:{ef_selector_defs, ef_modules} cs=:{cs_symbol_table} - #! entry = sreadPtr id_info cs_symbol_table + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table # selectors = retrieveSelectorIndexes ei_mod_index entry (field_module, field_index, field_nr, ef_selector_defs, ef_modules, cs) - = get_field_nr ei_mod_index selector opt_type selectors ef_selector_defs ef_modules cs + = get_field_nr ei_mod_index selector opt_type selectors ef_selector_defs ef_modules { cs & cs_symbol_table = cs_symbol_table } = (RecordSelection { glob_object = MakeDefinedSymbol selector field_index 1, glob_module = field_module } field_nr, free_vars, e_state, {e_info & ef_selector_defs = ef_selector_defs, ef_modules = ef_modules }, cs) where @@ -1620,20 +1637,22 @@ where get_field_nr mod_index sel_id _ [] selector_defs modules cs=:{cs_error} = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError id_name " selector not defined" cs_error }) get_field_nr mod_index sel_id (Yes type_id=:{id_info}) selectors selector_defs modules cs=:{cs_symbol_table,cs_error} - #! entry = sreadPtr id_info cs_symbol_table - # (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + # (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index | type_index <> NotFound - #! (selector_index, selector_offset, selector_defs, modules) + # (selector_index, selector_offset, selector_defs, modules) = determine_selector mod_index type_module type_index selectors selector_defs modules | selector_offset <> NoIndex - = (type_module, selector_index, selector_offset, selector_defs, modules, cs) - = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError id_name " selector not defined" cs_error }) - = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError type_id " type not defined" cs_error }) + = (type_module, selector_index, selector_offset, selector_defs, modules, { cs & cs_symbol_table = cs_symbol_table }) + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_symbol_table = cs_symbol_table, + cs_error = checkError id_name " selector not defined" cs_error }) + = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_symbol_table = cs_symbol_table, + cs_error = checkError type_id " type not defined" cs_error }) get_field_nr mod_index sel_id No [{glob_object,glob_module}] selector_defs modules cs | mod_index == glob_module - #! selector_offset = selector_defs.[glob_object].sd_field_nr + # (selector_offset,selector_defs) = selector_defs![glob_object].sd_field_nr = (glob_module, glob_object, selector_offset, selector_defs, modules, cs) - #! selector_offset = modules.[glob_module].dcl_common.com_selector_defs.[glob_object].sd_field_nr + # (selector_offset,modules) = modules![glob_module].dcl_common.com_selector_defs.[glob_object].sd_field_nr = (glob_module, glob_object, selector_offset, selector_defs, modules, cs) get_field_nr mod_index sel_id No _ selector_defs modules cs=:{cs_error} = (NoIndex, NoIndex, NoIndex, selector_defs, modules, { cs & cs_error = checkError sel_id " ambiguous selector specified" cs_error }) @@ -1754,7 +1773,8 @@ where tuple_2_symbol.glob_object.ds_index <= cons_index && cons_index <= tuple_2_symbol.glob_object.ds_index + 30, cs) transform_sub_patterns mod_index def_level [pattern : patterns] tup_id tup_index arg_var all_binds var_store expr_heap e_info cs - # match_expr = TupleSelect tup_id tup_index arg_var + # (this_arg_var, expr_heap) = adjust_match_expression arg_var expr_heap + match_expr = TupleSelect tup_id tup_index this_arg_var (binds, var_store, expr_heap, e_info, cs) = transfromPatternIntoBind mod_index def_level pattern match_expr var_store expr_heap e_info cs = transform_sub_patterns mod_index def_level patterns tup_id (inc tup_index) arg_var (binds ++ all_binds) var_store expr_heap e_info cs transform_sub_patterns mod_index _ [] _ _ _ binds var_store expr_heap e_info cs @@ -1764,8 +1784,9 @@ where all_binds var_store expr_heap e_info cs # {fs_name, fs_index} = fields.[field_index] selector = { glob_module = field_module, glob_object = MakeDefinedSymbol fs_name fs_index 1} + (this_record_expr, expr_heap) = adjust_match_expression record_expr expr_heap (binds, var_store, expr_heap, e_info, cs) - = transfromPatternIntoBind mod_index def_level pattern (Selection No record_expr [ RecordSelection selector field_index ]) + = transfromPatternIntoBind mod_index def_level pattern (Selection No this_record_expr [ RecordSelection selector field_index ]) var_store expr_heap e_info cs = transform_sub_patterns_of_record mod_index def_level patterns fields field_module (inc field_index) record_expr (binds ++ all_binds) var_store expr_heap e_info cs @@ -1785,11 +1806,17 @@ where bind_match_expr match_expr opt_var_bind var_heap expr_heap # new_name = newVarId "_x" (var_info_ptr, var_heap) = newPtr VI_Empty var_heap - (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - bound_var = { var_name = new_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr } +// (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + bound_var = { var_name = new_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } free_var = { fv_name = new_name, fv_info_ptr = var_info_ptr, fv_def_level = def_level, fv_count = 0 } = (Var bound_var, [{bind_src = match_expr, bind_dst = free_var} : opt_var_bind], var_heap, expr_heap) + adjust_match_expression (Var var) expr_heap + # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap + = (Var { var & var_expr_ptr = var_expr_ptr }, expr_heap) + adjust_match_expression match_expr expr_heap + = (match_expr, expr_heap) + transfromPatternIntoBind mod_index def_level (AP_WildCard _) src_expr var_store expr_heap e_info cs = ([], var_store, expr_heap, e_info, cs) transfromPatternIntoBind _ _ pattern src_expr var_store expr_heap e_info cs @@ -2236,7 +2263,7 @@ where checkFunction :: !Index !Index !Level !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef},!*ExpressionInfo, !*Heaps, !*CheckState); checkFunction mod_index fun_index def_level fun_defs e_info=:{ef_type_defs,ef_modules,ef_class_defs,ef_is_macro_fun} heaps=:{hp_var_heap,hp_expression_heap,hp_type_heaps} cs=:{cs_error} - #! fun_def = fun_defs.[fun_index] + # (fun_def,fun_defs) = fun_defs![fun_index] # {fun_symb,fun_pos,fun_body,fun_type} = fun_def position = newPosition fun_symb fun_pos cs = { cs & cs_error = pushErrorAdmin position cs_error } @@ -2272,9 +2299,8 @@ where remove_calls_from_symbol_table fun_index fun_level [{fc_index, fc_level} : fun_calls] fun_defs symbol_table | fc_level <= fun_level - #! {fun_symb=fun_symb=:{id_info}} = fun_defs.[fc_index] - #! entry = sreadPtr id_info symbol_table -// ---> ("remove_calls_from_symbol_table", fun_symb, ptrToInt id_info, fc_index) + # ({fun_symb=fun_symb=:{id_info}}, fun_defs) = fun_defs![fc_index] + # (entry, symbol_table) = readPtr id_info symbol_table # (c,cs) = get_calls entry.ste_kind | fun_index == c = remove_calls_from_symbol_table fun_index fun_level fun_calls fun_defs (symbol_table <:= (id_info,{ entry & ste_kind = STE_FunctionOrMacro cs})) @@ -2681,7 +2707,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs adjust_predefined_module_symbol :: !Index !(!*PredefinedSymbols, !*SymbolTable) -> (!*PredefinedSymbols, !*SymbolTable) adjust_predefined_module_symbol predef_index (pre_def_symbols, symbol_table) # (mod_symb, pre_def_symbols) = pre_def_symbols![predef_index] - #! mod_entry = sreadPtr mod_symb.pds_ident.id_info symbol_table + # (mod_entry, symbol_table) = readPtr mod_symb.pds_ident.id_info symbol_table = case mod_entry.ste_kind of STE_Module _ -> ({ pre_def_symbols & [predef_index] = { mod_symb & pds_module = cIclModIndex, pds_def = mod_entry.ste_index }}, symbol_table) @@ -2706,7 +2732,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs = [] check_predefined_module {id_info} modules macro_and_fun_defs heaps cs=:{cs_symbol_table} - #! entry = sreadPtr id_info cs_symbol_table + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table # cs = { cs & cs_symbol_table = cs_symbol_table <:= (id_info, { entry & ste_kind = STE_ClosedModule })} {ste_kind = STE_Module mod, ste_index} = entry (modules, macro_and_fun_defs, heaps, cs) @@ -2715,16 +2741,16 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs = (modules, macro_and_fun_defs, heaps, addDeclaredSymbolsToSymbolTable cIsADclModule ste_index dcls_local dcls_import cs) check_dcl_module iinfo=:{ii_modules} heaps cs=:{cs_symbol_table} - #! dcl_mod = ii_modules.[cIclModIndex] - # dcl_info = dcl_mod.dcl_name.id_info - #! entry = sreadPtr dcl_info cs_symbol_table - # (_, iinfo, heaps, cs) = checkImport dcl_info entry iinfo heaps cs + # (dcl_mod, ii_modules) = ii_modules![cIclModIndex] + # dcl_info = dcl_mod.dcl_name.id_info + # (entry, cs_symbol_table) = readPtr dcl_info cs_symbol_table + # (_, iinfo, heaps, cs) = checkImport dcl_info entry { iinfo & ii_modules = ii_modules } heaps { cs & cs_symbol_table = cs_symbol_table } = (iinfo, heaps, cs) collect_specialized_functions_in_dcl_module :: !w:{# DclModule} !v:{# ClassInstance} !u:{# FunDef} !Index !*VarHeap !*TypeVarHeap !*ExpressionHeap -> (![FunDef], !w:{# DclModule}, !v:{# ClassInstance}, !u:{# FunDef}, !Index, !(Optional {# Index}), !*VarHeap, !*TypeVarHeap, !*ExpressionHeap) collect_specialized_functions_in_dcl_module modules icl_instances icl_functions first_free_index var_heap type_var_heap expr_heap - #! dcl_mod = modules.[cIclModIndex] + # (dcl_mod, modules) = modules![cIclModIndex] # {dcl_specials,dcl_functions,dcl_common,dcl_class_specials,dcl_conversions} = dcl_mod = case dcl_conversions of Yes conversion_table @@ -2750,8 +2776,8 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs build_conversion_table_for_instances dcl_class_inst_index dcl_instances class_instances_table icl_instances new_table | dcl_class_inst_index < size class_instances_table # icl_index = class_instances_table.[dcl_class_inst_index] - #! icl_instance = icl_instances.[icl_index] - dcl_instance = dcl_instances.[dcl_class_inst_index] + # (icl_instance, icl_instances) = icl_instances![icl_index] + dcl_instance = dcl_instances.[dcl_class_inst_index] # new_table = build_conversion_table_for_instances_of_members 0 dcl_instance.ins_members icl_instance.ins_members new_table = build_conversion_table_for_instances (inc dcl_class_inst_index) dcl_instances class_instances_table icl_instances new_table = (new_table, icl_instances) @@ -2768,10 +2794,10 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs | spec_index < last_index # {ft_type,ft_specials = SP_FunIndex dcl_index} = dcl_fun_types.[spec_index] icl_index = conversion_table.[dcl_index] - #! icl_fun = icl_functions.[icl_index] - (new_fun_def, heaps) = build_function next_fun_index icl_fun ft_type heaps - (new_fun_defs, funs_index_heaps) - = collect_specialized_functions (inc spec_index) last_index dcl_fun_types conversion_table (icl_functions, inc next_fun_index, heaps) + (icl_fun, icl_functions) = icl_functions![icl_index] + (new_fun_def, heaps) = build_function next_fun_index icl_fun ft_type heaps + (new_fun_defs, funs_index_heaps) + = collect_specialized_functions (inc spec_index) last_index dcl_fun_types conversion_table (icl_functions, inc next_fun_index, heaps) = ([new_fun_def : new_fun_defs], funs_index_heaps) = ([], (icl_functions, next_fun_index, heaps)) @@ -2802,7 +2828,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs copy_instance_types types fun_defs = foldl copy_instance_type fun_defs types copy_instance_type fun_defs (index, symbol_type) - #! inst_def = fun_defs.[index] + # (inst_def, fun_defs) = fun_defs![index] = { fun_defs & [index] = { inst_def & fun_type = Yes symbol_type }} adjust_instance_types_of_array_functions_in_std_array_icl dcl_modules class_instances fun_defs predef_symbols @@ -2819,6 +2845,8 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs = (dcl_modules, class_instances, fun_defs, predef_symbols) = (dcl_modules, class_instances, fun_defs, predef_symbols) where + adjust_instance_types_of_array_functions :: !Index !{#.Index} !Int !*(!u:{# ClassInstance},!*{# FunDef},!v:{#PredefinedSymbol}) + -> (!u:{# ClassInstance},!*{# FunDef},!v:{#PredefinedSymbol}) adjust_instance_types_of_array_functions array_class_index offset_table inst_index (class_instances, fun_defs, predef_symbols) # ({ins_class={glob_module,glob_object={ds_index}},ins_type,ins_members}, class_instances) = class_instances![inst_index] | glob_module == cIclModIndex && ds_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols @@ -2826,6 +2854,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs = (class_instances, fun_defs, predef_symbols) = (class_instances, fun_defs, predef_symbols) + make_instance_strict :: !{#DefinedSymbol} !{#Index} !Int !*{# FunDef} -> *{# FunDef} make_instance_strict instances offset_table ins_offset instance_defs # {ds_index} = instances.[ins_offset] (inst_def, instance_defs) = instance_defs![ds_index] @@ -2871,7 +2900,7 @@ arrayFunOffsetToPD_IndexTable member_defs predef_symbols where offset_to_PD_index pd_index (table, member_defs, predef_symbols) # ({pds_def}, predef_symbols) = predef_symbols![pd_index] - #! {me_offset} = member_defs.[pds_def] + # ({me_offset}, member_defs) = member_defs![pds_def] = ({ table & [me_offset] = pd_index }, member_defs, predef_symbols) elemTypeIsStrict [TA {type_index={glob_object,glob_module}} _ : _] predef_symbols @@ -2910,8 +2939,8 @@ checkImports [] iinfo=:{ii_modules,ii_deps} heaps cs #! mod_num = size ii_modules = (mod_num, iinfo, heaps, cs) checkImports [ {import_module = {id_info}}: mods ] iinfo heaps cs=:{cs_symbol_table} - #! entry = sreadPtr id_info cs_symbol_table - # (min_mod_num1, iinfo, heaps, cs) = checkImport id_info entry iinfo heaps cs + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + # (min_mod_num1, iinfo, heaps, cs) = checkImport id_info entry iinfo heaps { cs & cs_symbol_table = cs_symbol_table } (min_mod_num2, iinfo, heaps, cs) = checkImports mods iinfo heaps cs = (min min_mod_num1 min_mod_num2, iinfo, heaps, cs) @@ -2937,9 +2966,9 @@ checkImport module_id_info entry=:{ste_kind = STE_Module mod, ste_index} iinfo=: = (min_mod_num, iinfo, heaps, cs) where check_component lowest_mod_info [mod_info : ds] modules macro_and_fun_defs heaps cs=:{cs_symbol_table} - #! entry = sreadPtr mod_info cs_symbol_table + # (entry, cs_symbol_table) = readPtr mod_info cs_symbol_table # {ste_kind=STE_OpenModule _ mod,ste_index} = entry - (modules, macro_and_fun_defs, heaps, cs) = checkDclModule mod ste_index modules macro_and_fun_defs heaps cs + (modules, macro_and_fun_defs, heaps, cs) = checkDclModule mod ste_index modules macro_and_fun_defs heaps { cs & cs_symbol_table = cs_symbol_table } cs = { cs & cs_symbol_table = cs.cs_symbol_table <:= (mod_info, { entry & ste_kind = STE_ClosedModule })} | lowest_mod_info == mod_info = (ds, modules, macro_and_fun_defs, heaps, cs) @@ -2963,11 +2992,13 @@ initialDclModule ({mod_name, mod_defs=mod_defs=:{def_funtypes,def_macros}, mod_t , dcl_conversions = No , dcl_is_system = case mod_type of MK_System -> True - _ -> False + _ -> False } - + +checkDclModule :: !(Module (CollectedDefinitions ClassInstance IndexRange)) !Index !*{#DclModule} !*{#FunDef} !*Heaps !*CheckState + -> (!*{#DclModule}, !*{#FunDef}, !*Heaps, !*CheckState) checkDclModule {mod_name,mod_imports,mod_defs} mod_index modules icl_functions heaps=:{hp_var_heap, hp_type_heaps} cs - #! dcl_mod = modules.[mod_index] + # (dcl_mod, modules) = modules![mod_index] # dcl_defined = dcl_mod.dcl_declared.dcls_local dcl_common = createCommonDefinitions mod_defs dcl_macros = mod_defs.def_macros @@ -3028,8 +3059,8 @@ checkDclModule {mod_name,mod_imports,mod_defs} mod_index modules icl_functions h = ({ e_info.ef_modules & [ mod_index ] = dcl_mod }, icl_functions, heaps, { cs & cs_symbol_table = cs_symbol_table }) where collect_imported_symbols [{import_module={id_info},import_symbols,import_file_position} : mods ] all_decls modules cs=:{cs_symbol_table} - #! entry = sreadPtr id_info cs_symbol_table - # (decls_of_imported_module, modules, cs) = collect_declarations_of_module id_info entry [] modules cs + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + # (decls_of_imported_module, modules, cs) = collect_declarations_of_module id_info entry [] modules { cs & cs_symbol_table = cs_symbol_table} (imported_decls, modules, cs) = possibly_filter_decls import_symbols decls_of_imported_module import_file_position modules cs = collect_imported_symbols mods (imported_decls++all_decls) modules cs @@ -3040,14 +3071,14 @@ where all_decls modules cs=:{cs_symbol_table} # cs = { cs & cs_symbol_table = cs_symbol_table <:= (module_id_info, { entry & ste_kind = STE_LockedModule })} (imported_decls, modules, cs) = collect_imported_symbols mod_imports [] modules cs - #! dcl_mod = modules.[ste_index] + # (dcl_mod, modules) = modules![ste_index] # (declared, cs) = determine_declared_symbols ste_index dcl_mod.dcl_declared.dcls_local imported_decls cs = ( [(ste_index, declared) : all_decls] , modules , { cs & cs_symbol_table = cs.cs_symbol_table <:= (module_id_info, { entry & ste_kind = old_kind })} ) collect_declarations_of_module module_id_info entry=:{ste_index, ste_kind= STE_ClosedModule} all_decls modules cs - #! {dcl_declared} = modules.[ste_index] + # ({dcl_declared}, modules) = modules![ste_index] = ([(ste_index, dcl_declared) : all_decls], modules, cs) collect_declarations_of_module module_id_info entry=:{ste_kind= STE_LockedModule} all_decls modules cs = (all_decls, modules, cs) @@ -3064,35 +3095,35 @@ where = cs adjust_predefined_symbols mod_index class_members class_instances fun_types cs=:{cs_predef_symbols} - #! pre_mod = cs_predef_symbols.[PD_StdArray] + # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdArray] | pre_mod.pds_def == mod_index - # cs = cs + # cs = { cs & cs_predef_symbols = cs_predef_symbols} <=< adjust_predef_symbols PD_CreateArrayFun PD_UnqArraySizeFun mod_index STE_Member <=< adjust_predef_symbol PD_ArrayClass mod_index STE_Class (class_members, class_instances, fun_types, cs_predef_symbols) = adjust_instance_types_of_array_functions_in_std_array_dcl mod_index class_members class_instances fun_types cs.cs_predef_symbols = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols }) - #! pre_mod = cs_predef_symbols.[PD_PredefinedModule] + # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_PredefinedModule] | pre_mod.pds_def == mod_index - = (class_members, class_instances, fun_types, cs + = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols} <=< adjust_predef_symbols PD_ListType PD_UnboxedArrayType mod_index STE_Type <=< adjust_predef_symbols PD_ConsSymbol PD_Arity32TupleSymbol mod_index STE_Constructor <=< adjust_predef_symbol PD_TypeCodeClass mod_index STE_Class <=< adjust_predef_symbol PD_TypeCodeMember mod_index STE_Member) - #! pre_mod = cs_predef_symbols.[PD_StdBool] + # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdBool] | pre_mod.pds_def == mod_index - = (class_members, class_instances, fun_types, cs + = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols} <=< adjust_predef_symbol PD_AndOp mod_index STE_DclFunction <=< adjust_predef_symbol PD_OrOp mod_index STE_DclFunction) - #! pre_mod = cs_predef_symbols.[PD_StdDynamics] + # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdDynamics] | pre_mod.pds_def == mod_index - = (class_members, class_instances, fun_types, cs + = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols} <=< adjust_predef_symbol PD_TypeObjectType mod_index STE_Type <=< adjust_predef_symbol PD_TypeConsSymbol mod_index STE_Constructor <=< adjust_predef_symbol PD_variablePlaceholder mod_index STE_Constructor <=< adjust_predef_symbol PD_unify mod_index STE_DclFunction <=< adjust_predef_symbol PD_undo_indirections mod_index STE_DclFunction) - = (class_members, class_instances, fun_types, cs) + = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols}) where adjust_predef_symbols next_symb last_symb mod_index symb_kind cs=:{cs_predef_symbols, cs_symbol_table, cs_error} @@ -3103,12 +3134,12 @@ where <=< adjust_predef_symbols (inc next_symb) last_symb mod_index symb_kind adjust_predef_symbol predef_index mod_index symb_kind cs=:{cs_predef_symbols,cs_symbol_table,cs_error} - #! pre_symb = cs_predef_symbols.[predef_index] - # pre_id = pre_symb.pds_ident + # (pre_symb, cs_predef_symbols) = cs_predef_symbols![predef_index] + # pre_id = pre_symb.pds_ident #! pre_index = determine_index_of_symbol (sreadPtr pre_id.id_info cs_symbol_table) symb_kind | pre_index <> NoIndex = { cs & cs_predef_symbols = {cs_predef_symbols & [predef_index] = { pre_symb & pds_def = pre_index, pds_module = mod_index }}} - = { cs & cs_error = checkError pre_id " function not defined" cs_error } + = { cs & cs_predef_symbols = cs_predef_symbols, cs_error = checkError pre_id " function not defined" cs_error } where determine_index_of_symbol {ste_kind, ste_index} symb_kind | ste_kind == symb_kind @@ -3124,6 +3155,8 @@ where (class_instances, fun_types, predef_symbols) = (class_members, class_instances, fun_types, predef_symbols) where + adjust_instance_types_of_array_functions :: .Index !Index !{#.Index} !Int !*(!u:{# ClassInstance},!*{# FunType},!v:{#PredefinedSymbol}) + -> (!u:{# ClassInstance},!*{# FunType},!v:{#PredefinedSymbol}) adjust_instance_types_of_array_functions array_mod_index array_class_index offset_table inst_index (class_instances, fun_types, predef_symbols) # ({ins_class={glob_module,glob_object={ds_index}},ins_type,ins_members}, class_instances) = class_instances![inst_index] | glob_module == array_mod_index && ds_index == array_class_index && elemTypeIsStrict ins_type.it_types predef_symbols @@ -3131,6 +3164,7 @@ where = (class_instances, fun_types, predef_symbols) = (class_instances, fun_types, predef_symbols) + make_instance_strict :: !{#DefinedSymbol} !{#Index} !Int !*{# FunType} -> *{# FunType} make_instance_strict instances offset_table ins_offset instance_defs # {ds_index} = instances.[ins_offset] (inst_def, instance_defs) = instance_defs![ds_index] @@ -3142,17 +3176,16 @@ NewEntry symbol_table symb_ptr def_kind def_index level previous :== addImportsToSymbolTable :: ![ParsedImport] ![(!Declaration, !LineNr)] !*{# DclModule} !*CheckState -> (![(!Declaration, !LineNr)], !*{# DclModule}, !*CheckState) -addImportsToSymbolTable [{import_module={id_info},import_symbols, import_file_position} : mods ] - explicit_akku modules cs=:{cs_symbol_table} - #! {ste_index} = sreadPtr id_info cs_symbol_table - #! {dcl_declared=decls_of_imported_module} = modules.[ste_index] - (imported_decls, modules, cs) = possibly_filter_decls import_symbols - [(ste_index, decls_of_imported_module)] import_file_position modules cs - | isEmpty imported_decls +addImportsToSymbolTable [{import_module={id_info},import_symbols, import_file_position} : mods ] explicit_akku modules cs=:{cs_symbol_table} + # ({ste_index}, cs_symbol_table) = readPtr id_info cs_symbol_table + # ({dcl_declared=decls_of_imported_module}, modules) = modules![ste_index] + (imported_decls, modules, cs) = possibly_filter_decls import_symbols [(ste_index, decls_of_imported_module)] import_file_position + modules { cs & cs_symbol_table = cs_symbol_table } + | isEmpty imported_decls = addImportsToSymbolTable mods explicit_akku modules cs - #! (_,{dcls_import,dcls_local,dcls_explicit}) = hd imported_decls - = addImportsToSymbolTable mods (dcls_explicit++explicit_akku) - modules (addDeclaredSymbolsToSymbolTable cIsNotADclModule ste_index dcls_local dcls_import cs) + # (_,{dcls_import,dcls_local,dcls_explicit}) = hd imported_decls + = addImportsToSymbolTable mods (dcls_explicit++explicit_akku) + modules (addDeclaredSymbolsToSymbolTable cIsNotADclModule ste_index dcls_local dcls_import cs) addImportsToSymbolTable [] explicit_akku modules cs = (explicit_akku, modules, cs) @@ -3230,7 +3263,7 @@ instance <<< SpecialSubstitution where (<<<) file {ss_environ} = file <<< ss_environ -instance <<< Ptr a +instance <<< (Ptr a) where (<<<) file ptr = file <<< "[[" <<< ptrToInt ptr <<< "]]" @@ -3244,4 +3277,22 @@ retrieveGlobalDefinition {ste_kind,ste_def_level,ste_index} requ_kind mod_index = (ste_index, mod_index) = (NotFound, mod_index) +/* 2.0 ... +removeLocalsFromSymbolTable :: !Level ![Ident] !LocalDefs !u:(m a) !*(Heap SymbolTableEntry) + -> (!u:(m a), !.Heap SymbolTableEntry) | Array m a & toIdent a +... */ +removeLocalsFromSymbolTable level loc_vars (CollectedLocalDefs {loc_functions={ir_from,ir_to}}) defs symbol_table + = remove_defs_from_symbol_table level ir_from ir_to defs (removeLocalIdentsFromSymbolTable level loc_vars symbol_table) +where + remove_defs_from_symbol_table level from_index to_index defs symbol_table + | from_index == to_index + = (defs, symbol_table) + #! def = defs.[from_index] + id_info = (toIdent def).id_info + entry = sreadPtr id_info symbol_table + | level == entry.ste_def_level + = remove_defs_from_symbol_table level (inc from_index) to_index defs (symbol_table <:= (id_info, entry.ste_previous)) + = remove_defs_from_symbol_table level (inc from_index) to_index defs symbol_table + + diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl index 36f7c73..9418951 100644 --- a/frontend/checksupport.dcl +++ b/frontend/checksupport.dcl @@ -78,12 +78,12 @@ cConversionTableSize :== 8 } :: IclModule = - { icl_name :: !Ident - , icl_functions :: !.{# FunDef } - , icl_instances :: !IndexRange - , icl_specials :: !IndexRange - , icl_common :: !.CommonDefs - , icl_declared :: !Declarations + { icl_name :: !Ident + , icl_functions :: !.{# FunDef } + , icl_instances :: !IndexRange + , icl_specials :: !IndexRange + , icl_common :: !.CommonDefs + , icl_declared :: !Declarations , icl_imported_objects :: ![ImportedObject] } @@ -121,7 +121,7 @@ instance envLookUp TypeVar, AttributeVar, ATypeVar class toIdent a :: !a -> Ident -instance toIdent ConsDef, TypeDef a, ClassDef, MemberDef, FunDef, SelectorDef // , ClassInstance +instance toIdent ConsDef, (TypeDef a), ClassDef, MemberDef, FunDef, SelectorDef // , ClassInstance instance toIdent SymbIdent, TypeSymbIdent, BoundVar, TypeVar, ATypeVar, Ident instance toInt STE_Kind @@ -129,7 +129,7 @@ instance <<< STE_Kind, IdentPos, Declaration retrieveAndRemoveImportsFromSymbolTable :: ![(.a,.Declarations)] [Declaration] *(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry); -addLocalFunctionDefsToSymbolTable :: Level Index .Index u:(a FunDef) *SymbolTable *ErrorAdmin -> (v:(a FunDef),.SymbolTable,.ErrorAdmin) | Array .a, [u <= v]; +addLocalFunctionDefsToSymbolTable :: !Level !Index !Index !u:{#FunDef} !*SymbolTable !*ErrorAdmin -> (!u:{# FunDef}, !*SymbolTable, !*ErrorAdmin) addDefToSymbolTable :: !Level !Index !Ident !STE_Kind !*SymbolTable !*ErrorAdmin -> (!* SymbolTable, !*ErrorAdmin) addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] ![.Declaration] !*CheckState -> .CheckState; addLocalSymbolsToSymbolTable :: ![.Declaration] Int !*CheckState -> .CheckState; @@ -139,5 +139,4 @@ retrieveImportsFromSymbolTable :: ![Import ImportDeclaration] ![Declaration] !*{ removeFieldFromSelectorDefinition :: !Ident .Int .Int !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; removeDeclarationsFromSymbolTable :: ![Declaration] !Int !*(Heap SymbolTableEntry) -> *Heap SymbolTableEntry; removeLocalIdentsFromSymbolTable :: .Int !.[Ident] !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; -removeLocalsFromSymbolTable :: .Level .[Ident] LocalDefs u:(a b) *(Heap SymbolTableEntry) -> (v:(a b),.Heap SymbolTableEntry) | Array .a & select_u , toIdent b, [u <= v]; removeIdentFromSymbolTable :: !.Int !Ident !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index 6e57ca1..f693445 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -226,12 +226,12 @@ where _ -> ([{ symbol & dcl_kind = ste_kind } : decls ], symbol_table <:= (id_info, ste_previous)) -addLocalFunctionDefsToSymbolTable :: Level Index .Index u:(a FunDef) *SymbolTable *ErrorAdmin -> (v:(a FunDef),.SymbolTable,.ErrorAdmin) | Array .a, [u <= v]; +addLocalFunctionDefsToSymbolTable :: !Level !Index !Index !u:{#FunDef} !*SymbolTable !*ErrorAdmin -> (!u:{# FunDef}, !*SymbolTable, !*ErrorAdmin) addLocalFunctionDefsToSymbolTable level from_index to_index fun_defs symbol_table error | from_index == to_index = (fun_defs, symbol_table, error) - #! fun_def = fun_defs.[from_index] - (symbol_table, error) = addDefToSymbolTable level from_index fun_def.fun_symb (STE_FunctionOrMacro []) symbol_table error + # (fun_def, fun_defs) = fun_defs![from_index] + (symbol_table, error) = addDefToSymbolTable level from_index fun_def.fun_symb (STE_FunctionOrMacro []) symbol_table error = addLocalFunctionDefsToSymbolTable level (inc from_index) to_index fun_defs symbol_table error NewEntry symbol_table symb_ptr def_kind def_index level previous :== @@ -328,10 +328,9 @@ where retrieveImportsFromSymbolTable :: ![Import ImportDeclaration] ![Declaration] !*{#DclModule} !*(Heap SymbolTableEntry) -> *(![Declaration],!*{#DclModule},!*Heap SymbolTableEntry); retrieveImportsFromSymbolTable [{import_module=import_module=:{id_info},import_symbols} : mods ] decls modules symbol_table - #! entry = sreadPtr id_info symbol_table - # {ste_index} = entry - #! {dcl_declared={dcls_import,dcls_local}} = modules.[ste_index] - (decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable dcls_import dcls_local decls symbol_table + # ({ste_index}, symbol_table) = readPtr id_info symbol_table + ({dcl_declared={dcls_import,dcls_local}}, modules) = modules![ste_index] + (decls, symbol_table) = retrieveAndRemoveImportsOfModuleFromSymbolTable dcls_import dcls_local decls symbol_table = retrieveImportsFromSymbolTable mods decls modules symbol_table retrieveImportsFromSymbolTable [] decls modules symbol_table = (decls, modules, symbol_table) @@ -356,22 +355,19 @@ removeDeclarationsFromSymbolTable decls scope symbol_table = foldSt (remove_declaration scope) decls symbol_table where remove_declaration scope {dcl_ident={id_name,id_info}, dcl_index} symbol_table - #! entry = sreadPtr id_info symbol_table - # {ste_kind,ste_previous} = entry + # ({ste_kind,ste_previous}, symbol_table) = readPtr id_info symbol_table = case ste_kind of - STE_Field field_id - # symbol_table = removeFieldFromSelectorDefinition field_id NoIndex dcl_index symbol_table - | ste_previous.ste_def_level == scope - -> symbol_table <:= (id_info, ste_previous.ste_previous) - -> symbol_table <:= (id_info, ste_previous) -// MW.. - STE_Empty - -> symbol_table -// ..MW - _ - | ste_previous.ste_def_level == scope - -> symbol_table <:= (id_info, ste_previous.ste_previous) - -> symbol_table <:= (id_info, ste_previous) + STE_Field field_id + # symbol_table = removeFieldFromSelectorDefinition field_id NoIndex dcl_index symbol_table + | ste_previous.ste_def_level == scope + -> symbol_table <:= (id_info, ste_previous.ste_previous) + -> symbol_table <:= (id_info, ste_previous) + STE_Empty + -> symbol_table + _ + | ste_previous.ste_def_level == scope + -> symbol_table <:= (id_info, ste_previous.ste_previous) + -> symbol_table <:= (id_info, ste_previous) removeLocalIdentsFromSymbolTable :: .Int !.[Ident] !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; @@ -379,21 +375,6 @@ removeLocalIdentsFromSymbolTable level idents symbol_table = foldSt (removeIdentFromSymbolTable level) idents symbol_table -removeLocalsFromSymbolTable :: .Level .[Ident] LocalDefs u:(a b) *(Heap SymbolTableEntry) -> (v:(a b),.Heap SymbolTableEntry) | Array .a & select_u , toIdent b, [u <= v]; -removeLocalsFromSymbolTable level loc_vars (CollectedLocalDefs {loc_functions={ir_from,ir_to}}) defs symbol_table - = remove_defs_from_symbol_table level ir_from ir_to defs (removeLocalIdentsFromSymbolTable level loc_vars symbol_table) -where - remove_defs_from_symbol_table level from_index to_index defs symbol_table - | from_index == to_index - = (defs, symbol_table) - #! def = defs.[from_index] - id_info = (toIdent def).id_info - entry = sreadPtr id_info symbol_table - | level == entry.ste_def_level - = remove_defs_from_symbol_table level (inc from_index) to_index defs (symbol_table <:= (id_info, entry.ste_previous)) - = remove_defs_from_symbol_table level (inc from_index) to_index defs symbol_table - - removeIdentFromSymbolTable :: !.Int !Ident !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; removeIdentFromSymbolTable level {id_name,id_info} symbol_table #! {ste_previous,ste_def_level} = sreadPtr id_info symbol_table @@ -432,7 +413,7 @@ instance toIdent ConsDef where toIdent cons = cons.cons_symb -instance toIdent TypeDef a +instance toIdent (TypeDef a) where toIdent td = td.td_name @@ -512,9 +493,6 @@ where (STE_BoundTypeVariable _) = file <<< "STE_BoundTypeVariable" (<<<) file - (STE_BoundType _) - = file <<< "STE_BoundType" - (<<<) file (STE_Imported _ _) = file <<< "STE_Imported" (<<<) file diff --git a/frontend/checktypes.dcl b/frontend/checktypes.dcl index 3695103..ff94143 100644 --- a/frontend/checktypes.dcl +++ b/frontend/checktypes.dcl @@ -20,6 +20,9 @@ checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedT createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*CheckState -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState) +bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps; +clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps; + isATopConsVar cv :== cv < 0 encodeTopConsVar cv :== dec (~cv) decodeTopConsVar cv :== ~(inc cv) diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index ffa1f7c..6483065 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -63,7 +63,8 @@ where instance bindTypes TypeVar where bindTypes cti tv=:{tv_name=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table}) - #! var_def = sreadPtr id_info cs_symbol_table + # (var_def, cs_symbol_table) = readPtr id_info cs_symbol_table + cs = { cs & cs_symbol_table = cs_symbol_table } = case var_def.ste_kind of STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count} # cs = { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, { var_def & ste_kind = STE_BoundTypeVariable { bv & stv_count = inc stv_count }})} @@ -89,8 +90,9 @@ where = (TV tv, attr, ts_ti_cs) bindTypes cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} type=:(TA type_cons=:{type_name=type_name=:{id_info}} types) (ts=:{ts_type_defs,ts_modules}, ti, cs=:{cs_symbol_table}) - #! entry = sreadPtr id_info cs_symbol_table - # (type_index, type_module) = retrieveGlobalDefinition entry STE_Type cti_module_index + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + cs = { cs & cs_symbol_table = cs_symbol_table } + (type_index, type_module) = retrieveGlobalDefinition entry STE_Type cti_module_index | type_index <> NotFound # ({td_arity,td_attribute},type_index,ts_type_defs,ts_modules) = getTypeDef type_index type_module cti_module_index ts_type_defs ts_modules ts = { ts & ts_type_defs = ts_type_defs, ts_modules = ts_modules } @@ -140,11 +142,12 @@ bindTypesOfCons :: !Index !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymb bindTypesOfConstructors _ _ _ _ _ [] ts_ti_cs = ts_ti_cs bindTypesOfConstructors cti=:{cti_lhs_attribute} cons_index free_vars free_attrs type_lhs [{ds_index}:conses] (ts=:{ts_cons_defs}, ti=:{ti_type_heaps}, cs) - #! cons_def = ts_cons_defs.[ds_index] + # (cons_def, ts_cons_defs) = ts_cons_defs![ds_index] # (exi_vars, (ti_type_heaps, cs)) = addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_type_heaps cs (st_args, cons_arg_vars, st_attr_env, (ts, ti, cs)) - = bind_types_of_cons cons_def.cons_type.st_args cti free_vars [] (ts, { ti & ti_type_heaps = ti_type_heaps }, cs) + = bind_types_of_cons cons_def.cons_type.st_args cti free_vars [] + ({ ts & ts_cons_defs = ts_cons_defs }, { ti & ti_type_heaps = ti_type_heaps }, cs) cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel exi_vars cs.cs_symbol_table (ts, ti, cs) = bindTypesOfConstructors cti (inc cons_index) free_vars free_attrs type_lhs conses (ts, ti, { cs & cs_symbol_table = cs_symbol_table }) @@ -191,7 +194,7 @@ checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_cons [{at_annotation = AN_None, at_attribute = atv_attribute,at_type = TV atv_variable} \\ {atv_variable, atv_attribute} <- td_args]} (ts, ti, cs) = bindTypesOfConstructors cti 0 [ atv_variable \\ {atv_variable} <- td_args] attr_vars type_lhs [rec_cons] ts_ti_cs - #! rec_cons_def = ts.ts_cons_defs.[ds_index] + # (rec_cons_def, ts) = ts!ts_cons_defs.[ds_index] # {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def (ts_selector_defs, ti_var_heap, cs_error) = check_selectors 0 rt_fields cti_type_index st_args st_result st_vars st_attr_vars cons_exi_vars ts.ts_selector_defs ti.ti_var_heap cs.cs_error @@ -202,7 +205,7 @@ where check_selectors field_nr fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs var_heap error | field_nr < size fields # {fs_index} = fields.[field_nr] - #! sel_def = selector_defs.[fs_index] + # (sel_def, selector_defs) = selector_defs![fs_index] # [sel_type:sel_types] = sel_types # (st_attr_env, error) = addToAttributeEnviron sel_type.at_attribute rec_type.at_attribute [] error # (new_type_ptr, var_heap) = newPtr VI_Empty var_heap @@ -224,8 +227,9 @@ isATopConsVar cv :== cv < 0 encodeTopConsVar cv :== dec (~cv) decodeTopConsVar cv :== ~(inc cv) +checkTypeDef :: !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState); checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error} - #! type_def = ts_type_defs.[type_index] + # (type_def, ts_type_defs) = ts_type_defs![type_index] # {td_name,td_pos,td_args,td_attribute} = type_def position = newPosition td_name td_pos cs_error = pushErrorAdmin position cs_error @@ -234,7 +238,8 @@ checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=: = addTypeVariablesToSymbolTable td_args attr_vars { ti_type_heaps & th_attrs = th_attrs } { cs & cs_error = cs_error } type_def = { type_def & td_args = type_vars, td_index = type_index, td_attrs = attr_vars, td_attribute = td_attribute } (td_rhs, (ts, ti, cs)) = checkRhsOfTypeDef type_def attr_vars - { cti_module_index = module_index, cti_type_index = type_index, cti_lhs_attribute = td_attribute } (ts,{ ti & ti_type_heaps = ti_type_heaps}, cs) + { cti_module_index = module_index, cti_type_index = type_index, cti_lhs_attribute = td_attribute } + ({ ts & ts_type_defs = ts_type_defs },{ ti & ti_type_heaps = ti_type_heaps}, cs) = ({ ts & ts_type_defs = { ts.ts_type_defs & [type_index] = { type_def & td_rhs = td_rhs }}}, ti, { cs & cs_error = popErrorAdmin cs.cs_error, cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel type_vars cs.cs_symbol_table }) @@ -249,147 +254,138 @@ where CS_Checked :== 1 CS_Checking :== 0 -:: SynTypeInfo = - { sti_type_defs ::!.{# CheckedTypeDef} - , sti_modules ::!.{# DclModule} - , sti_marks ::!.{# Int} +:: ExpandState = + { exp_type_defs ::!.{# CheckedTypeDef} + , exp_modules ::!.{# DclModule} + , exp_marks ::!.{# Int} + , exp_type_heaps ::!.TypeHeaps + , exp_error ::!.ErrorAdmin } +class expand a :: !Index !a !*ExpandState -> (!a, !*ExpandState) -class expand a :: !Index !a !*SynTypeInfo !*CheckState -> (!a, !*SynTypeInfo, !*CheckState) +expandTypeVariable :: TypeVar !*ExpandState -> (!Type, !*ExpandState) +expandTypeVariable {tv_info_ptr} expst=:{exp_type_heaps} + # (TVI_Type type, th_vars) = readPtr tv_info_ptr exp_type_heaps.th_vars + = (type, { expst & exp_type_heaps = { exp_type_heaps & th_vars = th_vars }}) -expandTypeVariable :: TypeVar !*SynTypeInfo !*CheckState -> (!Type, !TypeAttribute, !*SynTypeInfo, !*CheckState) -expandTypeVariable {tv_name={id_info}} sti cs=:{cs_symbol_table} - #! {ste_kind = STE_BoundType {at_attribute,at_type}} = sreadPtr id_info cs_symbol_table - = (at_type, at_attribute, sti, cs) - +expandTypeAttribute :: !TypeAttribute !*ExpandState -> (!TypeAttribute, !*ExpandState) +expandTypeAttribute (TA_Var {av_info_ptr}) expst=:{exp_type_heaps} + # (AVI_Attr attr, th_attrs) = readPtr av_info_ptr exp_type_heaps.th_attrs + = (attr, { expst & exp_type_heaps = { exp_type_heaps & th_attrs = th_attrs }}) +expandTypeAttribute attr expst + = (attr, expst) instance expand Type where - expand module_index (TV tv) sti cs - # (type, _, sti, cs) = expandTypeVariable tv sti cs - = (type, sti, cs) - expand module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) sti=:{sti_marks} cs=:{cs_error,cs_symbol_table} + expand module_index (TV tv) expst + = expandTypeVariable tv expst + expand module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) expst=:{exp_marks,exp_error} | module_index == glob_module - #! mark = sti_marks.[glob_object] + #! mark = exp_marks.[glob_object] | mark == CS_NotChecked - # (sti, cs) = expandSynType module_index glob_object sti cs - (types, sti, cs) = expand module_index types sti cs - = (TA type_cons types, sti, cs) + # expst = expandSynType module_index glob_object expst + (types, expst) = expand module_index types expst + = (TA type_cons types,expst) | mark == CS_Checked - # (types, sti, cs) = expand module_index types sti cs - = (TA type_cons types, sti, cs) + # (types, expst) = expand module_index types expst + = (TA type_cons types, expst) // | mark == CS_Checking - = (type, sti, { cs & cs_error = checkError type_name "cyclic dependency between type synonyms" cs_error }) - # (types, sti, cs) = expand module_index types sti cs - = (TA type_cons types, sti, cs) - expand module_index (arg_type --> res_type) sti cs - # (arg_type, sti, cs) = expand module_index arg_type sti cs - (res_type, sti, cs) = expand module_index res_type sti cs - = (arg_type --> res_type, sti, cs) - expand module_index (CV tv :@: types) sti cs - # (type, _, sti, cs) = expandTypeVariable tv sti cs - (types, sti, cs) = expand module_index types sti cs - = (simplify_type_appl type types, sti, cs) + = (type, { expst & exp_error = checkError type_name "cyclic dependency between type synonyms" exp_error }) + # (types, expst) = expand module_index types expst + = (TA type_cons types, expst) + expand module_index (arg_type --> res_type) expst + # (arg_type, expst) = expand module_index arg_type expst + (res_type, expst) = expand module_index res_type expst + = (arg_type --> res_type, expst) + expand module_index (CV tv :@: types) expst + # (type, expst) = expandTypeVariable tv expst + (types, expst) = expand module_index types expst + = (simplify_type_appl type types, expst) where simplify_type_appl :: !Type ![AType] -> Type simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) simplify_type_appl (TV tv) type_args = CV tv :@: type_args - expand module_index type sti cs - = (type, sti, cs) + expand module_index type expst + = (type, expst) instance expand [a] | expand a where - expand module_index [x:xs] sti cs - # (x, sti, cs) = expand module_index x sti cs - (xs, sti, cs) = expand module_index xs sti cs - = ([x:xs], sti, cs) - expand module_index [] sti cs - = ([], sti, cs) + expand module_index [x:xs] expst + # (x, expst) = expand module_index x expst + (xs, expst) = expand module_index xs expst + = ([x:xs], expst) + expand module_index [] expst + = ([], expst) instance expand AType where - expand module_index atype=:{at_type=(TV tv)} sti cs - # (at_type, attr, sti, cs) = expandTypeVariable tv sti cs - = ({ atype & at_type = at_type, at_attribute = attr }, sti, cs) - expand module_index atype=:{at_type} sti cs - # (at_type, sti, cs) = expand module_index at_type sti cs - = ({ atype & at_type = at_type }, sti, cs) + expand module_index atype=:{at_type,at_attribute} expst + # (at_attribute, expst) = expandTypeAttribute at_attribute expst + (at_type, expst) = expand module_index at_type expst + = ({ atype & at_type = at_type, at_attribute = at_attribute }, expst) -class look_for_cycles a :: !Index !a !(!*SynTypeInfo, !*CheckState) -> (!*SynTypeInfo, !*CheckState) +class look_for_cycles a :: !Index !a !*ExpandState -> *ExpandState instance look_for_cycles Type where - look_for_cycles module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) (sti=:{sti_marks}, cs=:{cs_error}) + look_for_cycles module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) expst=:{exp_marks,exp_error} | module_index == glob_module - #! mark = sti_marks.[glob_object] + #! mark = exp_marks.[glob_object] | mark == CS_NotChecked - # (sti, cs) = expandSynType module_index glob_object sti cs - = look_for_cycles module_index types (sti, cs) + # expst = expandSynType module_index glob_object expst + = look_for_cycles module_index types expst | mark == CS_Checked - = look_for_cycles module_index types (sti, cs) - = (sti, { cs & cs_error = checkError type_name "cyclic dependency between type synonyms" cs_error }) - = look_for_cycles module_index types (sti, cs) - look_for_cycles module_index (arg_type --> res_type) state - = look_for_cycles module_index res_type (look_for_cycles module_index arg_type state) - look_for_cycles module_index (type :@: types) state - = look_for_cycles module_index types state - look_for_cycles module_index type state - = state + = look_for_cycles module_index types expst + = { expst & exp_error = checkError type_name "cyclic dependency between type synonyms" exp_error } + = look_for_cycles module_index types expst + look_for_cycles module_index (arg_type --> res_type) expst + = look_for_cycles module_index res_type (look_for_cycles module_index arg_type expst) + look_for_cycles module_index (type :@: types) expst + = look_for_cycles module_index types expst + look_for_cycles module_index type expst + = expst instance look_for_cycles [a] | look_for_cycles a where - look_for_cycles mod_index l state - = foldr (look_for_cycles mod_index) state l + look_for_cycles mod_index l expst + = foldr (look_for_cycles mod_index) expst l instance look_for_cycles AType where - look_for_cycles mod_index {at_type} state - = look_for_cycles mod_index at_type state + look_for_cycles mod_index {at_type} expst + = look_for_cycles mod_index at_type expst -expandSynType :: !Index !Index !*SynTypeInfo !*CheckState -> (!*SynTypeInfo, !*CheckState) -expandSynType mod_index type_index sti=:{sti_type_defs,sti_marks,sti_modules} cs - #! type_def = sti_type_defs.[type_index] +expandSynType :: !Index !Index !*ExpandState -> *ExpandState +expandSynType mod_index type_index expst=:{exp_type_defs} + # (type_def, exp_type_defs) = exp_type_defs![type_index] + expst = { expst & exp_type_defs = exp_type_defs } = case type_def.td_rhs of SynType type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} - # (type_def2,_,sti_type_defs,sti_modules) = getTypeDef glob_object glob_module mod_index sti_type_defs sti_modules - -> case type_def2.td_rhs of + # ({td_args,td_attribute,td_rhs}, _, exp_type_defs, exp_modules) = getTypeDef glob_object glob_module mod_index expst.exp_type_defs expst.exp_modules + expst = { expst & exp_type_defs = exp_type_defs, exp_modules = exp_modules } + -> case td_rhs of SynType rhs_type - # cs_symbol_table = bind_args type_def2.td_args types cs.cs_symbol_table + # exp_type_heaps = bindTypeVarsAndAttributes td_attribute type_def.td_attribute td_args types expst.exp_type_heaps position = newPosition type_def.td_name type_def.td_pos - cs_error = pushErrorAdmin position cs.cs_error - sti_marks = { sti_marks & [type_index] = CS_Checking } - (exp_type, sti, cs) = expand mod_index rhs_type.at_type - { sti_type_defs = sti_type_defs, sti_modules = sti_modules, sti_marks = sti_marks } - { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table } - -> ({sti & sti_type_defs = { sti.sti_type_defs & [type_index] = { type_def & td_rhs = SynType { type & at_type = exp_type }}}, - sti_marks = { sti.sti_marks & [type_index] = CS_Checked }}, - { cs & cs_symbol_table = free_args type_def2.td_args cs.cs_symbol_table, cs_error = popErrorAdmin cs.cs_error }) + exp_error = pushErrorAdmin position expst.exp_error + exp_marks = { expst.exp_marks & [type_index] = CS_Checking } + (exp_type, expst) = expand mod_index rhs_type.at_type { expst & exp_marks = exp_marks, + exp_error = exp_error, exp_type_heaps = exp_type_heaps } + -> {expst & exp_type_defs = { expst.exp_type_defs & [type_index] = { type_def & td_rhs = SynType { type & at_type = exp_type }}}, + exp_marks = { expst.exp_marks & [type_index] = CS_Checked }, + exp_type_heaps = clearBindingsOfTypeVarsAndAttributes td_attribute td_args expst.exp_type_heaps, + exp_error = popErrorAdmin expst.exp_error } + _ - # sti_marks = { sti_marks & [type_index] = CS_Checking } + # exp_marks = { expst.exp_marks & [type_index] = CS_Checking } position = newPosition type_def.td_name type_def.td_pos - (sti, cs) = look_for_cycles mod_index types - ({ sti_type_defs = sti_type_defs, sti_modules = sti_modules, sti_marks = sti_marks }, - { cs & cs_error = pushErrorAdmin position cs.cs_error }) - -> ({ sti & sti_marks = { sti.sti_marks & [type_index] = CS_Checked }}, { cs & cs_error = popErrorAdmin cs.cs_error }) - + expst = look_for_cycles mod_index types { expst & exp_marks = exp_marks, exp_error = pushErrorAdmin position expst.exp_error } + -> { expst & exp_marks = { expst.exp_marks & [type_index] = CS_Checked }, exp_error = popErrorAdmin expst.exp_error } _ - -> ({ sti_type_defs = sti_type_defs, sti_modules = sti_modules, sti_marks = { sti_marks & [type_index] = CS_Checked }}, cs) -where - bind_args [{atv_variable = {tv_name = {id_info}}} : type_vars] [type : types] symbol_table - #! entry = sreadPtr id_info symbol_table - = bind_args type_vars types symbol_table <:= (id_info, - { ste_index = NoIndex, ste_kind = STE_BoundType type, ste_def_level = cGlobalScope, ste_previous = entry }) - bind_args [] [] symbol_table - = symbol_table - - free_args [{atv_variable = {tv_name = {id_info}}} : type_vars] symbol_table - #! {ste_previous} = sreadPtr id_info symbol_table - = free_args type_vars (symbol_table <:= (id_info, ste_previous)) - free_args [] symbol_table - = symbol_table + -> { expst & exp_marks = { expst.exp_marks & [type_index] = CS_Checked }} instance toString KindInfo where @@ -422,20 +418,21 @@ where | type_index == nr_of_types | cs.cs_error.ea_ok && not is_main_dcl # marks = createArray nr_of_types CS_NotChecked - (type_defs, modules, cs) = expand_syn_types module_index 0 nr_of_types - { sti_type_defs = ts.ts_type_defs, sti_modules = ts.ts_modules, sti_marks = marks } cs - = (type_defs, ts.ts_cons_defs, ts.ts_selector_defs, modules, ti_var_heap, ti_type_heaps, cs) + {exp_type_defs,exp_modules,exp_type_heaps,exp_error} = expand_syn_types module_index 0 nr_of_types + { exp_type_defs = ts.ts_type_defs, exp_modules = ts.ts_modules, exp_marks = marks, + exp_type_heaps = ti_type_heaps, exp_error = cs.cs_error } + = (exp_type_defs, ts.ts_cons_defs, ts.ts_selector_defs, exp_modules, ti_var_heap, exp_type_heaps, { cs & cs_error = exp_error }) = (ts.ts_type_defs, ts.ts_cons_defs, ts.ts_selector_defs, ts.ts_modules, ti_var_heap, ti_type_heaps, cs) # (ts, ti, cs) = checkTypeDef type_index module_index ts ti cs = check_type_defs is_main_dcl (inc type_index) nr_of_types module_index ts ti cs - expand_syn_types module_index type_index nr_of_types sti cs + expand_syn_types module_index type_index nr_of_types expst | type_index == nr_of_types - = (sti.sti_type_defs, sti.sti_modules, cs) - | sti.sti_marks.[type_index] == CS_NotChecked - # (sti, cs) = expandSynType module_index type_index sti cs - = expand_syn_types module_index (inc type_index) nr_of_types sti cs - = expand_syn_types module_index (inc type_index) nr_of_types sti cs + = expst + | expst.exp_marks.[type_index] == CS_NotChecked + # expst = expandSynType module_index type_index expst + = expand_syn_types module_index (inc type_index) nr_of_types expst + = expand_syn_types module_index (inc type_index) nr_of_types expst :: OpenTypeInfo = { oti_heaps :: !.TypeHeaps @@ -450,8 +447,7 @@ where } determineAttributeVariable attr_var=:{av_name=attr_name=:{id_info}} oti=:{oti_heaps,oti_all_attrs} symbol_table - #! entry = sreadPtr id_info symbol_table - # {ste_kind,ste_def_level} = entry + # (entry=:{ste_kind,ste_def_level}, symbol_table) = readPtr id_info symbol_table | ste_kind == STE_Empty || ste_def_level == cModuleScope #! (new_attr_ptr, th_attrs) = newPtr AVI_Empty oti_heaps.th_attrs # symbol_table = symbol_table <:= (id_info,{ ste_index = NoIndex, ste_kind = STE_TypeAttribute new_attr_ptr, @@ -491,40 +487,42 @@ newAttribute DAK_None var_name attr oti cs getTypeDef :: !Index !Index !Index !u:{# CheckedTypeDef} !v:{# DclModule} -> (!CheckedTypeDef, !Index , !u:{# CheckedTypeDef}, !v:{# DclModule}) getTypeDef type_index type_module module_index type_defs modules | type_module == module_index - #! type_def = type_defs.[type_index] + # (type_def, type_defs) = type_defs![type_index] = (type_def, type_index, type_defs, modules) - #! {dcl_common={com_type_defs},dcl_conversions} = modules.[type_module] - #! type_def = com_type_defs.[type_index] - # type_index = convertIndex type_index (toInt STE_Type) dcl_conversions + # ({dcl_common={com_type_defs},dcl_conversions}, modules) = modules![type_module] + type_def = com_type_defs.[type_index] + type_index = convertIndex type_index (toInt STE_Type) dcl_conversions = (type_def, type_index, type_defs, modules) getClassDef :: !Index !Index !Index !u:{# ClassDef} !v:{# DclModule} -> (!ClassDef, !Index , !u:{# ClassDef}, !v:{# DclModule}) getClassDef class_index type_module module_index class_defs modules | type_module == module_index #! si = size class_defs - #! class_def = class_defs.[class_index] + # (class_def, class_defs) = class_defs![class_index] = (class_def, class_index, class_defs, modules) - #! {dcl_common={com_class_defs},dcl_conversions} = modules.[type_module] - #! class_def = com_class_defs.[class_index] - # class_index = convertIndex class_index (toInt STE_Class) dcl_conversions + # ({dcl_common={com_class_defs},dcl_conversions}, modules) = modules![type_module] + class_def = com_class_defs.[class_index] + class_index = convertIndex class_index (toInt STE_Class) dcl_conversions = (class_def, class_index, class_defs, modules) -checkTypeVar mod_index scope dem_attr tv=:{tv_name=var_name=:{id_name,id_info}} tv_attr (ots, oti, cs=:{cs_symbol_table}) - #! entry = sreadPtr id_info cs_symbol_table - # {ste_kind,ste_def_level} = entry +checkTypeVar :: !Level !DemandedAttributeKind !TypeVar !TypeAttribute !(!*OpenTypeInfo, !*CheckState) + -> (! TypeVar, !TypeAttribute, !(!*OpenTypeInfo, !*CheckState)) +checkTypeVar scope dem_attr tv=:{tv_name=var_name=:{id_name,id_info}} tv_attr (oti, cs=:{cs_symbol_table}) + # (entry=:{ste_kind,ste_def_level},cs_symbol_table) = readPtr id_info cs_symbol_table | ste_kind == STE_Empty || ste_def_level == cModuleScope - # (new_attr, oti=:{oti_heaps,oti_all_vars}, cs) = newAttribute dem_attr id_name tv_attr oti cs + # (new_attr, oti=:{oti_heaps,oti_all_vars}, cs) = newAttribute dem_attr id_name tv_attr oti { cs & cs_symbol_table = cs_symbol_table } (new_var_ptr, th_vars) = newPtr (TVI_Attribute new_attr) oti_heaps.th_vars new_var = { tv & tv_info_ptr = new_var_ptr } - = (new_var, new_attr, (ots, { oti & oti_heaps = { oti_heaps & th_vars = th_vars }, oti_all_vars = [new_var : oti_all_vars]}, + = (new_var, new_attr, ({ oti & oti_heaps = { oti_heaps & th_vars = th_vars }, oti_all_vars = [new_var : oti_all_vars]}, { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr, ste_def_level = scope, ste_previous = entry })})) # (STE_TypeVariable tv_info_ptr) = ste_kind {oti_heaps} = oti (var_info, th_vars) = readPtr tv_info_ptr oti_heaps.th_vars - (var_attr, oti, cs) = check_attribute id_name dem_attr var_info tv_attr { oti & oti_heaps = { oti_heaps & th_vars = th_vars }} cs - = ({ tv & tv_info_ptr = tv_info_ptr }, var_attr, (ots, oti, cs)) + (var_attr, oti, cs) = check_attribute id_name dem_attr var_info tv_attr { oti & oti_heaps = { oti_heaps & th_vars = th_vars }} + { cs & cs_symbol_table = cs_symbol_table } + = ({ tv & tv_info_ptr = tv_info_ptr }, var_attr, (oti, cs)) where check_attribute var_name DAK_Ignore (TVI_Attribute prev_attr) this_attr oti cs=:{cs_error} = (TA_Multi, oti, cs) @@ -577,13 +575,12 @@ where = (TA_Multi, oti, cs) -checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} ots_oti_cs - # (tv, at_attribute, ots_oti_cs) = checkTypeVar mod_index scope dem_attr tv at_attribute ots_oti_cs - = ({ type & at_type = TV tv, at_attribute = at_attribute }, ots_oti_cs) +checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} (ots, oti, cs) + # (tv, at_attribute, (oti, cs)) = checkTypeVar scope dem_attr tv at_attribute (oti, cs) + = ({ type & at_type = TV tv, at_attribute = at_attribute }, (ots, oti, cs)) checkOpenAType mod_index scope dem_attr type=:{at_type = GTV var_id=:{tv_name={id_info}}} (ots, oti=:{oti_heaps,oti_global_vars}, cs=:{cs_symbol_table}) # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table - (type_var, oti_global_vars, th_vars, entry) - = retrieve_global_variable var_id entry oti_global_vars oti_heaps.th_vars + (type_var, oti_global_vars, th_vars, entry) = retrieve_global_variable var_id entry oti_global_vars oti_heaps.th_vars = ({type & at_type = TV type_var, at_attribute = TA_Multi }, (ots, { oti & oti_heaps = { oti_heaps & th_vars = th_vars }, oti_global_vars = oti_global_vars }, { cs & cs_symbol_table = cs_symbol_table <:= (id_info, entry) })) where @@ -607,9 +604,10 @@ where = (var, global_vars, var_heap, { entry & ste_previous = ste_previous }) checkOpenAType mod_index scope dem_attr type=:{ at_type=TA type_cons=:{type_name=type_name=:{id_name,id_info}} types, at_attribute} - (ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table,cs_error}) - #! entry = sreadPtr id_info cs_symbol_table - # (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index + (ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table}) + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + cs = { cs & cs_symbol_table = cs_symbol_table } + (type_index, type_module) = retrieveGlobalDefinition entry STE_Type mod_index | type_index <> NotFound # ({td_arity,td_args,td_attribute},type_index,ots_type_defs,ots_modules) = getTypeDef type_index type_module mod_index ots_type_defs ots_modules ots = { ots & ots_type_defs = ots_type_defs, ots_modules = ots_modules } @@ -618,8 +616,8 @@ checkOpenAType mod_index scope dem_attr type=:{ at_type=TA type_cons=:{type_name (types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope dem_attr types td_args (ots, oti, cs) (new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr td_attribute) id_name at_attribute oti cs = ({ type & at_type = TA type_cons types, at_attribute = new_attr } , (ots, oti, cs)) - = (type, (ots, oti, {cs & cs_error = checkError type_name "used with wrong arity" cs_error})) - = (type, (ots, oti, {cs & cs_error = checkError type_name "undefined" cs_error})) + = (type, (ots, oti, {cs & cs_error = checkError type_name "used with wrong arity" cs.cs_error})) + = (type, (ots, oti, {cs & cs_error = checkError type_name "undefined" cs.cs_error})) where check_args_of_type_cons mod_index scope dem_attr [] _ cot_state = ([], cot_state) @@ -640,9 +638,9 @@ checkOpenAType mod_index scope dem_attr type=:{at_type = arg_type --> result_typ (result_type, (ots, oti, cs)) = checkOpenAType mod_index scope DAK_None result_type cot_state (new_attr, oti, cs) = newAttribute dem_attr "-->" at_attribute oti cs = ({ type & at_type = arg_type --> result_type, at_attribute = new_attr }, (ots, oti, cs)) -checkOpenAType mod_index scope dem_attr type=:{at_type = CV tv :@: types, at_attribute} cot_state - # (cons_var, _, cot_state) = checkTypeVar mod_index scope DAK_None tv TA_Multi cot_state - (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope DAK_None) types cot_state +checkOpenAType mod_index scope dem_attr type=:{at_type = CV tv :@: types, at_attribute} (ots, oti, cs) + # (cons_var, _, (oti, cs)) = checkTypeVar scope DAK_None tv TA_Multi (oti, cs) + (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope DAK_None) types (ots, oti, cs) (new_attr, oti, cs) = newAttribute dem_attr ":@:" at_attribute oti cs = ({ type & at_type = CV cons_var :@: types, at_attribute = new_attr }, (ots, oti, cs)) checkOpenAType mod_index scope dem_attr type=:{at_attribute} (ots, oti, cs) @@ -697,15 +695,16 @@ where = ([], cs) check_attr_inequality ineq=:{ai_demanded=ai_demanded=:{av_name=dem_name},ai_offered=ai_offered=:{av_name=off_name}} cs=:{cs_symbol_table,cs_error} - #! dem_entry = sreadPtr dem_name.id_info cs_symbol_table + # (dem_entry, cs_symbol_table) = readPtr dem_name.id_info cs_symbol_table # (found_dem_attr, dem_attr_ptr) = retrieve_attribute dem_entry | found_dem_attr - #! off_entry = sreadPtr off_name.id_info cs_symbol_table + # (off_entry, cs_symbol_table) = readPtr off_name.id_info cs_symbol_table # (found_off_attr, off_attr_ptr) = retrieve_attribute off_entry | found_off_attr - = ({ai_demanded = { ai_demanded & av_info_ptr = dem_attr_ptr }, ai_offered = { ai_offered & av_info_ptr = off_attr_ptr }}, cs) - = (ineq, { cs & cs_error = checkError off_name "attribute variable undefined" cs_error }) - = (ineq, { cs & cs_error = checkError dem_name "attribute variable undefined" cs_error }) + = ({ai_demanded = { ai_demanded & av_info_ptr = dem_attr_ptr }, ai_offered = { ai_offered & av_info_ptr = off_attr_ptr }}, + { cs & cs_symbol_table = cs_symbol_table }) + = (ineq, { cs & cs_error = checkError off_name "attribute variable undefined" cs_error, cs_symbol_table = cs_symbol_table }) + = (ineq, { cs & cs_error = checkError dem_name "attribute variable undefined" cs_error, cs_symbol_table = cs_symbol_table }) retrieve_attribute {ste_kind = STE_TypeAttribute attr_ptr, ste_def_level, ste_index} | ste_def_level == cGlobalScope @@ -725,9 +724,11 @@ where -> (!TypeContext,!z:{#CheckedTypeDef},!x:{#ClassDef},!w:{#DclModule},!*TypeHeaps,!*CheckState), [u v <= w, v u <= z] check_type_context tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types} mod_index type_defs class_defs modules heaps cs=:{cs_symbol_table, cs_predef_symbols} +/* // MW.. - #! {pds_ident} = cs_predef_symbols.[PD_TypeCodeClass] - pre_mod = cs_predef_symbols.[PD_PredefinedModule] + # ({pds_ident},cs_predef_symbols) = cs_predef_symbols![PD_TypeCodeClass] + (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_PredefinedModule] + cs = { cs & cs_predef_symbols = cs_predef_symbols } # (modules, cs) = case ds_ident==pds_ident of True # ({dcl_name}, modules) = modules![mod_index] | pre_mod.pds_def <> mod_index @@ -735,7 +736,9 @@ where -> (modules, cs) // the predefined module does not have to import StdDynamics _ -> (modules, cs) // .. MW - #! entry = sreadPtr id_info cs_symbol_table +*/ + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + cs = { cs & cs_symbol_table = cs_symbol_table } # (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index | class_index <> NotFound # (class_def, class_index, class_defs, modules) = getClassDef class_index class_module mod_index class_defs modules @@ -871,15 +874,15 @@ where add_type_variable_to_symbol_table :: !Level !ATypeVar !*(!*TypeVarHeap,!*CheckState) -> (!ATypeVar,!(!*TypeVarHeap, !*CheckState)) add_type_variable_to_symbol_table scope atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} (type_var_heap, cs=:{cs_symbol_table,cs_error}) - #! var_info = tv_name.id_info - var_entry = sreadPtr var_info cs_symbol_table + # var_info = tv_name.id_info + (var_entry, cs_symbol_table) = readPtr var_info cs_symbol_table | var_entry.ste_kind == STE_Empty || scope < var_entry.ste_def_level #! (new_var_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap # cs_symbol_table = cs_symbol_table <:= (var_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr, ste_def_level = scope, ste_previous = var_entry }) = ({atv & atv_attribute = TA_Multi, atv_variable = { atv_variable & tv_info_ptr = new_var_ptr }}, (type_var_heap, { cs & cs_symbol_table = cs_symbol_table, cs_error = check_attribute atv_attribute cs_error})) - = (atv, (type_var_heap, { cs & cs_error = checkError tv_name.id_name " type variable already defined" cs_error })) + = (atv, (type_var_heap, { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error })) check_attribute TA_Unique error = error @@ -897,12 +900,11 @@ checkSpecialTypeVars (SP_ParsedSubstitutions env) cs = (SP_ParsedSubstitutions env, cs) where check_type_var bind=:{bind_dst=type_var=:{tv_name={id_name,id_info}}} cs=:{cs_symbol_table,cs_error} - #! entry = sreadPtr id_info cs_symbol_table - # {ste_kind,ste_def_level} = entry + # ({ste_kind,ste_def_level}, cs_symbol_table) = readPtr id_info cs_symbol_table | ste_kind <> STE_Empty && ste_def_level == cGlobalScope # (STE_TypeVariable tv_info_ptr) = ste_kind - = ({ bind & bind_dst = { type_var & tv_info_ptr = tv_info_ptr}}, cs) - = (bind, { cs & cs_error = checkError id_name " type variable not defined" cs_error }) + = ({ bind & bind_dst = { type_var & tv_info_ptr = tv_info_ptr}}, { cs & cs_symbol_table = cs_symbol_table }) + = (bind, { cs & cs_symbol_table= cs_symbol_table, cs_error = checkError id_name " type variable not defined" cs_error }) checkSpecialTypeVars SP_None cs = (SP_None, cs) /* @@ -955,8 +957,8 @@ where -> (!ATypeVar, !(![AttributeVar], !*TypeHeaps, !*CheckState)) add_type_variable_to_symbol_table atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} (attr_vars, heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error }) - #! tv_info = tv_name.id_info - entry = sreadPtr tv_info cs_symbol_table + # tv_info = tv_name.id_info + (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table | entry.ste_def_level < cOuterMostLevel # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars atv_variable = { atv_variable & tv_info_ptr = tv_info_ptr } @@ -967,7 +969,7 @@ where = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, (attr_vars, heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) = (atv, (attr_vars, { heaps & th_vars = th_vars }, - { cs & cs_error = checkError tv_name.id_name " type variable already defined" cs_error})) + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error})) check_attribute :: !TypeAttribute !String ![AttributeVar] !*AttrVarHeap !*ErrorAdmin -> (!TypeAttribute, ![AttributeVar], !*AttrVarHeap, !*ErrorAdmin) @@ -994,8 +996,8 @@ where -> (!ATypeVar, !(!*TypeHeaps, !*CheckState)) add_type_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} (heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error }) - #! tv_info = tv_name.id_info - entry = sreadPtr tv_info cs_symbol_table + # tv_info = tv_name.id_info + (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table | entry.ste_def_level < cOuterMostLevel # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars atv_variable = { atv_variable & tv_info_ptr = tv_info_ptr } @@ -1006,7 +1008,7 @@ where = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, (heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) = (atv, ({ heaps & th_vars = th_vars }, - { cs & cs_error = checkError tv_name.id_name " type variable already defined" cs_error})) + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error})) check_attribute :: !TypeAttribute !TypeAttribute !String !*ErrorAdmin -> (!TypeAttribute, !*ErrorAdmin) @@ -1043,9 +1045,9 @@ cUniversalVariable :== False removeDefinitionFromSymbolTable level {id_info} symbol_table | isNilPtr id_info = symbol_table - #! entry = sreadPtr id_info symbol_table - | entry.ste_def_level == level - = symbol_table <:= (id_info, entry.ste_previous) + # ({ste_def_level, ste_previous}, symbol_table) = readPtr id_info symbol_table + | ste_def_level == level + = symbol_table <:= (id_info, ste_previous) = symbol_table removeAttributesFromSymbolTable :: ![AttributeVar] !*SymbolTable -> *SymbolTable @@ -1067,10 +1069,12 @@ makeAttributedType attr annot type :== { at_attribute = attr, at_annotation = an createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*CheckState -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState) createClassDictionaries mod_index class_defs modules first_type_index first_selector_index first_cons_index type_var_heap var_heap cs - # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) = create_class_dictionaries mod_index 0 class_defs modules [] - { index_type = first_type_index, index_cons= first_cons_index, index_selector = first_selector_index } type_var_heap var_heap cs - (type_defs, sel_defs, cons_defs, cs_symbol_table) = foldSt collect_type_def rev_dictionary_list ([], [], [], cs.cs_symbol_table) - = (class_defs, modules, type_defs, sel_defs, cons_defs, type_var_heap, var_heap, {cs & cs_symbol_table = cs_symbol_table }) + | cs.cs_error.ea_ok + # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) = create_class_dictionaries mod_index 0 class_defs modules [] + { index_type = first_type_index, index_cons= first_cons_index, index_selector = first_selector_index } type_var_heap var_heap cs + (type_defs, sel_defs, cons_defs, cs_symbol_table) = foldSt collect_type_def rev_dictionary_list ([], [], [], cs.cs_symbol_table) + = (class_defs, modules, type_defs, sel_defs, cons_defs, type_var_heap, var_heap, {cs & cs_symbol_table = cs_symbol_table }) + = (class_defs, modules, [], [], [], type_var_heap, var_heap, cs) where collect_type_def type_ptr (type_defs, sel_defs, cons_defs, symbol_table) # ({ ste_kind = STE_DictType type_def }, symbol_table) = readPtr type_ptr symbol_table @@ -1222,6 +1226,33 @@ where = (field, var_heap, symbol_table <:= (id_info, { ste_kind = STE_DictField sel_def, ste_index = selector_index, ste_def_level = NotALevel, ste_previous = abort "empty SymbolTableEntry" })) +bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps; +bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps + # th_attrs = bind_attribute form_root_attribute act_root_attribute type_heaps.th_attrs + = fold2St bind_type_and_attr form_type_args act_type_args { type_heaps & th_attrs = th_attrs } +where + bind_type_and_attr {atv_attribute, atv_variable={tv_info_ptr}} {at_type,at_attribute} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), + th_attrs = bind_attribute atv_attribute at_attribute th_attrs } + + bind_attribute (TA_Var {av_info_ptr}) attr th_attrs + = th_attrs <:= (av_info_ptr, AVI_Attr attr) + bind_attribute _ _ th_attrs + = th_attrs + +clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps -> *TypeHeaps; +clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps + # th_attrs = clear_attribute form_root_attribute type_heaps.th_attrs + = foldSt clear_type_and_attr form_type_args { type_heaps & th_attrs = th_attrs } +where + clear_type_and_attr {atv_attribute, atv_variable={tv_info_ptr}} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Empty), th_attrs = clear_attribute atv_attribute th_attrs } + + clear_attribute (TA_Var {av_info_ptr}) th_attrs + = th_attrs <:= (av_info_ptr, AVI_Empty) + clear_attribute _ th_attrs + = th_attrs + class toVariable var :: !STE_Kind !Ident -> var instance toVariable TypeVar diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 1517ee6..b01c74c 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -38,7 +38,7 @@ import RWSDebug } :: TypesCorrespondMonad - :== !*TypesCorrespondState -> (!Bool, !*TypesCorrespondState) + :== !*TypesCorrespondState -> *(!Bool, !*TypesCorrespondState) :: ExpressionsCorrespondState = { ec_correspondences // ec_correspondences.[i]==j <=> (functions i and j are already compared @@ -130,7 +130,6 @@ compareDefImp untransformed dcl_modules icl_module heaps error_admin (icl_functions, hp_var_heap, hp_expression_heap, tc_state, error_admin) = compareMacrosWithConversion conversion_table.[cMacroDefs] dcl_macros untransformed icl_functions hp_var_heap hp_expression_heap tc_state error_admin - (icl_functions, tc_state, error_admin) = compareFunctionTypesWithConversions conversion_table.[cFunctionDefs] dcl_functions icl_functions tc_state error_admin @@ -155,9 +154,6 @@ compareDefImp untransformed dcl_modules icl_module heaps error_admin compareWithConversions conversions dclDefs iclDefs tc_state error_admin = iFoldSt (compareWithConversion conversions dclDefs) 0 (size conversions) (iclDefs, tc_state, error_admin) -compareWithConversion :: !w:(a x:Int) !.(b c) !Int !(!u:(d c), !*TypesCorrespondState, !*ErrorAdmin) - -> (!v:(d c), !.TypesCorrespondState, !.ErrorAdmin) - | Array .b & getIdentPos , select_u , t_corresponds , uselect_u c & Array .d & Array .a, [u <= v, w <= x]; compareWithConversion conversions dclDefs dclIndex (iclDefs, tc_state, error_admin) # icl_index = conversions.[dclIndex] | icl_index==dclIndex @@ -172,9 +168,6 @@ compareFunctionTypesWithConversions conversions dcl_fun_types icl_functions tc_s = iFoldSt (compareTwoFunctionTypes conversions dcl_fun_types) 0 (size conversions) (icl_functions, tc_state, error_admin) -compareTwoFunctionTypes :: !w:(a x:Int) !.(b FunType) !.Int !(!u:(c FunDef),!*TypesCorrespondState,!*ErrorAdmin) - -> (!v:(c FunDef),!.TypesCorrespondState,!.ErrorAdmin) - | Array .b & Array .c & Array .a, [u <= v, w <= x]; compareTwoFunctionTypes conversions dcl_fun_types dclIndex (icl_functions, tc_state, error_admin) # (fun_def=:{fun_type}, icl_functions) = icl_functions![conversions.[dclIndex]] = case fun_type of @@ -337,19 +330,25 @@ instance t_corresponds [a] | t_corresponds a where t_corresponds _ _ = return False -instance t_corresponds {# a} | t_corresponds , select_u , size_u a where + +// instance t_corresponds {# a} | t_corresponds a & Array {#} a // 2.0 + +instance t_corresponds {# a} | ArrayElem , t_corresponds a +where t_corresponds dclArray iclArray # size_dclArray = size dclArray | size_dclArray<>size iclArray = return False - = loop (size_dclArray-1) dclArray iclArray + = loop (size_dclArray-1) dclArray iclArray where +// loop :: !Int !{# a} !{# a} -> *TypesCorrespondMonad | t_corresponds a & Array {#} a // 2.0 loop i dclArray iclArray | i<0 = return True - = t_corresponds dclArray.[i] iclArray.[i] + = t_corresponds dclArray.[i] iclArray.[i] &&& loop (i-1) dclArray iclArray + instance t_corresponds (Optional a) | t_corresponds a where t_corresponds No No = return True @@ -437,7 +436,6 @@ instance t_corresponds AType where _ -> (False, tc_state) _ -> (False, tc_state) where - simple_corresponds dclDef iclDef = t_corresponds dclDef.at_attribute iclDef.at_attribute &&& t_corresponds dclDef.at_type iclDef.at_type @@ -486,7 +484,7 @@ instance t_corresponds AType where # (actual_arg, type_var_heap) = possibly_dereference actual_arg type_var_heap = bind_type_vars` formal_args actual_args (writePtr atv_variable.tv_info_ptr (TVI_AType actual_arg) type_var_heap) -// --->("binding", atv_variable.tv_name,"to",actual_arg) + // --->("binding", atv_variable.tv_name,"to",actual_arg) bind_type_vars` _ _ type_var_heap = type_var_heap @@ -711,7 +709,7 @@ instance e_corresponds FunDef where where from_body (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs]) from_body (CheckedBody {cb_args, cb_rhs}) = (cb_args, cb_rhs) - + instance e_corresponds TransformedBody where e_corresponds dclDef iclDef = e_corresponds dclDef.tb_args iclDef.tb_args @@ -775,6 +773,8 @@ instance e_corresponds Expression where = e_corresponds dcl icl e_corresponds EE EE = do_nothing + e_corresponds (NoBind _) (NoBind _) + = do_nothing e_corresponds _ _ = give_error "" diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index b953168..f4ff4c1 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -44,7 +44,7 @@ where convert_groups group_nr groups global_type_instances fun_defs_and_ci | group_nr == size groups = (groups, fun_defs_and_ci) - #! group = groups.[group_nr] + # (group, groups) = groups![group_nr] = convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci) convert_function group_nr global_type_instances fun (fun_defs, ci) @@ -568,7 +568,7 @@ zipAppend2 xs [] zs = zs zipAppend2 [x : xs] [y : ys] zs = [ (x,y) : zipAppend2 xs ys zs ] -instance <<< Ptr a +instance <<< (Ptr a) where (<<<) file ptr = file <<< ptrToInt ptr diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 9004bc3..e50d792 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -28,7 +28,7 @@ where convertCases bound_vars group_index common_defs t ci = app2St (convertCases bound_vars group_index common_defs, convertCases bound_vars group_index common_defs) t ci -instance convertCases Bind a b | convertCases a +instance convertCases (Bind a b) | convertCases a where convertCases bound_vars group_index common_defs bind=:{bind_src} ci # (bind_src, ci) = convertCases bound_vars group_index common_defs bind_src ci @@ -456,7 +456,7 @@ where group_index = gf_fun_def.fun_info.fi_group_index (Yes ft) = gf_fun_def.fun_type (ft, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType common_defs ft imported_types imported_conses type_heaps var_heap - #! group = groups.[group_index] + # (group, groups) = groups![group_index] = ({ groups & [group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, [ { gf_fun_def & fun_type = Yes ft }: fun_defs], imported_types, imported_conses, type_heaps, var_heap) @@ -478,13 +478,13 @@ where convert_groups group_nr groups dcl_functions common_defs fun_defs_and_ci | group_nr == size groups = (groups, fun_defs_and_ci) - #! group = groups.[group_nr] + # (group, groups) = groups![group_nr] = convert_groups (inc group_nr) groups dcl_functions common_defs (foldSt (convert_function group_nr dcl_functions common_defs) group.group_members fun_defs_and_ci) convert_function group_index dcl_functions common_defs fun (fun_defs, collected_imports, ci) - #! fun_def = fun_defs.[fun] + # (fun_def, fun_defs) = fun_defs![fun] # {fun_body,fun_type} = fun_def (fun_body, (collected_imports, ci)) = eliminate_code_sharing_in_function dcl_functions common_defs fun_body /* (fun_body ---> ("convert_function", fun_def.fun_symb, fun_body)) */ (collected_imports, ci) (fun_body, ci) = convert_cases_into_function_patterns fun_body fun_type group_index common_defs ci @@ -621,10 +621,11 @@ where = (imported_types, type_heaps, var_heap) convert_imported_constructors common_defs [ {glob_module, glob_object} : conses ] imported_types type_heaps var_heap # {com_cons_defs,com_selector_defs} = common_defs.[glob_module] - {cons_type_ptr,cons_type,cons_type_index} = common_defs.[glob_module].com_cons_defs.[glob_object] + {cons_type_ptr,cons_type,cons_type_index,cons_symb} = common_defs.[glob_module].com_cons_defs.[glob_object] (cons_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs cons_type imported_types conses type_heaps var_heap var_heap = var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type) ({td_rhs}, imported_types) = imported_types![glob_module].[cons_type_index] +// ---> ("convert_imported_constructors", cons_symb, cons_type) = case td_rhs of RecordType {rt_fields} # (imported_types, conses, type_heaps, var_heap) @@ -820,10 +821,12 @@ where */ copy EE cp_info = (EE, cp_info) + copy (NoBind ptr) cp_info + = (NoBind ptr, cp_info) copy expr cp_info = abort ("copy (Expression) does not match" ---> expr) -instance copy Optional a | copy a +instance copy (Optional a) | copy a where copy (Yes expr) cp_info # (expr, cp_info) = copy expr cp_info @@ -1049,6 +1052,8 @@ where = weightedRefCount dcl_functions common_defs depth type_code_expr rc_info weightedRefCount dcl_functions common_defs depth EE rc_info = rc_info + weightedRefCount dcl_functions common_defs depth (NoBind ptr) rc_info + = rc_info weightedRefCount dcl_functions common_defs depth expr rc_info = abort ("weightedRefCount [Expression] (convertcases, 864))" ---> expr) @@ -1294,13 +1299,13 @@ where di_expr_heap = writePtr inner_let_info_ptr (EI_LetType ((take nr_of_strict_lets let_type)++strict_inner_types)) di_expr_heap -> (Let { inner_let & let_strict_binds = let_strict_binds++inner_let.let_strict_binds}, {dl_info & di_expr_heap = di_expr_heap}) - _ -> (Let { lad & let_strict_binds = let_strict_binds, let_expr = let_expr, let_lazy_binds = []}, + _ -> (Let { lad & let_strict_binds = let_strict_binds, let_expr = let_expr, let_lazy_binds = []}, {dl_info & di_expr_heap = dl_info.di_expr_heap <:= (let_info_ptr, EI_LetType (take nr_of_strict_lets let_type))}) where set_let_expression_info depth [(let_strict, {bind_src,bind_dst}):binds][ref_count:ref_counts][type:types] var_heap # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap lei = { lei_count = ref_count, lei_depth = depth, lei_var = { bind_dst & fv_info_ptr = new_info_ptr }, - lei_expression = bind_src, lei_type = type, lei_status = LES_Untouched } + lei_expression = bind_src, lei_type = type, lei_status = LES_Untouched } = set_let_expression_info depth binds ref_counts types (var_heap <:= (bind_dst.fv_info_ptr, VI_LetExpression lei)) set_let_expression_info depth [] _ _ var_heap = var_heap @@ -1338,7 +1343,9 @@ where = (expr, dl_info) distributeLets depth EE dl_info = (EE, dl_info) - + distributeLets depth (NoBind ptr) dl_info + = (NoBind ptr, dl_info) + my_zip [] [] = [] my_zip [x:xs][y:ys] = [(x,y) : my_zip xs ys] @@ -1486,7 +1493,7 @@ where (<<<) file EI_Empty = file <<< "*Empty*" (<<<) file (EI_CaseType _) = file <<< "CaseType" -instance <<< Ptr a +instance <<< (Ptr a) where (<<<) file ptr = file <<< ptrToInt ptr diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index b10df13..f04a136 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -407,7 +407,10 @@ element_appears imported_st element_ident dcl_index element_appears imported_st element_ident dcl_index [h=:(struct_id, SI_DotDot, st, optInfo):t] atomic_imports unimp_index index modules cs - | (case st of {ST_stomm_stomm_stomm _ -> True; _ -> False}) && (False->>"element_appears weird case") + | (case st of + ST_stomm_stomm_stomm _ + -> True + _ -> False) && (False->>"element_appears weird case") = undef # (appears, defined, opt_element_idents, modules, cs) = element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs @@ -783,8 +786,8 @@ instance consequences Expression instance consequences FunctionBody where consequences (CheckedBody body) = consequences body consequences (TransformedBody body) = consequences body - // other alternatives should not occur - + consequences (RhsMacroBody body) = consequences body + instance consequences FunType where consequences {ft_type} = consequences ft_type diff --git a/frontend/frontend.dcl b/frontend/frontend.dcl index 2ada4a3..47db4e2 100644 --- a/frontend/frontend.dcl +++ b/frontend/frontend.dcl @@ -1,6 +1,6 @@ definition module frontend -from scanner import SearchPaths, String +from scanner import SearchPaths from general import Optional, Yes, No import checksupport, transform, overloading diff --git a/frontend/frontend.icl b/frontend/frontend.icl index bde4809..6638dda 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -22,7 +22,6 @@ frontEndInterface :: !Ident !SearchPaths !*PredefinedSymbols !*HashTable !*Files frontEndInterface mod_ident search_paths predef_symbols hash_table files error io out # (ok, mod, hash_table, error, predef_symbols, files) = wantModule cWantIclFile mod_ident (hash_table ---> ("Parsing:", mod_ident)) error search_paths predef_symbols files - #! mod_type = mod.mod_type | not ok = (predef_symbols, hash_table, files, error, io, out, No) # (ok, mod, nr_of_global_funs, mod_functions, dcl_mod, predef_mod, modules, hash_table, error, predef_symbols, files) @@ -35,10 +34,10 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i hash_table = { hash_table & hte_symbol_heap = symbol_table} | not ok = (predef_symbols, hash_table, files, error, io, out, No) - # {icl_functions,icl_instances,icl_specials,icl_common,icl_declared={dcls_import}} = icl_mod + # {icl_functions,icl_instances,icl_specials,icl_common,icl_declared} = icl_mod // (components, icl_functions, error) = showComponents components 0 True icl_functions error (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, error) - = typeProgram mod_type (components -*-> "Typing") icl_functions icl_specials icl_common dcls_import dcl_mods heaps predef_symbols error + = typeProgram (components -*-> "Typing") icl_functions icl_specials icl_common icl_declared.dcls_import dcl_mods heaps predef_symbols error | not ok = (predef_symbols, hash_table, files, error, io, out, No) @@ -56,31 +55,17 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i = analyseGroups common_defs array_instances (components -*-> "Transform") fun_defs var_heap expression_heap (components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) = transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs dcl_types used_conses_in_dynamics var_heap type_heaps expression_heap -/* - - (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap) - = analyseGroups common_defs (components -*-> "Transform") fun_defs heaps.hp_var_heap heaps.hp_expression_heap - (components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) - = transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs var_heap heaps.hp_type_heaps expression_heap - (components, fun_defs, error) = showComponents components 0 True fun_defs error - -*/ (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps -/* - (components, fun_defs, predef_symbols, dcl_types, used_conses, var_heap, type_heaps, expression_heap) - = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components -*-> "convertDynamics") fun_defs predef_symbols - dcl_types used_conses var_heap type_heaps expression_heap - (components, fun_defs, out) = showComponents components 0 True fun_defs out -*/ (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) = convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses var_heap type_heaps expression_heap (dcl_types, type_heaps, var_heap) = convertImportedTypeSpecifications dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap -// (components, fun_defs, out) = showComponents components 0 False fun_defs out + (components, fun_defs, out) = showComponents components 0 False fun_defs out + = (predef_symbols,hash_table,files,error,io,out, - Yes { fe_icl = {icl_mod & icl_functions=fun_defs} + Yes { fe_icl = {icl_mod & icl_functions=fun_defs } , fe_dcls = dcl_mods , fe_components = components , fe_varHeap = var_heap @@ -90,11 +75,14 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i } ) where + + build_optional_icl_dcl_conversions :: !Int !(Optional {# Index}) -> Optional {# Index} build_optional_icl_dcl_conversions size No = Yes (build_icl_dcl_conversions size {}) build_optional_icl_dcl_conversions size (Yes dcl_icl_conversions) = Yes (build_icl_dcl_conversions size dcl_icl_conversions) - + + build_icl_dcl_conversions :: !Int !{# Index} -> {# Index} build_icl_dcl_conversions table_size dcl_icl_conversions # dcl_table_size = size dcl_icl_conversions icl_dcl_conversions = update_conversion_array 0 dcl_table_size dcl_icl_conversions (createArray table_size NoIndex) @@ -137,7 +125,7 @@ where show_component [] show_types fun_defs file = (fun_defs, file <<< '\n') show_component [fun:funs] show_types fun_defs file - #! fun_def = fun_defs.[fun] + # (fun_def, fun_defs) = fun_defs![fun] | 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) @@ -154,7 +142,7 @@ where show_component [] fun_defs _ file = (fun_defs, file <<< '\n') show_component [fun:funs] fun_defs acc_args file - #! fd = fun_defs.[fun] + # (fd, fun_defs) = fun_defs![fun] # file = show_accumulating_arguments acc_args.[fun].cc_args (file <<< fd.fun_symb <<< '.' <<< fun <<< " (") = show_component funs fun_defs acc_args (file <<< ") ") @@ -186,7 +174,7 @@ where show_types [] fun_defs file = (fun_defs, file <<< '\n') show_types [fun:funs] fun_defs file - #! fun_def = fun_defs.[fun] + # (fun_def, fun_defs) = fun_defs![fun] # properties = { form_properties = cAttributed bitor cAnnotated, form_attr_position = No } (Yes ftype) = fun_def.fun_type = show_types funs fun_defs (file <<< fun_def.fun_symb <<< " :: " <:: (properties, ftype) <<< '\n' ) diff --git a/frontend/general.dcl b/frontend/general.dcl index e2215df..ac5e052 100644 --- a/frontend/general.dcl +++ b/frontend/general.dcl @@ -16,7 +16,7 @@ instance <<< [a] | <<< a , bind_dst :: !b } -:: Env a b :== [Bind a b] +:: Env a b :== [.Bind a b] :: Optional x = Yes !x | No diff --git a/frontend/general.icl b/frontend/general.icl index 4db7f96..d5669db 100644 --- a/frontend/general.icl +++ b/frontend/general.icl @@ -7,7 +7,7 @@ import StdEnv , bind_dst :: !b } -:: Env a b :== [Bind a b] +:: Env a b :== [.Bind a b] :: Optional x = Yes !x | No diff --git a/frontend/main.icl b/frontend/main.icl index a5251ce..d907e1c 100644 --- a/frontend/main.icl +++ b/frontend/main.icl @@ -21,6 +21,15 @@ Start world CommandLoop proj ms=:{ms_io} + # answer = "c t5\n" + (command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer)) + | command == [] + = CommandLoop proj { ms & ms_io = ms_io} + # (ready, proj, ms) = DoCommand command argument proj { ms & ms_io = ms_io} + = ms + +/* +CommandLoop proj ms=:{ms_io} # (answer, ms_io) = freadline (ms_io <<< "> ") (command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer)) | command == [] @@ -29,6 +38,7 @@ CommandLoop proj ms=:{ms_io} | ready = ms = CommandLoop proj ms +*/ :: MainStateDefs funs funtypes types conses classes instances members selectors = { msd_funs :: !funs diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 25576f4..fa12fe9 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -2,7 +2,7 @@ implementation module overloading import StdEnv -import syntax, check, type, typesupport, utilities, unitype, predef, RWSDebug +import syntax, check, type, typesupport, utilities, unitype, predef, checktypes, RWSDebug :: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty @@ -161,10 +161,6 @@ where = (CA_Context tc, [{ tc & tc_var = tc_var } : new_contexts], special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error) -/* reduceContext :: !ClassDef !InstanceTree ![Type] !{# CommonDefs} !ClassInstanceInfo !*SpecialInstances ![LocalTypePatternVariable] - !*TypeHeaps !*Coercions !*PredefinedSymbols !*ErrorAdmin - -> *(![ReducedContext], !*SpecialInstances, ![LocalTypePatternVariable], !*TypeHeaps, !*Coercions, !*PredefinedSymbols, !*ErrorAdmin) -*/ reduce_context {tc_class=class_symb=:{glob_object={ds_index},glob_module},tc_types} defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error @@ -242,7 +238,7 @@ where adjust_type_attribute defs (TA type_cons1 cons_args1) (TA type_cons2 cons_args2) (ok, coercion_env, type_heaps) | type_cons1 == type_cons2 - # (ok, coercion_env) = fold2St adjust_attribute cons_args1 cons_args2 (ok, coercion_env) + # (ok, coercion_env) = fold2St (adjust_attribute type_cons1.type_name) cons_args1 cons_args2 (ok, coercion_env) = (ok, coercion_env, type_heaps) # (_, type1, type_heaps) = tryToExpandTypeSyn defs type_cons1 cons_args1 type_heaps (_, type2, type_heaps) = tryToExpandTypeSyn defs type_cons2 cons_args2 type_heaps @@ -250,9 +246,9 @@ where adjust_type_attribute _ _ _ state = state - adjust_attribute {at_attribute} {at_attribute = TA_Var _} state + adjust_attribute _ {at_attribute} {at_attribute = TA_Var _} state = state - adjust_attribute {at_attribute} {at_attribute = TA_Unique} (ok, coercion_env) + adjust_attribute type_cons {at_attribute} {at_attribute = TA_Unique} (ok, coercion_env) = case at_attribute of TA_Unique -> (ok, coercion_env) @@ -261,7 +257,7 @@ where -> (ok && succ, coercion_env) _ -> (False, coercion_env) - adjust_attribute {at_attribute} attr (ok, coercion_env) + adjust_attribute type_cons {at_attribute} attr (ok, coercion_env) = case at_attribute of TA_Multi -> (ok, coercion_env) @@ -315,7 +311,7 @@ where try_to_unbox (TB _) _ predef_symbols_type_heaps = (True, No, predef_symbols_type_heaps) try_to_unbox (TA type_symb=:{type_index={glob_module,glob_object},type_arity} type_args) defs (predef_symbols, type_heaps) - # {td_arity,td_rhs, td_args} = defs.[glob_module].com_type_defs.[glob_object] + # {td_arity,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object] = case td_rhs of RecordType _ -> (True, (Yes type_symb), (predef_symbols, type_heaps)) @@ -326,7 +322,7 @@ where is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols -> (unboxable, No, (predef_symbols, type_heaps)) SynType {at_type} - # (expanded_type, type_heaps) = expandTypeSyn td_args type_args at_type type_heaps + # (expanded_type, type_heaps) = expandTypeSyn td_attribute td_args type_args at_type type_heaps -> try_to_unbox expanded_type defs (predef_symbols, type_heaps) _ -> (False, No, (predef_symbols, type_heaps)) @@ -358,27 +354,6 @@ where ai_record = record } -/* - # (inst_members, si_array_instances, si_next_array_member_index) = add_array_instance record members si_next_array_member_index si_array_instances - = (inst_members, { special_instances & si_array_instances = si_array_instances, si_next_array_member_index = si_next_array_member_index }) - - add_array_instance :: !TypeSymbIdent !{# DefinedSymbol} !Index !u:[ArrayInstance] - -> (!{#DefinedSymbol}, !u:[ArrayInstance], !Index) - add_array_instance record members next_member_index instances=:[inst : insts] - # cmp = record =< inst.ai_record - | cmp == Equal - = (inst.ai_members, instances, next_member_index) - | cmp == Smaller - # ai_members = { { class_member & ds_index = next_inst_index } \\ - class_member <-: members & next_inst_index <- [next_member_index .. ]} - = (ai_members, [{ ai_members = ai_members, ai_record = record } : instances ], next_member_index + size members) - # (found_inst, insts, next_member_index) = add_array_instance record members next_member_index insts - = (found_inst, [inst : insts], next_member_index) - add_array_instance record members next_member_index [] - # ai_members = { { class_member & ds_index = next_inst_index } \\ - class_member <-: members & next_inst_index <- [next_member_index .. ]} - = (ai_members, [{ ai_members = ai_members, ai_record = record }], next_member_index + size members) -*/ reduce_TC_context type_code_class tc_type special_instances type_pattern_vars var_heap = reduce_tc_context type_code_class tc_type (special_instances, type_pattern_vars, var_heap) where @@ -440,29 +415,19 @@ addGlobalTCInstance type_of_TC (next_member_index, []) = (next_member_index, (inc next_member_index, [{ gtci_index = next_member_index, gtci_type = type_of_TC }])) tryToExpandTypeSyn defs cons_id=:{type_name,type_index={glob_object,glob_module}} type_args type_heaps - # {td_name,td_rhs,td_args} = defs.[glob_module].com_type_defs.[glob_object] + # {td_name,td_rhs,td_args,td_attribute} = defs.[glob_module].com_type_defs.[glob_object] = case td_rhs of SynType {at_type} - # (expanded_type, type_heaps) = expandTypeSyn td_args type_args at_type type_heaps + # (expanded_type, type_heaps) = expandTypeSyn td_attribute td_args type_args at_type type_heaps -> (True, expanded_type, type_heaps) _ -> (False, TA cons_id type_args, type_heaps) -where - is_synonym_type (SynType _) - = True - is_synonym_type type_rhs - = False -expandTypeSyn td_args type_args td_rhs type_heaps - # type_heaps = fold2St bind_var td_args type_args type_heaps +expandTypeSyn td_attribute td_args type_args td_rhs type_heaps + # type_heaps = bindTypeVarsAndAttributes td_attribute TA_Multi td_args type_args type_heaps (expanded_type, type_heaps) = substitute td_rhs type_heaps - = (expanded_type, type_heaps) -where - bind_var {atv_attribute = TA_Var {av_info_ptr}, atv_variable={tv_info_ptr}} {at_attribute, at_type} type_heaps=:{th_vars,th_attrs} - = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } - bind_var {atv_variable={tv_info_ptr}} {at_type} type_heaps=:{th_vars} - = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } - + = (expanded_type, clearBindingsOfTypeVarsAndAttributes td_attribute td_args type_heaps) + class match type :: !{# CommonDefs} !type !type !*TypeHeaps -> (!Bool, !*TypeHeaps) instance match AType @@ -557,13 +522,14 @@ where tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState -> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState) tryToSolveOverloading ocs defs instance_info coercion_env os - # (reduced_contexts, contexts, coercion_env, type_pattern_vars, os) = foldSt (reduce_contexts defs instance_info) ocs - ([], [], coercion_env, [], os) - (contexts, os_var_heap) = foldSt add_spec_contexts ocs (contexts, os.os_var_heap) - (contexts, os_type_heaps) = remove_sub_classes contexts os.os_type_heaps - (os_type_heaps, os_symbol_heap) = foldSt (convert_dictionaries defs contexts) reduced_contexts (os_type_heaps, os.os_symbol_heap) - = (contexts, coercion_env, type_pattern_vars, { os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap, os_var_heap = os_var_heap }) - + # (reduced_contexts, contexts, coercion_env, type_pattern_vars, os) = foldSt (reduce_contexts defs instance_info) ocs ([], [], coercion_env, [], os) + | os.os_error.ea_ok + # (contexts, os_var_heap) = foldSt add_spec_contexts ocs (contexts, os.os_var_heap) + (contexts, os_type_heaps) = remove_sub_classes contexts os.os_type_heaps + { hp_var_heap, hp_expression_heap, hp_type_heaps} = foldSt (convert_dictionaries defs contexts) reduced_contexts + { hp_var_heap = os_var_heap, hp_expression_heap = os.os_symbol_heap, hp_type_heaps = os_type_heaps} + = (contexts, coercion_env, type_pattern_vars, { os & os_type_heaps = hp_type_heaps, os_symbol_heap = hp_expression_heap, os_var_heap = hp_var_heap }) + = ([], coercion_env, type_pattern_vars, os) where reduce_contexts defs instance_info (opt_spec_contexts, expr_ptrs, pos, index) rc_state = foldSt (reduce_contexts_of_application defs instance_info) expr_ptrs rc_state @@ -620,8 +586,7 @@ where = context = [tc : context] - convert_dictionaries :: !{# CommonDefs } ![TypeContext] !(!SymbIdent,!ExprInfoPtr,![ClassApplication]) !(!*TypeHeaps, !*ExpressionHeap) - -> !(!*TypeHeaps, !*ExpressionHeap) + convert_dictionaries :: !{# CommonDefs } ![TypeContext] !(!SymbIdent,!ExprInfoPtr,![ClassApplication]) !*Heaps -> *Heaps convert_dictionaries defs contexts (oc_symbol, over_info_ptr, class_applications) heaps = convertOverloadedCall defs contexts oc_symbol over_info_ptr class_applications heaps @@ -630,18 +595,17 @@ selectFromDictionary dict_mod dict_index member_index defs { fs_name, fs_index } = rt_fields.[member_index] = { glob_module = dict_mod, glob_object = { ds_ident = fs_name, ds_index = fs_index, ds_arity = 1 }} -getDictionaryConstructor {glob_module, glob_object = {ds_ident,ds_index}} defs +getDictionaryTypeAndConstructor {glob_module, glob_object = {ds_ident,ds_index}} defs # {class_dictionary} = defs.[glob_module].com_class_defs.[ds_index] (RecordType {rt_constructor}) = defs.[glob_module].com_type_defs.[class_dictionary.ds_index].td_rhs - = rt_constructor + = (class_dictionary, rt_constructor) -convertOverloadedCall :: !{#CommonDefs} ![TypeContext] !SymbIdent !ExprInfoPtr ![ClassApplication] !(!*TypeHeaps, !*ExpressionHeap) - -> (!*TypeHeaps, !*ExpressionHeap) +convertOverloadedCall :: !{#CommonDefs} ![TypeContext] !SymbIdent !ExprInfoPtr ![ClassApplication] !*Heaps -> *Heaps convertOverloadedCall defs contexts {symb_name,symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} expr_ptr [class_appl:class_appls] heaps # mem_def = defs.[glob_module].com_member_defs.[glob_object] (class_exprs, heaps) = convertClassApplsToExpressions defs contexts class_appls heaps - (inst_expr, (type_heaps, expr_heap)) = adjust_member_application defs contexts mem_def symb_arity class_appl class_exprs heaps - = (type_heaps, expr_heap <:= (expr_ptr, inst_expr)) + (inst_expr, heaps) = adjust_member_application defs contexts mem_def symb_arity class_appl class_exprs heaps + = { heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_ptr, inst_expr)} where adjust_member_application defs contexts {me_symb,me_offset,me_class} symb_arity (CA_Instance red_contexts) class_exprs heaps # ({glob_module,glob_object}, red_contexts) = find_instance_of_member me_class me_offset red_contexts @@ -649,12 +613,12 @@ where class_exprs = exprs ++ class_exprs = (EI_Instance { glob_module = glob_module, glob_object = { ds_ident = me_symb, ds_arity = length class_exprs, ds_index = glob_object }} class_exprs, heaps) - adjust_member_application defs contexts {me_symb,me_offset,me_class={glob_module,glob_object}} symb_arity (CA_Context tc) class_exprs (type_heaps, expr_heap) - # (class_context, address, type_heaps) = determineContextAddress contexts defs tc type_heaps + adjust_member_application defs contexts {me_symb,me_offset,me_class={glob_module,glob_object}} symb_arity (CA_Context tc) class_exprs heaps=:{hp_type_heaps} + # (class_context, address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps {class_dictionary={ds_index}} = defs.[glob_module].com_class_defs.[glob_object] selector = selectFromDictionary glob_module ds_index me_offset defs - = (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) class_context.tc_var class_exprs, (type_heaps, expr_heap)) - + = (EI_Selection (generateClassSelection address [RecordSelection selector me_offset]) class_context.tc_var class_exprs, + { heaps & hp_type_heaps = hp_type_heaps } ) adjust_member_application defs contexts _ _ (CA_GlobalTypeCode {tci_index,tci_contexts}) _ heaps # (exprs, heaps) = convertClassApplsToExpressions defs contexts tci_contexts heaps = (EI_TypeCode (TCE_Constructor tci_index (map expressionToTypeCodeExpression exprs)), heaps) @@ -671,11 +635,11 @@ where find_instance_of_member_in_constraints me_class me_offset [] = abort "Error in module overloading: find_instance_of_member_in_constraints\n" convertOverloadedCall defs contexts {symb_kind = SK_TypeCode} expr_info_ptr class_appls heaps - # (class_expressions, (type_heaps, expr_heap)) = convertClassApplsToExpressions defs contexts class_appls heaps - = (type_heaps, expr_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions))) + # (class_expressions, heaps) = convertClassApplsToExpressions defs contexts class_appls heaps + = { heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_TypeCodes (map expressionToTypeCodeExpression class_expressions))} convertOverloadedCall defs contexts {symb_name} expr_info_ptr appls heaps - # (class_expressions, (type_heaps, expr_heap)) = convertClassApplsToExpressions defs contexts appls heaps - = (type_heaps, expr_heap <:= (expr_info_ptr, EI_Context class_expressions)) + # (class_expressions, heaps) = convertClassApplsToExpressions defs contexts appls heaps + = { heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_Context class_expressions)} expressionToTypeCodeExpression (TypeCodeExpression texpr) = texpr @@ -683,57 +647,86 @@ expressionToTypeCodeExpression (Var {var_info_ptr}) = TCE_Var var_info_ptr generateClassSelection address last_selectors = mapAppend (\(off_set,selector) -> RecordSelection selector off_set) address last_selectors - -convertClassApplsToExpressions defs contexts cl_appls heaps + + +AttributedType type :== { at_attribute = TA_Multi, at_annotation = AN_None, at_type = type } + + +convertClassApplsToExpressions defs contexts cl_appls heaps = mapSt (convert_class_appl_to_expression defs contexts) cl_appls heaps where - convert_class_appl_to_expression defs contexts (CA_Instance {rcs_class_context,rcs_constraints_contexts}) heaps - # (class_symb, class_members, instance_types, heaps) - = convert_reduced_context_to_expression defs contexts rcs_class_context heaps - (members_of_constraints, (type_heaps, expr_heap)) - = convert_list_of_reduced_contexts_to_expressions defs contexts rcs_constraints_contexts heaps - {ds_ident,ds_index,ds_arity} = getDictionaryConstructor class_symb defs - record_symbol = { symb_name = ds_ident, symb_kind = SK_Constructor {glob_module = class_symb.glob_module, glob_object = ds_index}, symb_arity = ds_arity } - (app_info_ptr, expr_heap) = newPtr (EI_ClassTypes instance_types) expr_heap - = (App { app_symb = record_symbol, app_args = class_members ++ members_of_constraints, app_info_ptr = app_info_ptr }, (type_heaps, expr_heap)) - convert_class_appl_to_expression defs contexts (CA_Context tc) (type_heaps, expr_heap) - # (class_context, context_address, type_heaps) = determineContextAddress contexts defs tc type_heaps + convert_class_appl_to_expression defs contexts (CA_Instance rcs) heaps + = convert_reduced_contexts_to_expression defs contexts rcs heaps + convert_class_appl_to_expression defs contexts (CA_Context tc) heaps=:{hp_type_heaps} + # (class_context, context_address, hp_type_heaps) = determineContextAddress contexts defs tc hp_type_heaps | isEmpty context_address - = (ClassVariable class_context.tc_var, (type_heaps, expr_heap)) - = (Selection No (ClassVariable class_context.tc_var) (generateClassSelection context_address []), (type_heaps, expr_heap)) + = (ClassVariable class_context.tc_var, { heaps & hp_type_heaps = hp_type_heaps }) + = (Selection No (ClassVariable class_context.tc_var) (generateClassSelection context_address []), { heaps & hp_type_heaps = hp_type_heaps }) convert_class_appl_to_expression defs contexts (CA_LocalTypeCode new_var_ptr) heaps = (TypeCodeExpression (TCE_Var new_var_ptr), heaps) convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_index,tci_contexts}) heaps # (exprs, heaps) = convertClassApplsToExpressions defs contexts tci_contexts heaps = (TypeCodeExpression (TCE_Constructor tci_index (map expressionToTypeCodeExpression exprs)), heaps) - - convert_reduced_context_to_expression defs contexts {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts, rc_types} heaps - # (expressions, heaps) = convertClassApplsToExpressions defs contexts rc_red_contexts heaps - members = build_class_members 0 rc_inst_members rc_inst_module expressions (length expressions) - = (rc_class, members, rc_types, heaps) - where - build_class_members mem_offset ins_members mod_index class_arguments arity - | mem_offset == size ins_members - = [] - # expressions = build_class_members (inc mem_offset) ins_members mod_index class_arguments arity - {ds_ident,ds_index} = ins_members.[mem_offset] - = [ App { app_symb = { symb_name = ds_ident, symb_kind = SK_Function { glob_object = ds_index, glob_module = mod_index }, - symb_arity = arity }, app_args = class_arguments, app_info_ptr = nilPtr } : expressions ] - convert_list_of_reduced_contexts_to_expressions defs contexts list_of_rcs heaps - = mapSt (convert_reduced_contexts_to_expressions defs contexts) list_of_rcs heaps - - convert_reduced_contexts_to_expressions defs contexts {rcs_class_context,rcs_constraints_contexts} heaps - # (class_symb, rc_exprs, instance_types, heaps) - = convert_reduced_context_to_expression defs contexts rcs_class_context heaps - (rcs_exprs, (type_heaps, expr_heap)) - = convert_list_of_reduced_contexts_to_expressions defs contexts rcs_constraints_contexts heaps - {ds_ident,ds_index,ds_arity} = getDictionaryConstructor class_symb defs - record_symbol = { symb_name = ds_ident, symb_kind = SK_Constructor {glob_module = class_symb.glob_module, glob_object = ds_index}, symb_arity = ds_arity } - (app_info_ptr, expr_heap) = newPtr (EI_ClassTypes instance_types) expr_heap - rc_record = App { app_symb = record_symbol, app_args = rc_exprs ++ rcs_exprs, app_info_ptr = app_info_ptr } - = (rc_record, (type_heaps, expr_heap)) - + convert_reduced_contexts_to_expression defs contexts {rcs_class_context,rcs_constraints_contexts} heaps + # (rcs_exprs, heaps) = mapSt (convert_reduced_contexts_to_expression defs contexts) rcs_constraints_contexts heaps + = convert_reduced_context_to_expression defs contexts rcs_class_context rcs_exprs heaps + where + convert_reduced_context_to_expression defs contexts {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts, rc_types} dictionary_args heaps + # (expressions, heaps) = convertClassApplsToExpressions defs contexts rc_red_contexts heaps + context_size = length expressions + | size rc_inst_members > 1 && context_size > 0 + # (let_binds, let_types, rev_dicts, hp_var_heap, hp_expression_heap) + = foldSt (bind_shared_dictionary (size rc_inst_members)) expressions ([], [], [], heaps.hp_var_heap, heaps.hp_expression_heap) + dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module (reverse rev_dicts) context_size dictionary_args + (dict_expr, hp_expression_heap) = build_dictionary rc_class rc_types dictionary_args defs hp_expression_heap + | isEmpty let_binds + = (dict_expr, { heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }) + # (let_info_ptr, hp_expression_heap) = newPtr (EI_LetType let_types) hp_expression_heap + = (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = dict_expr, let_info_ptr = let_info_ptr }, + { heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap }) + # dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module expressions context_size dictionary_args + (dict_expr, hp_expression_heap) = build_dictionary rc_class rc_types dictionary_args defs heaps.hp_expression_heap + = (dict_expr, { heaps & hp_expression_heap = hp_expression_heap }) + + build_class_members mem_offset ins_members mod_index class_arguments arity dictionary_args + | mem_offset == 0 + = dictionary_args + # mem_offset = dec mem_offset + {ds_ident,ds_index} = ins_members.[mem_offset] + mem_expr = App { app_symb = { + symb_name = ds_ident, + symb_kind = SK_Function { glob_object = ds_index, glob_module = mod_index }, + symb_arity = arity }, + app_args = class_arguments, + app_info_ptr = nilPtr } + = build_class_members mem_offset ins_members mod_index class_arguments arity [ mem_expr : dictionary_args ] + + build_dictionary class_symbol instance_types dictionary_args defs expr_heap + # (dict_type, dict_cons) = getDictionaryTypeAndConstructor class_symbol defs + record_symbol = { symb_name = dict_cons.ds_ident, + symb_kind = SK_Constructor {glob_module = class_symbol.glob_module, glob_object = dict_cons.ds_index}, + symb_arity = dict_cons.ds_arity } + dict_type_symbol = MakeTypeSymbIdent {glob_module = class_symbol.glob_module, glob_object = dict_type.ds_index} dict_type.ds_ident dict_type.ds_arity + class_type = TA dict_type_symbol [ AttributedType type \\ type <- instance_types ] + (app_info_ptr, expr_heap) = newPtr (EI_DictionaryType class_type) expr_heap + rc_record = App { app_symb = record_symbol, app_args = dictionary_args, app_info_ptr = app_info_ptr } + = (rc_record, expr_heap) + + bind_shared_dictionary nr_of_members dict=:(Let {let_expr=App {app_symb={symb_name}, app_info_ptr}}) (binds, types, rev_dicts, var_heap, expr_heap) + # (EI_DictionaryType class_type, expr_heap) = readPtr app_info_ptr expr_heap + (var_info_ptr, var_heap) = newPtr VI_Empty var_heap + fv = { fv_name = symb_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = nr_of_members } + var = { var_name = symb_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } + = ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) + bind_shared_dictionary nr_of_members dict=:(App {app_symb={symb_name}, app_info_ptr}) (binds, types, rev_dicts, var_heap, expr_heap) + # (EI_DictionaryType class_type, expr_heap) = readPtr app_info_ptr expr_heap + (var_info_ptr, var_heap) = newPtr VI_Empty var_heap + fv = { fv_name = symb_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = nr_of_members } + var = { var_name = symb_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr } + = ([{bind_src = dict, bind_dst = fv} : binds ], [ AttributedType class_type : types ], [Var var : rev_dicts], var_heap, expr_heap) + bind_shared_dictionary nr_of_members dict (binds, types, rev_dicts, var_heap, expr_heap) + = (binds, types, [dict : rev_dicts], var_heap, expr_heap) determineContextAddress :: ![TypeContext] !{#CommonDefs} !TypeContext !*TypeHeaps -> (!TypeContext, ![(Int, Global DefinedSymbol)], !*TypeHeaps) @@ -803,7 +796,7 @@ where = convertDynamicTypes fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap) (TransformedBody tb) = fun_body (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error}) = updateExpression fi_group_index tb.tb_rhs - { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs, + { ui_instance_calls = [], ui_symbol_heap = symbol_heap, ui_fun_defs = fun_defs, ui_local_vars = [], ui_fun_env = fun_env, ui_var_heap = var_heap, ui_error = error } fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs}} = update_dynamics funs type_pattern_vars { ui_fun_defs & [fun] = fun_def } ui_fun_env ui_symbol_heap type_code_info ui_var_heap ui_error @@ -825,12 +818,12 @@ where // ---> ("remove_overloaded_function", fun_symb, st_context)) error = setErrorAdmin (newPosition fun_symb fun_pos) error (type_code_info, symbol_heap, type_pattern_vars, var_heap) = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap) - (tb_rhs, {ui_instance_calls, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error}) - = updateExpression fun_info.fi_group_index tb_rhs { ui_instance_calls = [], ui_symbol_heap = symbol_heap, + (tb_rhs, {ui_instance_calls, ui_local_vars, ui_symbol_heap, ui_var_heap, ui_fun_defs, ui_fun_env, ui_error}) + = updateExpression fun_info.fi_group_index tb_rhs { ui_instance_calls = [], ui_local_vars = fun_info.fi_local_vars, ui_symbol_heap = symbol_heap, ui_var_heap = var_heap, ui_fun_defs = fun_defs, ui_fun_env = fun_env, ui_error = error } (tb_args, var_heap) = foldSt retrieve_class_argument rev_variables (tb_args, ui_var_heap) - fun_def = { fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, - fun_arity = length tb_args, fun_info = { fun_info & fi_calls = fun_info.fi_calls ++ ui_instance_calls } } + fun_def = { fun_def & fun_body = TransformedBody {tb_args = tb_args, tb_rhs = tb_rhs}, fun_arity = length tb_args, + fun_info = { fun_info & fi_calls = fun_info.fi_calls ++ ui_instance_calls, fi_local_vars = ui_local_vars } } = ({ ui_fun_defs & [fun_index] = fun_def }, ui_fun_env, ui_symbol_heap, type_code_info, var_heap, ui_error) // ---> ("remove_overloaded_function", fun_symb, tb_args, tb_rhs) @@ -955,6 +948,7 @@ where :: UpdateInfo = { ui_instance_calls :: ![FunCall] + , ui_local_vars :: ![FreeVar] , ui_symbol_heap :: !.ExpressionHeap , ui_var_heap :: !.VarHeap , ui_fun_defs :: !.{# FunDef} @@ -971,7 +965,8 @@ where # (app_args, ui) = updateExpression group_index app_args ui | isNilPtr app_info_ptr = (App { app & app_args = app_args }, ui) - #! symb_info = sreadPtr app_info_ptr ui.ui_symbol_heap + # (symb_info, ui_symbol_heap) = readPtr app_info_ptr ui.ui_symbol_heap + ui = { ui & ui_symbol_heap = ui_symbol_heap } = case symb_info of EI_Empty #! fun_index = get_recursive_fun_index group_index symb_kind ui.ui_fun_defs @@ -1004,8 +999,8 @@ where select_expr = Selection No (Var { var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr }) selectors | isEmpty all_args -> (select_expr, { ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) - -> (select_expr @ all_args, examine_calls context_args { ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) - + -> (select_expr @ all_args, examine_calls context_args + { ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) where build_context_arg symb {tc_var} (var_heap, error) @@ -1020,10 +1015,11 @@ where _ -> abort "build_context_arg (overloading.icl)" + get_recursive_fun_index :: !Index !SymbKind !{# FunDef} -> Index get_recursive_fun_index group_index (SK_Function {glob_module,glob_object}) fun_defs | glob_module == cIclModIndex - # ({fun_info={fi_group_index}, fun_index}, fun_defs) = fun_defs![glob_object] - | fi_group_index == group_index + # {fun_info, fun_index} = fun_defs.[glob_object] + | fun_info.fi_group_index == group_index = fun_index = NoIndex = NoIndex @@ -1061,10 +1057,18 @@ where where examine_calls_in_expr (App {app_symb = {symb_name,symb_kind}, app_args}) ui = examine_calls app_args (examine_application symb_kind ui) + examine_calls_in_expr (Let {let_expr,let_lazy_binds}) ui + # ui = examine_calls_in_expr let_expr ui + = foldSt (examine_calls_bind) let_lazy_binds (examine_calls_in_expr let_expr ui) examine_calls_in_expr _ ui = ui + + examine_calls_bind {bind_src,bind_dst} ui=:{ui_local_vars} + = examine_calls_in_expr bind_src { ui & ui_local_vars = [bind_dst : ui_local_vars ]} + examine_calls [] ui = ui + updateExpression group_index (expr @ exprs) ui @@ -1104,13 +1108,13 @@ where updateExpression group_index expr ui = (expr, ui) -instance updateExpression Bind a b | updateExpression a +instance updateExpression (Bind a b) | updateExpression a where updateExpression group_index bind=:{bind_src} ui # (bind_src, ui) = updateExpression group_index bind_src ui = ({bind & bind_src = bind_src }, ui) -instance updateExpression Optional a | updateExpression a +instance updateExpression (Optional a) | updateExpression a where updateExpression group_index (Yes x) ui # (x, ui) = updateExpression group_index x ui @@ -1146,7 +1150,8 @@ instance updateExpression Selection where updateExpression group_index (ArraySelection selector=:{glob_object={ds_ident}} expr_ptr index_expr) ui # (index_expr, ui) = updateExpression group_index index_expr ui - #! symb_info = sreadPtr expr_ptr ui.ui_symbol_heap + (symb_info, ui_symbol_heap) = readPtr expr_ptr ui.ui_symbol_heap + ui = { ui & ui_symbol_heap = ui_symbol_heap } = case symb_info of EI_Instance array_select [] -> (ArraySelection array_select expr_ptr index_expr, ui) diff --git a/frontend/parse.icl b/frontend/parse.icl index 94d18a0..0617577 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -236,12 +236,13 @@ wantModule :: !Bool !Ident !*HashTable !*File !SearchPaths !*PredefinedSymbols ! wantModule iclmodule file_id=:{id_name} hash_table error searchPaths pre_def_symbols files # file_name = if iclmodule (id_name +++ ".icl") (id_name +++ ".dcl") = case openScanner file_name searchPaths files of - (Yes scanState, files) -> initModule file_name scanState pre_def_symbols files + (Yes scanState, files) -> initModule file_name scanState hash_table error pre_def_symbols files (No , files) -> let mod = { mod_name = file_id, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in (False, mod, hash_table, error <<< "Could not open: " <<< file_name <<< "\n", pre_def_symbols, files) where - initModule :: String ScanState !*PredefinedSymbols *Files -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) - initModule file_name scanState pre_def_symbols files + initModule :: String ScanState !*HashTable !*File !*PredefinedSymbols *Files + -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) + initModule file_name scanState hash_table error pre_def_symbols files # (succ, mod_type, mod_name, scanState) = try_module_header iclmodule scanState | succ # pState = { ps_scanState = scanState diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 29cea4f..c401606 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -22,7 +22,7 @@ SelectPredefinedIdents predefs | i == PD_NrOfPredefSymbols = (idents, symbols) // otherwise - #! symbol = symbols.[i] + # (symbol, symbols) = symbols![i] = selectIdents (i+1) {idents & [i] = symbol.pds_ident} symbols predef :: Int PredefinedIdents -> ParsedExpr @@ -228,7 +228,7 @@ where # (from_expr, fun_defs, ca) = collectFunctions from_expr ca = (SQ_From from_expr, fun_defs, ca) -instance collectFunctions Bind a b | collectFunctions a & collectFunctions b +instance collectFunctions (Bind a b) | collectFunctions a & collectFunctions b where collectFunctions bind=:{bind_src,bind_dst} ca # ((bind_src,bind_dst), fun_defs, ca) = collectFunctions (bind_src,bind_dst) ca @@ -294,7 +294,7 @@ where = (locals, [], ca) // ... RWS -instance collectFunctions NodeDef a | collectFunctions a +instance collectFunctions (NodeDef a) | collectFunctions a where collectFunctions node_def=:{nd_dst,nd_alts,nd_locals} ca # ((nd_dst,(nd_alts,nd_locals)), fun_defs, ca) = collectFunctions (nd_dst,(nd_alts,nd_locals)) ca diff --git a/frontend/predef.icl b/frontend/predef.icl index aa1468f..2ae1a83 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -236,15 +236,15 @@ where | nr_of_vars == 0 = (type_vars, pre_def_symbols) # nr_of_vars = dec nr_of_vars - #! var_id = pre_def_symbols.[PD_TypeVar_a0 + nr_of_vars] + # (var_id, pre_def_symbols) = pre_def_symbols![PD_TypeVar_a0 + nr_of_vars] = make_type_vars nr_of_vars [MakeTypeVar var_id.pds_ident : type_vars] pre_def_symbols new_defined_symbol symbol_index arity ds_index pre_def_symbols - #! ds_ident = pre_def_symbols.[symbol_index] + # (ds_ident, pre_def_symbols) = pre_def_symbols![symbol_index] = ({ ds_ident = ds_ident.pds_ident, ds_arity = 2, ds_index = ds_index }, pre_def_symbols) make_type_def type_cons_index type_vars type_rhs pre_def_symbols - #! type_ident = pre_def_symbols.[type_cons_index] + # (type_ident, pre_def_symbols) = pre_def_symbols![type_cons_index] = (MakeTypeDef type_ident.pds_ident (map (\tv -> MakeAttributedTypeVar tv) type_vars) type_rhs TA_None [] NoPos, pre_def_symbols) make_TC_class_def pre_def_symbols diff --git a/frontend/refmark.dcl b/frontend/refmark.dcl index 0b8a1a3..1ac9df4 100644 --- a/frontend/refmark.dcl +++ b/frontend/refmark.dcl @@ -2,5 +2,5 @@ definition module refmark import syntax, checksupport, unitype -makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !{# CommonDefs } !*VarHeap !*ExpressionHeap !*ErrorAdmin - -> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) +makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !v:TypeDefInfos !*VarHeap !*ExpressionHeap !*ErrorAdmin + -> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !v:TypeDefInfos, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) diff --git a/frontend/refmark.icl b/frontend/refmark.icl index abe40c7..f528fa6 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -23,7 +23,7 @@ addSelection var_expr_ptr sel [] = [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] } ] addSelection var_expr_ptr sel sels=:[selection=:{ su_field,su_multiply,su_uniquely } : selections] | sel == su_field - = [ { selection & su_multiply = su_multiply ++ [var_expr_ptr : su_multiply], su_uniquely = [] } : selections ] + = [ { selection & su_multiply = su_multiply ++ [var_expr_ptr : su_uniquely], su_uniquely = [] } : selections ] | sel < su_field = [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] } : sels ] = [ selection : addSelection var_expr_ptr sel selections ] @@ -72,20 +72,23 @@ where rcu_selectively = [], rcu_uniquely = [] } -> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } ) +refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var_name var_info_ptr var_expr_ptr var_heap + # occ_ref_count = adjustRefCount sel var_occ.occ_ref_count var_expr_ptr + = case var_occ.occ_bind of // ---> (var_name,var_expr_ptr,occ_ref_count,var_occ.occ_ref_count) of + OB_OpenLet let_expr + # var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr }) + -> refMark free_vars sel let_expr var_heap + OB_Pattern used_pattern_vars occ_bind + -> markPatternVariables sel used_pattern_vars (var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })) + _ + -> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count }) + instance refMark BoundVar where refMark free_vars sel {var_name,var_expr_ptr,var_info_ptr} var_heap - # (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap - occ_ref_count = adjustRefCount sel var_occ.occ_ref_count var_expr_ptr - = case var_occ.occ_bind of - OB_OpenLet let_expr - # var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr }) - -> refMark free_vars sel let_expr var_heap - OB_Pattern used_pattern_vars occ_bind - -> markPatternVariables sel used_pattern_vars (var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })) - _ - -> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count }) + # (var_occ, var_heap) = readPtr var_info_ptr var_heap + = refMarkOfVariable free_vars sel var_occ var_name var_info_ptr var_expr_ptr var_heap instance refMark Expression where @@ -116,8 +119,7 @@ where = foldr bind_is_observing (True, var_heap) binds where bind_is_observing {bind_dst={fv_info_ptr}} (observe, var_heap) - #! info = sreadPtr fv_info_ptr var_heap - # (VI_Occurrence {occ_observing}) = info + # (VI_Occurrence {occ_observing}, var_heap) = readPtr fv_info_ptr var_heap = (occ_observing && observe, var_heap) let_combine free_vars var_heap @@ -156,8 +158,9 @@ where ref_mark_of_fields field_nr free_vars [] var var_heap = var_heap - ref_mark_of_fields field_nr free_vars [{bind_src = EE} : fields] var var_heap - # var_heap = refMark free_vars field_nr var var_heap + ref_mark_of_fields field_nr free_vars [{bind_src = NoBind expr_ptr} : fields] var=:{var_name,var_info_ptr} var_heap + # (var_occ, var_heap) = readPtr var_info_ptr var_heap + var_heap = refMarkOfVariable free_vars field_nr var_occ var_name var_info_ptr expr_ptr var_heap = ref_mark_of_fields (inc field_nr) free_vars fields var var_heap ref_mark_of_fields field_nr free_vars [{bind_src} : fields] var var_heap # var_heap = refMark free_vars NotASelector bind_src var_heap @@ -179,7 +182,7 @@ where isUsed RC_Unused = False isUsed _ = True -instance refMark Bind a b | refMark a +instance refMark (Bind a b) | refMark a where refMark free_vars sel {bind_src} var_heap = refMark free_vars NotASelector bind_src var_heap @@ -211,20 +214,6 @@ where collect_used_vars [] arg_nr collected_vars = collected_vars -markVariables variables var_heap - = foldSt markVariable variables var_heap - -markVariable {fv_name,fv_info_ptr} var_heap - # (VI_Occurrence var_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap - = case occ_ref_count of - RC_Unused - -> var_heap - RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively} - # rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ rcu_multiply) - -> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & - occ_ref_count = RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] }}) -// ---> ("markVariable", fv_name, rcu_multiply) - collectLocalLetVars free_vars var_heap = foldSt (foldSt collect_local_let_var) free_vars ([], var_heap) where @@ -375,8 +364,7 @@ parCombine free_vars var_heap = foldSt (foldSt (par_combine)) free_vars var_heap where par_combine {fv_info_ptr} var_heap - #! old_info = sreadPtr fv_info_ptr var_heap - # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous=[prev_ref_count:prev_counts]}) = old_info + # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous=[prev_ref_count:prev_counts]}, var_heap) = readPtr fv_info_ptr var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = parCombineRefCount occ_ref_count prev_ref_count , occ_previous = prev_counts }) @@ -385,8 +373,7 @@ caseCombine do_par_combine free_vars var_heap depth = foldSt (foldSt (case_combine do_par_combine depth)) free_vars var_heap where case_combine do_par_combine depth {fv_name,fv_info_ptr} var_heap - #! old_info = sreadPtr fv_info_ptr var_heap - # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}) = old_info + # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap (occ_ref_count, occ_previous) = case_combine_ref_counts do_par_combine occ_ref_count occ_previous (dec depth) = var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = occ_ref_count , occ_previous = occ_previous }) // ---> ("case_combine", fv_name, occ_ref_count) @@ -479,40 +466,41 @@ seqCombineRefCount (RC_Used sec_ref) (RC_Used prim_ref) make_primary_selections_on_unique [] = [] -makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !{# CommonDefs } !*VarHeap !*ExpressionHeap !*ErrorAdmin - -> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) -makeSharedReferencesNonUnique [] fun_defs coercion_env subst defs var_heap expr_heap error - = (fun_defs, coercion_env, subst, var_heap, expr_heap, error) -makeSharedReferencesNonUnique [fun : funs] fun_defs coercion_env subst defs var_heap expr_heap error - #! fun_def = fun_defs.[fun] - # (coercion_env, subst, var_heap, expr_heap, error) - = make_shared_references_of_funcion_non_unique fun_def coercion_env subst defs var_heap expr_heap error - = makeSharedReferencesNonUnique funs fun_defs coercion_env subst defs var_heap expr_heap error +makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !v:TypeDefInfos !*VarHeap !*ExpressionHeap !*ErrorAdmin + -> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !v:TypeDefInfos, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) +makeSharedReferencesNonUnique [] fun_defs coercion_env subst type_def_infos var_heap expr_heap error + = (fun_defs, coercion_env, subst, type_def_infos, var_heap, expr_heap, error) +makeSharedReferencesNonUnique [fun : funs] fun_defs coercion_env subst type_def_infos var_heap expr_heap error + # (fun_def, fun_defs) = fun_defs![fun] + # (coercion_env, subst, type_def_infos, var_heap, expr_heap, error) + = make_shared_references_of_funcion_non_unique fun_def coercion_env subst type_def_infos var_heap expr_heap error + = makeSharedReferencesNonUnique funs fun_defs coercion_env subst type_def_infos var_heap expr_heap error where make_shared_references_of_funcion_non_unique {fun_symb, fun_pos, fun_body = TransformedBody {tb_args,tb_rhs},fun_info={fi_local_vars}} - coercion_env subst defs var_heap expr_heap error + coercion_env subst type_def_infos var_heap expr_heap error # variables = tb_args ++ fi_local_vars - (subst, var_heap, expr_heap) = clear_occurrences variables subst defs var_heap expr_heap - var_heap = refMark [tb_args] NotASelector tb_rhs var_heap + (subst, type_def_infos, var_heap, expr_heap) = clear_occurrences variables subst type_def_infos var_heap expr_heap + var_heap = refMark [tb_args] NotASelector tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb, tb_rhs)) var_heap + //tb_rhs var_heap // position = newPosition fun_symb fun_pos (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env var_heap expr_heap (setErrorAdmin position error) - = (coercion_env, subst, var_heap, expr_heap, error) + = (coercion_env, subst, type_def_infos, var_heap, expr_heap, error) where - clear_occurrences vars subst defs var_heap expr_heap - = foldSt (initial_occurrence defs) vars (subst, var_heap, expr_heap) + clear_occurrences vars subst type_def_infos var_heap expr_heap + = foldSt initial_occurrence vars (subst, type_def_infos, var_heap, expr_heap) where - initial_occurrence defs {fv_name,fv_info_ptr} (subst, var_heap, expr_heap) + initial_occurrence {fv_name,fv_info_ptr} (subst, type_def_infos, var_heap, expr_heap) # (VI_Type {at_type,at_attribute}, var_heap) = readPtr fv_info_ptr var_heap = case at_type of TempV tv_number - #! is_oberving = hasObservingType subst.[tv_number] defs - -> (subst, var_heap <:= (fv_info_ptr, + #! is_oberving = has_observing_type type_def_infos subst.[tv_number] + -> (subst, type_def_infos, var_heap <:= (fv_info_ptr, VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], occ_observing = is_oberving, occ_bind = OB_Empty }), expr_heap) _ - -> (subst, var_heap <:= (fv_info_ptr, + -> (subst, type_def_infos, var_heap <:= (fv_info_ptr, VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], occ_observing = False, occ_bind = OB_Empty }), expr_heap) @@ -521,12 +509,11 @@ where = foldl make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) vars make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) fv=:{fv_name,fv_info_ptr} - #! var_info = sreadPtr fv_info_ptr var_heap - # (VI_Occurrence occ) = var_info + # (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap = case occ.occ_ref_count of RC_Used {rcu_multiply,rcu_selectively} # (coercion_env, expr_heap, error) = make_shared_occurrences_non_unique fv rcu_multiply (coercion_env, expr_heap, error) -// (coercion_env, expr_heap, error) = foldSt (make_selection_non_unique fv) rcu_selectively (coercion_env, expr_heap, error) + (coercion_env, expr_heap, error) = foldSt (make_selection_non_unique fv) rcu_selectively (coercion_env, expr_heap, error) -> (coercion_env, var_heap, expr_heap, error) _ -> (coercion_env, var_heap, expr_heap, error) @@ -537,29 +524,30 @@ where make_shared_occurrence_non_unique free_var var_expr_ptr (coercion_env, expr_heap, error) | isNilPtr var_expr_ptr = (coercion_env, expr_heap, error) - #! expr_info = sreadPtr var_expr_ptr expr_heap - # (EI_Attribute sa_attr_nr) = expr_info - # (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env - | succ -// ---> ("make_shared_occurrence_non_unique", free_var) - = (coercion_env, expr_heap, error) - = (coercion_env, expr_heap, uniquenessError { cp_expression = FreeVar free_var} " demanded attribute cannot be offered by shared object" error) - + # (expr_info, expr_heap) = readPtr var_expr_ptr expr_heap + = case expr_info of + EI_Attribute sa_attr_nr + # (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env + | succ + ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr) + -> (coercion_env, expr_heap, error) + -> (coercion_env, expr_heap, uniquenessError { cp_expression = FreeVar free_var} " demanded attribute cannot be offered by shared object" error) + _ + -> abort ("make_shared_occurrence_non_unique" ---> ((free_var, var_expr_ptr) <<- expr_info)) make_selection_non_unique fv {su_multiply} cee = make_shared_occurrences_non_unique fv su_multiply cee -hasObservingType TE defs - = True -hasObservingType (TB basic_type) defs - = True -hasObservingType (TempV var_number) defs - = True -hasObservingType (TA {type_index = {glob_object,glob_module}} type_args) defs - # {td_properties} = defs.[glob_module].com_type_defs.[glob_object] - = True -// = foldSt (\ {at_type} ok -> ok && hasObservingType at_type defs) type_args (td_properties bitand cIsHyperStrict <> 0) -hasObservingType type defs - = False + has_observing_type type_def_infos TE + = True + has_observing_type type_def_infos (TB basic_type) + = True + has_observing_type type_def_infos (TempV var_number) + = True + has_observing_type type_def_infos (TA {type_index = {glob_object,glob_module}} type_args) + # {tdi_properties} = type_def_infos.[glob_module].[glob_object] + = foldSt (\ {at_type} ok -> ok && has_observing_type type_def_infos at_type) type_args (tdi_properties bitand cIsHyperStrict <> 0) + has_observing_type type_def_infos type + = False instance <<< ReferenceCount @@ -573,19 +561,8 @@ where -instance <<< Ptr v +instance <<< (Ptr v) where (<<<) file ptr = file <<< '[' <<< ptrToInt ptr <<< ']' -import Debug - -show - = debugShowWithOptions [DebugMaxChars 80, DebugMaxDepth 5] - -instance <<< VarInfo -where - (<<<) file vi - = file <<< show vi - - diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index a908829..41680bb 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -40,7 +40,7 @@ instance toString Ident | STE_TypeVariable !TypeVarInfoPtr | STE_TypeAttribute !AttrVarInfoPtr | STE_BoundTypeVariable !STE_BoundTypeVariable - | STE_BoundType !AType +// | STE_BoundType !AType | STE_Imported !STE_Kind !Index | STE_DclFunction | STE_Module !(Module (CollectedDefinitions ClassInstance IndexRange)) @@ -332,6 +332,7 @@ cIsNonCoercible :== 2 , tdi_group_nr :: !Int , tdi_group_vars :: ![Int] , tdi_cons_vars :: ![Int] + , tdi_tmp_index :: !Int , tdi_classification :: !TypeClassification } @@ -459,7 +460,7 @@ cIsALocalVar :== False VI_Pattern !AuxiliaryPattern | VI_Default !Int | VI_Indirection !Int | /* used during conversion of dynamics; the Int indiacted the refenrence count */ VI_Body !SymbIdent !TransformedBody ![FreeVar] | /* used during fusion */ - VI_Dictionary !SymbIdent ![Expression] ![Type] | /* used during fusion */ + VI_Dictionary !SymbIdent ![Expression] !Type | /* used during fusion */ VI_Extended !ExtendedVarInfo !VarInfo :: ExtendedVarInfo = EVI_VarType !AType @@ -511,7 +512,6 @@ cNonRecursiveAppl :== False :: TypeSymbIdent = { type_name :: !Ident -// , type_appl_kind :: !ApplicationKind , type_arity :: !Int , type_index :: !Global Index , type_prop :: !TypeSymbProperties @@ -548,7 +548,7 @@ cNonRecursiveAppl :== False :: Producer = PR_Empty | PR_Function !SymbIdent !Index !Int // Int: number of actual arguments in application - | PR_Class !App ![BoundVar] ![Type] + | PR_Class !App ![BoundVar] !Type // | PR_Constructor !SymbIdent ![Expression] | PR_GeneratedFunction !SymbIdent !Index !Int // Int: number of actual arguments in application @@ -607,10 +607,10 @@ cNonRecursiveAppl :== False | EI_Attribute !Int - /* EI_ClassTypes is used to store the instance types of a class These type are used during fusion to generate proper types for + /* EI_DictionaryType is used to store the instance type of a class. This type are used during fusion to generate proper types for the fusion result (i.e. the resulting function after elimination of dictionaries) */ - | EI_ClassTypes ![Type] + | EI_DictionaryType !Type | EI_CaseType !CaseType | EI_LetType ![AType] | EI_CaseTypeAndRefCounts !CaseType !RefCountsInCase @@ -988,6 +988,7 @@ cIsNotStrict :== False | TypeCodeExpression !TypeCodeExpression | EE + | NoBind ExprInfoPtr /* auxiliary, to store fields that are not specified in a record expression */ :: CodeBinding variable :== Env String variable @@ -1006,14 +1007,6 @@ cIsNotStrict :== False , case_ident :: !Optional Ident , case_info_ptr :: !ExprInfoPtr } -/* -:: Let = - { let_strict :: !Bool - , let_binds :: !(Env Expression FreeVar) - , let_expr :: !Expression - , let_info_ptr :: !ExprInfoPtr - } -*/ :: Let = { let_strict_binds :: !Env Expression FreeVar @@ -1130,10 +1123,10 @@ cNotALineNumber :== -1 /* Used for hashing identifiers */ instance == ModuleKind, Ident -instance <<< Module a | <<< a, ParsedDefinition, InstanceType, AttributeVar, TypeVar, SymbolType, Expression, Type, Ident, Global object | <<< object, - Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, Bind a b | <<< a & <<< b, ParsedConstructor, TypeDef a | <<< a, TypeVarInfo, +instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, TypeVar, SymbolType, Expression, Type, Ident, (Global object) | <<< object, + Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, (Bind a b) | <<< a & <<< b, ParsedConstructor, (TypeDef a) | <<< a, TypeVarInfo, BasicValue, ATypeVar, TypeRhs, FunctionPattern, (Import from_symbol) | <<< from_symbol, ImportDeclaration, ImportedIdent, CasePatterns, - Optional a | <<< a, ConsVariable, BasicType, Annotation, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance + (Optional a) | <<< a, ConsVariable, BasicType, Annotation, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance, SignClassification instance == TypeAttribute instance == Annotation @@ -1148,7 +1141,7 @@ EmptySymbolTableEntry :== cNotAGroupNumber :== -1 EmptyTypeDefInfo :== { tdi_kinds = [], tdi_properties = cAllBitsClear, tdi_group = [], tdi_group_vars = [], tdi_cons_vars = [], - tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber } + tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber, tdi_tmp_index = NoIndex } MakeTypeVar name :== { tv_name = name, tv_info_ptr = nilPtr } MakeVar name :== { var_name = name, var_info_ptr = nilPtr, var_expr_ptr = nilPtr } diff --git a/frontend/syntax.icl b/frontend/syntax.icl index a9303c1..8ac3090 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -46,7 +46,6 @@ where toString {import_module} = toString import_module | STE_TypeVariable !TypeVarInfoPtr | STE_TypeAttribute !AttrVarInfoPtr | STE_BoundTypeVariable !STE_BoundTypeVariable - | STE_BoundType !AType | STE_Imported !STE_Kind !Index | STE_DclFunction | STE_Module !(Module (CollectedDefinitions ClassInstance IndexRange)) @@ -436,7 +435,7 @@ cIsALocalVar :== False VI_Pattern !AuxiliaryPattern | VI_Default !Int | VI_Indirection !Int | /* used during conversion of dynamics; the Int indiacted the refenrence count */ VI_Body !SymbIdent !TransformedBody ![FreeVar] | /* used during fusion */ - VI_Dictionary !SymbIdent ![Expression] ![Type] | /* used during fusion */ + VI_Dictionary !SymbIdent ![Expression] !Type | /* used during fusion */ VI_Extended !ExtendedVarInfo !VarInfo :: ExtendedVarInfo = EVI_VarType !AType @@ -517,7 +516,7 @@ cNotVarNumber :== -1 :: Producer = PR_Empty | PR_Function !SymbIdent !Index !Int // Int: number of actual arguments in application - | PR_Class !App ![BoundVar] ![Type] + | PR_Class !App ![BoundVar] !Type // | PR_Constructor !SymbIdent ![Expression] | PR_GeneratedFunction !SymbIdent !Index !Int // Int: number of actual arguments in application @@ -579,7 +578,7 @@ cNotVarNumber :== -1 /* EI_ClassTypes is used to store the instance types of a class These type are used during fusion to generate proper types for the fusion result (i.e. the resulting function after elimination of dictionaries) */ - | EI_ClassTypes ![Type] + | EI_DictionaryType !Type | EI_CaseType !CaseType | EI_LetType ![AType] | EI_CaseTypeAndRefCounts !CaseType !RefCountsInCase @@ -817,6 +816,7 @@ cNotVarNumber :== -1 , tdi_group_nr :: !Int , tdi_group_vars :: ![Int] , tdi_cons_vars :: ![Int] + , tdi_tmp_index :: !Int , tdi_classification :: !TypeClassification } @@ -949,6 +949,7 @@ cIsNotStrict :== False | TypeCodeExpression !TypeCodeExpression | EE + | NoBind ExprInfoPtr /* auxiliary, to store fields that are not specified in a record expression */ :: CodeBinding variable :== Env String variable @@ -1276,7 +1277,7 @@ where (<<<) file {var_name,var_info_ptr,var_expr_ptr} = file <<< var_name <<< '<' <<< ptrToInt var_info_ptr <<< ',' <<< ptrToInt var_expr_ptr <<< '>' -instance <<< Bind a b | <<< a & <<< b +instance <<< (Bind a b) | <<< a & <<< b where (<<<) file {bind_src,bind_dst} = file <<< bind_dst <<< " = " <<< bind_src @@ -1362,6 +1363,7 @@ where (<<<) file WildCard = file <<< '_' (<<<) file (MatchExpr _ cons expr) = file <<< cons <<< " =: " <<< expr (<<<) file EE = file <<< "** E **" + (<<<) file (NoBind _) = file <<< "** NB **" (<<<) file (DynamicExpr {dyn_expr,dyn_uni_vars,dyn_type_code}) = writeVarPtrs (file <<< "dynamic " <<< dyn_expr <<< " :: ") dyn_uni_vars <<< dyn_type_code // (<<<) file (TypeCase type_case) = file <<< type_case (<<<) file (TypeCodeExpression type_code) = file <<< type_code @@ -1419,7 +1421,7 @@ where (<<<) file (LocalParsedDefs defs) = file <<< defs (<<<) file (CollectedLocalDefs defs) = file <<< defs -instance <<< NodeDef dst | <<< dst +instance <<< (NodeDef dst) | <<< dst where (<<<) file {nd_dst,nd_alts,nd_locals} = file <<< nd_dst <<< nd_alts <<< nd_locals @@ -1575,7 +1577,7 @@ where (<<<) file {ds_ident} = file <<< ds_ident -instance <<< TypeDef a | <<< a +instance <<< (TypeDef a) | <<< a where (<<<) file {td_name, td_args, td_rhs} = file <<< ":: " <<< td_name <<< ' ' <<< td_args <<< td_rhs @@ -1648,16 +1650,16 @@ instance <<< ClassInstance where (<<<) file {ins_class,ins_type} = file <<< ins_class <<< " :: " <<< ins_type -instance <<< Optional a | <<< a +instance <<< (Optional a) | <<< a where (<<<) file (Yes x) = file <<< x (<<<) file No = file -instance <<< Module a | <<< a +instance <<< (Module a) | <<< a where (<<<) file {mod_name,mod_type,mod_defs} = file <<< mod_type <<< mod_name <<< mod_defs -instance <<< CollectedDefinitions a b | <<< a & <<< b +instance <<< (CollectedDefinitions a b) | <<< a & <<< b where (<<<) file {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances} = file @@ -1700,7 +1702,7 @@ where // (<<<) file {id_name,id_index} = file <<< id_name <<< '.' <<< id_index (<<<) file {id_name} = file <<< id_name -instance <<< Global a | <<< a +instance <<< (Global a) | <<< a where (<<<) file {glob_object,glob_module} = file <<< glob_object <<< "M:" <<< glob_module @@ -1754,7 +1756,7 @@ EmptySymbolTableEntry :== cNotAGroupNumber :== -1 EmptyTypeDefInfo :== { tdi_kinds = [], tdi_properties = cAllBitsClear, tdi_group = [], tdi_group_vars = [], tdi_cons_vars = [], - tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber } + tdi_classification = EmptyTypeClassification, tdi_group_nr = cNotAGroupNumber, tdi_tmp_index = NoIndex } MakeTypeVar name :== { tv_name = name, tv_info_ptr = nilPtr } MakeVar name :== { var_name = name, var_info_ptr = nilPtr, var_expr_ptr = nilPtr } diff --git a/frontend/trans.icl b/frontend/trans.icl index 517eb34..a945ce4 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -37,7 +37,7 @@ where partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo) partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num} - #! fd = fun_defs.[fun_index] + # (fd, fun_defs) = fun_defs![fun_index] # {fi_calls} = fd.fun_info (min_dep, fun_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs (push_on_dep_stack fun_index pi) = try_to_close_group fun_index pi_next_num min_dep max_fun_nr fun_defs pi @@ -276,6 +276,8 @@ instance consumerRequirements Expression where = (cPassive, False, ai) consumerRequirements EE _ ai = (cPassive, False, ai) + consumerRequirements (NoBind _) _ ai + = (cPassive, False, ai) consumerRequirements expr _ ai = abort ("consumerRequirements ") // <<- expr) @@ -323,7 +325,9 @@ instance consumerRequirements Case where consumerRequirements kees=:{case_expr,case_guards,case_default,case_info_ptr} common_defs ai # (cce, _, ai) = consumerRequirements case_expr common_defs ai (ccgs, unsafe_bits, ai) = consumer_requirements_of_guards case_guards common_defs ai - has_default = case case_default of { Yes _ -> True; _ -> False } + has_default = case case_default of + Yes _ -> True + _ -> False (ccd, default_is_unsafe, ai) = consumerRequirements case_default common_defs ai (every_constructor_appears_in_safe_pattern, may_be_active) = inspect_patterns common_defs has_default case_guards unsafe_bits safe = (has_default && not default_is_unsafe) || every_constructor_appears_in_safe_pattern @@ -506,7 +510,7 @@ analyseGroups common_defs {ir_from, ir_to} groups fun_defs var_heap expr_heap ([], createArray nr_of_funs { cc_size = 0, cc_args = [], cc_linear_bits = []}, groups, fun_defs, var_heap, expr_heap) where analyse_group common_defs group_nr (cleanup_info, class_env, groups, fun_defs, var_heap, expr_heap) - #! {group_members} = groups.[group_nr] + # ({group_members}, groups) = groups![group_nr] # (nr_of_vars, nr_of_local_vars, var_heap, class_env, fun_defs) = initial_cons_class group_members 0 0 var_heap class_env fun_defs initial_subst = createArray (nr_of_vars + nr_of_local_vars) cPassive (ai_cases_of_vars_for_group, ai, fun_defs) @@ -548,7 +552,7 @@ where = ([], var_heap) initial_cons_class [fun : funs] next_var_number nr_of_local_vars var_heap class_env fun_defs - #! fun_def = fun_defs.[fun] + # (fun_def, fun_defs) = fun_defs![fun] # (TransformedBody {tb_args}) = fun_def.fun_body (fresh_vars, next_var_number, var_heap) = fresh_variables tb_args 0 next_var_number var_heap = initial_cons_class funs next_var_number (length fun_def.fun_info.fi_local_vars + nr_of_local_vars) var_heap @@ -564,7 +568,7 @@ where = ([], next_var_number, var_heap) analyse_functions common_defs [fun : funs] cfvog_accu ai fun_defs - #! fun_def = fun_defs.[fun] + # (fun_def, fun_defs) = fun_defs![fun] # (TransformedBody {tb_args, tb_rhs}) = fun_def.fun_body nr_of_args = length tb_args ai = { ai & ai_cur_ref_counts = createArray (nr_of_args + length fun_def.fun_info.fi_local_vars) 0, @@ -587,7 +591,7 @@ where collect_classifications [] class_env class_subst = class_env collect_classifications [fun : funs] class_env class_subst - #! fun_class = class_env.[fun] + # (fun_class, class_env) = class_env![fun] # fun_class = determine_classification fun_class class_subst = collect_classifications funs { class_env & [fun] = fun_class /*---> (fun, fun_class)*/} class_subst where @@ -607,15 +611,15 @@ mapAndLength f [x : xs] mapAndLength f [] = (0, []) -:: *TransformInfo = - { ti_fun_defs :: !*{# FunDef} - , ti_instances :: !*{! InstanceInfo } +:: TransformInfo = + { ti_fun_defs :: !.{# FunDef} + , ti_instances :: !.{! InstanceInfo } , ti_cons_args :: !{! ConsClasses} , ti_new_functions :: ![FunctionInfoPtr] - , ti_fun_heap :: !*FunctionHeap - , ti_var_heap :: !*VarHeap - , ti_symbol_heap :: !*ExpressionHeap - , ti_type_heaps :: !*TypeHeaps + , ti_fun_heap :: !.FunctionHeap + , ti_var_heap :: !.VarHeap + , ti_symbol_heap :: !.ExpressionHeap + , ti_type_heaps :: !.TypeHeaps , ti_next_fun_nr :: !Index , ti_cleanup_info :: !CleanupInfo , ti_recursion_introduced :: !Optional Index @@ -632,7 +636,7 @@ mapAndLength f [] :: RootCaseMode = NotRootCase | RootCase | RootCaseOfZombie -class transform a :: !a !ReadOnlyTI !TransformInfo -> (!a, !TransformInfo) +class transform a :: !a !ReadOnlyTI !*TransformInfo -> (!a, !*TransformInfo) instance transform Expression where @@ -758,7 +762,8 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf | not is_active -> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem) # algebraicPatterns = getAlgebraicPatterns case_guards - aci = case opt_aci of { Yes aci -> aci } + aci = case opt_aci of + Yes aci -> aci (may_be_match_expr, ti) = match_and_instantiate aci.aci_linearity_of_patterns cons_index app_args algebraicPatterns case_default ro ti -> case may_be_match_expr of Yes match_expr @@ -873,7 +878,10 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf (outer_guards, us=:{us_cleanup_info}) = unfold outer_case.case_guards us (expr_info, ti_symbol_heap) = readPtr outer_case.case_info_ptr us.us_symbol_heap (new_info_ptr, ti_symbol_heap) = newPtr expr_info ti_symbol_heap - new_cleanup_info = case expr_info of {(EI_Extended _ _) -> [new_info_ptr:us_cleanup_info]; _ -> us_cleanup_info} + new_cleanup_info = case expr_info of + EI_Extended _ _ + -> [new_info_ptr:us_cleanup_info] + _ -> us_cleanup_info ti = { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = ti_symbol_heap, ti_cleanup_info=new_cleanup_info } new_case = { outer_case & case_expr = guard_expr, case_guards=outer_guards, case_info_ptr=new_info_ptr } (guard_expr, ti) = transformCase new_case ro ti @@ -935,6 +943,7 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf match_and_instantiate _ cons_index app_args [] default_expr ro ti = transform default_expr { ro & ro_root_case_mode = NotRootCase } ti +possibly_generate_case_function :: !Case !ActiveCaseInfo !ReadOnlyTI !*TransformInfo -> *(!Expression, !*TransformInfo) possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced} // | False->>("possibly_generate_case_function") // = undef @@ -973,6 +982,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti No -> (new_expr, { ti & ti_recursion_introduced = old_ti_recursion_introduced }) where + get_fun_def_and_cons_args :: !SymbKind !{!ConsClasses} !u:{# FunDef} !*FunctionHeap -> (!FunDef, !ConsClasses, !u:{# FunDef}, !*FunctionHeap) get_fun_def_and_cons_args (SK_Function {glob_object}) cons_args fun_defs fun_heap # (fun_def, fun_defs) = fun_defs![glob_object] = (fun_def, cons_args.[glob_object], fun_defs, fun_heap) @@ -982,6 +992,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti = (fun_def, cons_args.[fun_index], fun_defs, fun_heap) # (FI_Function {gf_fun_def, gf_cons_args}, fun_heap) = readPtr fun_info_ptr fun_heap = (gf_fun_def, gf_cons_args, fun_defs, fun_heap) + /* get_fun_def_and_cons_args (SK_Function {glob_object}) cons_args fun_defs fun_heap # (fun_def, fun_defs) = fun_defs![glob_object] @@ -1120,7 +1131,7 @@ writeExprInfo expr_info_ptr new_expr_info symbol_heap EI_Extended extensions _ -> writePtr expr_info_ptr (EI_Extended extensions new_expr_info) symbol_heap _ -> writePtr expr_info_ptr new_expr_info symbol_heap -instance transform Bind a b | transform a +instance transform (Bind a b) | transform a where transform bind=:{bind_src} ro ti # (bind_src, ti) = transform bind_src ro ti @@ -1150,7 +1161,7 @@ where # (patterns, ti) = transform patterns ro ti = (DynamicPatterns patterns, ti) -instance transform Optional a | transform a +instance transform (Optional a) | transform a where transform (Yes x) ro ti # (x, ti) = transform x ro ti @@ -1259,7 +1270,10 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi us = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = Yes ti_type_heaps, us_cleanup_info=ti_cleanup_info, us_handle_aci_free_vars = RemoveThem } (tb_rhs, {us_var_heap,us_symbol_heap,us_opt_type_heaps=Yes type_heaps, us_cleanup_info}) = unfold tb_rhs us - ro = { ro & ro_root_case_mode = case tb_rhs of {Case _ -> RootCase; _ -> NotRootCase}, + ro = { ro & ro_root_case_mode = case tb_rhs of + Case _ + -> RootCase + _ -> NotRootCase, ro_fun= { symb_name = fd.fun_symb, symb_kind = SK_GeneratedFunction fun_def_ptr ti_next_fun_nr, symb_arity = fun_arity}, ro_fun_args = new_fun_args } @@ -1302,7 +1316,7 @@ where [linear_bit : new_linear_bits], [cons_arg /* was cActive*/ : new_cons_args], type_var_heap, symbol_heap, fun_defs, fun_heap, writeVarInfo fv_info_ptr (VI_Variable fv_name new_info_ptr) var_heap) - determine_arg (PR_Class class_app free_vars class_types) {fv_info_ptr,fv_name} type _ + determine_arg (PR_Class class_app free_vars class_type) {fv_info_ptr,fv_name} type _ (vars, types, new_linear_bits, new_cons_args, type_var_heap, symbol_heap, fun_defs, fun_heap, var_heap) = ( mapAppend (\{var_info_ptr,var_name} -> { fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0 }) @@ -1311,11 +1325,11 @@ where , mapAppend (\_ -> True) free_vars new_linear_bits , mapAppend (\_ -> cActive) free_vars new_cons_args // , bind_class_types type.at_type (class_types ---> ("determine_arg", (class_app.app_symb.symb_name, class_app.app_args), type.at_type, class_types)) type_var_heap - , bind_class_types type.at_type class_types type_var_heap + , bind_class_types type.at_type class_type type_var_heap , symbol_heap , fun_defs , fun_heap - , writeVarInfo fv_info_ptr (VI_Dictionary class_app.app_symb class_app.app_args class_types) var_heap + , writeVarInfo fv_info_ptr (VI_Dictionary class_app.app_symb class_app.app_args class_type) var_heap ) determine_arg producer {fv_info_ptr,fv_name} type (_,(outer_type_vars, ti_cons_args, consumer_body_rhs)) @@ -1369,11 +1383,11 @@ where = foldr (\atype1 atype2->{at_attribute=TA_None, at_annotation=AN_None, at_type=atype1-->atype2}) st_result (drop nr_of_applied_args st_args) - bind_class_types (TA _ context_types) instance_types type_var_heap + bind_class_types (TA _ context_types) (TA _ instance_types) type_var_heap = bind_context_types context_types instance_types type_var_heap where - bind_context_types [atype : atypes] [type : types] type_var_heap - = bind_context_types atypes types (bind_type atype.at_type type type_var_heap) + bind_context_types [ctype : atypes] [itype : types] type_var_heap + = bind_context_types atypes types (bind_type ctype.at_type itype.at_type type_var_heap) bind_context_types [] [] type_var_heap = type_var_heap bind_class_types _ _ type_var_heap @@ -1419,11 +1433,11 @@ where = max fun_def.fun_info.fi_group_index current_max max_group_index_of_producer (PR_GeneratedFunction { symb_kind = SK_GeneratedFunction fun_ptr fun_index} _ _) current_max fun_defs fun_heap cons_args - # fun_def = case fun_index < size fun_defs of - True -> fun_defs.[fun_index] - _ # (FI_Function generated_function) = sreadPtr fun_ptr fun_heap - -> generated_function.gf_fun_def - = max fun_def.fun_info.fi_group_index current_max + | fun_index < size fun_defs + # {fun_info} = fun_defs.[fun_index] + = max fun_info.fi_group_index current_max + # (FI_Function generated_function) = sreadPtr fun_ptr fun_heap + = max generated_function.gf_fun_def.fun_info.fi_group_index current_max /* max_group_index_of_producer (PR_GeneratedFunction { symb_kind = SK_GeneratedFunction fun_ptr _} _ _) current_max fun_defs fun_heap cons_args @@ -1550,7 +1564,7 @@ createBindingsForUnifiedTypes type_1 type_2 all_type_vars type_var_heap = ({ tv_name=new_name, tv_info_ptr=new_tv_info_ptr }, type_var_heap) - only_tv :: u:Type -> Optional u:TypeVar; + only_tv :: Type -> Optional TypeVar only_tv (TV tv) = Yes tv only_tv _ = No @@ -1658,9 +1672,9 @@ transformApplication app=:{app_symb=symb=:{symb_kind = SK_Function {glob_module, | glob_module == cIclModIndex | glob_object < size ti_cons_args #! cons_class = ti_cons_args.[glob_object] - instances = ti_instances.[glob_object] - fun_def = ti_fun_defs.[glob_object] - = transformFunctionApplication fun_def instances cons_class app extra_args ro ti + (instances, ti_instances) = ti_instances![glob_object] + (fun_def, ti_fun_defs) = ti_fun_defs![glob_object] + = transformFunctionApplication fun_def instances cons_class app extra_args ro { ti & ti_instances = ti_instances, ti_fun_defs = ti_fun_defs } // It seems as if we have an array function | isEmpty extra_args = (App app, ti) @@ -1682,9 +1696,9 @@ transformApplication app=:{app_symb={symb_name,symb_kind = SK_GeneratedFunction ro ti=:{ti_cons_args,ti_instances,ti_fun_defs,ti_fun_heap} | fun_index < size ti_cons_args #! cons_class = ti_cons_args.[fun_index] - instances = ti_instances.[fun_index] - fun_def = ti_fun_defs.[fun_index] - = transformFunctionApplication fun_def instances cons_class app extra_args ro ti + (instances, ti_instances) = ti_instances![fun_index] + (fun_def, ti_fun_defs) = ti_fun_defs![fun_index] + = transformFunctionApplication fun_def instances cons_class app extra_args ro { ti & ti_instances = ti_instances, ti_fun_defs = ti_fun_defs } # (FI_Function {gf_fun_def,gf_instance_info,gf_cons_args}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap = transformFunctionApplication gf_fun_def gf_instance_info gf_cons_args app extra_args ro { ti & ti_fun_heap = ti_fun_heap } transformApplication app [] ro ti @@ -1726,10 +1740,10 @@ where determineProducer :: !Bool !Bool !App !ExprInfo ![Expression] !Index !*{! Producer} !*TransformInfo -> (!*{! Producer}, ![Expression], !*TransformInfo) // XXX check for linear_bit also in case of a constructor ? -determineProducer _ _ app=:{app_symb = symb=:{symb_kind = SK_Constructor _}, app_args} (EI_ClassTypes types) new_args prod_index producers ti +determineProducer _ _ app=:{app_symb = symb=:{symb_kind = SK_Constructor _}, app_args} (EI_DictionaryType type) new_args prod_index producers ti # (app_args, (new_vars, ti_var_heap)) = renewVariables app_args ([], ti.ti_var_heap) (new_args, ti_var_heap) = mapAppendSt retrieve_old_var new_vars new_args ti_var_heap - = ({ producers & [prod_index] = PR_Class { app & app_args = app_args } new_vars types}, new_args, { ti & ti_var_heap = ti_var_heap }) + = ({ producers & [prod_index] = PR_Class { app & app_args = app_args } new_vars type}, new_args, { ti & ti_var_heap = ti_var_heap }) where retrieve_old_var {var_info_ptr} var_heap # (var_info, var_heap) = readVarInfo var_info_ptr var_heap @@ -1761,10 +1775,13 @@ determineProducer _ _ app _ new_args _ producers ti determineFunAppProducer {fun_body, fun_arity} nr_of_app_args new_producer is_applied_to_macro_fun linear_bit app=:{app_args} new_args prod_index producers ti # is_curried = fun_arity<>nr_of_app_args - is_expanding = case fun_body of { Expanding _ -> True; _ -> False } + is_expanding = case fun_body of + Expanding _ + -> True + _ -> False is_good_producer = not is_expanding && (implies is_curried is_applied_to_macro_fun) - && (implies (not is_curried) (SwitchFusion (linear_bit && is_good_body tb_rhs) False)) + && (implies (not is_curried) (SwitchFusion (linear_bit && is_sexy_body tb_rhs) False)) // curried applications may be fused with non linear consumers in functions local to a macro | is_good_producer = ({ producers & [prod_index] = new_producer}, app_args ++ new_args, ti) @@ -1772,15 +1789,17 @@ determineFunAppProducer {fun_body, fun_arity} nr_of_app_args new_producer where (TransformedBody {tb_rhs}) = fun_body - is_good_body (AnyCodeExpr _ _ _) = False - is_good_body (ABCCodeExpr _ _) = False - is_good_body (Let {let_strict_binds}) = isEmpty let_strict_binds + // when two function bodies have fusion with each other this only leads into satisfaction if one body + // fulfills the following sexyness property + is_sexy_body (AnyCodeExpr _ _ _) = False + is_sexy_body (ABCCodeExpr _ _) = False + is_sexy_body (Let {let_strict_binds}) = isEmpty let_strict_binds // currently a producer's body must not be a let with strict bindings. The code sharing elimination algorithm assumes that // all strict let bindings are on the top level expression (see "convertCasesOfFunctionsIntoPatterns"). This assumption // could otherwise be violated during fusion. // -> Here is place for optimisation: Either the fusion algorithm or the code sharing elimination algorithm could be // extended to generate new functions when a strict let ends up during fusion in a non top level position (MW) - is_good_body _ = True + is_sexy_body _ = True /* verify_class_members [ App {app_symb, app_args} : mems] @@ -1876,7 +1895,7 @@ transformGroups cleanup_info groups fun_defs cons_args common_defs imported_fun where transform_groups group_nr groups common_defs imported_funs imported_types collected_imports ti | group_nr < size groups - #! group = groups.[group_nr] + # (group, groups) = groups![group_nr] # {group_members} = group # (ti_fun_defs, imported_types, collected_imports, ti_type_heaps, ti_var_heap) = foldSt (convert_function_type common_defs) group_members @@ -1887,20 +1906,22 @@ where = (groups, imported_types, collected_imports, ti) transform_function common_defs imported_funs fun ti=:{ti_fun_defs} - #! fun_def = ti_fun_defs.[fun] + # (fun_def, ti_fun_defs) = ti_fun_defs![fun] # {fun_body = TransformedBody tb} = fun_def ro = { ro_imported_funs = imported_funs , ro_common_defs = common_defs - , ro_root_case_mode = case tb of {{tb_rhs=Case _} -> RootCase; _ -> NotRootCase} + , ro_root_case_mode = get_root_case_mode tb , ro_fun = fun_def_to_symb_ident fun fun_def , ro_fun_args = tb.tb_args } - (fun_rhs, ti) = transform tb.tb_rhs ro ti + (fun_rhs, ti) = transform tb.tb_rhs ro { ti & ti_fun_defs = ti_fun_defs } = { ti & ti_fun_defs = {ti.ti_fun_defs & [fun] = { fun_def & fun_body = TransformedBody { tb & tb_rhs = fun_rhs }}}} where fun_def_to_symb_ident fun_index {fun_symb,fun_arity} = { symb_name=fun_symb, symb_kind=SK_Function {glob_object=fun_index, glob_module=cIclModIndex } , symb_arity=fun_arity } + get_root_case_mode {tb_rhs=Case _} = RootCase + get_root_case_mode _ = NotRootCase add_new_function_to_group :: !{# CommonDefs} !FunctionHeap !FunctionInfoPtr !(!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) @@ -1910,7 +1931,7 @@ where # (Yes ft=:{st_args,st_result}) = gf_fun_def.fun_type ((st_result,st_args), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) = expandSynTypes common_defs (st_result,st_args) { ets_type_defs = imported_types, ets_collected_conses = collected_imports, ets_type_heaps = type_heaps, ets_var_heap = var_heap } - #! group = groups.[group_index] + # (group, groups) = groups![group_index] = ({ groups & [group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, [ { gf_fun_def & fun_type = Yes { ft & st_result = st_result, st_args = st_args }} : fun_defs], ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) @@ -2358,7 +2379,7 @@ instance <<< InstanceInfo file = foldSt (\pr file -> file<<<pr<<<",") [el \\ el<-:producers] file = write_ii r (file<<<")") -instance <<< Ptr a +instance <<< (Ptr a) where (<<<) file p = file <<< ptrToInt p diff --git a/frontend/transform.icl b/frontend/transform.icl index 4adb5b8..606e9a3 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -202,9 +202,9 @@ unfoldVariable var=:{var_name,var_info_ptr} us app_args = [ Var { var_name=fv_name, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr } \\ {fv_name,fv_info_ptr}<-vars], app_info_ptr = nilPtr }, us) - VI_Dictionary app_symb app_args class_types - # (new_class_types, us_opt_type_heaps) = substitute_class_types class_types us.us_opt_type_heaps - (new_info_ptr, us_symbol_heap) = newPtr (EI_ClassTypes new_class_types) us.us_symbol_heap + VI_Dictionary app_symb app_args class_type + # (new_class_type, us_opt_type_heaps) = substitute_class_types class_type us.us_opt_type_heaps + (new_info_ptr, us_symbol_heap) = newPtr (EI_DictionaryType new_class_type) us.us_symbol_heap -> (App { app_symb = app_symb, app_args = app_args, app_info_ptr = new_info_ptr }, { us & us_opt_type_heaps = us_opt_type_heaps, us_symbol_heap = us_symbol_heap }) _ @@ -305,7 +305,7 @@ where _ -> case (app_symb.symb_kind, isNilPtr app_info_ptr) of (SK_Constructor _, False) # (app_info, us_symbol_heap) = readPtr app_info_ptr us.us_symbol_heap - (new_app_info, us_opt_type_heaps) = substitute_EI_ClassTypes app_info us.us_opt_type_heaps + (new_app_info, us_opt_type_heaps) = substitute_EI_DictionaryType app_info us.us_opt_type_heaps (new_ptr, us_symbol_heap) = newPtr new_app_info us_symbol_heap -> (new_ptr, { us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps }) _ -> (nilPtr, us) @@ -321,10 +321,10 @@ where is_function_or_macro _ = False - substitute_EI_ClassTypes (EI_ClassTypes class_types) (Yes type_heaps) - # (new_class_types, type_heaps) = substitute class_types type_heaps - = (EI_ClassTypes new_class_types, Yes type_heaps) - substitute_EI_ClassTypes x opt_type_heaps + substitute_EI_DictionaryType (EI_DictionaryType class_type) (Yes type_heaps) + # (new_class_type, type_heaps) = substitute class_type type_heaps + = (EI_DictionaryType new_class_type, Yes type_heaps) + substitute_EI_DictionaryType x opt_type_heaps = (x, opt_type_heaps) instance unfold (Bind a b) | unfold a @@ -348,7 +348,8 @@ where = ({ kees & case_expr = case_expr,case_guards = case_guards, case_default = case_default, case_info_ptr = new_info_ptr}, us) where update_active_case_info_and_unfold case_expr=:(Var {var_info_ptr}) case_info_ptr us=:{us_handle_aci_free_vars} - #! case_info = sreadPtr case_info_ptr us.us_symbol_heap + # (case_info, us_symbol_heap) = readPtr case_info_ptr us.us_symbol_heap + us = { us & us_symbol_heap = us_symbol_heap } = case case_info of EI_Extended (EEI_ActiveCase aci=:{aci_free_vars}) ei #!(new_aci_free_vars, us) = case us_handle_aci_free_vars of @@ -358,7 +359,8 @@ where No -> (No, us) Yes fvs # (fvs_subst, us) = mapSt unfoldBoundVar fvs us -> (Yes fvs_subst, us) - var_info = sreadPtr var_info_ptr us.us_var_heap + (var_info, us_var_heap) = readPtr var_info_ptr us.us_var_heap + us = { us & us_var_heap = us_var_heap } -> case var_info of VI_Body fun_symb {tb_args, tb_rhs} new_aci_params # tb_args_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-tb_args ] @@ -398,9 +400,8 @@ where = unfold case_expr us unfoldBoundVar {var_info_ptr} us - #!var_info = sreadPtr var_info_ptr us.us_var_heap - # (VI_Expression (Var act_var)) = var_info - = (act_var, us) + # (VI_Expression (Var act_var), us_var_heap) = readPtr var_info_ptr us.us_var_heap + = (act_var, { us & us_var_heap = us_var_heap }) instance unfold Let @@ -480,7 +481,7 @@ where = (collected_calls, fun_defs, symbol_table) examineFunctionCall {id_info} fc=:{fc_index} (calls, symbol_table) - #! entry = sreadPtr id_info symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table = case entry.ste_kind of STE_Called indexes | isMember fc_index indexes @@ -549,7 +550,7 @@ partitionateMacros {ir_from,ir_to} mod_index fun_defs modules var_heap symbol_he # partitioning_info = { pi_var_heap = var_heap, pi_symbol_heap = symbol_heap, pi_symbol_table = symbol_table, pi_error = error, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } - (fun_defs, modules, {pi_symbol_table, pi_var_heap, pi_symbol_heap, pi_error, pi_next_group, pi_groups, pi_marks, pi_deps}) + (fun_defs, modules, {pi_symbol_table, pi_var_heap, pi_symbol_heap, pi_error, pi_next_group, pi_groups, pi_deps}) = iFoldSt (pationate_macro mod_index max_fun_nr) ir_from ir_to (fun_defs, modules, partitioning_info) = (foldSt reset_body_of_rhs_macro pi_deps fun_defs, modules, pi_var_heap, pi_symbol_heap, pi_symbol_table, pi_error) where @@ -698,7 +699,7 @@ where # ({fun_symb = { id_info }, fun_kind}, fun_defs) = fun_defs![fc_index] | fun_kind == FK_Macro = (collected_calls, fun_defs, symbol_table) - #! entry = sreadPtr id_info symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table = ([fc : collected_calls], fun_defs, symbol_table <:= (id_info, { ste_kind = STE_Called [fc_index], ste_index = NoIndex, ste_def_level = NotALevel, ste_previous = entry })) @@ -707,7 +708,7 @@ removeFunctionCallsFromSymbolTable calls fun_defs symbol_table where remove_function_call_from_symbol_table {fc_index} (fun_defs, symbol_table) # ({fun_symb = { id_info }}, fun_defs) = fun_defs![fc_index] - #! entry = sreadPtr id_info symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table = (fun_defs, symbol_table <:= (id_info, entry.ste_previous)) @@ -1023,7 +1024,7 @@ where expand (App app=:{app_symb = symb=:{symb_arity, symb_kind = SK_Macro {glob_object,glob_module}}, app_args}) fun_and_macro_defs mod_index modules es # (app_args, fun_and_macro_defs, modules, (calls, state)) = expand app_args fun_and_macro_defs mod_index modules es - #! macro = fun_and_macro_defs.[glob_object] + # (macro, fun_and_macro_defs) = fun_and_macro_defs![glob_object] | macro.fun_arity == symb_arity # (expr, fun_and_macro_defs, es) = unfoldMacro macro app_args fun_and_macro_defs (calls, state) = (expr, fun_and_macro_defs, modules, es) @@ -1190,7 +1191,7 @@ where | is_cyclic_s || is_cyclic_l = (Let {lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds }, free_vars, { cos & cos_var_heap = cos_var_heap, cos_error = checkError "" "cyclic let definition" cos.cos_error}) - | otherwise +// | otherwise # (let_expr, free_vars, cos) = collectVariables let_expr free_vars { cos & cos_var_heap = cos_var_heap } all_binds = mapAppend (\sb->(True, sb)) let_strict_binds [(False, lb) \\ lb<-let_lazy_binds] (collected_binds, free_vars, cos) = collect_variables_in_binds all_binds [] free_vars cos @@ -1308,7 +1309,7 @@ where collectVariables [] free_vars cos = ([], free_vars, cos) -instance collectVariables !(!a,!b) | collectVariables a & collectVariables b +instance collectVariables (!a,!b) | collectVariables a & collectVariables b where collectVariables (x,y) free_vars cos # (x, free_vars, cos) = collectVariables x free_vars cos @@ -1386,7 +1387,7 @@ where _ -> abort "collectVariables [BoundVar] (transform, 1227)" <<- (var_info ---> var_name) -instance <<< Ptr a +instance <<< (Ptr a) where (<<<) file p = file <<< ptrToInt p diff --git a/frontend/type.dcl b/frontend/type.dcl index d0f9bcb..9fe9b24 100644 --- a/frontend/type.dcl +++ b/frontend/type.dcl @@ -3,7 +3,6 @@ definition module type import StdArray import syntax, check -// MW0 typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File -typeProgram :: !ModuleKind !{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File +typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File) diff --git a/frontend/type.icl b/frontend/type.icl index 766841a..e285d3f 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -301,7 +301,7 @@ unifyTypeApplications cons_var1 type_args type=:(cons_var2 :@: types) modules su (types, subst) = arraySubst (drop diff types) subst = unify type_args types modules subst heaps = (False, subst, heaps) - | otherwise +// | otherwise # (succ, subst, heaps) = unifyTypes (cons_var1 :@: take diff type_args) TA_Multi (constructorVariableToTypeVariable cons_var2) TA_Multi modules subst heaps | succ # (type_args, subst) = arraySubst (drop diff type_args) subst @@ -371,13 +371,12 @@ cIsExistential :== True cIsNotExistential :== False freshCopyOfTypeVariable {tv_name,tv_info_ptr} cs=:{copy_heaps} - #! tv_info = sreadPtr tv_info_ptr copy_heaps.th_vars - = case tv_info of - TVI_Type fresh_var - -> (fresh_var, cs) + # (TVI_Type fresh_var, th_vars) = readPtr tv_info_ptr copy_heaps.th_vars +// = (fresh_var, { cs & copy_heaps.th_vars = th_vars } ) // 2.0 + = (fresh_var, { cs & copy_heaps = { copy_heaps & th_vars = th_vars }}) freshConsVariable {tv_info_ptr} type_var_heap - #! tv_info = sreadPtr tv_info_ptr type_var_heap + # (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap = (to_constructor_variable tv_info, type_var_heap) where to_constructor_variable (TVI_Type (TempV temp_var_id)) @@ -429,7 +428,7 @@ freshAlgebraicType {glob_module, glob_object} patterns common_defs ts=:{ts_var_s // ---> ("freshAlgebraicType", alg_type, cons_types) where fresh_symbol_types [{ap_symbol={glob_object}}] cons_defs var_store copy_heaps - # {cons_type = {st_args,st_attr_env,st_result}, cons_index, cons_exi_vars, cons_exi_attrs} = cons_defs.[glob_object.ds_index] + # {cons_type = {st_args,st_attr_env,st_result}, cons_index, cons_exi_vars} = cons_defs.[glob_object.ds_index] (th_vars, var_store) = freshExistentialVariables cons_exi_vars (copy_heaps.th_vars, var_store) (attr_env, th_attrs) = fresh_environment st_attr_env ([], copy_heaps.th_attrs) (result_type, cs) = freshCopy st_result { copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars } } @@ -738,7 +737,7 @@ determineSymbolTypeOfFunction ident act_arity st=:{st_args,st_result,st_attr_var -> (curried_st, cons_variables, ts) standardFieldSelectorType {glob_object={ds_ident,ds_index},glob_module} {ti_common_defs} ts=:{ts_var_store,ts_type_heaps} - #! {sd_type,sd_exi_vars,sd_exi_attrs} = ti_common_defs.[glob_module].com_selector_defs.[ds_index] + #! {sd_type,sd_exi_vars} = ti_common_defs.[glob_module].com_selector_defs.[ds_index] # (th_vars, ts_var_store) = freshExistentialVariables sd_exi_vars (ts_type_heaps.th_vars, ts_var_store) (inst, cons_variables, ts) = freshSymbolType cWithFreshContextVars sd_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store } = (inst, ts) @@ -769,7 +768,7 @@ cIsRecursive :== True cIsNotRecursive :== False storeAttribute (Yes expt_ptr) type_attribute symbol_heap - = writePtr expt_ptr (EI_Attribute (toInt type_attribute)) symbol_heap + = symbol_heap <:= (expt_ptr, EI_Attribute (toInt type_attribute)) storeAttribute No type_attribute symbol_heap = symbol_heap @@ -1009,7 +1008,7 @@ where = case result_type_symb of Yes {glob_object={ds_ident,ds_index,ds_arity}, glob_module} # (var, ts) = freshAttributedVariable ts - (result_type, (reqs, ts)) = requirementsOfSelectors ti No expr selectors False var expr opt_expr_ptr (reqs, ts) + (result_type, (reqs, ts)) = requirementsOfSelectors ti No expr selectors False var expr (reqs, ts) tuple_type = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity non_unique_type_var = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TempV ts.ts_var_store } req_type_coercions @@ -1020,13 +1019,12 @@ where -> (result_type, No, ({ reqs & req_type_coercions = req_type_coercions }, {ts & ts_var_store = inc ts.ts_var_store, ts_expr_heap = storeAttribute opt_expr_ptr TA_Multi ts.ts_expr_heap})) _ - # (result_type, (reqs, ts)) = requirementsOfSelectors ti No expr selectors True expr_type expr opt_expr_ptr (reqs, ts) - -> ( result_type, No, (reqs, { ts & ts_expr_heap = storeAttribute opt_expr_ptr result_type.at_attribute ts.ts_expr_heap })) - + # (result_type, reqs_ts) = requirementsOfSelectors ti No expr selectors True expr_type expr (reqs, ts) + -> (result_type, opt_expr_ptr, reqs_ts) requirements ti (Update composite_expr selectors elem_expr) reqs_ts # (composite_expr_type, opt_composite_expr_ptr, reqs_ts) = requirements ti composite_expr reqs_ts - (result_type, reqs_ts) = requirementsOfSelectors ti (Yes elem_expr) composite_expr selectors True composite_expr_type composite_expr opt_composite_expr_ptr reqs_ts - = (composite_expr_type, No, reqs_ts) + (result_type, reqs_ts) = requirementsOfSelectors ti (Yes elem_expr) composite_expr selectors True composite_expr_type composite_expr reqs_ts + = (composite_expr_type, opt_composite_expr_ptr, reqs_ts) requirements ti (RecordUpdate {glob_module,glob_object={ds_index,ds_arity}} expression expressions) (reqs, ts) # (lhs, ts) = standardLhsConstructorType ds_index glob_module ds_arity ti ts @@ -1044,8 +1042,9 @@ where # reqs_ts = requirements_of_field ti expression field dem_type off_type reqs_ts = requirements_of_fields ti expression fields dem_types off_types reqs_ts - requirements_of_field ti expression {bind_src=EE} dem_field_type off_field_type (reqs=:{req_type_coercions}, ts) - # coercion = { tc_demanded = dem_field_type, tc_offered = off_field_type, tc_position = { cp_expression = expression }, tc_coercible = True } + requirements_of_field ti expression {bind_src=NoBind expr_ptr} dem_field_type off_field_type (reqs=:{req_type_coercions}, ts) + # ts = { ts & ts_expr_heap = ts.ts_expr_heap <:= (expr_ptr, EI_Attribute (toInt dem_field_type.at_attribute)) } + coercion = { tc_demanded = dem_field_type, tc_offered = off_field_type, tc_position = { cp_expression = expression }, tc_coercible = True } = ({ reqs & req_type_coercions = [ coercion : req_type_coercions ]}, ts) requirements_of_field ti _ {bind_src} dem_field_type _ reqs_ts # (expr_type, opt_expr_ptr, (reqs, ts)) = requirements ti bind_src reqs_ts @@ -1089,6 +1088,14 @@ where requirements _ expr reqs_ts = (abort ("Error in requirements\n" ---> expr), No, reqs_ts) + +requirementsOfSelectors ti opt_expr expr [selector] tc_coercible sel_expr_type sel_expr reqs_ts + = requirementsOfSelector ti opt_expr expr selector tc_coercible sel_expr_type sel_expr reqs_ts +requirementsOfSelectors ti opt_expr expr [selector : selectors] tc_coercible sel_expr_type sel_expr reqs_ts + # (result_type, reqs_ts) = requirementsOfSelector ti No expr selector tc_coercible sel_expr_type sel_expr reqs_ts + = requirementsOfSelectors ti opt_expr expr selectors tc_coercible result_type sel_expr reqs_ts + +/* requirementsOfSelectors ti opt_expr expr [selector] tc_coercible sel_expr_type sel_expr opt_expr_ptr (reqs, ts) # ts_expr_heap = storeAttribute opt_expr_ptr sel_expr_type.at_attribute ts.ts_expr_heap = requirementsOfSelector ti opt_expr expr selector tc_coercible sel_expr_type sel_expr (reqs, { ts & ts_expr_heap = ts_expr_heap }) @@ -1102,10 +1109,10 @@ where requirements_of_remaining_selectors ti opt_expr expr [selector : selectors] tc_coercible sel_expr_type sel_expr reqs_ts # (result_type, reqs_ts) = requirementsOfSelector ti No expr selector tc_coercible sel_expr_type sel_expr reqs_ts = requirements_of_remaining_selectors ti opt_expr expr selectors tc_coercible result_type sel_expr reqs_ts - -requirementsOfSelector ti _ expr (RecordSelection field filed_nr) tc_coercible sel_expr_type sel_expr (reqs, ts ) +*/ +requirementsOfSelector ti _ expr (RecordSelection field _) tc_coercible sel_expr_type sel_expr (reqs, ts ) # ({tst_args, tst_result, tst_attr_env}, ts) = standardFieldSelectorType field ti ts - req_type_coercions = [{ tc_demanded = sel_expr_type, tc_offered = hd tst_args, tc_position = { cp_expression = sel_expr }, tc_coercible = tc_coercible } : + req_type_coercions = [{ tc_demanded = hd tst_args, tc_offered = sel_expr_type, tc_position = { cp_expression = sel_expr }, tc_coercible = tc_coercible } : reqs.req_type_coercions ] = (tst_result, ({ reqs & req_type_coercions = req_type_coercions }, ts)) requirementsOfSelector ti opt_expr expr (ArraySelection {glob_object = {ds_ident,ds_index,ds_arity},glob_module} expr_ptr index_expr) tc_coercible sel_expr_type sel_expr (reqs, ts) @@ -1114,9 +1121,10 @@ requirementsOfSelector ti opt_expr expr (ArraySelection {glob_object = {ds_ident (dem_array_type, dem_index_type, rest_type) = array_and_index_type tst_args reqs ={ reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, req_cons_variables = [ cons_variables : reqs.req_cons_variables ]} (index_type, opt_expr_ptr, (reqs, ts)) = requirements ti index_expr (reqs, ts) + ts_expr_heap = storeAttribute opt_expr_ptr dem_index_type.at_attribute ts.ts_expr_heap reqs = { reqs & req_type_coercions = [{ tc_demanded = dem_index_type, tc_offered = index_type, tc_position = { cp_expression = expr }, tc_coercible = True }, { tc_demanded = dem_array_type, tc_offered = sel_expr_type, tc_position = { cp_expression = sel_expr }, tc_coercible = tc_coercible } : reqs.req_type_coercions ]} - (reqs, ts) = requirements_of_update ti opt_expr rest_type (reqs, ts) + (reqs, ts) = requirements_of_update ti opt_expr rest_type (reqs, { ts & ts_expr_heap = ts_expr_heap }) | isEmpty tst_context = (tst_result, (reqs, ts)) = (tst_result, ({ reqs & req_overloaded_calls = [expr_ptr : reqs.req_overloaded_calls ]}, { ts & ts_expr_heap = @@ -1164,8 +1172,8 @@ InitFunEnv nr_of_fun_defs CreateInitialSymbolTypes common_defs [] defs_and_state = defs_and_state CreateInitialSymbolTypes common_defs [fun : funs] (fun_defs, pre_def_symbols, req_cons_variables, ts) - #! fd = fun_defs.[fun] - # (pre_def_symbols, req_cons_variables, ts) = initial_symbol_type common_defs fd (pre_def_symbols, req_cons_variables, ts) + # (fd, fun_defs) = fun_defs![fun] + (pre_def_symbols, req_cons_variables, ts) = initial_symbol_type common_defs fd (pre_def_symbols, req_cons_variables, ts) = CreateInitialSymbolTypes common_defs funs (fun_defs, pre_def_symbols, req_cons_variables, ts) where initial_symbol_type common_defs {fun_type = Yes ft=:{st_arity,st_args,st_result,st_attr_vars,st_attr_env}, fun_lifted, fun_info = {fi_dynamics} } @@ -1317,14 +1325,14 @@ cleanUpAndCheckFunctionTypes [] _ defs type_contexts coercion_env attr_partition = (fun_defs, ts) cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts) - #! fd = fun_defs.[fun] + # (fd, fun_defs) = fun_defs![fun] # (type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun defs type_contexts req_case_and_let_exprs coercion_env attr_partition type_var_env attr_var_env ts = cleanUpAndCheckFunctionTypes funs reqs defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts) where clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun defs type_contexts case_and_let_exprs coercion_env attr_partition type_var_env attr_var_env ts - #! env_type = ts.ts_fun_env.[fun] + # (env_type, ts) = ts!ts_fun_env.[fun] # ts = { ts & ts_error = setErrorAdmin (newPosition fun_symb fun_pos) ts.ts_error} = case env_type of ExpandedType fun_type tmp_fun_type exp_fun_type @@ -1371,11 +1379,9 @@ addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars,st_con , fe_location :: !IdentPos } -// MW0 was typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File -typeProgram :: !ModuleKind !{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File +typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File) -// MW0 was typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file -typeProgram mod_type comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file +typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file #! fun_env_size = size fun_defs # ts_error = {ea_file = file, ea_loc = [], ea_ok = True } @@ -1400,7 +1406,6 @@ typeProgram mod_type comps fun_defs specials icl_defs imports modules {hp_var_he = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts) // MW0 was (fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env fun_defs (fun_defs, ts_fun_env, ts_error=:{ea_ok=no_start_rule_error}) = update_function_types 0 comps ts.ts_fun_env fun_defs ts_error - (type_error, fun_defs, predef_symbols, special_instances, {ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps}) // MW0 was = type_instances specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances, // MW0 was { ts & ts_fun_env = ts_fun_env }) @@ -1533,8 +1538,8 @@ where = (True, fun_defs, os_predef_symbols, os_special_instances, create_erroneous_function_types comp { ts & ts_type_heaps = os_type_heaps, ts_error = { os_error & ea_ok = True }, ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_td_infos = ts_td_infos, ts_expr_heap = os_symbol_heap, ts_var_heap = os_var_heap }) - # (fun_defs, coercion_env, subst, os_var_heap, os_symbol_heap, os_error) - = makeSharedReferencesNonUnique comp fun_defs coercion_env subst ti_common_defs os_var_heap os_symbol_heap os_error + # (fun_defs, coercion_env, subst, ts_td_infos, os_var_heap, os_symbol_heap, os_error) + = makeSharedReferencesNonUnique comp fun_defs coercion_env subst ts_td_infos os_var_heap os_symbol_heap os_error (subst, {coer_offered,coer_demanded}, ts_td_infos, ts_type_heaps, ts_error) = build_coercion_env fun_reqs subst coercion_env ti_common_defs cons_var_vects ts_td_infos os_type_heaps os_error (attr_partition, coer_demanded) = partitionateAttributes coer_offered coer_demanded @@ -1640,18 +1645,17 @@ where = expand_types_of_cases_and_lets reqs (foldl expand_case_or_let_type heap_and_subst req_case_and_let_exprs) expand_case_or_let_type (expr_heap, subst) info_ptr - #! info = sreadPtr info_ptr expr_heap - = case info of - EI_CaseType case_type + = case (readPtr info_ptr expr_heap) of + (EI_CaseType case_type, expr_heap) # (case_type, subst) = arraySubst case_type subst - -> (writePtr info_ptr (EI_CaseType case_type) expr_heap, subst) - EI_LetType let_type + -> (expr_heap <:= (info_ptr, EI_CaseType case_type), subst) + (EI_LetType let_type, expr_heap) # (let_type, subst) = arraySubst let_type subst - -> (writePtr info_ptr (EI_LetType let_type) expr_heap, subst) + -> (expr_heap <:= (info_ptr, EI_LetType let_type), subst) expand_function_types :: ![Int] !*{!Type} *{! FunctionType} -> (!*{!Type}, *{! FunctionType}) expand_function_types [fun : funs] subst ts_fun_env - #! fun_type = ts_fun_env.[fun] + # (fun_type, ts_fun_env) = ts_fun_env![fun] = case fun_type of UncheckedType tst # (exp_tst, subst) = arraySubst tst subst @@ -1665,6 +1669,7 @@ where // MW0 was update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType}) update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} !*ErrorAdmin -> (!*{#FunDef}, !*{!FunctionType}, !.ErrorAdmin) +// MW0 was update_function_types group_index comps fun_env fun_defs update_function_types group_index comps fun_env fun_defs error_admin | group_index == size comps // MW0 was = (fun_defs, fun_env) @@ -1682,9 +1687,9 @@ where // MW0 was update_function_types_in_component [ fun_index : funs ] fun_env fun_defs update_function_types_in_component [ fun_index : funs ] fun_env fun_defs error_admin # (CheckedType checked_fun_type, fun_env) = fun_env![fun_index] - #! fd = fun_defs.[fun_index] + # (fd, fun_defs) = fun_defs![fun_index] // MW0.. - # is_start_rule = fd.fun_symb.id_name=="Start" && fd.fun_info.fi_def_level==1 && mod_type==MK_Main + # is_start_rule = fd.fun_symb.id_name=="Start" && fd.fun_info.fi_def_level==1 error_admin = case is_start_rule of False -> error_admin _ -> check_type_of_start_rule fd checked_fun_type error_admin @@ -1711,15 +1716,16 @@ where = mapSt (type_function ti) group (cons_variables, fun_defs, ts) // ((cons_variables, fun_defs, ts) ---> "[(") ---> ")]" type_function ti fun_index (cons_variables, fun_defs, ts=:{ts_fun_env, ts_var_heap, ts_expr_heap, ts_error}) - #! fd = fun_defs.[fun_index] - type = ts_fun_env.[fun_index] - # {fun_symb,fun_arity,fun_body=TransformedBody {tb_args,tb_rhs},fun_pos, fun_info, fun_type} = fd + # (fd, fun_defs) = fun_defs![fun_index] + (type, ts_fun_env) = ts_fun_env![fun_index] + {fun_symb,fun_arity,fun_body=TransformedBody {tb_args,tb_rhs},fun_pos, fun_info, fun_type} = fd temp_fun_type = type_of type ts_var_heap = makeBase tb_args temp_fun_type.tst_args ts_var_heap fe_location = newPosition fun_symb fun_pos ts_error = setErrorAdmin fe_location ts_error reqs = { req_overloaded_calls = [], req_type_coercions = [], req_attr_coercions = [], req_case_and_let_exprs = [], req_cons_variables = cons_variables } - ( rhs_type, rhs_expr_ptr, (rhs_reqs, ts)) = requirements ti tb_rhs (reqs, { ts & ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error }) + ( rhs_type, rhs_expr_ptr, (rhs_reqs, ts)) = requirements ti tb_rhs (reqs, + { ts & ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error, ts_fun_env = ts_fun_env }) req_type_coercions = [{tc_demanded = temp_fun_type.tst_result,tc_offered = rhs_type, tc_position = {cp_expression = tb_rhs }, tc_coercible = True} : rhs_reqs.req_type_coercions ] ts_expr_heap = storeAttribute rhs_expr_ptr temp_fun_type.tst_result.at_attribute ts.ts_expr_heap @@ -1782,7 +1788,7 @@ where = foldSt create_erroneous_function_type group ts create_erroneous_function_type fun ts - #! env_type = ts.ts_fun_env.[fun] + # (env_type, ts) = ts!ts_fun_env.[fun] = case env_type of ExpandedType fun_type tmp_fun_type exp_fun_type # (fun_type, ts_type_heaps) = extendSymbolType fun_type tmp_fun_type.tst_lifted ts.ts_type_heaps diff --git a/frontend/typeproperties.dcl b/frontend/typeproperties.dcl index fc7677a..430aba9 100644 --- a/frontend/typeproperties.dcl +++ b/frontend/typeproperties.dcl @@ -17,7 +17,6 @@ EmptyTypeClassification :: TypeClassification TopSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = bitnot 0 } ArrowSignClass :== { sc_pos_vect = 2, sc_neg_vect = 1 } -PosSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = 0 } :: Sign = { pos_sign :: !Bool @@ -36,7 +35,9 @@ signClassToSign :: !SignClassification !Int -> Sign IsPositive sign_class index :== sign_class.sc_pos_vect bitand (1 << index) <> 0 IsNegative sign_class index :== sign_class.sc_neg_vect bitand (1 << index) <> 0 */ + instance <<< Sign +instance * Sign :: TypeSign key = { ts_cons_var_signs :: !key diff --git a/frontend/typeproperties.icl b/frontend/typeproperties.icl index 267dfd8..d646e06 100644 --- a/frontend/typeproperties.icl +++ b/frontend/typeproperties.icl @@ -136,4 +136,23 @@ addPropClassification :: ![PropClassification] !PropClassification !TypeClassifi addPropClassification hio_props prop_class tc=:{tc_props} = { tc & tc_props = treeInsert hio_props { ts_cons_var_props = hio_props, ts_type_prop = prop_class } tc_props } +instance * Sign +where + (*) sign1 sign2 + | sign1.pos_sign + | sign1.neg_sign + = sign1 + = sign2 + | sign1.neg_sign + = { pos_sign = sign2.neg_sign, neg_sign = sign2.pos_sign } + = sign1 + +/* + = { pos_sign = sign1.pos_sign * sign2.pos_sign || sign1.neg_sign * sign2.neg_sign, + neg_sign = sign1.pos_sign * sign2.neg_sign || sign1.neg_sign * sign2.pos_sign } + +instance * Bool +where + (*) b1 b2 = b1 && b2 || not b1 && not b2 +*/ diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index effb01d..48b53f6 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -1,7 +1,7 @@ implementation module typesupport import StdEnv, StdCompare -import syntax, parse, check, unitype, utilities // , RWSDebug +import syntax, parse, check, unitype, utilities, checktypes // , RWSDebug // MW: this switch is used to en(dis)able the fusion algorithm SwitchFusion fuse dont_fuse :== dont_fuse @@ -91,8 +91,8 @@ where instance clean_up Type where - clean_up cui (TempV tv_number) cus=:{cus_var_env} - #! type = cus_var_env.[tv_number] + clean_up cui (TempV tv_number) cus + # (type, cus) = cus!cus_var_env.[tv_number] = cleanUpVariable cui.cui_top_level type tv_number cus clean_up cui (TA tc types) cus # (types, cus) = clean_up cui types cus @@ -104,12 +104,12 @@ where clean_up cui t=:(TB _) cus = (t, cus) clean_up cui (TempCV tempvar :@: types) cus - #! type = cus.cus_var_env.[tempvar] + # (type, cus) = cus!cus_var_env.[tempvar] # (type, cus) = cleanUpVariable cui.cui_top_level type tempvar cus (types, cus) = clean_up cui types cus = (simplifyTypeApplication type types, cus) - clean_up cui (TempQV qv_number) cus=:{cus_var_env,cus_error} - #! type = cus_var_env.[qv_number] + clean_up cui (TempQV qv_number) cus=:{cus_error} + # (type, cus) = cus!cus_var_env.[qv_number] | cui.cui_top_level = cleanUpVariable True type qv_number {cus & cus_error = existentialError cus_error} = cleanUpVariable False type qv_number cus @@ -162,7 +162,7 @@ where instance cleanUpClosed Type where cleanUpClosed (TempV tv_number) env - #! type = env.[tv_number] + # (type, env) = env![tv_number] = cleanUpClosedVariable type env cleanUpClosed (TA tc types) env # (cur, types, env) = cleanUpClosed types env @@ -171,7 +171,7 @@ where # (cur, (argtype,restype), env) = cleanUpClosed (argtype,restype) env = (cur, argtype --> restype, env) cleanUpClosed (TempCV tv_number :@: types) env - #! type = env.[tv_number] + # (type, env) = env![tv_number] # (cur1, type, env) = cleanUpClosedVariable type env | checkCleanUpResult cur1 cUndefinedVar = (cur1, TempCV tv_number :@: types, env) @@ -558,19 +558,9 @@ where expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps) expandTypeApplication type_args form_attr type_rhs arg_types act_attr type_heaps=:{th_attrs} - # th_attrs = bind_attr form_attr act_attr th_attrs - = substitute type_rhs (fold2St bind_type_and_attr type_args arg_types { type_heaps & th_attrs = th_attrs }) -where - bind_type_and_attr {atv_attribute = TA_Var {av_name,av_info_ptr}, atv_variable={tv_info_ptr}} {at_attribute,at_type} {th_vars,th_attrs} - = { th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } - bind_type_and_attr {atv_variable={tv_info_ptr}} {at_type} type_heaps=:{th_vars} - = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } - - bind_attr (TA_Var {av_name,av_info_ptr}) attr th_attrs - = th_attrs <:= (av_info_ptr, AVI_Attr attr) - bind_attr _ attr th_attrs - = th_attrs - + # type_heaps = bindTypeVarsAndAttributes form_attr act_attr type_args arg_types type_heaps + (exp_type, type_heaps) = substitute type_rhs type_heaps + = (exp_type, clearBindingsOfTypeVarsAndAttributes form_attr type_args type_heaps) VarIdTable :: {# String} VarIdTable =: { "a", "b", "c", "d", "e", "f", "g", "h", "i", "j" } @@ -746,7 +736,7 @@ where fill_environment [] attr_env = attr_env fill_environment [{ac_demanded,ac_offered} : coercions ] attr_env - #! offered = attr_env.[ac_demanded] + # (offered, attr_env) = attr_env![ac_demanded] = fill_environment coercions { attr_env & [ac_demanded] = TA_List ac_offered offered } clear_environment :: ![AttrCoercion] !*{! TypeAttribute} -> *{! TypeAttribute} diff --git a/frontend/unitype.icl b/frontend/unitype.icl index 5665d83..add10e3 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -2,7 +2,7 @@ implementation module unitype import StdEnv -import syntax, analunitypes, type, utilities // , RWSDebug +import syntax, analunitypes, type, utilities, checktypes, RWSDebug import cheat @@ -198,7 +198,7 @@ liftSubstitution subst modules cons_vars attr_store type_var_heap td_infos where lift_substitution var_index modules cons_vars subst ls | var_index < size subst - #! type = subst.[var_index] + # (type, subst) = subst![var_index] # (type, subst, ls) = lift modules cons_vars type subst ls = lift_substitution (inc var_index) modules cons_vars { subst & [var_index] = type } ls = (subst, ls.ls_next_attr, ls.ls_type_var_heap, ls.ls_td_infos) @@ -238,27 +238,30 @@ where (res_type, subst, ls) = lift modules cons_vars res_type subst ls = (arg_type --> res_type, subst, ls) lift modules cons_vars (TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity} cons_args) subst ls - # (cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars cons_args subst ls + # ({tdi_kinds}, ls) = ls!ls_td_infos.[glob_module].[glob_object] + (cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars cons_args tdi_kinds subst ls (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos = (TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) where - lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] !*{!Type} !*LiftState + lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !*{!Type} !*LiftState -> (![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState) - lift_list modules cons_vars [] subst ls + lift_list modules cons_vars [] _ subst ls = ([], [], [], subst, ls) - lift_list modules cons_vars [t:ts] subst ls + lift_list modules cons_vars [t:ts] [tk : tks] subst ls # (t, subst, ls) = lift modules cons_vars t subst ls - (ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts subst ls - = case t.at_type of - TA {type_arity,type_prop} _ - -> ([t:ts], [adjustSignClass type_prop.tsp_sign type_arity : sign_classes], - [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes], subst, ls) - TempV tmp_var_id - | isPositive tmp_var_id cons_vars - -> ([t:ts], [PosSignClass : sign_classes], [PropClass : prop_classes], subst, ls) - -> ([t:ts], [TopSignClass : sign_classes], [NoPropClass : prop_classes], subst, ls) - _ - -> ([t:ts], [TopSignClass : sign_classes], [PropClass : prop_classes], subst, ls) + (ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls + | IsArrowKind tk + = case t.at_type of + TA {type_arity,type_prop} _ + -> ([t:ts], [adjustSignClass type_prop.tsp_sign type_arity : sign_classes], + [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes], subst, ls) + TempV tmp_var_id + | isPositive tmp_var_id cons_vars + -> ([t:ts], [PostiveSignClass : sign_classes], [PropClass : prop_classes], subst, ls) + -> ([t:ts], [TopSignClass : sign_classes], [NoPropClass : prop_classes], subst, ls) + _ + -> ([t:ts], [TopSignClass : sign_classes], [PropClass : prop_classes], subst, ls) + = ([t:ts], sign_classes, prop_classes, subst, ls) lift modules cons_vars (TempCV temp_var :@: types) subst ls # (type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls @@ -316,9 +319,12 @@ where (at_type, subst_and_es) = expandType modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) = ({ attr_type & at_type = at_type, at_attribute = at_attribute }, subst_and_es) where - expand_attribute (TA_Var {av_info_ptr}) attr_var_heap - # (AVI_Attr attr, attr_var_heap) = readPtr av_info_ptr attr_var_heap - = (attr, attr_var_heap) + expand_attribute (TA_Var {av_name,av_info_ptr}) attr_var_heap + = case (readPtr av_info_ptr attr_var_heap) of + (AVI_Attr attr, attr_var_heap) + -> (attr, attr_var_heap) + (info, attr_var_heap) + -> abort ("expand_attribute (unitype.icl)" ---> (av_name <<- info )) expand_attribute attr attr_var_heap = (attr, attr_var_heap) @@ -329,6 +335,9 @@ expandTempTypeVariable tv_number (subst, es) TE -> (TempV tv_number, (subst, es)) _ -> (type, (subst, es)) +IsArrowKind (KindArrow _) = True +IsArrowKind _ = False + instance expandType Type where expandType modules cons_vars (TempV tv_number) es @@ -340,31 +349,34 @@ where # (arg_type, es) = expandType modules cons_vars arg_type es (res_type, es) = expandType modules cons_vars res_type es = (arg_type --> res_type, es) - expandType modules cons_vars (TA cons_id=:{type_name, type_index={glob_object,glob_module}} cons_args) es - # (cons_args, sign_classes, prop_classes, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args es + expandType modules cons_vars (TA cons_id=:{type_name, type_index={glob_object,glob_module}} cons_args) (subst, es) + # ({tdi_kinds}, es) = es!es_td_infos.[glob_module].[glob_object] + (cons_args, hio_signs, hio_props, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args tdi_kinds (subst, es) (type_prop, th_vars, es_td_infos) - = typeProperties glob_object glob_module sign_classes prop_classes modules es_type_heaps.th_vars es_td_infos + = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos = (TA { cons_id & type_prop = type_prop } cons_args, (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) // ---> ("expandType", type_name, type_prop.tsp_propagation) where - expand_type_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] !*(!u:{!Type}, !*ExpansionState) - -> (![AType], ![SignClassification], ![PropClassification], !*(!u:{!Type}, !*ExpansionState)) - expand_type_list modules cons_vars [] es + expand_type_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !(!u:{!Type}, !*ExpansionState) + -> (![AType], ![SignClassification], ![PropClassification], !(!u:{!Type}, !*ExpansionState)) + expand_type_list modules cons_vars [] _ es = ([], [], [], es) - expand_type_list modules cons_vars [t:ts] es + expand_type_list modules cons_vars [t:ts] [tk : tks] es # (t, es) = expandType modules cons_vars t es - (ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts es - = case t.at_type of - TA {type_arity,type_prop} _ - -> ([t:ts], [adjustSignClass type_prop.tsp_sign type_arity : sign_classes], - [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes], es) - TempV tmp_var_id - | isPositive tmp_var_id cons_vars - -> ([t:ts], [PosSignClass : sign_classes], [PropClass : prop_classes], es) - -> ([t:ts], [TopSignClass : sign_classes], [NoPropClass : prop_classes], es) - _ - -> ([t:ts], [TopSignClass : sign_classes], [PropClass : prop_classes], es) + (ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es + | IsArrowKind tk + = case t.at_type of + TA {type_arity,type_prop} _ + -> ([t:ts], [adjustSignClass type_prop.tsp_sign type_arity : sign_classes], + [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes], es) + TempV tmp_var_id + | isPositive tmp_var_id cons_vars + -> ([t:ts], [PostiveSignClass : sign_classes], [PropClass : prop_classes], es) + -> ([t:ts], [TopSignClass : sign_classes], [NoPropClass : prop_classes], es) + _ + -> ([t:ts], [TopSignClass : sign_classes], [PropClass : prop_classes], es) + = ([t:ts], sign_classes, prop_classes, es) expandType modules cons_vars (TempCV temp_var :@: types) es # (type, es) = expandTempTypeVariable temp_var es @@ -393,16 +405,6 @@ where toInt TA_TempExVar = AttrExi -instance * Bool -where - (*) b1 b2 = b1 && b2 || not b1 && not b2 - -instance * Sign -where - (*) sign1 sign2 - = { pos_sign = sign1.pos_sign * sign2.pos_sign || sign1.neg_sign * sign2.neg_sign, - neg_sign = sign1.pos_sign * sign2.neg_sign || sign1.neg_sign * sign2.pos_sign } - :: CoercionState = { crc_type_heaps :: !.TypeHeaps , crc_coercions :: !.Coercions @@ -572,8 +574,8 @@ where tryToMakeNonUnique :: !Int !*Coercions -> (!Bool, !*Coercions) tryToMakeNonUnique attr coercions=:{coer_demanded} #! s = size coer_demanded - | isUnique coer_demanded.[attr - -?-> (s <= attr, ("tryToMakeNonUnique", s, attr))] + | isUnique coer_demanded.[attr] +// -?-> (s <= attr, ("tryToMakeNonUnique", s, attr))] = (False, coercions) = (True, makeNonUnique attr coercions) // ---> ("tryToMakeNonUnique", attr) @@ -585,21 +587,18 @@ Success (Yes _) = False instance coerce AType where - coerce sign defs cons_vars tpos at1=:{at_attribute=attr1,at_type=type1} at2=:{at_attribute=attr2,at_type=type2} cs=:{crc_coercions} + coerce sign defs cons_vars tpos at1=:{at_attribute=attr1, at_type = type1} at2=:{at_attribute=attr2} cs=:{crc_coercions} # attr_sign = adjust_sign sign type1 cons_vars (succ, crc_coercions) = coerceAttributes attr1 attr2 attr_sign crc_coercions | succ - # (succ, cs) = coerce sign defs cons_vars tpos type1 type2 { cs & crc_coercions = crc_coercions } + # (succ, cs) = coerceTypes sign defs cons_vars tpos at1 at2 { cs & crc_coercions = crc_coercions } | Success succ # (succ1, crc_coercions) = add_propagation_inequalities attr1 type1 cs.crc_coercions - (succ2, crc_coercions) = add_propagation_inequalities attr2 type2 crc_coercions + (succ2, crc_coercions) = add_propagation_inequalities attr2 at2.at_type crc_coercions = (if (succ1 && succ2) No (Yes tpos), { cs & crc_coercions = crc_coercions }) = (succ, cs) = (Yes tpos, { cs & crc_coercions = crc_coercions }) - // ---> ("coerceAttributes", attr1, attr2, sign) - where - adjust_sign :: !Sign !Type {# BOOLVECT} -> Sign adjust_sign sign (TempV _) cons_vars = TopSign @@ -637,84 +636,75 @@ where add_propagation_inequalities attr type coercions = (True, coercions) -isSynonymType (SynType _) - = True -isSynonymType type_rhs - = False - -tryToExpandTypeSyn defs cons_vars cons_id=:{type_index={glob_object,glob_module}} type_args type_heaps td_infos - # {td_rhs,td_args} = defs.[glob_module].com_type_defs.[glob_object] - | isSynonymType td_rhs - # (SynType {at_type}) = td_rhs - type_heaps = fold2St bind_type_and_attr td_args type_args type_heaps - (expanded_type, (_, {es_type_heaps, es_td_infos})) - = expandType defs cons_vars at_type ({}, { es_type_heaps = type_heaps, es_td_infos = td_infos }) - = (True, expanded_type, es_type_heaps, es_td_infos) -// ---> expanded_type - = (False, TA cons_id type_args, type_heaps, td_infos) -where - bind_type_and_attr {atv_attribute = TA_Var {av_info_ptr}, atv_variable={tv_info_ptr}} {at_attribute,at_type} {th_vars,th_attrs} - = { th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } - bind_type_and_attr {atv_variable={tv_info_ptr}} {at_type} type_heaps=:{th_vars} - = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } - - -instance coerce Type -where - coerce sign defs cons_vars tpos (TA dem_cons dem_args) (TA off_cons off_args) cs=:{crc_type_heaps, crc_td_infos} - | dem_cons == off_cons - = coercions_of_arg_types sign defs cons_vars tpos dem_args off_args dem_cons.type_prop.tsp_sign 0 cs - # (_, dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars dem_cons dem_args crc_type_heaps crc_td_infos - (_, off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars off_cons off_args crc_type_heaps crc_td_infos - = coerce sign defs cons_vars tpos dem_type off_type { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } - where - coercions_of_arg_types sign defs cons_vars tpos [t1 : ts1] [t2 : ts2] sign_class arg_number cs - # arg_sign = sign * signClassToSign sign_class arg_number - (succ, cs) = coerce arg_sign defs cons_vars [arg_number : tpos] t1 t2 cs - | Success succ - = coercions_of_arg_types sign defs cons_vars tpos ts1 ts2 sign_class (inc arg_number) cs - = (succ, cs) - coercions_of_arg_types sign defs cons_vars tpos [] [] _ _ cs - = (No, cs) - - coerce sign defs cons_vars tpos (TA dem_cons dem_args) off_type cs=:{crc_type_heaps, crc_td_infos} - # (succ, dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars dem_cons dem_args crc_type_heaps crc_td_infos - | succ - = coerce sign defs cons_vars tpos dem_type off_type { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } - = (No, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }) - coerce sign defs cons_vars tpos dem_type (TA off_cons off_args) cs=:{crc_type_heaps, crc_td_infos} - # (succ, off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars off_cons off_args crc_type_heaps crc_td_infos - | succ - = coerce sign defs cons_vars tpos dem_type off_type { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } - = (No, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }) - coerce sign defs cons_vars tpos (arg_type1 --> res_type1) (arg_type2 --> res_type2) cs - # arg_sign = NegativeSign * sign - # (succ, cs) = coerce arg_sign defs cons_vars [0 : tpos] arg_type1 arg_type2 cs - | Success succ - = coerce sign defs cons_vars [1 : tpos] res_type1 res_type2 cs - = (succ, cs) - coerce _ defs cons_vars tpos (cons_var :@: types1) (_ :@: types2) cs - # sign = determine_sign_of_arg_types cons_var cons_vars - = coercions_of_type_list sign defs cons_vars tpos 0 types1 types2 cs +tryToExpandTypeSyn :: !{#CommonDefs} !{#BOOLVECT} !TypeSymbIdent ![AType] !TypeAttribute !*TypeHeaps !*TypeDefInfos + -> (!Bool, !Type, !*TypeHeaps, !*TypeDefInfos) +tryToExpandTypeSyn defs cons_vars cons_id=:{type_index={glob_object,glob_module}} type_args attribute type_heaps td_infos + # {td_rhs,td_args,td_attribute,td_name} = defs.[glob_module].com_type_defs.[glob_object] + = case td_rhs of + SynType {at_type} + # type_heaps = bindTypeVarsAndAttributes td_attribute attribute td_args type_args type_heaps + (expanded_type, (_, {es_type_heaps, es_td_infos})) = expandType defs cons_vars at_type + ({}, { es_type_heaps = type_heaps, es_td_infos = td_infos }) + -> (True, expanded_type, clearBindingsOfTypeVarsAndAttributes attribute td_args es_type_heaps, es_td_infos) + _ + -> (False, TA cons_id type_args, type_heaps, td_infos) + +coerceTypes :: !Sign !{# CommonDefs} !{# BOOLVECT} !TypePosition !AType !AType !*CoercionState -> (!Optional TypePosition, !*CoercionState) +coerceTypes sign defs cons_vars tpos dem_type=:{at_type = TA dem_cons dem_args} off_type=:{at_type = TA off_cons off_args} cs=:{crc_type_heaps, crc_td_infos} + | dem_cons == off_cons + = coercions_of_arg_types sign defs cons_vars tpos dem_args off_args dem_cons.type_prop.tsp_sign 0 cs + # (_, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos + (_, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars off_cons off_args off_type.at_attribute crc_type_heaps crc_td_infos + = coerceTypes sign defs cons_vars tpos { dem_type & at_type = exp_dem_type } { off_type & at_type = exp_off_type } + { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } where - determine_sign_of_arg_types (TempCV tmp_var_id) cons_vars - | isPositive tmp_var_id cons_vars - = PositiveSign - = TopSign - determine_sign_of_arg_types _ cons_vars - = TopSign - -// coercions_of_type_list :: !Sign !{# CommonDefs} !{# BOOLVECT} ![a] ![a] !*CoercionState -> (!Bool,!*CoercionState) | coerce a - coercions_of_type_list sign defs cons_vars tpos arg_number [t1 : ts1] [t2 : ts2] cs - # (succ, cs) = coerce sign defs cons_vars [arg_number : tpos] t1 t2 cs - | Success succ - = coercions_of_type_list sign defs cons_vars tpos (inc arg_number) ts1 ts2 cs + coercions_of_arg_types sign defs cons_vars tpos [t1 : ts1] [t2 : ts2] sign_class arg_number cs + # arg_sign = sign * signClassToSign sign_class arg_number + (succ, cs) = coerce arg_sign defs cons_vars [arg_number : tpos] t1 t2 cs + | Success succ + = coercions_of_arg_types sign defs cons_vars tpos ts1 ts2 sign_class (inc arg_number) cs = (succ, cs) - coercions_of_type_list sign defs cons_vars tpos arg_number [] [] cs + coercions_of_arg_types sign defs cons_vars tpos [] [] _ _ cs = (No, cs) - - coerce sign defs cons_vars tpos _ _ cs +coerceTypes sign defs cons_vars tpos dem_type=:{at_type = TA dem_cons dem_args} off_type cs=:{crc_type_heaps, crc_td_infos} + # (succ, exp_dem_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars dem_cons dem_args dem_type.at_attribute crc_type_heaps crc_td_infos + | succ + = coerceTypes sign defs cons_vars tpos { dem_type & at_type = exp_dem_type } off_type + { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } + = (No, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }) +coerceTypes sign defs cons_vars tpos dem_type off_type=:{at_type = TA off_cons off_args} cs=:{crc_type_heaps, crc_td_infos} + # (succ, exp_off_type, crc_type_heaps, crc_td_infos) = tryToExpandTypeSyn defs cons_vars off_cons off_args off_type.at_attribute + crc_type_heaps crc_td_infos + | succ + = coerceTypes sign defs cons_vars tpos dem_type { off_type & at_type = exp_off_type } + { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos } + = (No, { cs & crc_type_heaps = crc_type_heaps, crc_td_infos = crc_td_infos }) +coerceTypes sign defs cons_vars tpos {at_type = arg_type1 --> res_type1} {at_type = arg_type2 --> res_type2} cs + # arg_sign = NegativeSign * sign + # (succ, cs) = coerce arg_sign defs cons_vars [0 : tpos] arg_type1 arg_type2 cs + | Success succ + = coerce sign defs cons_vars [1 : tpos] res_type1 res_type2 cs + = (succ, cs) +coerceTypes _ defs cons_vars tpos {at_type = cons_var :@: types1} {at_type = _ :@: types2} cs + # sign = determine_sign_of_arg_types cons_var cons_vars + = coercions_of_type_list sign defs cons_vars tpos 0 types1 types2 cs +where + determine_sign_of_arg_types (TempCV tmp_var_id) cons_vars + | isPositive tmp_var_id cons_vars + = PositiveSign + = TopSign + determine_sign_of_arg_types _ cons_vars + = TopSign + + coercions_of_type_list sign defs cons_vars tpos arg_number [t1 : ts1] [t2 : ts2] cs + # (succ, cs) = coerce sign defs cons_vars [arg_number : tpos] t1 t2 cs + | Success succ + = coercions_of_type_list sign defs cons_vars tpos (inc arg_number) ts1 ts2 cs + = (succ, cs) + coercions_of_type_list sign defs cons_vars tpos arg_number [] [] cs = (No, cs) +coerceTypes sign defs cons_vars tpos _ _ cs + = (No, cs) AttrRestricted :== 0 diff --git a/frontend/utilities.dcl b/frontend/utilities.dcl index 30eba7c..66c2866 100644 --- a/frontend/utilities.dcl +++ b/frontend/utilities.dcl @@ -1,6 +1,5 @@ definition module utilities -from StdString import String from StdEnv import Eq, not, Ord, IncDec import StdMisc, general @@ -10,6 +9,8 @@ import _aconcat For Strings */ +from StdString import String // 1.3 + stringToCharList :: !String -> [Char] charListToString :: ![Char] -> String revCharListToString :: !Int ![Char] -> String |