Commit 34e3e4aa authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

extension: not necessary to repeat definitions of dcl-module in icl-module

parent 8bbc3793
This diff is collapsed.
...@@ -3,7 +3,7 @@ definition module checksupport ...@@ -3,7 +3,7 @@ definition module checksupport
import StdEnv import StdEnv
import syntax, predef import syntax, predef
cIclModIndex :== 0 // MW++ cIclModIndex :== 0
CS_NotChecked :== -1 CS_NotChecked :== -1
NotFound :== -1 NotFound :== -1
...@@ -11,8 +11,8 @@ NotFound :== -1 ...@@ -11,8 +11,8 @@ NotFound :== -1
cModuleScope :== 0 cModuleScope :== 0
cGlobalScope :== 1 cGlobalScope :== 1
cIsNotADclModule :== False // MW++ cIsNotADclModule :== False
cIsADclModule :== True // MW++ cIsADclModule :== True
:: VarHeap :== Heap VarInfo :: VarHeap :== Heap VarInfo
...@@ -55,6 +55,7 @@ cConversionTableSize :== 8 ...@@ -55,6 +55,7 @@ cConversionTableSize :== 8
:: Declaration = :: Declaration =
{ dcl_ident :: !Ident { dcl_ident :: !Ident
, dcl_pos :: !Position
, dcl_kind :: !STE_Kind , dcl_kind :: !STE_Kind
, dcl_index :: !Index , dcl_index :: !Index
} }
...@@ -62,7 +63,7 @@ cConversionTableSize :== 8 ...@@ -62,7 +63,7 @@ cConversionTableSize :== 8
:: Declarations = :: Declarations =
{ dcls_import ::![Declaration] { dcls_import ::![Declaration]
, dcls_local ::![Declaration] , dcls_local ::![Declaration]
, dcls_explicit ::![(!Declaration, !LineNr)] // MW++ , dcls_explicit ::![(!Declaration, !LineNr)]
} }
:: IclModule = :: IclModule =
...@@ -72,9 +73,7 @@ cConversionTableSize :== 8 ...@@ -72,9 +73,7 @@ cConversionTableSize :== 8
, icl_specials :: !IndexRange , icl_specials :: !IndexRange
, icl_common :: !.CommonDefs , icl_common :: !.CommonDefs
, icl_declared :: !Declarations , icl_declared :: !Declarations
// RWS ...
, icl_imported_objects :: ![ImportedObject] , icl_imported_objects :: ![ImportedObject]
// ... RWS
} }
:: DclModule = :: DclModule =
...@@ -85,6 +84,7 @@ cConversionTableSize :== 8 ...@@ -85,6 +84,7 @@ cConversionTableSize :== 8
, dcl_class_specials :: !IndexRange , dcl_class_specials :: !IndexRange
, dcl_specials :: !IndexRange , dcl_specials :: !IndexRange
, dcl_common :: !CommonDefs , dcl_common :: !CommonDefs
, dcl_sizes :: !{# Int}
, dcl_declared :: !Declarations , dcl_declared :: !Declarations
, dcl_conversions :: !Optional ConversionTable , dcl_conversions :: !Optional ConversionTable
, dcl_is_system :: !Bool , dcl_is_system :: !Bool
......
...@@ -64,6 +64,7 @@ where ...@@ -64,6 +64,7 @@ where
:: Declaration = :: Declaration =
{ dcl_ident :: !Ident { dcl_ident :: !Ident
, dcl_pos :: !Position
, dcl_kind :: !STE_Kind , dcl_kind :: !STE_Kind
, dcl_index :: !Index , dcl_index :: !Index
} }
...@@ -94,6 +95,7 @@ where ...@@ -94,6 +95,7 @@ where
, dcl_class_specials :: !IndexRange , dcl_class_specials :: !IndexRange
, dcl_specials :: !IndexRange , dcl_specials :: !IndexRange
, dcl_common :: !CommonDefs , dcl_common :: !CommonDefs
, dcl_sizes :: !{# Int}
, dcl_declared :: !Declarations , dcl_declared :: !Declarations
, dcl_conversions :: !Optional ConversionTable , dcl_conversions :: !Optional ConversionTable
, dcl_is_system :: !Bool , dcl_is_system :: !Bool
......
...@@ -2,8 +2,8 @@ definition module checktypes ...@@ -2,8 +2,8 @@ definition module checktypes
import checksupport, typesupport import checksupport, typesupport
checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !Int !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*TypeHeaps !*CheckState checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
-> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*TypeHeaps, !*CheckState) -> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState)
checkSymbolType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState checkSymbolType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState
-> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) -> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState)
...@@ -17,7 +17,7 @@ checkInstanceType :: !Index !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ...@@ -17,7 +17,7 @@ checkInstanceType :: !Index !InstanceType !Specials !u:{# CheckedTypeDef} !v:{#
checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState
-> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState) -> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState)
createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !Int !*TypeVarHeap !*VarHeap !*CheckState createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*CheckState
-> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState) -> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*TypeVarHeap, !*VarHeap, !*CheckState)
isATopConsVar cv :== cv < 0 isATopConsVar cv :== cv < 0
......
...@@ -12,7 +12,8 @@ import syntax, checksupport, check, typesupport, utilities, RWSDebug ...@@ -12,7 +12,8 @@ import syntax, checksupport, check, typesupport, utilities, RWSDebug
} }
:: TypeInfo = :: TypeInfo =
{ ti_heaps :: !.TypeHeaps { ti_var_heap :: !.VarHeap
, ti_type_heaps :: !.TypeHeaps
} }
:: CurrentTypeInfo = :: CurrentTypeInfo =
...@@ -138,19 +139,20 @@ bindTypesOfCons :: !Index !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymb ...@@ -138,19 +139,20 @@ bindTypesOfCons :: !Index !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymb
bindTypesOfConstructors _ _ _ _ _ [] ts_ti_cs bindTypesOfConstructors _ _ _ _ _ [] ts_ti_cs
= 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_heaps}, 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.[ds_index]
# (exi_vars, (ti_heaps, cs)) # (exi_vars, (ti_type_heaps, cs))
= addExistentionalTypeVariablesToSymbolTable cti_lhs_attribute cons_def.cons_exi_vars ti_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)) (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_heaps = ti_heaps }, cs) = bind_types_of_cons cons_def.cons_type.st_args cti free_vars [] (ts, { ti & ti_type_heaps = ti_type_heaps }, cs)
cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel exi_vars cs.cs_symbol_table 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) = bindTypesOfConstructors cti (inc cons_index) free_vars free_attrs type_lhs conses
(ts, ti, { cs & cs_symbol_table = cs_symbol_table }) (ts, ti, { cs & cs_symbol_table = cs_symbol_table })
cons_type = { cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = free_attrs, st_attr_env = st_attr_env } cons_type = { cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = free_attrs, st_attr_env = st_attr_env }
(new_type_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap
= ({ ts & ts_cons_defs = { ts.ts_cons_defs & [ds_index] = = ({ ts & ts_cons_defs = { ts.ts_cons_defs & [ds_index] =
{ cons_def & cons_type = cons_type, cons_index = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars, { cons_def & cons_type = cons_type, cons_index = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars,
cons_arg_vars = cons_arg_vars }}}, ti, cs) cons_type_ptr = new_type_ptr, cons_arg_vars = cons_arg_vars }}}, { ti & ti_var_heap = ti_var_heap }, cs)
where where
/* /*
check_types_of_cons :: ![AType] !Bool !Index !Level ![TypeVar] !TypeAttribute ![AttrInequality] !Conditions !*TypeSymbols !*TypeInfo !*CheckState check_types_of_cons :: ![AType] !Bool !Index !Level ![TypeVar] !TypeAttribute ![AttrInequality] !Conditions !*TypeSymbols !*TypeInfo !*CheckState
...@@ -175,10 +177,6 @@ where ...@@ -175,10 +177,6 @@ where
symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}})) symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}}))
/*
checkRhsOfTypeDef :: !CheckedTypeDef ![AttributeVar] !Bool !Index !Level !TypeAttribute !Index !Conditions !*TypeSymbols !*TypeInfo !*CheckState
-> (!TypeRhs, !TypeProperties, !Conditions, !Int, !*TypeSymbols, !*TypeInfo, !*CheckState)
*/
checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:AlgType conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:AlgType conses} attr_vars cti=:{cti_module_index,cti_type_index,cti_lhs_attribute} ts_ti_cs
# type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute, # type_lhs = { at_annotation = AN_None, at_attribute = cti_lhs_attribute,
at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity) at_type = TA (MakeTypeSymbIdent { glob_object = cti_type_index, glob_module = cti_module_index } td_name td_arity)
...@@ -195,23 +193,25 @@ checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_cons ...@@ -195,23 +193,25 @@ checkRhsOfTypeDef {td_name,td_arity,td_args,td_rhs = td_rhs=:RecordType {rt_cons
attr_vars type_lhs [rec_cons] ts_ti_cs attr_vars type_lhs [rec_cons] ts_ti_cs
#! rec_cons_def = ts.ts_cons_defs.[ds_index] #! rec_cons_def = ts.ts_cons_defs.[ds_index]
# {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def # {cons_type = { st_vars,st_args,st_result,st_attr_vars }, cons_exi_vars} = rec_cons_def
(ts_selector_defs, 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 cs.cs_error (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
= (td_rhs, ({ ts & ts_selector_defs = ts_selector_defs }, ti, { cs & cs_error = cs_error})) ts.ts_selector_defs ti.ti_var_heap cs.cs_error
= (td_rhs, ({ ts & ts_selector_defs = ts_selector_defs }, { ti & ti_var_heap = ti_var_heap }, { cs & cs_error = cs_error}))
where where
check_selectors :: !Index !{# FieldSymbol} !Index ![AType] !AType ![TypeVar] ![AttributeVar] ![ATypeVar] !*{#SelectorDef} !*ErrorAdmin check_selectors :: !Index !{# FieldSymbol} !Index ![AType] !AType ![TypeVar] ![AttributeVar] ![ATypeVar] !*{#SelectorDef} !*VarHeap !*ErrorAdmin
-> (!*{#SelectorDef},!*ErrorAdmin) -> (!*{#SelectorDef}, !*VarHeap, !*ErrorAdmin)
check_selectors field_nr fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs error 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 | field_nr < size fields
# {fs_index} = fields.[field_nr] # {fs_index} = fields.[field_nr]
#! sel_def = selector_defs.[fs_index] #! sel_def = selector_defs.[fs_index]
# [sel_type:sel_types] = sel_types # [sel_type:sel_types] = sel_types
# (st_attr_env, error) = addToAttributeEnviron sel_type.at_attribute rec_type.at_attribute [] error # (st_attr_env, error) = addToAttributeEnviron sel_type.at_attribute rec_type.at_attribute [] error
# (new_type_ptr, var_heap) = newPtr VI_Empty var_heap
sd_type = { sel_def.sd_type & st_arity = 1, st_args = [rec_type], st_result = sel_type, st_vars = st_vars, sd_type = { sel_def.sd_type & st_arity = 1, st_args = [rec_type], st_result = sel_type, st_vars = st_vars,
st_attr_vars = st_attr_vars, st_attr_env = st_attr_env } st_attr_vars = st_attr_vars, st_attr_env = st_attr_env }
selector_defs = { selector_defs & [fs_index] = { sel_def & sd_type = sd_type, sd_field_nr = field_nr, sd_type_index = rec_type_index, selector_defs = { selector_defs & [fs_index] = { sel_def & sd_type = sd_type, sd_field_nr = field_nr, sd_type_index = rec_type_index,
sd_exi_vars = exi_vars } } sd_type_ptr = new_type_ptr, sd_exi_vars = exi_vars } }
= check_selectors (inc field_nr) fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs error = check_selectors (inc field_nr) fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs var_heap error
= (selector_defs, error) = (selector_defs, var_heap, error)
checkRhsOfTypeDef {td_rhs = SynType type} _ cti ts_ti_cs checkRhsOfTypeDef {td_rhs = SynType type} _ cti ts_ti_cs
# (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs # (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs
= (SynType type, ts_ti_cs) = (SynType type, ts_ti_cs)
...@@ -224,18 +224,17 @@ isATopConsVar cv :== cv < 0 ...@@ -224,18 +224,17 @@ isATopConsVar cv :== cv < 0
encodeTopConsVar cv :== dec (~cv) encodeTopConsVar cv :== dec (~cv)
decodeTopConsVar cv :== ~(inc cv) decodeTopConsVar cv :== ~(inc cv)
// checkTypeDef :: !Bool !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!Int, !Conditions, !*TypeSymbols, !*TypeInfo, !*CheckState); checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error}
checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_heaps} cs=:{cs_error}
#! type_def = ts_type_defs.[type_index] #! type_def = ts_type_defs.[type_index]
# {td_name,td_pos,td_args,td_attribute,td_properties} = type_def # {td_name,td_pos,td_args,td_attribute,td_properties} = type_def
position = newPosition td_name td_pos position = newPosition td_name td_pos
cs_error = pushErrorAdmin position cs_error cs_error = pushErrorAdmin position cs_error
(td_attribute, attr_vars, th_attrs) = determine_root_attribute td_attribute td_name.id_name ti_heaps.th_attrs (td_attribute, attr_vars, th_attrs) = determine_root_attribute td_attribute td_name.id_name ti_type_heaps.th_attrs
(type_vars, (attr_vars, ti_heaps, cs)) (type_vars, (attr_vars, ti_type_heaps, cs))
= addTypeVariablesToSymbolTable td_args attr_vars { ti_heaps & th_attrs = th_attrs } { cs & cs_error = cs_error } = 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 } 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 (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_heaps = ti_heaps}, cs) { cti_module_index = module_index, cti_type_index = type_index, cti_lhs_attribute = td_attribute } (ts,{ 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, = ({ 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 & cs_error = popErrorAdmin cs.cs_error,
cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel type_vars cs.cs_symbol_table }) cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel type_vars cs.cs_symbol_table })
...@@ -406,21 +405,23 @@ where ...@@ -406,21 +405,23 @@ where
kind_list_to_string [] = "" kind_list_to_string [] = ""
kind_list_to_string [k:ks] = " -> " +++ toString k +++ kind_list_to_string ks kind_list_to_string [k:ks] = " -> " +++ toString k +++ kind_list_to_string ks
*/ */
checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !Int !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*TypeHeaps !*CheckState
-> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*TypeHeaps, !*CheckState) checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
checkTypeDefs is_main_dcl type_defs module_index nr_of_types cons_defs selector_defs modules heaps cs -> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState)
checkTypeDefs is_main_dcl type_defs module_index cons_defs selector_defs modules var_heap type_heaps cs
#! nr_of_types = size type_defs
# ts = { ts_type_defs = type_defs, ts_cons_defs = cons_defs, ts_selector_defs = selector_defs, ts_modules = modules } # ts = { ts_type_defs = type_defs, ts_cons_defs = cons_defs, ts_selector_defs = selector_defs, ts_modules = modules }
ti = { ti_heaps = heaps } ti = { ti_type_heaps = type_heaps, ti_var_heap = var_heap }
= check_type_defs is_main_dcl 0 nr_of_types module_index ts ti cs = check_type_defs is_main_dcl 0 nr_of_types module_index ts ti cs
where where
check_type_defs is_main_dcl type_index nr_of_types module_index ts ti=:{ti_heaps} cs check_type_defs is_main_dcl type_index nr_of_types module_index ts ti=:{ti_type_heaps,ti_var_heap} cs
| type_index == nr_of_types | type_index == nr_of_types
| cs.cs_error.ea_ok && not is_main_dcl | cs.cs_error.ea_ok && not is_main_dcl
# marks = createArray nr_of_types CS_NotChecked # marks = createArray nr_of_types CS_NotChecked
(type_defs, modules, cs) = expand_syn_types module_index 0 nr_of_types (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 { 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_heaps, cs) = (type_defs, ts.ts_cons_defs, ts.ts_selector_defs, modules, ti_var_heap, ti_type_heaps, cs)
= (ts.ts_type_defs, ts.ts_cons_defs, ts.ts_selector_defs, ts.ts_modules, ti_heaps, cs) = (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 # (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 = check_type_defs is_main_dcl (inc type_index) nr_of_types module_index ts ti cs
...@@ -1047,9 +1048,9 @@ removeVariablesFromSymbolTable scope vars symbol_table ...@@ -1047,9 +1048,9 @@ removeVariablesFromSymbolTable scope vars symbol_table
makeAttributedType attr annot type :== { at_attribute = attr, at_annotation = annot, at_type = type } makeAttributedType attr annot type :== { at_attribute = attr, at_annotation = annot, at_type = type }
createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !Int !*TypeVarHeap !*VarHeap !*CheckState createClassDictionaries :: !Index !*{#ClassDef} !u:{#.DclModule} !Index !Index !Index !*TypeVarHeap !*VarHeap !*CheckState
-> (!*{#ClassDef}, !u:{#DclModule}, ![CheckedTypeDef], ![SelectorDef], ![ConsDef], !*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 upper_limit type_var_heap var_heap cs 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 [] # (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 { 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) (type_defs, sel_defs, cons_defs, cs_symbol_table) = foldSt collect_type_def rev_dictionary_list ([], [], [], cs.cs_symbol_table)
...@@ -1070,8 +1071,7 @@ where ...@@ -1070,8 +1071,7 @@ where
= ( sel_defs, symbol_table) = ( sel_defs, symbol_table)
create_class_dictionaries mod_index class_index class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs create_class_dictionaries mod_index class_index class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs
// MW was | class_index < size class_defs | class_index < size class_defs
| class_index < upper_limit
# (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) = # (class_defs, modules, rev_dictionary_list, indexes, type_var_heap, var_heap, cs) =
create_class_dictionary mod_index class_index class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs create_class_dictionary mod_index class_index class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs
= create_class_dictionaries mod_index (inc class_index) class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs = create_class_dictionaries mod_index (inc class_index) class_defs modules rev_dictionary_list indexes type_var_heap var_heap cs
......
...@@ -617,7 +617,9 @@ reorganizeDefinitions icl_module [PD_Type type_def=:{td_rhs = ConsList cons_defs ...@@ -617,7 +617,9 @@ reorganizeDefinitions icl_module [PD_Type type_def=:{td_rhs = ConsList cons_defs
# (cons_symbs, cons_count) = determine_symbols_of_conses cons_defs cons_count # (cons_symbs, cons_count) = determine_symbols_of_conses cons_defs cons_count
(fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca
type_def = { type_def & td_rhs = AlgType cons_symbs } type_def = { type_def & td_rhs = AlgType cons_symbs }
c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = cons_defs ++ c_defs.def_constructors } /* Sjaak ... */
c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = mapAppend ParsedConstructorToConsDef cons_defs c_defs.def_constructors }
/* ... Sjaak */
= (fun_defs, c_defs, imports, imported_objects, ca) = (fun_defs, c_defs, imports, imported_objects, ca)
where where
determine_symbols_of_conses [{pc_cons_name,pc_cons_arity} : conses] next_cons_index determine_symbols_of_conses [{pc_cons_name,pc_cons_arity} : conses] next_cons_index
...@@ -634,8 +636,10 @@ reorganizeDefinitions icl_module [PD_Type type_def=:{td_name, td_rhs = SelectorL ...@@ -634,8 +636,10 @@ reorganizeDefinitions icl_module [PD_Type type_def=:{td_name, td_rhs = SelectorL
pc_arg_types = [ ps_field_type \\ {ps_field_type} <- sel_defs ], pc_exi_vars = exivars } pc_arg_types = [ ps_field_type \\ {ps_field_type} <- sel_defs ], pc_exi_vars = exivars }
type_def = { type_def & td_rhs = RecordType {rt_constructor = { ds_ident = td_name, ds_arity = cons_arity, ds_index = cons_count }, type_def = { type_def & td_rhs = RecordType {rt_constructor = { ds_ident = td_name, ds_arity = cons_arity, ds_index = cons_count },
rt_fields = { sel \\ sel <- sel_syms }}} rt_fields = { sel \\ sel <- sel_syms }}}
c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [cons_def : c_defs.def_constructors], /* Sjaak ... */
def_selectors = sel_defs ++ c_defs.def_selectors } c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [ParsedConstructorToConsDef cons_def : c_defs.def_constructors],
def_selectors = mapAppend ParsedSelectorToSelectorDef sel_defs c_defs.def_selectors }
/* ... Sjaak */
= (fun_defs, c_defs, imports, imported_objects, ca) = (fun_defs, c_defs, imports, imported_objects, ca)
where where
determine_symbols_of_selectors [{ps_field_name,ps_field_var} : sels] next_selector_index determine_symbols_of_selectors [{ps_field_name,ps_field_var} : sels] next_selector_index
...@@ -671,7 +675,7 @@ where ...@@ -671,7 +675,7 @@ where
check_symbols_of_class_members [PD_TypeSpec pos name prio opt_type=:(Yes type=:{st_context,st_arity}) specials : defs] type_context ca check_symbols_of_class_members [PD_TypeSpec pos name prio opt_type=:(Yes type=:{st_context,st_arity}) specials : defs] type_context ca
# (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca # (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca
| isEmpty bodies | isEmpty bodies
# mem_def = { me_symb = name, me_type = { type & st_context = [type_context : st_context ]}, me_pos = pos, me_priority = prio, # mem_def = { me_symb = name, me_type = { type & st_context = [type_context : st_context ]}, me_pos = pos, me_priority = prio,
me_offset = NoIndex, me_class_vars = [], me_class = { glob_module = NoIndex, glob_object = NoIndex}, me_type_ptr = nilPtr } me_offset = NoIndex, me_class_vars = [], me_class = { glob_module = NoIndex, glob_object = NoIndex}, me_type_ptr = nilPtr }
( mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca ( mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca
= ([mem_def : mem_defs], mem_macros, ca) = ([mem_def : mem_defs], mem_macros, ca)
......
...@@ -214,7 +214,8 @@ buildPredefinedModule pre_def_symbols ...@@ -214,7 +214,8 @@ buildPredefinedModule pre_def_symbols
(class_def, member_def, pre_def_symbols) = make_TC_class_def pre_def_symbols (class_def, member_def, pre_def_symbols) = make_TC_class_def pre_def_symbols
= ({ mod_name = pre_mod_id, mod_type = MK_System, mod_imports = [], mod_imported_objects = [], = ({ mod_name = pre_mod_id, mod_type = MK_System, mod_imports = [], mod_imported_objects = [],
mod_defs = { mod_defs = {
def_types = [string_def, list_def : type_defs], def_constructors = [cons_def, nil_def : cons_defs], def_selectors = [], def_classes = [class_def], def_types = [string_def, list_def : type_defs], def_constructors
= [ParsedConstructorToConsDef cons_def, ParsedConstructorToConsDef nil_def : cons_defs], def_selectors = [], def_classes = [class_def],
def_macros = { ir_from = 0, ir_to = 0 }, def_members = [member_def], def_funtypes = [], def_instances = [] }}, pre_def_symbols) def_macros = { ir_from = 0, ir_to = 0 }, def_members = [member_def], def_funtypes = [], def_instances = [] }}, pre_def_symbols)
where where
add_tuple_defs pre_mod_id tup_arity type_defs cons_defs pre_def_symbols add_tuple_defs pre_mod_id tup_arity type_defs cons_defs pre_def_symbols
...@@ -226,7 +227,7 @@ where ...@@ -226,7 +227,7 @@ where
(tuple_type_def, pre_def_symbols) = make_type_def (GetTupleTypeIndex tup_arity) type_vars (AlgType [tuple_cons_symb]) pre_def_symbols (tuple_type_def, pre_def_symbols) = make_type_def (GetTupleTypeIndex tup_arity) type_vars (AlgType [tuple_cons_symb]) pre_def_symbols
tuple_cons_def = { pc_cons_name = tuple_id.pds_ident, pc_cons_arity = tup_arity, pc_cons_pos = PreDefPos pre_mod_id, tuple_cons_def = { pc_cons_name = tuple_id.pds_ident, pc_cons_arity = tup_arity, pc_cons_pos = PreDefPos pre_mod_id,
pc_arg_types = [ MakeAttributedType (TV tv) \\ tv <- type_vars], pc_cons_prio = NoPrio, pc_exi_vars = []} pc_arg_types = [ MakeAttributedType (TV tv) \\ tv <- type_vars], pc_cons_prio = NoPrio, pc_exi_vars = []}
= add_tuple_defs pre_mod_id (dec tup_arity) [tuple_type_def : type_defs] [tuple_cons_def : cons_defs] pre_def_symbols = add_tuple_defs pre_mod_id (dec tup_arity) [tuple_type_def : type_defs] [ParsedConstructorToConsDef tuple_cons_def : cons_defs] pre_def_symbols
= (type_defs, cons_defs, pre_def_symbols) = (type_defs, cons_defs, pre_def_symbols)
where where
make_type_vars nr_of_vars type_vars pre_def_symbols make_type_vars nr_of_vars type_vars pre_def_symbols
......
...@@ -84,8 +84,8 @@ instance toString Ident ...@@ -84,8 +84,8 @@ instance toString Ident
:: CollectedDefinitions instance_kind macro_defs = :: CollectedDefinitions instance_kind macro_defs =
{ def_types :: ![TypeDef TypeRhs] { def_types :: ![TypeDef TypeRhs]
, def_constructors :: ![ParsedConstructor] , def_constructors :: ![ConsDef]
, def_selectors :: ![ParsedSelector] , def_selectors :: ![SelectorDef]
, def_macros :: !macro_defs , def_macros :: !macro_defs
, def_classes :: ![ClassDef] , def_classes :: ![ClassDef]
, def_members :: ![MemberDef] , def_members :: ![MemberDef]
...@@ -1185,17 +1185,18 @@ MakeTypeSymbIdent type_index name arity ...@@ -1185,17 +1185,18 @@ MakeTypeSymbIdent type_index name arity
MakeSymbIdent name arity :== { symb_name = name, symb_kind = SK_Unknown, symb_arity = arity } MakeSymbIdent name arity :== { symb_name = name, symb_kind = SK_Unknown, symb_arity = arity }
MakeConstant name :== MakeSymbIdent name 0 MakeConstant name :== MakeSymbIdent name 0
ParsedSelectorToSelectorDef ps var_ptr :== ParsedSelectorToSelectorDef ps :==
{ sd_symb = ps.ps_selector_name, sd_field_nr = NoIndex, sd_pos = ps.ps_field_pos, sd_type_index = NoIndex, { sd_symb = ps.ps_selector_name, sd_field_nr = NoIndex, sd_pos = ps.ps_field_pos, sd_type_index = NoIndex,
sd_exi_vars = [], /* sd_exi_attrs = [], */ sd_type_ptr = var_ptr, sd_field = ps.ps_field_name, sd_exi_vars = [], sd_type_ptr = nilPtr, sd_field = ps.ps_field_name,
sd_type = { st_vars = [], st_args = [], st_result = ps.ps_field_type, st_arity = 0, st_context = [], sd_type = { st_vars = [], st_args = [], st_result = ps.ps_field_type, st_arity = 0, st_context = [],
st_attr_env = [], st_attr_vars = [] }} st_attr_env = [], st_attr_vars = [] }}
ParsedConstructorToConsDef pc var_ptr :== ParsedConstructorToConsDef pc :==
{ cons_symb = pc.pc_cons_name, cons_pos = pc.pc_cons_pos, cons_priority = pc.pc_cons_prio, cons_index = NoIndex, cons_type_index = NoIndex, { cons_symb = pc.pc_cons_name, cons_pos = pc.pc_cons_pos, cons_priority = pc.pc_cons_prio, cons_index = NoIndex, cons_type_index = NoIndex,
cons_type = { st_vars = [], st_args = pc.pc_arg_types, st_result = MakeAttributedType TE, cons_type = { st_vars = [], st_args = pc.pc_arg_types, st_result = MakeAttributedType TE,
st_arity = pc.pc_cons_arity, st_context = [], st_attr_env = [], st_attr_vars = []}, st_arity = pc.pc_cons_arity, st_context = [], st_attr_env = [], st_attr_vars = []},
cons_exi_vars = pc.pc_exi_vars, /* cons_exi_attrs = [], */ cons_type_ptr = var_ptr, cons_arg_vars = [] } cons_exi_vars = pc.pc_exi_vars, cons_type_ptr = nilPtr, cons_arg_vars = [] }
ParsedInstanceToClassInstance pi members :== ParsedInstanceToClassInstance pi members :==
{ ins_class = {glob_object = MakeDefinedSymbol pi.pi_class NoIndex (length pi.pi_types), glob_module = NoIndex}, ins_ident = pi.pi_ident, { ins_class = {glob_object = MakeDefinedSymbol pi.pi_class NoIndex (length pi.pi_types), glob_module = NoIndex}, ins_ident = pi.pi_ident,
......
...@@ -88,8 +88,8 @@ where toString {import_module} = toString import_module ...@@ -88,8 +88,8 @@ where toString {import_module} = toString import_module
:: CollectedDefinitions instance_kind macro_defs = :: CollectedDefinitions instance_kind macro_defs =
{ def_types :: ![TypeDef TypeRhs] { def_types :: ![TypeDef TypeRhs]
, def_constructors :: ![ParsedConstructor] , def_constructors :: ![ConsDef]
, def_selectors :: ![ParsedSelector] , def_selectors :: ![SelectorDef]
, def_macros :: !macro_defs , def_macros :: !macro_defs
, def_classes :: ![ClassDef] , def_classes :: ![ClassDef]
, def_members :: ![MemberDef] , def_members :: ![MemberDef]
...@@ -1772,17 +1772,17 @@ MakeTypeSymbIdent type_index name arity ...@@ -1772,17 +1772,17 @@ MakeTypeSymbIdent type_index name arity
MakeSymbIdent name arity :== { symb_name = name, symb_kind = SK_Unknown, symb_arity = arity } MakeSymbIdent name arity :== { symb_name = name, symb_kind = SK_Unknown, symb_arity = arity }
MakeConstant name :== MakeSymbIdent name 0 MakeConstant name :== MakeSymbIdent name 0
ParsedSelectorToSelectorDef ps var_ptr :== ParsedSelectorToSelectorDef ps :==
{ sd_symb = ps.ps_selector_name, sd_field_nr = NoIndex, sd_pos = ps.ps_field_pos, sd_type_index = NoIndex, { sd_symb = ps.ps_selector_name, sd_field_nr = NoIndex, sd_pos = ps.ps_field_pos, sd_type_index = NoIndex,
sd_exi_vars = [], /* sd_exi_attrs = [], */ sd_type_ptr = var_ptr, sd_field = ps.ps_field_name, sd_exi_vars = [], sd_type_ptr = nilPtr, sd_field = ps.ps_field_name,
sd_type = { st_vars = [], st_args = [], st_result = ps.ps_field_type, st_arity = 0, st_context = [], sd_type = { st_vars = [], st_args = [], st_result = ps.ps_field_type, st_arity = 0, st_context = [],
st_attr_env = [], st_attr_vars = [] }} st_attr_env = [], st_attr_vars = [] }}
ParsedConstructorToConsDef pc var_ptr :== ParsedConstructorToConsDef pc :==
{ cons_symb = pc.pc_cons_name, cons_pos = pc.pc_cons_pos, cons_priority = pc.pc_cons_prio, cons_index = NoIndex, cons_type_index = NoIndex, { cons_symb = pc.pc_cons_name, cons_pos = pc.pc_cons_pos, cons_priority = pc.pc_cons_prio, cons_index = NoIndex, cons_type_index = NoIndex,
cons_type = { st_vars = [], st_args = pc.pc_arg_types, st_result = MakeAttributedType TE,