Commit e783db98 authored by Martin Wierich's avatar Martin Wierich
Browse files

changes to make compiler compatible with itself

parent 13d15f5c
......@@ -28,4 +28,4 @@ ptrToInt :: !(Ptr w) -> Int
where
(ptr, val) = ptr_and_val
instance == Ptr a
instance == (Ptr a)
......@@ -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
......
......@@ -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
......@@ -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)
......
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
......
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
......
......@@ -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
......
This diff is collapsed.
This diff is collapsed.
......@@ -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;
......@@ -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
......@@ -511,9 +492,6 @@ where
(<<<) file
(STE_BoundTypeVariable _)
= file <<< "STE_BoundTypeVariable"
(<<<) file
(STE_BoundType _)
= file <<< "STE_BoundType"
(<<<) file
(STE_Imported _ _)
= file <<< "STE_Imported"
......
......@@ -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)
This diff is collapsed.
......@@ -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 ""
......
......@@ -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
......
......@@ -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