Skip to content
GitLab
Commit 24ce7815 authored by clean's avatar clean
Browse files

reduce memory allocation

parent f885f33d
Show whitespace changes
Inline Side-by-side
frontend/checksupport.dcl
View file @ 24ce7815
......@@ -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);
......
frontend/checksupport.icl
View file @ 24ce7815
......@@ -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 }
......@@ -202,24 +203,73 @@ retrieveAndRemoveImportsOfModuleFromSymbolTable imports locals all_decls symbol_
# (all_decls, symbol_table) = retrieve_declared_symbols imports all_decls symbol_table
= 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,20 +343,43 @@ 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}
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
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
= foldSt add_global_definition decls cs
......
frontend/checktypes.icl
View file @ 24ce7815
......@@ -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
......
frontend/explicitimports.icl
View file @ 24ce7815
......@@ -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]
......
frontend/parse.icl
View file @ 24ce7815
......@@ -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;
......
frontend/scanner.dcl
View file @ 24ce7815
......@@ -6,11 +6,6 @@ import StdEnv, general
:: * ScanState
//:: *Input
//:: * InputStream
//:: LongToken
//:: Buffer x
:: FilePosition = {fp_line :: !Int, fp_col :: !Int}
instance <<< FilePosition
......
frontend/scanner.icl
View file @ 24ce7815
......@@ -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,_):_]}