Commit 24ce7815 authored by clean's avatar clean
Browse files

reduce memory allocation

parent f885f33d
...@@ -129,7 +129,7 @@ retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaratio ...@@ -129,7 +129,7 @@ retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaratio
addLocalFunctionDefsToSymbolTable :: !Level !Index !Index !u:{#FunDef} !*SymbolTable !*ErrorAdmin -> (!u:{# FunDef}, !*SymbolTable, !*ErrorAdmin) addLocalFunctionDefsToSymbolTable :: !Level !Index !Index !u:{#FunDef} !*SymbolTable !*ErrorAdmin -> (!u:{# FunDef}, !*SymbolTable, !*ErrorAdmin)
addDefToSymbolTable :: !Level !Index !Ident !STE_Kind !*SymbolTable !*ErrorAdmin -> (!* SymbolTable, !*ErrorAdmin) addDefToSymbolTable :: !Level !Index !Ident !STE_Kind !*SymbolTable !*ErrorAdmin -> (!* SymbolTable, !*ErrorAdmin)
addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] ![.Declaration] !*CheckState -> .CheckState; addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] ![.Declaration] !*CheckState -> .CheckState;
addLocalSymbolsToSymbolTable :: ![.Declaration] Int !*CheckState -> .CheckState; //addLocalSymbolsToSymbolTable :: ![.Declaration] Int !*CheckState -> .CheckState;
addFieldToSelectorDefinition :: !Ident (Global .Int) !*CheckState -> .CheckState; addFieldToSelectorDefinition :: !Ident (Global .Int) !*CheckState -> .CheckState;
addGlobalDefinitionsToSymbolTable :: ![.Declaration] !*CheckState -> .CheckState; addGlobalDefinitionsToSymbolTable :: ![.Declaration] !*CheckState -> .CheckState;
retrieveImportsFromSymbolTable :: ![Import ImportDeclaration] ![Declaration] !*{#DclModule} !*(Heap SymbolTableEntry) -> *(![Declaration],!*{#DclModule},!*Heap SymbolTableEntry); retrieveImportsFromSymbolTable :: ![Import ImportDeclaration] ![Declaration] !*{#DclModule} !*(Heap SymbolTableEntry) -> *(![Declaration],!*{#DclModule},!*Heap SymbolTableEntry);
......
...@@ -155,6 +155,7 @@ checkWarning id mess error=:{ea_file,ea_loc=[]} ...@@ -155,6 +155,7 @@ checkWarning id mess error=:{ea_file,ea_loc=[]}
checkWarning id mess error=:{ea_file,ea_loc} checkWarning id mess error=:{ea_file,ea_loc}
= { error & ea_file = ea_file <<< "Check Warning " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n' } = { error & ea_file = ea_file <<< "Check Warning " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n' }
checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a; checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorWithIdentPos ident_pos mess error=:{ea_file} checkErrorWithIdentPos ident_pos mess error=:{ea_file}
= { error & ea_file = ea_file <<< "Check Error " <<< ident_pos <<< ":" <<< mess <<< '\n', ea_ok = False } = { error & ea_file = ea_file <<< "Check Error " <<< ident_pos <<< ":" <<< mess <<< '\n', ea_ok = False }
...@@ -202,24 +203,73 @@ retrieveAndRemoveImportsOfModuleFromSymbolTable imports locals all_decls symbol_ ...@@ -202,24 +203,73 @@ retrieveAndRemoveImportsOfModuleFromSymbolTable imports locals all_decls symbol_
# (all_decls, symbol_table) = retrieve_declared_symbols imports all_decls symbol_table # (all_decls, symbol_table) = retrieve_declared_symbols imports all_decls symbol_table
= retrieve_declared_symbols locals all_decls symbol_table = retrieve_declared_symbols locals all_decls symbol_table
where where
retrieve_declared_symbols :: ![Declaration] ![Declaration] !*SymbolTable -> (![Declaration], !*SymbolTable)
retrieve_declared_symbols [symbol=:{dcl_ident=ident=:{id_info},dcl_kind,dcl_index}:symbols] decls symbol_table
#! entry = sreadPtr id_info symbol_table
# {ste_kind,ste_def_level} = entry
| ste_kind == STE_Empty || ste_def_level > cModuleScope
= retrieve_declared_symbols symbols decls symbol_table
# symbol_table = symbol_table <:= (id_info, entry.ste_previous)
= case ste_kind of
STE_Field selector_id
| case dcl_kind of
STE_Field f -> f==selector_id
_ -> False
-> retrieve_declared_symbols symbols [symbol : decls ] (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table)
#! symbol = { symbol & dcl_kind = ste_kind }
-> retrieve_declared_symbols symbols [symbol : decls ] (removeFieldFromSelectorDefinition selector_id NoIndex dcl_index symbol_table)
STE_Imported (STE_Field selector_id) def_mod
| case dcl_kind of
STE_Imported (STE_Field f) d -> d==def_mod && f==selector_id
_ -> False
-> retrieve_declared_symbols symbols [symbol : decls ] (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table)
#! symbol = { symbol & dcl_kind = ste_kind }
-> retrieve_declared_symbols symbols [symbol : decls ] (removeFieldFromSelectorDefinition selector_id def_mod dcl_index symbol_table)
_
| same_STE_Kind ste_kind dcl_kind
-> retrieve_declared_symbols symbols [symbol : decls ] symbol_table
#! symbol = { symbol & dcl_kind = ste_kind }
-> retrieve_declared_symbols symbols [symbol : decls ] symbol_table
retrieve_declared_symbols [] decls symbol_table
= (decls, symbol_table)
/*
retrieve_declared_symbols :: ![Declaration] ![Declaration] !*SymbolTable -> (![Declaration], !*SymbolTable) retrieve_declared_symbols :: ![Declaration] ![Declaration] !*SymbolTable -> (![Declaration], !*SymbolTable)
retrieve_declared_symbols decls collected_decls symbol_table retrieve_declared_symbols decls collected_decls symbol_table
= foldSt retrieve_declared_symbol decls (collected_decls, symbol_table) = foldSt retrieve_declared_symbol decls (collected_decls, symbol_table)
retrieve_declared_symbol symbol=:{dcl_ident=ident=:{id_info},dcl_kind,dcl_index} (decls, symbol_table) retrieve_declared_symbol symbol=:{dcl_ident=ident=:{id_info},dcl_kind,dcl_index} (decls, symbol_table)
#! entry = sreadPtr id_info symbol_table #! entry = sreadPtr id_info symbol_table
# {ste_kind,ste_def_level,ste_previous} = entry // # {ste_kind,ste_def_level,ste_previous} = entry
# {ste_kind,ste_def_level} = entry
| ste_kind == STE_Empty || ste_def_level > cModuleScope | ste_kind == STE_Empty || ste_def_level > cModuleScope
= (decls, symbol_table) = (decls, symbol_table)
= case ste_kind of = case ste_kind of
STE_Field selector_id STE_Field selector_id
-> ([{ symbol & dcl_kind = ste_kind } : decls ], // -> ([{ symbol & dcl_kind = ste_kind } : decls ],
removeFieldFromSelectorDefinition selector_id NoIndex dcl_index (symbol_table <:= (id_info, ste_previous))) // removeFieldFromSelectorDefinition selector_id NoIndex dcl_index (symbol_table <:= (id_info, ste_previous)))
#! symbol = { symbol & dcl_kind = ste_kind }
-> ([symbol : decls ],
removeFieldFromSelectorDefinition selector_id NoIndex dcl_index (symbol_table <:= (id_info, entry.ste_previous)))
STE_Imported (STE_Field selector_id) def_mod STE_Imported (STE_Field selector_id) def_mod
-> ([{ symbol & dcl_kind = ste_kind } : decls ], // -> ([{ symbol & dcl_kind = ste_kind } : decls ],
removeFieldFromSelectorDefinition selector_id def_mod dcl_index (symbol_table <:= (id_info, ste_previous))) // removeFieldFromSelectorDefinition selector_id def_mod dcl_index (symbol_table <:= (id_info, ste_previous)))
#! symbol = { symbol & dcl_kind = ste_kind }
-> ([symbol : decls ],
removeFieldFromSelectorDefinition selector_id def_mod dcl_index (symbol_table <:= (id_info, entry.ste_previous)))
_ _
-> ([{ symbol & dcl_kind = ste_kind } : decls ], symbol_table <:= (id_info, ste_previous)) // -> ([{ symbol & dcl_kind = ste_kind } : decls ], symbol_table <:= (id_info, ste_previous))
#! symbol = { symbol & dcl_kind = ste_kind }
-> ([symbol : decls ], symbol_table <:= (id_info, entry.ste_previous))
*/
same_STE_Kind (STE_Imported s1 i1) (STE_Imported s2 i2) = i1==i2 && same_STE_Kind s1 s2
same_STE_Kind STE_DclFunction STE_DclFunction = True
same_STE_Kind STE_Type STE_Type = True
same_STE_Kind STE_Instance STE_Instance = True
same_STE_Kind STE_Member STE_Member = True
same_STE_Kind STE_Class STE_Class = True
same_STE_Kind (STE_Field f1) (STE_Field f2) = f1==f2
same_STE_Kind _ _ = False
addLocalFunctionDefsToSymbolTable :: !Level !Index !Index !u:{#FunDef} !*SymbolTable !*ErrorAdmin -> (!u:{# FunDef}, !*SymbolTable, !*ErrorAdmin) addLocalFunctionDefsToSymbolTable :: !Level !Index !Index !u:{#FunDef} !*SymbolTable !*ErrorAdmin -> (!u:{# FunDef}, !*SymbolTable, !*ErrorAdmin)
addLocalFunctionDefsToSymbolTable level from_index to_index fun_defs symbol_table error addLocalFunctionDefsToSymbolTable level from_index to_index fun_defs symbol_table error
...@@ -249,7 +299,8 @@ where ...@@ -249,7 +299,8 @@ where
= case dcl_kind of = case dcl_kind of
STE_Imported def_kind def_mod STE_Imported def_kind def_mod
| is_dcl_mod || def_mod <> cIclModIndex | is_dcl_mod || def_mod <> cIclModIndex
-> add_imports_to_symbol_table is_dcl_mod symbols (addImportedSymbol dcl_ident dcl_pos def_kind dcl_index def_mod cs) // -> add_imports_to_symbol_table is_dcl_mod symbols (addImportedSymbol dcl_ident dcl_pos def_kind dcl_index def_mod cs)
-> add_imports_to_symbol_table is_dcl_mod symbols (addIndirectlyImportedSymbol dcl_ident dcl_pos dcl_kind def_kind dcl_index def_mod cs)
-> add_imports_to_symbol_table is_dcl_mod symbols cs -> add_imports_to_symbol_table is_dcl_mod symbols cs
STE_FunctionOrMacro _ STE_FunctionOrMacro _
-> add_imports_to_symbol_table is_dcl_mod symbols (addImportedFunctionOrMacro dcl_ident dcl_index cs) -> add_imports_to_symbol_table is_dcl_mod symbols (addImportedFunctionOrMacro dcl_ident dcl_index cs)
...@@ -292,19 +343,42 @@ addImportedSymbol :: !Ident !Position !STE_Kind !.Int !.Int !*CheckState -> .Che ...@@ -292,19 +343,42 @@ addImportedSymbol :: !Ident !Position !STE_Kind !.Int !.Int !*CheckState -> .Che
addImportedSymbol ident pos def_kind def_index def_mod cs=:{cs_symbol_table} addImportedSymbol ident pos def_kind def_index def_mod cs=:{cs_symbol_table}
# (entry, cs_symbol_table) = readPtr ident.id_info cs_symbol_table # (entry, cs_symbol_table) = readPtr ident.id_info cs_symbol_table
= add_imported_symbol entry ident pos def_kind def_index def_mod { cs & cs_symbol_table = cs_symbol_table } = add_imported_symbol entry ident pos def_kind def_index def_mod { cs & cs_symbol_table = cs_symbol_table }
where where
add_imported_symbol entry=:{ste_kind = STE_Empty} {id_name,id_info} _ def_kind def_index def_mod cs=:{cs_symbol_table} add_imported_symbol /*entry=:*/{ste_kind = STE_Empty} {id_name,id_info} _ def_kind def_index def_mod cs=:{cs_symbol_table}
# cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info (STE_Imported def_kind def_mod) def_index cModuleScope entry} // JVG: read the entry again, because it is boxed
= case def_kind of # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
STE_Field selector_id # cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info (STE_Imported def_kind def_mod) def_index cModuleScope entry}
-> addFieldToSelectorDefinition selector_id { glob_module = def_mod, glob_object = def_index } cs = case def_kind of
_ STE_Field selector_id
-> cs -> addFieldToSelectorDefinition selector_id { glob_module = def_mod, glob_object = def_index } cs
add_imported_symbol entry=:{ste_kind = STE_Imported kind mod_index, ste_index} ident=:{id_info} _ def_kind def_index def_mod cs _
| kind == def_kind && mod_index == def_mod && ste_index == def_index -> cs
= cs add_imported_symbol /*entry=:*/{ste_kind = STE_Imported kind mod_index, ste_index} ident=:{id_info} _ def_kind def_index def_mod cs
add_imported_symbol entry ident pos def_kind def_index def_mod cs=:{cs_error} | kind == def_kind && mod_index == def_mod && ste_index == def_index
= { cs & cs_error = checkErrorWithIdentPos (newPosition ident pos) " multiply imported" cs_error} = cs
add_imported_symbol entry ident pos def_kind def_index def_mod cs=:{cs_error}
= { cs & cs_error = checkErrorWithIdentPos (newPosition ident pos) " multiply imported" cs_error}
// same as addImportedSymbol but does not create a new STE_Imported
addIndirectlyImportedSymbol :: !Ident !Position !STE_Kind !STE_Kind !.Int !.Int !*CheckState -> .CheckState;
addIndirectlyImportedSymbol ident pos dcl_kind def_kind def_index def_mod cs=:{cs_symbol_table}
# (entry, cs_symbol_table) = readPtr ident.id_info cs_symbol_table
= add_indirectly_imported_symbol entry ident pos def_kind def_index def_mod { cs & cs_symbol_table = cs_symbol_table }
where
add_indirectly_imported_symbol /*entry=:*/{ste_kind = STE_Empty} {id_name,id_info} _ def_kind def_index def_mod cs=:{cs_symbol_table}
// JVG: read the entry again, because it is boxed
# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
# cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info dcl_kind def_index cModuleScope entry}
= case def_kind of
STE_Field selector_id
-> addFieldToSelectorDefinition selector_id { glob_module = def_mod, glob_object = def_index } cs
_
-> cs
add_indirectly_imported_symbol /*entry=:*/{ste_kind = STE_Imported kind mod_index, ste_index} ident=:{id_info} _ def_kind def_index def_mod cs
| kind == def_kind && mod_index == def_mod && ste_index == def_index
= cs
add_indirectly_imported_symbol entry ident pos def_kind def_index def_mod cs=:{cs_error}
= { cs & cs_error = checkErrorWithIdentPos (newPosition ident pos) " multiply imported" cs_error}
addGlobalDefinitionsToSymbolTable :: ![.Declaration] !*CheckState -> .CheckState; addGlobalDefinitionsToSymbolTable :: ![.Declaration] !*CheckState -> .CheckState;
addGlobalDefinitionsToSymbolTable decls cs addGlobalDefinitionsToSymbolTable decls cs
......
...@@ -459,6 +459,8 @@ determineAttributeVariable attr_var=:{av_name=attr_name=:{id_info}} oti=:{oti_he ...@@ -459,6 +459,8 @@ determineAttributeVariable attr_var=:{av_name=attr_name=:{id_info}} oti=:{oti_he
:: DemandedAttributeKind = DAK_Ignore | DAK_Unique | DAK_None :: DemandedAttributeKind = DAK_Ignore | DAK_Unique | DAK_None
// JVG: added type:
newAttribute :: !.DemandedAttributeKind .{#Char} TypeAttribute !*OpenTypeInfo !*CheckState -> (!TypeAttribute,!.OpenTypeInfo,!.CheckState);
newAttribute DAK_Ignore var_name _ oti cs newAttribute DAK_Ignore var_name _ oti cs
= (TA_Multi, oti, cs) = (TA_Multi, oti, cs)
newAttribute DAK_Unique var_name new_attr oti cs newAttribute DAK_Unique var_name new_attr oti cs
...@@ -574,7 +576,8 @@ where ...@@ -574,7 +576,8 @@ where
check_attribute var_name dem_attr _ this_attr oti cs check_attribute var_name dem_attr _ this_attr oti cs
= (TA_Multi, oti, cs) = (TA_Multi, oti, cs)
//JVG: added type
checkOpenAType :: Int Int DemandedAttributeKind AType *(u:OpenTypeSymbols,*OpenTypeInfo,*CheckState) -> *(!AType,!*(!u:OpenTypeSymbols,!*OpenTypeInfo,!*CheckState));
checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} (ots, oti, cs) checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} (ots, oti, cs)
# (tv, at_attribute, (oti, cs)) = checkTypeVar scope dem_attr tv at_attribute (oti, cs) # (tv, at_attribute, (oti, cs)) = checkTypeVar scope dem_attr tv at_attribute (oti, cs)
= ({ type & at_type = TV tv, at_attribute = at_attribute }, (ots, oti, cs)) = ({ type & at_type = TV tv, at_attribute = at_attribute }, (ots, oti, cs))
...@@ -627,6 +630,8 @@ where ...@@ -627,6 +630,8 @@ where
(arg_types, cot_state) = check_args_of_type_cons mod_index scope dem_attr arg_types td_args cot_state (arg_types, cot_state) = check_args_of_type_cons mod_index scope dem_attr arg_types td_args cot_state
= ([arg_type : arg_types], cot_state) = ([arg_type : arg_types], cot_state)
*/ */
// JVG: added type:
check_args_of_type_cons :: Int Int [AType] [ATypeVar] !*(!u:OpenTypeSymbols,!*OpenTypeInfo,!*CheckState) -> *(!.[AType],!*(!u:OpenTypeSymbols,!*OpenTypeInfo,!*CheckState));
check_args_of_type_cons mod_index scope [] _ cot_state check_args_of_type_cons mod_index scope [] _ cot_state
= ([], cot_state) = ([], cot_state)
check_args_of_type_cons mod_index scope [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state check_args_of_type_cons mod_index scope [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state
......
...@@ -4,7 +4,6 @@ import StdEnv ...@@ -4,7 +4,6 @@ import StdEnv
import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug
temporary_import_solution_XXX yes no :== yes temporary_import_solution_XXX yes no :== yes
// to switch between importing modes. // to switch between importing modes.
// iff this is yes, then explicit imports happen in the old Clean 1.3 fashion. // iff this is yes, then explicit imports happen in the old Clean 1.3 fashion.
...@@ -253,6 +252,8 @@ instance == ConsequenceKind ...@@ -253,6 +252,8 @@ instance == ConsequenceKind
NoPosition :== -1 NoPosition :== -1
//JVG: added type
filter_decl :: [.Declaration] ([(Ident,AtomType)],[(Ident,StructureInfo,StructureType,Optional Int)]) Int *{#DclModule} *CheckState -> (!(!.[Declaration],!([(Ident,AtomType)],![(Ident,StructureInfo,StructureType,Optional Int)])),!.{#DclModule},!.CheckState);
filter_decl [] unimported _ modules cs filter_decl [] unimported _ modules cs
= (([], unimported), modules, cs) = (([], unimported), modules, cs)
filter_decl [decl:decls] unimported index modules cs filter_decl [decl:decls] unimported index modules cs
...@@ -317,7 +318,7 @@ atomAppears dcl_ident dcl_index (atomicImports, structureImports) index modules ...@@ -317,7 +318,7 @@ atomAppears dcl_ident dcl_index (atomicImports, structureImports) index modules
= atom_appears dcl_ident dcl_index atomicImports atomicImports 0 index modules cs = atom_appears dcl_ident dcl_index atomicImports atomicImports 0 index modules cs
= ((result, (atomicImports, structureImports)), modules, cs) = ((result, (atomicImports, structureImports)), modules, cs)
atom_appears :: Ident .Int [(Ident,.AtomType)] w:[y:(Ident,u1:AtomType)] !Int .Int !u:{#u3:DclModule} !*CheckState -> (!(.Bool,x:[z:(Ident,u2:AtomType)]),!v:{#DclModule},!.CheckState) , [u <= v, u1 <= u2, y <= z, w <= x, u <= u3];
atom_appears _ _ [] atomic_imports _ _ modules cs atom_appears _ _ [] atomic_imports _ _ modules cs
= ((False, atomic_imports), modules, cs) = ((False, atomic_imports), modules, cs)
atom_appears ident dcl_index [h=:(import_ident, atomType):t] atomic_imports unimp_index index modules cs atom_appears ident dcl_index [h=:(import_ident, atomType):t] atomic_imports unimp_index index modules cs
...@@ -357,6 +358,7 @@ instance == StructureType ...@@ -357,6 +358,7 @@ instance == StructureType
(==) ST_Class ST_Class = True (==) ST_Class ST_Class = True
(==) _ _ = False (==) _ _ = False
element_appears :: StructureType Ident Int [(Ident,.StructureInfo,u2:StructureType,z:Optional .Int)] u:[w:(Ident,u5:StructureInfo,u3:StructureType,y:Optional Int)] !Int Int !*{#DclModule} !*CheckState -> (!(Bool,v:[x:(Ident,u6:StructureInfo,u4:StructureType,u1:Optional Int)]),!.{#DclModule},!.CheckState), [y z <= u1, u3 <= u4, u5 <= u6, w <= x, u <= v, u2 <= u3];
element_appears _ _ _ [] atomic_imports _ _ modules cs element_appears _ _ _ [] atomic_imports _ _ modules cs
= ((False, atomic_imports), modules, cs) = ((False, atomic_imports), modules, cs)
// MW2 remove this later .. // MW2 remove this later ..
...@@ -442,6 +444,8 @@ lookup_type dcl_index index modules cs ...@@ -442,6 +444,8 @@ lookup_type dcl_index index modules cs
# com_type_def = dcl_module.dcl_common.com_type_defs.[dcl_index] # com_type_def = dcl_module.dcl_common.com_type_defs.[dcl_index]
= (com_type_def.td_rhs, modules, cs) = (com_type_def.td_rhs, modules, cs)
//JVG: added type:
element_appears_in_stomm_struct :: .StructureType Ident .Int .Int .String *{#DclModule} *CheckState -> (!Bool,!.{#DclModule},!.CheckState)
// MW remove this later CCC // MW remove this later CCC
element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs
| not do_temporary_import_solution_XXX | not do_temporary_import_solution_XXX
...@@ -449,8 +453,45 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n ...@@ -449,8 +453,45 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n
# (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index] # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index]
(module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
#! cs = { cs & cs_symbol_table=cs_symbol_table } #! cs = { cs & cs_symbol_table=cs_symbol_table }
= continuation imported_st module_entry.ste_kind dcl_module modules cs // = continuation imported_st module_entry.ste_kind dcl_module modules cs
= (appears imported_st module_entry.ste_kind dcl_module.dcl_common,modules,cs);
where where
appears ST_RecordType (STE_OpenModule _ modul) _
// lookup the constructors/fields for the algebraic type/record
# allTypes = modul.mod_defs.def_types
search = dropWhile (\{td_name} -> td_name.id_name<>type_name_string) allTypes
| isEmpty search
= False
# {td_rhs} = hd search
| not (isRecordType td_rhs)
= False
# element_idents = getElements td_rhs
= isMember element_ident element_idents
appears ST_RecordType STE_ClosedModule dcl_common
// lookup the type of the constructor and compare
# type_index = dcl_common.com_selector_defs.[dcl_index].sd_type_index
com_type_def = dcl_common.com_type_defs.[type_index]
appears = com_type_def.td_name.id_name==type_name_string
= appears
appears ST_Class (STE_OpenModule _ modul) _
// lookup the members for the class
# allClasses = modul.mod_defs.def_classes
search = dropWhile (\{class_name} -> class_name.id_name<>type_name_string) allClasses
| isEmpty search
= False
# {class_members} = hd search
element_idents = [ ds_ident \\ {ds_ident} <-:class_members ]
= isMember element_ident element_idents
appears ST_Class STE_ClosedModule dcl_common
// lookup the class and compare
# com_member_def = dcl_common.com_member_defs.[dcl_index]
{glob_object} = com_member_def.me_class
com_class_def = dcl_common.com_class_defs.[glob_object]
appears = com_class_def.class_name.id_name==type_name_string
= appears
appears _ _ _
= False
/*
continuation ST_RecordType (STE_OpenModule _ modul) _ modules cs continuation ST_RecordType (STE_OpenModule _ modul) _ modules cs
// lookup the constructors/fields for the algebraic type/record // lookup the constructors/fields for the algebraic type/record
# allTypes = modul.mod_defs.def_types # allTypes = modul.mod_defs.def_types
...@@ -486,6 +527,7 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n ...@@ -486,6 +527,7 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n
= (appears, modules, cs) = (appears, modules, cs)
continuation _ _ _ modules cs continuation _ _ _ modules cs
= (False, modules, cs) = (False, modules, cs)
*/
getElements (RecordType {rt_fields}) getElements (RecordType {rt_fields})
= [ fs_name \\ {fs_name}<-:rt_fields ] = [ fs_name \\ {fs_name}<-:rt_fields ]
getElements _ getElements _
...@@ -555,19 +597,19 @@ element_appears_in_struct imported_st element_ident dcl_index struct_ident index ...@@ -555,19 +597,19 @@ element_appears_in_struct imported_st element_ident dcl_index struct_ident index
check_completeness_of_module :: .Index [(.Declaration,.Int)] .String *(*{!.FunctionConsequence},*{#.DclModule},*{#FunDef},*ExpressionHeap,*CheckState) -> (.{!FunctionConsequence},.{#DclModule},.{#FunDef},.ExpressionHeap,.CheckState); check_completeness_of_module :: .Index [(.Declaration,.Int)] .String *(*{!.FunctionConsequence},*{#.DclModule},*{#FunDef},*ExpressionHeap,*CheckState) -> (.{!FunctionConsequence},.{#DclModule},.{#FunDef},.ExpressionHeap,.CheckState);
check_completeness_of_module mod_index dcls_explicit file_name (f_consequences, modules, icl_functions, expr_heap, cs) check_completeness_of_module mod_index dcls_explicit file_name (f_consequences, modules, icl_functions, expr_heap, cs)
# dcls_imp = [((dcl_ident, kind), (dcl_index, mod_index), (file_name, line_nr)) // # dcls_imp = [((dcl_ident, kind), (dcl_index, mod_index), (file_name, line_nr))
\\ ({dcl_ident, dcl_index, dcl_kind=STE_Imported kind mod_index}, line_nr) <- dcls_explicit] // \\ ({dcl_ident, dcl_index, dcl_kind=STE_Imported kind mod_index}, line_nr) <- dcls_explicit]
(conseqs, (f_consequences, modules, icl_functions, expr_heap)) # (conseqs, (f_consequences, modules, icl_functions, expr_heap))
= mapSt (consequences_of mod_index) dcls_imp (f_consequences, modules, icl_functions, expr_heap) = mapSt (consequences_of file_name mod_index) dcls_explicit (f_consequences, modules, icl_functions, expr_heap)
conseqs = flatten conseqs conseqs = flatten conseqs
#! (modules, cs) = foldr checkConsequenceError (modules, cs) conseqs #! (modules, cs) = foldr checkConsequenceError (modules, cs) conseqs
= (f_consequences, modules, icl_functions, expr_heap, cs) = (f_consequences, modules, icl_functions, expr_heap, cs)
consequences_of :: !Index consequences_of :: String !Index
(!IdentWithKind, !(!Index,!Index), !(!String, !Int)) !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap) !(!.Declaration,Int) !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap)
-> (![(!IdentWithKind, !IdentWithCKind, !(!String, !Int))], !(*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap)) -> (![(!IdentWithKind, !IdentWithCKind, !(!String, !Int))], !(*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap))
consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_index), errMsgInfo)
(f_consequences, modules, icl_functions, expr_heap) consequences_of file_name count ({dcl_ident, dcl_index, dcl_kind=STE_Imported expl_imp_kind mod_index}, line_nr) (f_consequences, modules, icl_functions, expr_heap)
= case expl_imp_kind of = case expl_imp_kind of
STE_FunctionOrMacro _ STE_FunctionOrMacro _
# (consequences, (f_consequences, icl_functions, expr_heap)) = consequences_of_macro count dcl_index f_consequences icl_functions expr_heap # (consequences, (f_consequences, icl_functions, expr_heap)) = consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
...@@ -576,6 +618,9 @@ consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_i ...@@ -576,6 +618,9 @@ consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_i
# (modul, modules) = modules![mod_index] # (modul, modules) = modules![mod_index]
-> (add_kind_and_error_info_to_consequences (consequences_of_simple_symbol expl_imp_kind modul dcl_index), (f_consequences, modules, icl_functions, expr_heap)) -> (add_kind_and_error_info_to_consequences (consequences_of_simple_symbol expl_imp_kind modul dcl_index), (f_consequences, modules, icl_functions, expr_heap))
where where
expl_imp_ident_kind=(dcl_ident,expl_imp_kind)
errMsgInfo = (file_name, line_nr)
add_kind_and_error_info_to_consequences consequences add_kind_and_error_info_to_consequences consequences
= [(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-removeDup consequences] = [(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-removeDup consequences]
......
...@@ -48,16 +48,29 @@ Conventions: ...@@ -48,16 +48,29 @@ Conventions:
, ps_hash_table :: !*HashTable , ps_hash_table :: !*HashTable
, ps_pre_def_symbols :: !*PredefinedSymbols , ps_pre_def_symbols :: !*PredefinedSymbols
} }
/*
appScanState :: (ScanState -> ScanState) !ParseState -> ParseState appScanState :: (ScanState -> ScanState) !ParseState -> ParseState
appScanState f pState=:{ps_scanState} appScanState f pState=:{ps_scanState}
# ps_scanState = f ps_scanState # ps_scanState = f ps_scanState
= { pState & ps_scanState = ps_scanState } = { pState & ps_scanState = ps_scanState }
*/
appScanState f pState:==appScanState pState
where
appScanState pState=:{ps_scanState}
# ps_scanState = f ps_scanState
= { pState & ps_scanState = ps_scanState }
/*
accScanState :: (ScanState -> (.t,ScanState)) !ParseState -> (.t,ParseState) accScanState :: (ScanState -> (.t,ScanState)) !ParseState -> (.t,ParseState)
accScanState f pState=:{ps_scanState} accScanState f pState=:{ps_scanState}
# ( x, ps_scanState) = f ps_scanState # ( x, ps_scanState) = f ps_scanState
= ( x, {pState & ps_scanState = ps_scanState }) = ( x, {pState & ps_scanState = ps_scanState })
*/
accScanState f pState:== accScanState pState
where
accScanState pState=:{ps_scanState}
# ( x, ps_scanState) = f ps_scanState
= ( x, {pState & ps_scanState = ps_scanState })
makeStringTypeSymbol pState=:{ps_pre_def_symbols} makeStringTypeSymbol pState=:{ps_pre_def_symbols}
#! string_id = ps_pre_def_symbols.[PD_StringType] #! string_id = ps_pre_def_symbols.[PD_StringType]
...@@ -2362,6 +2375,7 @@ where ...@@ -2362,6 +2375,7 @@ where
// transform one group of nested updates with the same first field // transform one group of nested updates with the same first field
// for example: f.g1 = e1, f.g2 = e2 -> f = {id.f & g1 = e1, g2 = e2}, // for example: f.g1 = e1, f.g2 = e2 -> f = {id.f & g1 = e1, g2 = e2},
// (id is ident to shared expression that's being updated) // (id is ident to shared expression that's being updated)
transform_update :: !Int [NestedUpdate] (Optional Ident,Optional Ident,ParseState) -> (FieldAssignment, !(!Optional Ident,!Optional Ident,ParseState)) transform_update :: !Int [NestedUpdate] (Optional Ident,Optional Ident,ParseState) -> (FieldAssignment, !(!Optional Ident,!Optional Ident,ParseState))
transform_update _ [{nu_selectors=[PS_Record fieldIdent field_record_type], nu_update_expr}] (shareIdent,record_type,pState) transform_update _ [{nu_selectors=[PS_Record fieldIdent field_record_type], nu_update_expr}] (shareIdent,record_type,pState)
# (record_type,pState) = check_field_and_record_types field_record_type record_type pState; # (record_type,pState) = check_field_and_record_types field_record_type record_type pState;
...@@ -2396,7 +2410,7 @@ where ...@@ -2396,7 +2410,7 @@ where
build_update record_type (Yes ident) expr assignments build_update record_type (Yes ident) expr assignments
= PE_Let False (LocalParsedDefs [buildNodeDef (PE_Ident ident) expr]) = PE_Let False (LocalParsedDefs [buildNodeDef (PE_Ident ident) expr])
(PE_Record (PE_Ident ident) record_type assignments) (PE_Record (PE_Ident ident) record_type assignments)
check_field_and_record_types :: (Optional Ident) (Optional Ident) ParseState -> (!Optional Ident,!ParseState); check_field_and_record_types :: (Optional Ident) (Optional Ident) ParseState -> (!Optional Ident,!ParseState);
check_field_and_record_types No record_type pState check_field_and_record_types No record_type pState
= (record_type,pState); = (record_type,pState);
......
...@@ -6,11 +6,6 @@ import StdEnv, general ...@@ -6,11 +6,6 @@ import StdEnv, general
:: * ScanState :: * ScanState
//:: *Input
//:: * InputStream
//:: LongToken
//:: Buffer x
:: FilePosition = {fp_line :: !Int, fp_col :: !Int} :: FilePosition = {fp_line :: !Int, fp_col :: !Int}
instance <<< FilePosition instance <<< FilePosition
......
...@@ -16,7 +16,45 @@ functions names starting with '->' require a ';' after the type. Solutions: ...@@ -16,7 +16,45 @@ functions names starting with '->' require a ';' after the type. Solutions:
*/ */
:: SearchPaths :== [String] :: SearchPaths :== [String]
:: * ScanState = :: *ScanState = ScanState !RScanState
instance getFilename ScanState
where
getFilename (ScanState scan_state)
# (file_name,scan_state) = getFilename scan_state
= (file_name,ScanState scan_state)
instance tokenBack ScanState
where
tokenBack (ScanState scan_state) = ScanState (tokenBack scan_state)
instance nextToken ScanState
where
nextToken context (ScanState scan_state)
# (token,scan_state) = nextToken context scan_state
= (token,ScanState scan_state)
instance currentToken ScanState
where
currentToken (ScanState scan_state)
# (token,scan_state) = currentToken scan_state
= (token,ScanState scan_state)
instance insertToken ScanState
where
insertToken token context (ScanState scan_state) = ScanState (insertToken token context scan_state)
instance replaceToken ScanState
where
replaceToken token (ScanState scan_state) = ScanState (replaceToken token scan_state)
instance getPosition ScanState
where
getPosition (ScanState scan_state)
# (position,scan_state) = getPosition scan_state
= (position,ScanState scan_state)
:: * RScanState =
{ ss_input :: ScanInput { ss_input :: ScanInput