aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorclean2000-06-20 15:28:14 +0000
committerclean2000-06-20 15:28:14 +0000
commitcb4458a91db44af4b0ace8dc798bc72c98e3e1c0 (patch)
tree30f68c7fc8bd5fbefe5bac8fef9acc2bf504313f
parentno message (diff)
reduce memory allocation
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@175 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
-rw-r--r--frontend/checksupport.dcl2
-rw-r--r--frontend/checksupport.icl114
-rw-r--r--frontend/checktypes.icl7
-rw-r--r--frontend/explicitimports.icl67
-rw-r--r--frontend/parse.icl18
-rw-r--r--frontend/scanner.dcl5
-rw-r--r--frontend/scanner.icl94
7 files changed, 246 insertions, 61 deletions
diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl
index d874610..df8b8bb 100644
--- a/frontend/checksupport.dcl
+++ b/frontend/checksupport.dcl
@@ -129,7 +129,7 @@ retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaratio
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;
+//addLocalSymbolsToSymbolTable :: ![.Declaration] Int !*CheckState -> .CheckState;
addFieldToSelectorDefinition :: !Ident (Global .Int) !*CheckState -> .CheckState;
addGlobalDefinitionsToSymbolTable :: ![.Declaration] !*CheckState -> .CheckState;
retrieveImportsFromSymbolTable :: ![Import ImportDeclaration] ![Declaration] !*{#DclModule} !*(Heap SymbolTableEntry) -> *(![Declaration],!*{#DclModule},!*Heap SymbolTableEntry);
diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl
index 3cccdc8..bacf06b 100644
--- a/frontend/checksupport.icl
+++ b/frontend/checksupport.icl
@@ -155,6 +155,7 @@ 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' }
+
checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorWithIdentPos ident_pos mess error=:{ea_file}
= { error & ea_file = ea_file <<< "Check Error " <<< ident_pos <<< ":" <<< mess <<< '\n', ea_ok = False }
@@ -203,23 +204,72 @@ retrieveAndRemoveImportsOfModuleFromSymbolTable imports locals all_decls symbol_
= retrieve_declared_symbols locals all_decls symbol_table
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 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)
#! 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
= (decls, symbol_table)
= case ste_kind of
STE_Field selector_id
- -> ([{ symbol & dcl_kind = ste_kind } : decls ],
- removeFieldFromSelectorDefinition selector_id NoIndex dcl_index (symbol_table <:= (id_info, ste_previous)))
+// -> ([{ symbol & dcl_kind = ste_kind } : decls ],
+// 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
- -> ([{ symbol & dcl_kind = ste_kind } : decls ],
- removeFieldFromSelectorDefinition selector_id def_mod dcl_index (symbol_table <:= (id_info, ste_previous)))
+// -> ([{ symbol & dcl_kind = ste_kind } : decls ],
+// 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 from_index to_index fun_defs symbol_table error
@@ -249,7 +299,8 @@ where
= case dcl_kind of
STE_Imported def_kind def_mod
| 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
STE_FunctionOrMacro _
-> 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
addImportedSymbol ident pos def_kind def_index def_mod cs=:{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 }
-where
- 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}
- = case def_kind of
- STE_Field selector_id
- -> addFieldToSelectorDefinition selector_id { glob_module = def_mod, glob_object = 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
- | kind == def_kind && mod_index == def_mod && ste_index == def_index
- = 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}
+ where
+ add_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 (STE_Imported def_kind def_mod) 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_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_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 decls cs
diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl
index 68e3c2e..5b4d4ac 100644
--- a/frontend/checktypes.icl
+++ b/frontend/checktypes.icl
@@ -459,6 +459,8 @@ determineAttributeVariable attr_var=:{av_name=attr_name=:{id_info}} oti=:{oti_he
:: 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
= (TA_Multi, oti, cs)
newAttribute DAK_Unique var_name new_attr oti cs
@@ -574,7 +576,8 @@ where
check_attribute var_name dem_attr _ this_attr 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)
# (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))
@@ -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_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
= ([], cot_state)
check_args_of_type_cons mod_index scope [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state
diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl
index c5251da..bd8d5db 100644
--- a/frontend/explicitimports.icl
+++ b/frontend/explicitimports.icl
@@ -4,7 +4,6 @@ import StdEnv
import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug
-
temporary_import_solution_XXX yes no :== yes
// to switch between importing modes.
// iff this is yes, then explicit imports happen in the old Clean 1.3 fashion.
@@ -253,6 +252,8 @@ instance == ConsequenceKind
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
= (([], unimported), modules, cs)
filter_decl [decl:decls] unimported index modules cs
@@ -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
= ((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
= ((False, atomic_imports), 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
(==) ST_Class ST_Class = True
(==) _ _ = 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
= ((False, atomic_imports), modules, cs)
// MW2 remove this later ..
@@ -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.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
element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs
| not do_temporary_import_solution_XXX
@@ -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]
(module_entry, cs_symbol_table) = readPtr id_info cs.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
+ 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
// lookup the constructors/fields for the algebraic type/record
# allTypes = modul.mod_defs.def_types
@@ -486,6 +527,7 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n
= (appears, modules, cs)
continuation _ _ _ modules cs
= (False, modules, cs)
+*/
getElements (RecordType {rt_fields})
= [ fs_name \\ {fs_name}<-:rt_fields ]
getElements _
@@ -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 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))
- \\ ({dcl_ident, dcl_index, dcl_kind=STE_Imported kind mod_index}, line_nr) <- dcls_explicit]
- (conseqs, (f_consequences, modules, icl_functions, expr_heap))
- = mapSt (consequences_of mod_index) dcls_imp (f_consequences, modules, icl_functions, expr_heap)
+// # 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]
+ # (conseqs, (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
#! (modules, cs) = foldr checkConsequenceError (modules, cs) conseqs
= (f_consequences, modules, icl_functions, expr_heap, cs)
-consequences_of :: !Index
- (!IdentWithKind, !(!Index,!Index), !(!String, !Int)) !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap)
+consequences_of :: String !Index
+ !(!.Declaration,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
STE_FunctionOrMacro _
# (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
# (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))
where
+ expl_imp_ident_kind=(dcl_ident,expl_imp_kind)
+ errMsgInfo = (file_name, line_nr)
+
add_kind_and_error_info_to_consequences consequences
= [(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-removeDup consequences]
diff --git a/frontend/parse.icl b/frontend/parse.icl
index 0bce664..d7f4049 100644
--- a/frontend/parse.icl
+++ b/frontend/parse.icl
@@ -48,16 +48,29 @@ Conventions:
, ps_hash_table :: !*HashTable
, ps_pre_def_symbols :: !*PredefinedSymbols
}
-
+/*
appScanState :: (ScanState -> ScanState) !ParseState -> ParseState
appScanState f pState=:{ps_scanState}
# ps_scanState = f 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 f pState=:{ps_scanState}
# ( x, ps_scanState) = f 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}
#! string_id = ps_pre_def_symbols.[PD_StringType]
@@ -2362,6 +2375,7 @@ where
// 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},
// (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 _ [{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;
@@ -2396,7 +2410,7 @@ where
build_update record_type (Yes ident) expr assignments
= PE_Let False (LocalParsedDefs [buildNodeDef (PE_Ident ident) expr])
(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 No record_type pState
= (record_type,pState);
diff --git a/frontend/scanner.dcl b/frontend/scanner.dcl
index fccdac9..dd00ae8 100644
--- a/frontend/scanner.dcl
+++ b/frontend/scanner.dcl
@@ -6,11 +6,6 @@ import StdEnv, general
:: * ScanState
-//:: *Input
-//:: * InputStream
-//:: LongToken
-//:: Buffer x
-
:: FilePosition = {fp_line :: !Int, fp_col :: !Int}
instance <<< FilePosition
diff --git a/frontend/scanner.icl b/frontend/scanner.icl
index c296e63..fca7784 100644
--- a/frontend/scanner.icl
+++ b/frontend/scanner.icl
@@ -16,7 +16,45 @@ functions names starting with '->' require a ';' after the type. Solutions:
*/
:: 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_offsides :: ! [(Int, Bool) ] // (column, defines newDefinition)
, ss_useLayout :: ! Bool
@@ -29,7 +67,7 @@ functions names starting with '->' require a ';' after the type. Solutions:
:: * Input =
{ inp_stream :: ! * InputStream
- , inp_filename :: String
+ , inp_filename :: !String
, inp_pos :: ! FilePosition
, inp_tabsize :: ! Int
}
@@ -180,7 +218,7 @@ where
# (filename,input) = getFilename input
= (filename,PushedToken tok input)
-instance getFilename ScanState
+instance getFilename RScanState
where
getFilename scanState=:{ss_input}
# (filename,ss_input) = getFilename ss_input
@@ -188,7 +226,7 @@ where
class getPosition state :: !*state -> (!FilePosition,!*state) // Position of current Token (or Char)
-instance getPosition ScanState
+instance getPosition RScanState
where
getPosition scanState=:{ss_tokenBuffer}
| isEmptyBuffer ss_tokenBuffer
@@ -202,7 +240,7 @@ where
class getCharPosition state :: !*state -> (FilePosition,!*state)
-instance getCharPosition ScanState
+instance getCharPosition RScanState
where
getCharPosition scanState=:{ss_input=Input input}
# (pos,input) = getPosition input
@@ -215,7 +253,7 @@ where getCharPosition input=:{inp_pos} = (inp_pos, input)
class nextToken state :: !Context !*state -> (!Token, !*state)
-instance nextToken ScanState
+instance nextToken RScanState
where
// nextToken newContext {ss_input=PushedToken token=:{lt_position,lt_token} rest,ss_tokenBuffer,ss_offsides,ss_useLayout}
nextToken newContext scanState=:{ss_input=input=:PushedToken token=:{lt_position,lt_token/*,lt_context*/} rest,ss_tokenBuffer}
@@ -339,7 +377,7 @@ where
class tokenBack state :: !*state -> !*state
-instance tokenBack ScanState
+instance tokenBack RScanState
where
tokenBack scanState=:{ss_tokenBuffer, ss_input}
| isEmptyBuffer ss_tokenBuffer = abort "tokenBack with empty token buffer"
@@ -351,7 +389,7 @@ where
class currentToken state :: !*state -> (!Token, !*state)
-instance currentToken ScanState
+instance currentToken RScanState
where currentToken scanState=:{ss_tokenBuffer}
| isEmptyBuffer ss_tokenBuffer
= (ErrorToken "dummy", scanState)
@@ -359,7 +397,7 @@ where currentToken scanState=:{ss_tokenBuffer}
class insertToken state :: !Token !Context !*state -> *state
-instance insertToken ScanState
+instance insertToken RScanState
where
insertToken t c scanState
/* # chars = if (isGeneratedToken t)
@@ -385,7 +423,7 @@ isGeneratedToken _ = False
class replaceToken state :: !Token !*state -> *state
-instance replaceToken ScanState
+instance replaceToken RScanState
where
replaceToken tok scanState=:{ss_tokenBuffer}
# (longToken,buffer) = get ss_tokenBuffer
@@ -1609,7 +1647,7 @@ openScanner file_name searchPaths files
(No, files)
-> (No, files)
(Yes file, files)
- -> (Yes { ss_input = Input
+ -> (Yes (ScanState { ss_input = Input
{ inp_stream = InFile file
, inp_filename = file_name
, inp_pos = {fp_line = 1, fp_col = 0}
@@ -1620,7 +1658,7 @@ openScanner file_name searchPaths files
, ss_offsides = [(1,False)] // to generate offsides between global definitions
, ss_useLayout = False
, ss_tokenBuffer = Buffer0
- }
+ })
, files
)
@@ -1636,9 +1674,12 @@ fopenInSearchPaths fileName [path : paths] mode f
= fopenInSearchPaths fileName paths mode f
closeScanner :: !ScanState !*Files -> *Files
-closeScanner scanState=:{ss_input=PushedToken _ input} files
- = closeScanner {scanState & ss_input = input} files
-closeScanner {ss_input=Input {inp_stream}} files
+closeScanner (ScanState scan_state) files = closeScanner_ scan_state files
+
+closeScanner_ :: !RScanState !*Files -> *Files
+closeScanner_ scanState=:{ss_input=PushedToken _ input} files
+ = closeScanner_ {scanState & ss_input = input} files
+closeScanner_ {ss_input=Input {inp_stream}} files
= case get_file inp_stream of
Yes file # (_,files) = fclose file files
-> files
@@ -1663,13 +1704,21 @@ isNewLine _ = False
//--- Offside handling ---//
//------------------------//
+UseLayout_ :: !RScanState -> (!Bool, !RScanState)
+UseLayout_ scanState = scanState!ss_useLayout
+
UseLayout :: !ScanState -> (!Bool, !ScanState)
-UseLayout scanState = scanState!ss_useLayout
+UseLayout (ScanState scanState)
+ # (ss_useLayout,scanState) = scanState!ss_useLayout
+ = (ss_useLayout,ScanState scanState)
setUseLayout :: !Bool !ScanState -> ScanState
-setUseLayout b ss = { ss & ss_useLayout = b } // -->> ("uselayout set to ",b)
+setUseLayout b (ScanState ss) = ScanState { ss & ss_useLayout = b }
-checkOffside :: !FilePosition !Token !ScanState -> (Token,ScanState)
+setUseLayout_ :: !Bool !RScanState -> RScanState
+setUseLayout_ b ss = { ss & ss_useLayout = b } // -->> ("uselayout set to ",b)
+
+checkOffside :: !FilePosition !Token !RScanState -> (Token,RScanState)
checkOffside pos token scanState=:{ss_offsides,ss_useLayout,ss_input}
| ~ ss_useLayout
= (token, scanState) //-->> (token,pos,"No layout rule applied")
@@ -1822,10 +1871,13 @@ canBeOffside (CodeBlockToken _) = False
canBeOffside _ = True
dropOffsidePosition :: !ScanState -> ScanState
-dropOffsidePosition scanState=:{ss_offsides} = { scanState & ss_offsides = drop 1 ss_offsides }
+dropOffsidePosition (ScanState s) = ScanState (dropOffsidePosition_ s)
+
+dropOffsidePosition_ :: !RScanState -> RScanState
+dropOffsidePosition_ scanState=:{ss_offsides} = { scanState & ss_offsides = drop 1 ss_offsides }
/*
-addOffsidePosition :: !ScanState -> (Int, ScanState)
+addOffsidePosition :: !RScanState -> (Int, RScanState)
addOffsidePosition scanState=:{ss_useLayout}
| ss_useLayout
# (position,scanState=:{ss_offsides}) = getPosition scanState
@@ -1834,7 +1886,7 @@ addOffsidePosition scanState=:{ss_useLayout}
| otherwise
= (1, scanState)
-atOffsidePosition :: !ScanState -> (!Bool, !ScanState)
+atOffsidePosition :: !RScanState -> (!Bool, !RScanState)
atOffsidePosition scanState=:{ss_offsides=[(col,_):_]}
# (position, scanState) = getPosition scanState
= (position.fp_col == col, scanState) -->> ("atOffsidePosition",position.fp_col,col)