Commit d4e8aaf9 authored by Jurrien Stutterheim's avatar Jurrien Stutterheim

Revert itasks-tonic back to the state of r2698

parent 18cf3d05
......@@ -4,7 +4,7 @@ import Tonic.Util
import Tonic.GraphGen
import Tonic.Pretty
import syntax, checksupport, compile, unitype, generics1
from overloading import :: InstanceTree (..), find_instance, :: Subst
from overloading import :: InstanceTree (..), find_instance
import StdFile
from CoclSystemDependent import DirectorySeparator, ensureCleanSystemFilesExists
import Text
......
......@@ -248,7 +248,7 @@ ppParsedExpr (PE_Ident symb) = text (case symb.id_name of
name -> name
)
ppParsedExpr PE_WildCard = char '_'
ppParsedExpr (PE_Lambda _ exprs rhsexpr _) = char '\\' <-> hcat (intersperse (text " ") (map ppParsedExpr exprs)) <-> text " -> " <-> ppRhs rhsexpr
ppParsedExpr (PE_Lambda _ exprs expr _) = char '\\' <-> hcat (intersperse (text " ") (map ppParsedExpr exprs)) <-> text " -> " <-> ppParsedExpr expr
ppParsedExpr (PE_Bound bind) = ppBoundExpr bind
ppParsedExpr (PE_Case _ expr alts) = text "case " <-> ppParsedExpr expr <-> text " of\n" <-> hcat (intersperse (text " ") (map ppCaseAlt alts))
ppParsedExpr (PE_Let defs expr) = text "let " <-> ppLocalDefs defs <-> text " in\n" <-> ppParsedExpr expr
......
......@@ -465,15 +465,8 @@ typeHasClassInstance` ty lookup_symbol inh chn
| coer_demanded = {}
, coer_offered = {}
}
# subst = { Subst
| subst_changed = False
, subst_array = {}
, subst_next_var_n = 0
, subst_previous_context_n = -1
, subst_context_n_at_last_update = -1
}
# heaps = chn.chn_heaps
# (inst, ctxs, hp_type_heaps, _) = find_instance [ty] instance_tree inh.inh_common_defs heaps.hp_type_heaps subst
# (inst, ctxs, uni_ok, hp_type_heaps, coercions) = find_instance [ty] instance_tree inh.inh_common_defs heaps.hp_type_heaps coercions
# chn = {chn & chn_heaps = {heaps & hp_type_heaps = hp_type_heaps}}
# defs = inh.inh_common_defs.[lookup_def.pds_module].com_class_defs.[lookup_def.pds_def]
= (inst.glob_module <> NotFound && inst.glob_object <> NotFound, chn)
......@@ -500,14 +493,11 @@ typeHasClassSynonymInstance ty lookup_symbol inh chn
tyHasClasses` :: {#{!InstanceTree}} (Global DefinedSymbol) Type *TypeHeaps -> *(Bool, *TypeHeaps)
tyHasClasses` class_instances {glob_module, glob_object} at_type hp_type_heaps
# instance_tree = class_instances.[glob_module].[glob_object.ds_index]
# subst = { Subst
| subst_changed = False
, subst_array = {}
, subst_next_var_n = 0
, subst_previous_context_n = -1
, subst_context_n_at_last_update = -1
}
# (inst, ctxs, hp_type_heaps, coercions) = find_instance [at_type] instance_tree inh.inh_common_defs hp_type_heaps subst
# coercions = { Coercions
| coer_demanded = {}
, coer_offered = {}
}
# (inst, ctxs, uni_ok, hp_type_heaps, coercions) = find_instance [at_type] instance_tree inh.inh_common_defs hp_type_heaps coercions
= (inst.glob_module <> NotFound && inst.glob_object <> NotFound, hp_type_heaps)
isInfix :: SymbIdent *ChnExpression -> *(Bool, *ChnExpression)
......@@ -936,21 +926,6 @@ refreshVariables fvs e chn
refreshVariables` (TupleSelect ds n e) (var_heap, expr_heap)
# (e, (var_heap, expr_heap)) = refreshVariables` e (var_heap, expr_heap)
= (TupleSelect ds n e, (var_heap, expr_heap))
refreshVariables` e=:(BasicExpr _) (var_heap, expr_heap)
= (e, (var_heap, expr_heap))
refreshVariables` (Conditional {if_cond, if_then, if_else}) (var_heap, expr_heap)
# (if_cond, (var_heap, expr_heap)) = refreshVariables` if_cond (var_heap, expr_heap)
# (if_then, (var_heap, expr_heap)) = refreshVariables` if_then (var_heap, expr_heap)
# (if_else, (var_heap, expr_heap)) = case if_else of
Yes e
# (e, (var_heap, expr_heap)) = (refreshVariables` e (var_heap, expr_heap))
= (Yes e, (var_heap, expr_heap))
_ = (No, (var_heap, expr_heap))
= (Conditional {if_cond = if_cond, if_then = if_then, if_else = if_else}, (var_heap, expr_heap))
refreshVariables` e=:(AnyCodeExpr _ _ _) (var_heap, expr_heap)
= (e, (var_heap, expr_heap))
refreshVariables` e=:(ABCCodeExpr _ _) (var_heap, expr_heap)
= (e, (var_heap, expr_heap))
refreshVariables` (MatchExpr gds e) (var_heap, expr_heap)
# (e, (var_heap, expr_heap)) = refreshVariables` e (var_heap, expr_heap)
= (MatchExpr gds e, (var_heap, expr_heap))
......@@ -967,25 +942,8 @@ refreshVariables fvs e chn
refreshVariables` (DictionariesFunction as e aty) (var_heap, expr_heap)
# (e, (var_heap, expr_heap)) = refreshVariables` e (var_heap, expr_heap)
= (DictionariesFunction as e aty, (var_heap, expr_heap))
refreshVariables` e=:(Constant _ _ _) (var_heap, expr_heap)
= (e, (var_heap, expr_heap))
refreshVariables` e=:(ClassVariable _) (var_heap, expr_heap)
= (e, (var_heap, expr_heap))
refreshVariables` (DynamicExpr de) (var_heap, expr_heap)
# (dyn_expr, (var_heap, expr_heap)) = refreshVariables` de.dyn_expr (var_heap, expr_heap)
= (DynamicExpr {de & dyn_expr = dyn_expr}, (var_heap, expr_heap))
refreshVariables` e=:(TypeCodeExpression _) (var_heap, expr_heap)
= (e, (var_heap, expr_heap))
refreshVariables` (TypeSignature f e) (var_heap, expr_heap)
# (e, (var_heap, expr_heap)) = refreshVariables` e (var_heap, expr_heap)
= (TypeSignature f e, (var_heap, expr_heap))
refreshVariables` e=:EE (var_heap, expr_heap)
= (e, (var_heap, expr_heap))
refreshVariables` e=:(NoBind _) (var_heap, expr_heap)
= (e, (var_heap, expr_heap))
refreshVariables` e=:(FailExpr _) (var_heap, expr_heap)
= (e, (var_heap, expr_heap))
refreshVariables` e (var_heap, expr_heap) = abort "refreshVariables` uncaught e"
refreshVariables` e (var_heap, expr_heap) = (e, (var_heap, expr_heap))
refreshSelection (ArraySelection gds eip e) (var_heap, expr_heap)
# (e, (var_heap, expr_heap)) = refreshVariables` e (var_heap, expr_heap)
......@@ -1179,14 +1137,11 @@ wrapBody inh syn hasTonic chn
tyHasITaskClasses` :: {#{!InstanceTree}} (Global DefinedSymbol) Type *TypeHeaps -> *(Bool, *TypeHeaps)
tyHasITaskClasses` class_instances {glob_module, glob_object} at_type hp_type_heaps
# instance_tree = class_instances.[glob_module].[glob_object.ds_index]
# subst = { Subst
| subst_changed = False
, subst_array = {}
, subst_next_var_n = 0
, subst_previous_context_n = -1
, subst_context_n_at_last_update = -1
}
# (inst, ctxs, hp_type_heaps, _) = find_instance [at_type] instance_tree common_defs hp_type_heaps subst
# coercions = { Coercions
| coer_demanded = {}
, coer_offered = {}
}
# (inst, ctxs, uni_ok, hp_type_heaps, coercions) = find_instance [at_type] instance_tree common_defs hp_type_heaps coercions
= (inst.glob_module <> NotFound && inst.glob_object <> NotFound, hp_type_heaps)
varNoITaskCtx :: FreeVar [TypeContext] *PredefinedSymbols -> *(Bool, *PredefinedSymbols)
......
......@@ -937,12 +937,6 @@ where
determine_kinds_of_context_class modules {tc_class=TCGeneric {gtc_kind}} infos_and_as
= infos_and_as
bind_kind_avars type_vars kind_ptrs type_var_heap
= fold2St bind_kind_avar type_vars kind_ptrs type_var_heap
where
bind_kind_avar {atv_variable={tv_info_ptr}} kind_info_ptr type_var_heap
= type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr)
bind_kind_vars type_vars kind_ptrs type_var_heap
= fold2St bind_kind_var type_vars kind_ptrs type_var_heap
where
......@@ -957,14 +951,14 @@ where
determine_kinds_of_members modules members member_defs class_kind_vars (class_infos, as)
= iFoldSt (determine_kind_of_member modules members member_defs class_kind_vars) 0 (size members) (class_infos, as)
determine_kind_of_member modules members member_defs class_kind_vars loc_member_index class_infos_and_as
# glob_member_index = members.[loc_member_index].ds_index
{me_class_vars,me_type={st_vars,st_args,st_result,st_context}} = member_defs.[glob_member_index]
other_contexts = tl st_context
(class_infos, as) = determine_kinds_of_context_classes other_contexts class_infos_and_as
as_type_var_heap = clear_variables st_vars as.as_type_var_heap
as_type_var_heap = bind_kind_avars me_class_vars class_kind_vars as_type_var_heap
as_type_var_heap = bind_kind_vars me_class_vars class_kind_vars as_type_var_heap
(as_type_var_heap, as_kind_heap) = fresh_kind_vars_for_unbound_vars st_vars as_type_var_heap as.as_kind_heap
as = determine_kinds_type_list modules [st_result:st_args] { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap}
= determine_kinds_of_type_contexts modules other_contexts class_infos as
......@@ -1048,7 +1042,7 @@ where
= (class_infos, as)
# (class_infos, as) = check_kinds_of_class_instance common_defs instance_defs.[instance_index] class_infos as
= check_kinds_of_class_instances common_defs (inc instance_index) instance_defs class_infos as
where
where
check_kinds_of_class_instance :: !{#CommonDefs} !ClassInstance !*ClassDefInfos !*AnalyseState -> (!*ClassDefInfos, !*AnalyseState)
check_kinds_of_class_instance common_defs {ins_class_index,ins_class_ident={ci_ident=Ident class_ident,ci_arity},ins_ident,ins_pos,ins_type={it_vars,it_types,it_context}} class_infos
as=:{as_type_var_heap,as_kind_heap,as_error}
......
......@@ -14,7 +14,7 @@ checkDclMacros :: !Index !Level !Index !Index !*ExpressionInfo !*Heaps !*CheckSt
checkForeignExportedFunctionTypes :: ![ForeignExport] !*ErrorAdmin !p:PredefinedSymbols !*{#FunDef}
-> (!*ErrorAdmin,!p:PredefinedSymbols,!*{#FunDef})
determineTypeOfMemberInstance :: !SymbolType ![ATypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin
-> (!SymbolType, !FunSpecials, !*TypeHeaps,!u: Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin)
arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x]
......
This diff is collapsed.
......@@ -1245,10 +1245,6 @@ cons_optional (Yes var) variables
cons_optional No variables
= variables
no_TFAC_argument [{at_type=TFAC _ _ _}:_] = False
no_TFAC_argument [_:args] = no_TFAC_argument args
no_TFAC_argument [] = True
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}
......@@ -1416,6 +1412,10 @@ where
= SK_LocalMacroFunction index.glob_object
= SK_Function index
no_TFAC_argument [{at_type=TFAC _ _ _}:_] = False
no_TFAC_argument [_:args] = no_TFAC_argument args
no_TFAC_argument [] = True
checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_input=:{ei_fun_index,ei_mod_index} e_state e_info cs
# (found,{decl_kind,decl_ident,decl_index},cs) = search_qualified_ident module_id ident_name ExpressionNameSpaceN cs
| not found
......@@ -1431,21 +1431,14 @@ checkQualifiedIdentExpression free_vars module_id ident_name is_expr_list e_inpu
# e_state = { e_state & es_calls = [DclFunCall mod_index decl_index : e_state.es_calls ]}
-> (app_expr, free_vars, e_state, e_info, cs)
STE_Imported STE_Constructor mod_index
# ({cons_type={st_arity,st_args,st_context},cons_priority,cons_number}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index]
# ({cons_type={st_arity,st_context},cons_priority,cons_number}, e_info) = e_info!ef_modules.[mod_index].dcl_common.com_cons_defs.[decl_index]
| cons_number <> -2
# kind = SK_Constructor { glob_object = decl_index, glob_module = mod_index }
symbol = { symb_ident = decl_ident, symb_kind = kind }
| isEmpty st_context
| no_TFAC_argument st_args
# kind = SK_Constructor { glob_object = decl_index, glob_module = mod_index }
symbol = { symb_ident = decl_ident, symb_kind = kind }
(app_expr,e_state) = build_application_or_constant_for_function symbol st_arity cons_priority e_state
-> (app_expr, free_vars, e_state, e_info, cs)
# kind = SK_OverloadedConstructor { glob_object = decl_index, glob_module = mod_index }
symbol = { symb_ident = decl_ident, symb_kind = kind }
(app_expr,e_state) = build_application_or_constant_for_function symbol st_arity cons_priority e_state
-> (app_expr, free_vars, e_state, e_info, cs)
# kind = SK_OverloadedConstructor { glob_object = decl_index, glob_module = mod_index }
symbol = { symb_ident = decl_ident, symb_kind = kind }
app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority
# (app_expr,e_state) = build_application_or_constant_for_function symbol st_arity cons_priority e_state
-> (app_expr, free_vars, e_state, e_info, cs)
# app_expr = build_application_or_constant_for_constructor symbol st_arity cons_priority
-> (app_expr, free_vars, e_state, e_info, cs)
# kind = SK_NewTypeConstructor { gi_index = decl_index, gi_module = mod_index }
# symbol = { symb_ident = decl_ident, symb_kind = kind }
......
......@@ -224,7 +224,7 @@ where
= (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
# (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
= check_generic_case_def index mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
= check_generic_case_defs (inc index) mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
= check_generic_case_defs (inc index) mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
check_generic_case_def index mod_index gen_case_defs generic_defs type_defs class_defs modules heaps cs
# (case_def=:{gc_pos,gc_type,gc_gcf}, gen_case_defs) = gen_case_defs![index]
......@@ -232,14 +232,14 @@ where
GCF gc_ident gcf=:{gcf_gident}
# cs = pushErrorAdmin (newPosition gc_ident gc_pos) cs
# (gc_type, gc_type_cons, type_defs, modules, heaps, cs)
= check_instance_type mod_index gc_type type_defs modules heaps cs
= check_instance_type mod_index gc_type type_defs modules heaps cs
# (generic_gi, cs) = get_generic_index gcf_gident mod_index cs
| not cs.cs_error.ea_ok
# cs = popErrorAdmin cs
-> (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
# case_def = {case_def & gc_gcf=GCF gc_ident {gcf & gcf_generic = generic_gi}, gc_type=gc_type, gc_type_cons=gc_type_cons}
# gen_case_defs = {gen_case_defs & [index] = case_def}
# cs = popErrorAdmin cs
# cs = popErrorAdmin cs
-> (gen_case_defs, generic_defs, type_defs, class_defs, modules, heaps, cs)
GCFS gcfs
# cs = pushErrorAdmin (newPosition {id_name="derive generic superclass",id_info=nilPtr} gc_pos) cs
......@@ -479,17 +479,17 @@ where
create_gencase_function_type {id_name} gc_type_cons gc_pos var_heap
#! fun_ident = genericIdentToFunIdent id_name gc_type_cons
#! (var_info_ptr, var_heap) = newPtr VI_Empty var_heap
#! fun =
{ ft_ident = fun_ident
, ft_arity = 0
, ft_priority = NoPrio
, ft_type = {st_vars=[],st_attr_vars=[],st_arity=0,st_args=[],st_result={at_type=TE,at_attribute=TA_Multi},st_attr_env=[],st_context=[],st_args_strictness=NotStrict}
, ft_pos = gc_pos
, ft_specials = FSP_None
, ft_type_ptr = var_info_ptr
#! fun =
{ ft_ident = fun_ident
, ft_arity = 0
, ft_priority = NoPrio
, ft_type = {st_vars=[],st_attr_vars=[],st_arity=0,st_args=[],st_result={at_type=TE,at_attribute=TA_Multi},st_attr_env=[],st_context=[],st_args_strictness=NotStrict}
, ft_pos = gc_pos
, ft_specials = FSP_None
, ft_type_ptr = var_info_ptr
, ft_pragmas = []
, ft_docs = ""
}
}
= (fun,var_heap)
NewEntry symbol_table symb_ptr def_kind def_index level previous :==
......
......@@ -4,17 +4,16 @@ import checksupport
checkTypeDefs :: !Index !(Optional (CopiedDefinitions, Int))
!*{#CheckedTypeDef} !*{#ConsDef} !*{#SelectorDef} !v:{#ClassDef} !*{#DclModule} !*Heaps !*CheckState
-> (!*{#CheckedTypeDef},!*{#ConsDef},!*{#SelectorDef},!v:{#ClassDef},!*{#DclModule},!*Heaps,!*CheckState)
-> (!*{#CheckedTypeDef}, *{#ConsDef},!*{#SelectorDef},!v:{#ClassDef},!*{#DclModule},!*Heaps,!*CheckState)
checkFunctionType :: !Index !SymbolType !FunSpecials !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType,!FunSpecials,!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*CheckState)
checkMemberType :: !Index !SymbolType !u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType,![ATypeVar],!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*CheckState)
checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
checkInstanceType :: !Index !GlobalIndex !ClassIdent !BITVECT
!InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!InstanceType,!Specials,!u:{# CheckedTypeDef},!v:{# ClassDef},!u:{# DclModule},!*TypeHeaps,!*CheckState)
checkInstanceType :: !Index !GlobalIndex !ClassIdent !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!InstanceType,!Specials,!u:{# CheckedTypeDef},!v:{# ClassDef},!u:{# DclModule},!*TypeHeaps,!*CheckState)
checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (![TypeVar], ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
......
This diff is collapsed.
......@@ -20,7 +20,3 @@ instance == BasicType, TypeVar, AttributeVar, AttrInequality, TypeSymbIdent, Def
instance < MemberDef
smallerOrEqual :: !Type !Type -> CompareValue
IF_ALLOW_NON_LINEAR_AND_OVERLAPPING_INSTANCES yes no :== no
compareInstances :: ![Type] ![Type] -> CompareValue
compareFunDepInstances :: ![Type] ![Type] !BITVECT -> CompareValue
......@@ -314,86 +314,3 @@ where
instance < MemberDef
where
(<) md1 md2 = md1.me_ident.id_name < md2.me_ident.id_name
(CAND) infix 3 :: !(!CompareValue, ![Ident], ![Ident]) (CompareValue, ![Ident], ![Ident]) -> (CompareValue, ![Ident], ![Ident])
(CAND) (cv1,vlist1a,vlist1b) cl2
| cv1 == Equal
= case cl2 of
(cv2,vlist2a,vlist2b)
| cv2 == Equal
-> (Equal, vlist1a ++ vlist2a, vlist1b ++ vlist2b)
-> cl2
= (cv1,vlist1a,vlist1b)
compareInstances :: ![Type] ![Type] -> CompareValue
compareInstances types1 types2
# (cv, vlist1, vlist2) = compare_lists types1 types2
| cv == Equal
# l1 = length (removeDup vlist1)
# l2 = length (removeDup vlist2)
| l1 == l2
= Equal
| l1 < l2
= Smaller
= Greater
= cv
where
compare_lists [type1:types1] [type2:types2]
= compareInstanceTypes type1 type2 CAND compare_lists types1 types2
compare_lists [] []
= (Equal, [],[])
compare_lists [] types
= (Smaller, [],[])
compare_lists types []
= (Greater, [],[])
compareFunDepInstances :: ![Type] ![Type] !BITVECT -> CompareValue
compareFunDepInstances types1 types2 fun_dep_vars
# (cv, vlist1, vlist2) = compare_lists types1 types2 fun_dep_vars
| cv == Equal
# l1 = length (removeDup vlist1)
# l2 = length (removeDup vlist2)
| l1 == l2
= Equal
| l1 < l2
= Smaller
= Greater
= cv
where
compare_lists [type1:types1] [type2:types2] fun_dep_vars
| fun_dep_vars bitand 1==0
= compareInstanceTypes type1 type2 CAND compare_lists types1 types2 (fun_dep_vars>>1)
= compare_lists types1 types2 (fun_dep_vars>>1)
compare_lists [] [] fun_dep_vars
= (Equal, [],[])
compare_lists [] types fun_dep_vars
= (Smaller, [],[])
compare_lists types [] fun_dep_vars
= (Greater, [],[])
compareInstanceTypes (TA tc1 a1) (TA tc2 a2) = (tc1 =< tc2,[],[]) CAND compareArguments a1 a2
compareInstanceTypes (TA tc1 a1) (TAS tc2 a2 _) = (tc1 =< tc2,[],[]) CAND compareArguments a1 a2
compareInstanceTypes (TAS tc1 a1 _) (TA tc2 a2) = (tc1 =< tc2,[],[]) CAND compareArguments a1 a2
compareInstanceTypes (TAS tc1 a1 _) (TAS tc2 a2 _) = (tc1 =< tc2,[],[]) CAND compareArguments a1 a2
compareInstanceTypes t1 t2
| equal_constructor t1 t2
= compare_arguments t1 t2
| less_constructor t1 t2
= (Smaller, [],[])
= (Greater, [],[])
where
compare_arguments (TB tb1) (TB tb2) = (tb1 =< tb2, [],[])
compare_arguments (t1a --> t1r) (t2a --> t2r) = compareInstanceTypes t1a.at_type t2a.at_type CAND compareInstanceTypes t1r.at_type t2r.at_type
compare_arguments (TArrow1 t1) (TArrow1 t2) = compareInstanceTypes t1.at_type t2.at_type
compare_arguments (TV tv1) (TV tv2) = (Equal, [tv1.tv_ident],[tv2.tv_ident])
compare_arguments type1 type2 = (Equal, [],[])
compareArguments [{at_type=type1}:types1] [{at_type=type2}:types2]
= compareInstanceTypes type1 type2 CAND compareArguments types1 types2
compareArguments [] []
= (Equal, [],[])
compareArguments [] types
= (Smaller, [],[])
compareArguments types []
= (Greater, [],[])
......@@ -4,8 +4,6 @@ import syntax
simplifyTypeApplication :: !Type ![AType] -> Type
simplifyAndCheckTypeApplication :: !Type ![AType] -> (!Bool, !Type)
convertSymbolType :: !Bool !{#CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap
-> (!SymbolType, !*ImportedTypes,!ImportedConstructors,!*TypeHeaps,!*VarHeap)
......
......@@ -102,7 +102,7 @@ addTypesOfDictionaries common_defs type_contexts type_args
= mapAppend (add_types_of_dictionary common_defs) type_contexts type_args
where
add_types_of_dictionary common_defs {tc_class = TCGeneric {gtc_generic_dict={gi_module,gi_index}}, tc_types}
#! generict_dict_ident = common_defs.[gi_module].com_type_defs.[gi_index].td_ident
#! generict_dict_ident = predefined_idents.[PD_TypeGenericDict]
/*
AA HACK:
Generic classes are always generated locally,
......
......@@ -62,7 +62,7 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
# {icl_common,icl_function_indices,icl_name,icl_import,icl_qualified_imports,icl_imported_objects,icl_foreign_exports,icl_used_module_numbers} = icl_mod
/*
(_,f,files) = fopen "components" FWriteText files
(groups, icl_functions, f) = showGroups groups 0 True icl_functions f
(components, icl_functions, f) = showGroups groups 0 True icl_functions f
/*
(n_functions,icl_functions) = usize icl_functions
(icl_functions,f) = showFunctions {ir_from=0,ir_to=n_functions} icl_functions f
......@@ -120,10 +120,6 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
type_heaps = { type_heaps & th_vars = th_vars }
# heaps = { heaps & hp_type_heaps = type_heaps, hp_expression_heap = hp_expression_heap, hp_generic_heap = gen_heap, hp_var_heap=hp_var_heap }
| not error_admin.ea_ok
= (No,{},dcl_mods,main_dcl_module_n,predef_symbols, hash_table, files, error_admin.ea_file, io, out, tcl_file, heaps)
# (saved_main_dcl_common, ti_common_defs) = replace {#dcl_common \\ {dcl_common}<-:dcl_mods} main_dcl_module_n icl_common
#! (ti_common_defs, groups, fun_defs, td_infos, heaps, hash_table, predef_symbols, dcl_mods, cached_dcl_macros, error_admin)
......@@ -148,14 +144,7 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
| ok<>ok
= abort "";
*/
/*
# (_,genout,files) = fopen "genout" FWriteText files
# (n_fun_defs,fun_defs) = usize fun_defs
# genout = show_class_members icl_mod.icl_common genout
# (groups, fun_defs, genout) = showGroups groups 0 True fun_defs genout
# (ok,files) = fclose genout files
| not ok = abort "could not write genout"
*/
#! ok = error_admin.ea_ok
| not ok
= (No,{},{},main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
......@@ -184,6 +173,7 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
= partitionateFunctions fun_defs (icl_global_functions++icl_function_indices.ifi_instance_indices
++[icl_function_indices.ifi_specials_indices
: icl_gencase_indices++icl_function_indices.ifi_type_function_indices])
| options.feo_up_to_phase == FrontEndPhaseTypeCheck
= frontSyntaxTree cached_dcl_macros cached_dcl_mods main_dcl_module_n
predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances heaps
......@@ -263,6 +253,12 @@ frontEndInterface opt_file_dir_time options mod_ident search_paths cached_dcl_mo
// # (dcl_mods, out) = showDclModules dcl_mods out
// # (components, fun_defs, out) = showComponents components 0 False fun_defs out
//# (_,f,files) = fopen ("Clean System Files/components_" +++ icl_mod.icl_name.id_name) FWriteText files
//(components, fun_defs, f) = showComponents components 0 False fun_defs f
//(ok,files) = fclose f files
//| ok<>ok
//= abort "";
/*
# (_,f,files) = fopen "components2" FWriteText files
(components, fun_defs, f) = showComponents components 0 False fun_defs f
......
This diff is collapsed.
......@@ -40,6 +40,4 @@ putPredefinedIdentInHashTable :: !Ident !IdentClass !*HashTable -> *HashTable
get_qualified_idents_from_hash_table :: !Ident !*HashTable -> (!QualifiedIdents,!*HashTable)
remove_qualified_idents_from_hash_table :: !*HashTable -> *HashTable
remove_icl_symbols_from_hash_table :: !*HashTable -> *HashTable
......@@ -33,7 +33,7 @@ import predef, syntax, compare_types, compare_constructor
:: BoxedIdent = {boxed_ident::!Ident}
newHashTable :: !*SymbolTable -> *HashTable
newHashTable symbol_heap = { hte_symbol_heap = symbol_heap, hte_entries = { HTE_Empty \\ i <- [0 .. dec HashTableArraySize] },hte_mark=0}
newHashTable symbol_heap = { hte_symbol_heap = symbol_heap, hte_entries = { HTE_Empty \\ i <- [0 .. dec cHashTableSize] },hte_mark=0}
set_hte_mark :: !Int !*HashTable -> *HashTable
set_hte_mark hte_mark ht = {ht & hte_mark=hte_mark}
......@@ -41,9 +41,7 @@ set_hte_mark hte_mark ht = {ht & hte_mark=hte_mark}
instance =< IdentClass
where
(=<) (IC_Instance types1) (IC_Instance types2)
= IF_ALLOW_NON_LINEAR_AND_OVERLAPPING_INSTANCES
(compareInstances types1 types2)
(compare_types types1 types2)
= compare_types types1 types2
(=<) (IC_InstanceMember types1) (IC_InstanceMember types2)
= compare_types types1 types2
(=<) (IC_GenericCase type1) (IC_GenericCase type2)
......@@ -81,10 +79,7 @@ where
= y1 =< y2
= cmp
cHashTableSize :== 1023
// the hte_entries array has an additional entry to store the modules with qualified indents
HashTableArraySize :== 1024
ModulesWithQualifiedIdentsHashTableIndex :== 1023
cHashTableSize :== 1023
hashValue :: !String -> Int
hashValue name
......@@ -129,53 +124,28 @@ putQualifiedIdentInHashTable :: !String !BoxedIdent !IdentClass !*HashTable -> (
putQualifiedIdentInHashTable module_name ident ident_class {hte_symbol_heap,hte_entries,hte_mark}
# hash_val = hashValue module_name
(entries,hte_entries) = hte_entries![hash_val]
(ident, old_qualified_idents, hte_symbol_heap, entries) = insert module_name ident ident_class (IC_Module NoQualifiedIdents) hte_mark hte_symbol_heap entries
(ident, hte_symbol_heap, entries) = insert module_name ident ident_class (IC_Module NoQualifiedIdents) hte_mark hte_symbol_heap entries
hte_entries = {hte_entries & [hash_val]=entries}
= case old_qualified_idents of
NoQualifiedIdents
# (entries,hte_entries) = hte_entries![ModulesWithQualifiedIdentsHashTableIndex]
(hte_symbol_heap, entries) = insert_module_with_qualified_idents module_name (IC_Module NoQualifiedIdents) hte_symbol_heap entries
hte_entries & [ModulesWithQualifiedIdentsHashTableIndex] = entries
-> (ident, {hte_symbol_heap = hte_symbol_heap, hte_entries = hte_entries,hte_mark=hte_mark})
_
-> (ident, {hte_symbol_heap = hte_symbol_heap, hte_entries = hte_entries,hte_mark=hte_mark})
= (ident, { hte_symbol_heap = hte_symbol_heap, hte_entries = hte_entries,hte_mark=hte_mark })
where
insert :: !String !BoxedIdent !IdentClass !IdentClass !Int !*SymbolTable *HashTableEntry
-> (!BoxedIdent, !QualifiedIdents, !*SymbolTable, !*HashTableEntry)
insert :: !String !BoxedIdent !IdentClass !IdentClass !Int !*SymbolTable *HashTableEntry -> (!BoxedIdent, !*SymbolTable, !*HashTableEntry)
insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap HTE_Empty
# (hte_symbol_ptr, hte_symbol_heap) = newPtr EmptySymbolTableEntry hte_symbol_heap
module_ident = { id_name = module_name, id_info = hte_symbol_ptr}
boxed_module_ident={boxed_ident=module_ident}
old_qualified_idents = NoQualifiedIdents
ident_class = IC_Module (QualifiedIdents ident.boxed_ident ident_class old_qualified_idents)
= (boxed_module_ident, old_qualified_idents, hte_symbol_heap, HTE_Ident boxed_module_ident ident_class hte_mark0 HTE_Empty HTE_Empty)
# module_ident = { id_name = module_name, id_info = hte_symbol_ptr}
# boxed_module_ident={boxed_ident=module_ident}
# ident_class = IC_Module (QualifiedIdents ident.boxed_ident ident_class NoQualifiedIdents)
= (boxed_module_ident, hte_symbol_heap, HTE_Ident boxed_module_ident ident_class hte_mark0 HTE_Empty HTE_Empty)
insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap (HTE_Ident hte_ident=:{boxed_ident={id_name}} hte_class hte_mark hte_left hte_right)
# cmp = (module_name,module_ident_class) =< (id_name,hte_class)
| cmp == Equal
# (IC_Module old_qualified_idents) = hte_class
ident_class = IC_Module (QualifiedIdents ident.boxed_ident ident_class old_qualified_idents)
= (hte_ident, old_qualified_idents, hte_symbol_heap, HTE_Ident hte_ident ident_class (hte_mark bitand hte_mark0) hte_left hte_right)
| cmp == Smaller
#! (boxed_ident, qualified_idents, hte_symbol_heap, hte_left) = insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap hte_left
= (boxed_ident, qualified_idents, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
#! (boxed_ident, qualified_idents, hte_symbol_heap, hte_right) = insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap hte_right
= (boxed_ident, qualified_idents, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
insert_module_with_qualified_idents :: !String !IdentClass !*SymbolTable *HashTableEntry -> (!*SymbolTable, !*HashTableEntry)
insert_module_with_qualified_idents name ident_class hte_symbol_heap HTE_Empty
# (hte_symbol_ptr, hte_symbol_heap) = newPtr EmptySymbolTableEntry hte_symbol_heap
ident = { id_name = name, id_info = hte_symbol_ptr}
boxed_ident={boxed_ident=ident}
= (hte_symbol_heap, HTE_Ident boxed_ident ident_class 0 HTE_Empty HTE_Empty)
insert_module_with_qualified_idents name ident_class hte_symbol_heap hte=:(HTE_Ident hte_ident=:{boxed_ident={id_name}} hte_class hte_mark hte_left hte_right)
# cmp = (name,ident_class) =< (id_name,hte_class)
| cmp == Equal
= (hte_symbol_heap, hte)
# (IC_Module qualified_idents) = hte_class
qualified_idents = QualifiedIdents ident.boxed_ident ident_class qualified_idents
= (hte_ident, hte_symbol_heap, HTE_Ident hte_ident (IC_Module qualified_idents) (hte_mark bitand hte_mark0) hte_left hte_right)
| cmp == Smaller
#! (hte_symbol_heap, hte_left) = insert_module_with_qualified_idents name ident_class hte_symbol_heap hte_left
= (hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
#! (hte_symbol_heap, hte_right) = insert_module_with_qualified_idents name ident_class hte_symbol_heap hte_right
= (hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
#! (boxed_ident, hte_symbol_heap, hte_left) = insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap hte_left
= (boxed_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
#! (boxed_ident, hte_symbol_heap, hte_right) = insert module_name ident ident_class module_ident_class hte_mark0 hte_symbol_heap hte_right
= (boxed_ident, hte_symbol_heap, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
putPredefinedIdentInHashTable :: !Ident !IdentClass !*HashTable -> *HashTable
putPredefinedIdentInHashTable predefined_ident=:{id_name} ident_class {hte_symbol_heap,hte_entries,hte_mark}
......@@ -220,42 +190,13 @@ where
#! (qualified_idents, hte_right) = find_qualified_idents module_name module_ident_class hte_right
= (qualified_idents, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
remove_qualified_idents_from_hash_table :: !*HashTable -> *HashTable
remove_qualified_idents_from_hash_table hash_table=:{hte_entries}
# (modules_with_qualified_idents,hte_entries) = hte_entries![ModulesWithQualifiedIdentsHashTableIndex]
hte_entries & [ModulesWithQualifiedIdentsHashTableIndex] = modules_with_qualified_idents
hte_entries = remove_qualified_idents_from_modules modules_with_qualified_idents hte_entries
= {hash_table & hte_entries = hte_entries}
where
remove_qualified_idents_from_modules (HTE_Ident hte_ident=:{boxed_ident={id_name}} hte_class=:(IC_Module NoQualifiedIdents) hte_mark hte_left hte_right) hte_entries
# hash_val = hashValue id_name
(entries,hte_entries) = hte_entries![hash_val]
(_, entries) = remove_qualified_idents_from_module id_name hte_class entries
hte_entries & [hash_val] = entries
= remove_qualified_idents_from_modules hte_right (remove_qualified_idents_from_modules hte_left hte_entries)
remove_qualified_idents_from_modules HTE_Empty hte_entries
= hte_entries
remove_qualified_idents_from_module :: !String !IdentClass *HashTableEntry -> (!Bool, !*HashTableEntry)
remove_qualified_idents_from_module module_name module_ident_class (HTE_Ident hte_ident=:{boxed_ident={id_name}} hte_class hte_mark hte_left hte_right)
# cmp = (module_name,module_ident_class) =< (id_name,hte_class)
| cmp == Equal
= (True, HTE_Ident hte_ident (IC_Module NoQualifiedIdents) hte_mark hte_left hte_right)
| cmp == Smaller
#! (found, hte_left) = remove_qualified_idents_from_module module_name module_ident_class hte_left
= (found, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
#! (found, hte_right) = remove_qualified_idents_from_module module_name module_ident_class hte_right
= (found, HTE_Ident hte_ident hte_class hte_mark hte_left hte_right)
remove_qualified_idents_from_module module_name module_ident_class HTE_Empty
= (False, HTE_Empty)
remove_icl_symbols_from_hash_table :: !*HashTable -> *HashTable