diff options
| -rw-r--r-- | frontend/checksupport.dcl | 2 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 114 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 7 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 67 | ||||
| -rw-r--r-- | frontend/parse.icl | 18 | ||||
| -rw-r--r-- | frontend/scanner.dcl | 5 | ||||
| -rw-r--r-- | frontend/scanner.icl | 94 |
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) |