diff options
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 10 | ||||
| -rw-r--r-- | frontend/parse.icl | 343 | ||||
| -rw-r--r-- | frontend/scanner.dcl | 4 | ||||
| -rw-r--r-- | frontend/scanner.icl | 602 | ||||
| -rw-r--r-- | frontend/utilities.dcl | 7 | ||||
| -rw-r--r-- | frontend/utilities.icl | 31 |
6 files changed, 432 insertions, 565 deletions
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 3e060f2..2d1682d 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -937,7 +937,7 @@ where = mapSt (check_out_parameter expr_level) params es_cs check_out_parameter expr_level bind=:{ bind_src, bind_dst } (e_state, cs) - | isLowerCaseName bind_dst.id_name + | isLowerCaseName bind_dst.id_name NoUnderscores # (entry, cs_symbol_table) = readPtr bind_dst.id_info cs.cs_symbol_table # (new_info_ptr, es_var_heap) = newPtr VI_Empty e_state.es_var_heap cs = checkPatternVariable expr_level entry bind_dst new_info_ptr { cs & cs_symbol_table = cs_symbol_table } @@ -1336,7 +1336,7 @@ checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patter = check_rhs def_level bind (foldSt check_index_expr bind_dst states) check_index_expr (PE_Ident {id_name}) states - | isLowerCaseName id_name + | isLowerCaseName id_name NoUnderscores = states // further with next alternative check_index_expr (PE_Basic (BVI _)) states @@ -1345,7 +1345,7 @@ checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patter = (var_env, ap_selections, var_heap, { cs & cs_error = checkError "variable or integer constant expected as index expression" "" cs.cs_error }) check_rhs def_level {bind_src=PE_Ident ident, bind_dst} (var_env, ap_selections, var_heap, cs) - | isLowerCaseName ident.id_name + | isLowerCaseName ident.id_name NoUnderscores # (entry,cs_symbol_table) = readPtr ident.id_info cs.cs_symbol_table # (rhs_var, var_heap) = allocate_free_var ident var_heap cs = checkPatternVariable def_level entry ident rhs_var.fv_info_ptr { cs & cs_symbol_table = cs_symbol_table } @@ -1400,7 +1400,7 @@ where checkBoundPattern {bind_src,bind_dst} opt_var p_input (var_env, array_patterns) ps e_info cs=:{cs_symbol_table} - | isLowerCaseName bind_dst.id_name + | isLowerCaseName bind_dst.id_name NoUnderscores # (entry, cs_symbol_table) = readPtr bind_dst.id_info cs_symbol_table # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap cs = checkPatternVariable p_input.pi_def_level entry bind_dst new_info_ptr { cs & cs_symbol_table = cs_symbol_table } @@ -1427,7 +1427,7 @@ checkIdentPattern :: !Bool !Ident !(Optional (Bind Ident VarInfoPtr)) !PatternIn checkIdentPattern is_expr_list id=:{id_name,id_info} opt_var {pi_def_level, pi_mod_index} accus=:(var_env, array_patterns) ps e_info cs=:{cs_symbol_table} # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table - | isLowerCaseName id_name + | isLowerCaseName id_name NoUnderscores # (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap cs = checkPatternVariable pi_def_level entry id new_info_ptr { cs & cs_symbol_table = cs_symbol_table } = (AP_Variable id new_info_ptr opt_var, ([ id : var_env ], array_patterns), { ps & ps_var_heap = ps_var_heap}, e_info, cs) diff --git a/frontend/parse.icl b/frontend/parse.icl index ae5f528..ca0136d 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -46,6 +46,7 @@ Conventions: { ps_scanState :: !ScanState , ps_error :: !*ParseErrorAdmin , ps_skipping :: !Bool + , ps_underscoreModule :: !Bool , ps_hash_table :: !*HashTable , ps_pre_def_symbols :: !*PredefinedSymbols } @@ -73,6 +74,10 @@ accScanState f pState:== accScanState pState # ( x, ps_scanState) = f ps_scanState = ( x, {pState & ps_scanState = ps_scanState }) +instance getFilename ParseState +where + getFilename pState = accScanState getFilename pState + makeStringTypeSymbol pState=:{ps_pre_def_symbols} #! string_id = ps_pre_def_symbols.[PD_StringType] = (MakeNewTypeSymbIdent string_id.pds_ident 0, pState) @@ -241,26 +246,44 @@ cGlobalContext :== 2 cDCLContext :== 0 cLocalContext :== 1 +// RWS ... +/* + A cClassOrInstanceDefsContext is a further restriction on a + local context, because no local node defs are allowed + This context stuff is getting far too complicated. + Possible solution: accept everything in the parser and + discriminate in postparse, depending on the context. +*/ +cClassOrInstanceDefsContext :== 4 +// ... RWS + SetGlobalContext iclmodule | iclmodule = cICLContext bitor cGlobalContext = cDCLContext bitor cGlobalContext - + SetLocalContext context :== context bitand (bitnot cGlobalContext) +// RWS ... +SetClassOrInstanceDefsContext context :== SetLocalContext (context bitor cClassOrInstanceDefsContext) +// ... RWS + isLocalContext context :== context bitand cGlobalContext == 0 isGlobalContext context :== not (isLocalContext context) isDclContext context :== context bitand cICLContext == 0 isIclContext context :== not (isDclContext context) +// RWS ... +isClassOrInstanceDefsContext context :== context bitand cClassOrInstanceDefsContext <> 0 +// ... RWS + cWantIclFile :== True cWantDclFile :== False wantModule :: !Bool !Ident !Position !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) wantModule iclmodule file_id=:{id_name} import_file_position hash_table error searchPaths pre_def_symbols files - # file_name = if iclmodule (id_name +++ ".icl") (id_name +++ ".dcl") = case openScanner file_name searchPaths files of (Yes scanState, files) # hash_table=set_hte_mark (if iclmodule 1 0) hash_table @@ -271,6 +294,7 @@ wantModule iclmodule file_id=:{id_name} import_file_position hash_table error se -> let mod = { mod_name = file_id, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in (False, mod, hash_table, error <<< "Error " <<< import_file_position <<< ": could not open " <<< file_name <<< "\n", pre_def_symbols, files) where + file_name = if iclmodule (id_name +++ ".icl") (id_name +++ ".dcl") initModule :: String ScanState !*HashTable !*File !*PredefinedSymbols *Files -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) initModule file_name scanState hash_table error pre_def_symbols files @@ -279,6 +303,7 @@ where # pState = { ps_scanState = scanState , ps_error = { pea_file = error, pea_ok = True } , ps_skipping = False + , ps_underscoreModule = file_name.[0] == '_' , ps_hash_table = hash_table , ps_pre_def_symbols = pre_def_symbols } @@ -373,7 +398,7 @@ where = pState # ({fp_line}, pState=:{ps_error={pea_file}}) = getPosition pState pea_file = pea_file <<< '[' <<< file_name <<< ',' <<< fp_line <<< "]: module name \"" <<< name - <<< "\" does not match file name\n" + <<< "\" does not match file name: \"" <<< file_name <<<"\"\n" = { pState & ps_error = { pea_file = pea_file, pea_ok = False }} check_layout_rule pState @@ -419,12 +444,12 @@ where try_definition :: !ParseContext !Token !Position !ParseState -> (!Bool, ParsedDefinition, !ParseState) try_definition context DoubleColonToken pos pState | ~(isGlobalContext context) - = (False,abort "no def(3)",parseError "definition" No "type definitions are only at the global level" pState) + = (False,abort "no def(3)",parseError "definition" No "type definitions only at the global level" (tokenBack pState)) # (def, pState) = wantTypeDef context pos pState = (True, def, pState) try_definition _ ImportToken pos pState | ~(isGlobalContext context) - = (False,abort "no def(3)",parseError "definition" No "imports are only at the global level" pState) + = (False,abort "no def(3)",parseError "definition" No "imports only at the global level" pState) # (token, pState) = nextToken FunctionContext pState | token == CodeToken && isIclContext context # (importedObjects, pState) = wantCodeImports pState @@ -434,7 +459,7 @@ where = (True, PD_Import imports, pState) try_definition _ FromToken pos pState | ~(isGlobalContext context) - = (False,abort "no def(3)",parseError "definition" No "imports are only at the global level" pState) + = (False,abort "no def(3)",parseError "definition" No "imports only at the global level" pState) # (imp, pState) = wantFromImports pState = (True, PD_Import [imp], pState) -->> imp /* try_definition _ ExportToken pos pState @@ -517,8 +542,10 @@ where = (PD_TypeSpec pos name prio No SP_None, wantEndOfDefinition "type defenition (5)" (tokenBack pState)) want_rhs_of_def context (No, args) token pos pState # pState = want_node_def_token pState token - // localsExpected = isNotEmpty args || isGlobalContext context - (rhs, pState) = wantRhs isEqualToken False (tokenBack pState) // PK localsExpected -> False + # (ss_useLayout, pState) = accScanState UseLayout pState +// localsExpected = isNotEmpty args || isGlobalContext context +// (rhs, pState) = wantRhs isEqualToken False (tokenBack pState) // PK localsExpected -> False + (rhs, pState) = wantRhs isEqualToken (~ ss_useLayout) (tokenBack pState) // PK localsExpected -> ~ ss_useLayout | isGlobalContext context = (PD_NodeDef pos (combine_args args) rhs, parseError "RHS" No "<global definition>" pState) = (PD_NodeDef pos (combine_args args) rhs, pState) @@ -529,10 +556,20 @@ where combine_args [arg] = arg combine_args args = PE_List args - want_rhs_of_def context (Yes (name, False), []) token pos pState +/* want_rhs_of_def context (Yes (name, False), []) token pos pState | isIclContext context && isLocalContext context && (token == DefinesColonToken || token == EqualToken) && isLowerCaseName name.id_name # (rhs, pState) = wantRhs (\_ -> True) False (tokenBack pState) = (PD_NodeDef pos (PE_Ident name) rhs, pState) +*/ // PK .. + want_rhs_of_def context (Yes (name, False), []) token pos pState=:{ps_underscoreModule} + | isIclContext context && isLocalContext context && (token == DefinesColonToken || token == EqualToken) && + isLowerCaseName name.id_name ps_underscoreModule +// RWS ... + && not (isClassOrInstanceDefsContext context) +// ... RWS + # (rhs, pState) = wantRhs (\_ -> True) False (tokenBack pState) + = (PD_NodeDef pos (PE_Ident name) rhs, pState) // ..PK + want_rhs_of_def context (Yes (name, is_infix), args) token pos pState # (fun_kind, code_allowed, pState) = token_to_fun_kind pState token (token, pState) = nextToken FunctionContext pState @@ -543,7 +580,9 @@ where // otherwise // ~ code_allowed = (PD_Function pos name is_infix args rhs fun_kind, parseError "rhs of def" No "no code" pState) # pState = tokenBack (tokenBack pState) - localsExpected = isNotEmpty args || isGlobalContext context +// localsExpected = isNotEmpty args || isGlobalContext context + (ss_useLayout, pState) = accScanState UseLayout pState + localsExpected = isNotEmpty args || isGlobalContext context || ~ ss_useLayout (rhs, pState) = wantRhs isRhsStartToken localsExpected pState = case fun_kind of FK_Function _ | isDclContext context @@ -618,7 +657,7 @@ wantCodeRhs pState } , rhs_locals = LocalParsedDefs [] } - , wantEndOfDefinition "code rhs" pState + , wantEndCodeRhs pState ) where want_code_expr :: !ParseState -> (!ParsedExpr, !ParseState) @@ -704,17 +743,19 @@ where want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) want_FunctionBody BarToken nodeDefs alts sep pState // # (lets, pState) = want_StrictLet pState // removed from 2.0 - # (file_name, line_nr, pState)= getFileAndLineNr pState // MW4++ + # (file_name, line_nr, pState)= getFileAndLineNr pState (token, pState) = nextToken FunctionContext pState | token == OtherwiseToken # (token, pState) = nextToken FunctionContext pState (nodeDefs2, token, pState) = want_LetBefores token pState + = want_FunctionBody token (nodeDefs ++ nodeDefs2) alts sep pState // to allow | otherwise | c1 = .. | c2 = .. +/* PK ??? = case token of BarToken # pState = parseError "RHS: default alternative" No "root expression instead of guarded expression" pState -> root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState _ -> root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState - | token == LetToken True +*/ | token == LetToken True # pState = parseError "RHS" No "No 'let!' in this version of Clean" pState = root_expression True token nodeDefs (reverse alts) sep pState # (guard, pState) = wantRhsExpressionT token pState @@ -725,7 +766,6 @@ where offside = position.fp_col (expr, pState) = want_FunctionBody token nodeDefs2 [] sep pState pState = wantEndNestedGuard (default_found expr) offside pState -// MW4 was: alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr } alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr, alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr } (token, pState) = nextToken FunctionContext pState @@ -733,17 +773,14 @@ where = want_FunctionBody token nodeDefs [alt:alts] sep pState // otherwise # (expr, pState) = root_expression True token nodeDefs2 [] sep pState -// MW4 was: alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr } alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr, alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr } (token, pState) = nextToken FunctionContext pState (nodeDefs, token, pState) = want_LetBefores token pState = want_FunctionBody token nodeDefs [alt:alts] sep pState -// MW4.. where guard_ident line_nr = { id_name = "_g;" +++ toString line_nr +++ ";", id_info = nilPtr } -// ..MW4 want_FunctionBody token nodeDefs alts sep pState = root_expression localsExpected token nodeDefs (reverse alts) sep pState @@ -917,11 +954,13 @@ want_2_0_import_declaration token pState // ..MW5 = case token of DoubleColonToken - # (name, pState) = wantConstructorName "import type" pState +// PK # (name, pState) = wantConstructorName "import type" pState + # (name, pState) = wantUpperCaseName "import type" pState (type_id, pState) = stringToIdent name IC_Type pState (ii_extended, token, pState) = optional_extension_with_next_token pState | token == OpenToken - # (conses, pState) = want_names (wantConstructorName "import type (..)") IC_Expression CloseToken pState +// PK # (conses, pState) = want_names (wantConstructorName "import type (..)") IC_Expression CloseToken pState + # (conses, pState) = want_names (wantUpperCaseName "import type (..)") IC_Expression CloseToken pState -> (ID_Type { ii_ident = type_id, ii_extended = ii_extended } (Yes conses), pState) | token == CurlyOpenToken # (fields, pState) = want_names (wantLowerCaseName "import record fields") (IC_Field type_id) CurlyCloseToken pState @@ -1017,7 +1056,9 @@ wantClassDefinition context pos pState # (begin_members, pState) = begin_member_group token pState | begin_members # (class_id, pState) = stringToIdent class_or_member_name IC_Class pState - (members, pState) = wantDefinitions (SetLocalContext context) pState +// RWS ... (members, pState) = wantDefinitions (SetLocalContext context) pState + (members, pState) = wantDefinitions (SetClassOrInstanceDefsContext context) pState +// ... RWS class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }, @@ -1057,7 +1098,8 @@ wantClassDefinition context pos pState = (False, pState) // token is still known: no tokenBack want_class_or_member_name pState - # (token, pState) = nextToken TypeContext pState +// PK # (token, pState) = nextToken TypeContext pState + # (token, pState) = nextToken GeneralContext pState | token == OpenToken # (member_name, pState) = want pState pState = wantToken GeneralContext "class definition" CloseToken pState @@ -1114,9 +1156,11 @@ wantInstanceDeclaration context pi_pos pState pi_members = [], pi_specials = SP_None, pi_pos = pi_pos, pi_generate = True}, pState) // ..AA | isIclContext context - # pState = tokenBack pState // AA - pState = want_begin_group pState - (pi_members, pState) = wantDefinitions context pState + # // PK pState = tokenBack pState // AA + pState = want_begin_group token pState +// RWS ... (pi_members, pState) = wantDefinitions (SetLocalContext context) pState + (pi_members, pState) = wantDefinitions (SetClassOrInstanceDefsContext context) pState +// ... RWS pState = wantEndGroup "instance" pState = (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context, @@ -1142,8 +1186,8 @@ wantInstanceDeclaration context pi_pos pState pi_members = [], pi_specials = specials, pi_pos = pi_pos, pi_generate = False}, pState) where - want_begin_group pState // For JvG layout - # (token, pState) = nextToken TypeContext pState + want_begin_group token pState // For JvG layout + # // (token, pState) = nextToken TypeContext pState PK (token, pState) = case token of SemicolonToken -> nextToken TypeContext pState @@ -1222,7 +1266,7 @@ optionalCoercions pState = (inequals ++ more_inequals, pState) = (inequals, tokenBack pState) want_attr_inequality (IdentToken var_name) pState - | isLowerCaseName var_name + | isLowerCaseName var_name NoUnderscores # (off_ident, pState) = stringToIdent var_name IC_TypeAttr pState (token, pState) = nextToken TypeContext pState | token == LessThanOrEqualToken @@ -1313,7 +1357,7 @@ tryAttributedTypeVar pState // otherwise = (False, no_type_var, tokenBack pState) where - is_type_arg_token (IdentToken t) = isLowerCaseName t + is_type_arg_token (IdentToken t) = isLowerCaseName t NoUnderscores is_type_arg_token DotToken = True is_type_arg_token AsteriskToken = True is_type_arg_token t = False @@ -1341,15 +1385,8 @@ where want_type_rhs context td=:{td_name,td_attribute} EqualToken annot pState # name = td_name.id_name pState = verify_annot_attr annot td_attribute name pState - (exi_vars, pState) = optionalQuantifiedVariables ExistentialQuantifier pState - (token, pState) = nextToken GeneralContext pState -// PK (token, pState) = nextToken TypeContext pState -// PK // MW (token, pState) = nextToken GeneralContext pState - (token, pState) = case token of // Make the ':' optional for now to handle 1.3 files - ColonToken -> nextToken GeneralContext pState -// PK ColonToken -> nextToken TypeContext (parseWarning "type RHS" ":-symbol after extential quantified variable should be removed" pState) -// PK // MW ColonToken -> nextToken GeneralContext (parseWarning "type RHS" ":-symbol after extential quantified variable should be removed" pState) - _ -> (token, pState) + (exi_vars, pState) = optionalExistentialQuantifiedVariables pState + (token, pState) = nextToken GeneralContext pState // should be TypeContext = case token of CurlyOpenToken # (fields, pState) = wantFields td_name pState @@ -1360,8 +1397,7 @@ where | isEmpty exi_vars -> (PD_Erroneous, parseError "Algebraic type" No "no colon, :," pState) -> (PD_Erroneous, parseError "Algebraic type" No "in this version of Clean no colon, :, after quantified variables" pState) -*/ _ - # (condefs, pState) = want_constructor_list exi_vars token pState +*/ _ # (condefs, pState) = want_constructor_list exi_vars token pState td = { td & td_rhs = ConsList condefs } | annot == AN_None -> (PD_Type td, pState) @@ -1404,13 +1440,15 @@ where want_constructor_list :: ![ATypeVar] !Token !ParseState -> (.[ParsedConstructor],ParseState) want_constructor_list exi_vars token pState + # token = basic_type_to_constructor token # (pc_cons_name, pc_cons_prio, pc_cons_pos, pState) = want_cons_name_and_prio token pState (pc_arg_types, pState) = parseList tryBrackAType pState cons = { pc_cons_name = pc_cons_name, pc_arg_types = pc_arg_types, pc_cons_arity = length pc_arg_types, pc_cons_prio = pc_cons_prio, pc_exi_vars = exi_vars, pc_cons_pos = pc_cons_pos} (token, pState) = nextToken TypeContext pState | token == BarToken - # (exi_vars, pState) = optionalQuantifiedVariables ExistentialQuantifier pState +// # (exi_vars, pState) = optionalQuantifiedVariables ExistentialQuantifier pState + # (exi_vars, pState) = optionalExistentialQuantifiedVariables pState // MW (token, pState) = nextToken TypeContext pState (token, pState) = nextToken GeneralContext pState (cons_list, pState) = want_constructor_list exi_vars token pState @@ -1419,12 +1457,12 @@ where = ([cons], tokenBack pState) where want_cons_name_and_prio :: !Token !ParseState -> (Ident, !Priority, !Position, !ParseState) - want_cons_name_and_prio tok=:(IdentToken name) pState + want_cons_name_and_prio tok=:(IdentToken name) pState=:{ps_underscoreModule} # (ident, pState) = stringToIdent name IC_Expression pState (fname, linenr, pState) = getFileAndLineNr pState (token, pState) = nextToken TypeContext pState (prio, pState) = optionalPriority cIsNotInfix token pState - | isLowerCaseName name + | isLowerCaseName name ps_underscoreModule = (ident, prio, LinePos fname linenr, parseError "Algebraic type: constructor definitions" (Yes tok) "constructor name" pState) = (ident, prio, LinePos fname linenr, pState) want_cons_name_and_prio OpenToken pState @@ -1443,6 +1481,16 @@ where want_cons_name_and_prio token pState = (erroneousIdent, NoPrio, NoPos, parseError "Algebraic type: constructor list" (Yes token) "constructor name" pState) + basic_type_to_constructor IntTypeToken = IdentToken "Int" + basic_type_to_constructor CharTypeToken = IdentToken "Char" + basic_type_to_constructor RealTypeToken = IdentToken "Real" + basic_type_to_constructor BoolTypeToken = IdentToken "Bool" + basic_type_to_constructor StringTypeToken = IdentToken "String" + basic_type_to_constructor FileTypeToken = IdentToken "File" + basic_type_to_constructor WorldTypeToken = IdentToken "World" + basic_type_to_constructor DynamicTypeToken = IdentToken "Dynamic" + basic_type_to_constructor token = token + makeAttributeVar name :== { av_name = name, av_info_ptr = nilPtr } optionalAnnotAndAttr :: !ParseState -> (!Bool, !Annotation, !TypeAttribute, !ParseState) @@ -1460,7 +1508,7 @@ where optional_attribute DotToken pState = (True, TA_Anonymous, pState) optional_attribute AsteriskToken pState = (True, TA_Unique, pState) optional_attribute (IdentToken id) pState - | isLowerCaseName id + | isLowerCaseName id NoUnderscores # (token, pState) = nextToken TypeContext pState | ColonToken == token # (ident, pState) = stringToIdent id IC_TypeAttr pState @@ -1489,7 +1537,7 @@ wantFields record_type pState (ps_selector_name, pState) = stringToIdent field_name IC_Selector pState (ps_field_var, pState) = stringToIdent field_name IC_Expression pState pState = wantToken TypeContext "record field" DoubleColonToken pState - (ps_field_type, pState) = want pState + (ps_field_type, pState) = want pState // wantAType = ({ ps_field_name = ps_field_name, ps_selector_name = ps_selector_name, ps_field_type = ps_field_type, ps_field_var = ps_field_var, ps_field_pos = LinePos fname linenr}, pState) @@ -1500,6 +1548,7 @@ makeSymbolType args result context attr_env :== instance want SymbolType where want pState + # (vars , pState) = optionalUniversalQuantifiedVariables pState // PK # (types, pState) = parseList tryBrackAType pState (token, pState) = nextToken TypeContext pState //-->> ("arg types:",types) (tspec, pState) = want_rest_of_symbol_type token types pState @@ -1552,7 +1601,7 @@ where # (token, pState) = nextToken TypeContext pState = case token of IdentToken name - | isLowerCaseName name + | isLowerCaseName name NoUnderscores # (ident, pState) = stringToIdent name IC_Type pState -> (MakeTypeVar ident, pState) -> (MakeTypeVar erroneousIdent, parseError "Type variable" (Yes token) "<type variable>" pState) @@ -1570,8 +1619,8 @@ adjustAttribute attr type pState = (attr, pState) stringToType :: !String !ParseState -> (!Type, !ParseState) -stringToType name pState - | isLowerCaseName name +stringToType name pState=:{ps_underscoreModule} + | isLowerCaseName name ps_underscoreModule = nameToTypeVar name pState # (id, pState) = stringToIdent name IC_Type pState = (TA (MakeNewTypeSymbIdent id 0) [], pState) @@ -1605,13 +1654,18 @@ where wantType :: !ParseState -> (!Type,!ParseState) wantType pState - # (succ, atype, pState) = tryAType False AN_None TA_None pState - (succ2, type, pState) = tryATypeToType atype pState - | succ&&succ2 - = (type, pState) - // otherwise //~ succ - # (token, pState) = nextToken TypeContext pState - = (type, parseError "type" (Yes token) "type" pState) + # (vars, pState) = optionalUniversalQuantifiedVariables pState + | isEmpty vars + # (succ, atype, pState) = tryAType False AN_None TA_None pState + (succ2, type, pState) = tryATypeToType atype pState + | succ&&succ2 + = (type, pState) + // otherwise //~ succ + # (token, pState) = nextToken TypeContext pState + = (type, parseError "type" (Yes token) "type" pState) + // ~(isEmpty vars) + # (type, pState) = wantType pState + = (TFA vars type, pState) wantAType :: !ParseState -> (!AType,!ParseState) wantAType pState @@ -1630,16 +1684,26 @@ tryType pState tryAType :: !Bool !Annotation !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState) tryAType tryAA annot attr pState + # (vars , pState) = optionalUniversalQuantifiedVariables pState # (types, pState) = parseList tryBrackAType pState | isEmpty types - = (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, pState) + | isEmpty vars + = (False, {at_annotation = annot, at_attribute = attr, at_type = TE}, pState) + // otherwise // PK + # (token, pState) = nextToken TypeContext pState + = (False, {at_annotation = annot, at_attribute = attr, at_type = TFA vars TE} + , parseError "annotated type" (Yes token) "type" (tokenBack pState)) # (token, pState) = nextToken TypeContext pState | token == ArrowToken - = tryFunctionType types annot attr pState + # (rtype, pState) = wantAType pState + atype = make_curry_type annot attr types rtype + | isEmpty vars + = ( True, atype, pState) + = ( True, { atype & at_type = TFA vars atype.at_type }, pState) // otherwise # pState = tokenBack pState = tryApplicationType types annot attr pState - +/* PK tryFunctionType :: ![AType] !Annotation !TypeAttribute !ParseState -> (!Bool,!AType,!ParseState) tryFunctionType types annot attr pState # (rtype, pState) = wantAType pState @@ -1647,6 +1711,7 @@ tryFunctionType types annot attr pState , make_curry_type annot attr types rtype , pState ) +*/ where make_curry_type annot attr [t1] res_type = {at_annotation = annot, at_attribute = attr, at_type = t1 --> res_type} @@ -1698,7 +1763,7 @@ trySimpleType annot attr pState trySimpleTypeT :: !Token !Annotation !TypeAttribute !ParseState -> (!Bool, !AType, !ParseState) trySimpleTypeT (IdentToken id) annot attr pState - | isLowerCaseName id + | isLowerCaseName id NoUnderscores # (typevar, pState) = nameToTypeVar id pState (attr, pState) = adjustAttribute attr typevar pState = (True, {at_annotation = annot, at_attribute = attr, at_type = typevar}, pState) @@ -1813,10 +1878,11 @@ determAttr attr1 attr2 type pState wantDynamicType :: !*ParseState -> *(!DynamicType,!*ParseState) wantDynamicType pState - # (type_vars, pState) = optionalQuantifiedVariables UniversalQuantifier pState +// # (type_vars, pState) = optionalQuantifiedVariables UniversalQuantifier pState + # (type_vars, pState) = optionalUniversalQuantifiedVariables pState (type, pState) = want pState = ({ dt_uni_vars = type_vars, dt_type = type, dt_global_vars = [] }, pState) - +/* PK :: QuantifierKind = UniversalQuantifier | ExistentialQuantifier instance == QuantifierKind @@ -1843,7 +1909,46 @@ where = (No, tokenBack (tokenBack pState)) try token pState = (No, tokenBack pState) +*/ +optionalExistentialQuantifiedVariables :: !*ParseState -> *(![ATypeVar],!*ParseState) +optionalExistentialQuantifiedVariables pState + # (token, pState) = nextToken TypeContext pState + = case token of + ExistsToken + # (vars, pState) = wantList "existential quantified variable(s)" tryAttributedFreeTypeVar pState + -> (vars, wantToken TypeContext "Existential Quantified Variables" ColonToken pState) + _ -> ([], tokenBack pState) +optionalUniversalQuantifiedVariables :: !*ParseState -> *(![ATypeVar],!*ParseState) +optionalUniversalQuantifiedVariables pState + # (token, pState) = nextToken TypeContext pState + = case token of + ForAllToken + # (vars, pState) = wantList "universal quantified variable(s)" tryAttributedFreeTypeVar pState + -> (vars, wantToken TypeContext "Universal Quantified Variables" ColonToken pState) + _ -> ([], tokenBack pState) + +tryAttributedFreeTypeVar :: !ParseState -> (Bool,ATypeVar,ParseState) +tryAttributedFreeTypeVar pState + # (token, pState) = nextToken TypeContext pState + = case token of + DotToken +// RWS ... + # (token, pState) = nextToken TypeContext pState +// ... RWS + # (succ,typevar, pState) = tryTypeVarT token pState + | succ + # atypevar = {atv_attribute = TA_Anonymous, atv_annotation = AN_None, atv_variable = typevar} + -> (True,atypevar,pState) + -> (False,abort "no ATypeVar",pState) + _ + # (succ,typevar, pState) = tryTypeVarT token pState + | succ + # atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar} + -> (True,atypevar,pState) + -> (False,abort "no ATypeVar",pState) + +/* PK optionalQuantifiedVariables :: !QuantifierKind !*ParseState -> *(![ATypeVar],!*ParseState) optionalQuantifiedVariables req_quant pState # (token, pState) = nextToken TypeContext pState @@ -1873,7 +1978,7 @@ where # atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar} -> (True,atypevar,pState) -> (False,abort "no ATypeVar",pState) - +*/ tryATypeToType :: !AType !ParseState -> (!Bool, !Type, !ParseState) tryATypeToType atype pState | atype.at_annotation <> AN_None @@ -1925,15 +2030,29 @@ wantRhsExpressionT token pState _ -> (PE_Empty, parseError "RHS expression" (Yes token) "<expression>" pState) wantLhsExpressionT :: !Token !ParseState -> (!ParsedExpr, !ParseState) -wantLhsExpressionT (IdentToken name) pState /* PK: to make a=:C x equivalent to a=:(C x) */ - | isLowerCaseName name +wantLhsExpressionT (IdentToken name) pState=:{ps_underscoreModule} /* PK: to make a=:C x equivalent to a=:(C x) */ + | isLowerCaseName name ps_underscoreModule # (id, pState) = stringToIdent name IC_Expression pState (token, pState) = nextToken FunctionContext pState | token == DefinesColonToken # (token, pState) = nextToken FunctionContext pState + = case token of + IdentToken ident + | ~ (isLowerCaseName ident ps_underscoreModule) + # (constructor, pState) = stringToIdent ident IC_Expression pState + (args, pState) = parseList trySimpleLhsExpression pState + -> (PE_Bound { bind_dst = id, bind_src = combineExpressions (PE_Ident constructor) args }, pState) + _ # (succ, expr, pState) = trySimpleLhsExpressionT token pState + | succ + # expr1 = PE_Bound { bind_dst = id, bind_src = expr } + # (exprs, pState) = parseList trySimpleLhsExpression pState + -> (combineExpressions expr1 exprs, pState) + // not succ + -> (PE_Empty, parseError "LHS expression" (Yes token) "<expression>" pState) +/* # (token, pState) = nextToken FunctionContext pState (expr, pState) = wantLhsExpressionT2 token pState = (PE_Bound { bind_dst = id, bind_src = expr }, pState) - | token == DoubleColonToken +*/ | token == DoubleColonToken # (dyn_type, pState) = wantDynamicType pState = (PE_DynamicPattern (PE_Ident id) dyn_type, pState) // token <> DefinesColonToken // token back and call to wantLhsExpressionT2 would do also. @@ -2030,8 +2149,8 @@ where = ([selector : selectors], pState) = ([selector], tokenBack pState) - want_selector (IdentToken name) pState - | isUpperCaseName name + want_selector (IdentToken name) pState=:{ps_underscoreModule} + | isUpperCaseName name ps_underscoreModule # (field, pState) = want (wantToken FunctionContext "array selector" DotToken pState) (field_id, pState) = stringToIdent field IC_Selector pState (type_id, pState) = stringToIdent name IC_Type pState @@ -2048,9 +2167,8 @@ trySimpleExpression is_pattern pState = trySimpleRhsExpression pState trySimpleExpressionT :: !Token !Bool !ParseState -> (!Bool, !ParsedExpr, !ParseState) - -trySimpleExpressionT (IdentToken name) is_pattern pState - | isLowerCaseName name +trySimpleExpressionT (IdentToken name) is_pattern pState=:{ps_underscoreModule} + | isLowerCaseName name ps_underscoreModule # (id, pState) = stringToIdent name IC_Expression pState | is_pattern # (token, pState) = nextToken FunctionContext pState @@ -2276,8 +2394,10 @@ where (lhs_expr, pState) = wantExpression cIsAPattern pState (token, pState) = nextToken FunctionContext pState | token == LeftArrowToken +//MW3 was: = want_generators IsListGenerator (toLineAndColumn qual_position) lhs_expr pState = want_generators IsListGenerator (toLineAndColumn qual_position) qual_filename lhs_expr pState | token == LeftArrowColonToken +//MW3 was: = want_generators IsArrayGenerator (toLineAndColumn qual_position) lhs_expr pState = want_generators IsArrayGenerator (toLineAndColumn qual_position) qual_filename lhs_expr pState = ({qual_generators = [], qual_filter = No, qual_position = {lc_line = 0, lc_column = 0}, qual_filename = "" }, parseError "comprehension: qualifier" (Yes token) "qualifier(s)" pState) @@ -2437,8 +2557,8 @@ where want_array_elems token pState = ([], parseError "array elements" (Yes token) "<array denotation>" pState) - want_record_pattern (IdentToken ident) pState - | isUpperCaseName ident + want_record_pattern (IdentToken ident) pState=:{ps_underscoreModule} + | isUpperCaseName ident ps_underscoreModule # pState = wantToken FunctionContext "record pattern" BarToken pState (type_id, pState) = stringToIdent ident IC_Type pState (token, pState) = nextToken FunctionContext pState @@ -2448,8 +2568,8 @@ where # (fields, pState) = want_field_assignments cIsAPattern token pState = (PE_Record PE_Empty No fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) - try_type_specification (IdentToken ident) pState - | isUpperCaseName ident || isFunnyIdName ident + try_type_specification (IdentToken ident) pState=:{ps_underscoreModule} + | isUpperCaseName ident ps_underscoreModule || isFunnyIdName ident # (token, pState) = nextToken FunctionContext pState | token == BarToken # (type_id, pState) = stringToIdent ident IC_Type pState @@ -2647,8 +2767,8 @@ where (LocalParsedDefs [index_def, select_def]) (PE_Update (PE_Ident array_id) (reverse [PS_Array (PE_Ident index_id) : initial_selectors]) updated_element), pState) - want_field_assignments is_pattern token=:(IdentToken ident) pState - | isLowerCaseName ident + want_field_assignments is_pattern token=:(IdentToken ident) pState=:{ps_underscoreModule} + | isLowerCaseName ident ps_underscoreModule # (field, pState) = want_field_expression is_pattern ident pState (token, pState) = nextToken FunctionContext pState | token == CommaToken @@ -2667,8 +2787,8 @@ where want_field_assignments is_pattern token pState = ([], parseError "record or array field assignments" (Yes token) "field name" pState) - try_field_assignment (IdentToken ident) pState - | isLowerCaseName ident + try_field_assignment (IdentToken ident) pState=:{ps_underscoreModule} + | isLowerCaseName ident ps_underscoreModule # (token, pState) = nextToken FunctionContext pState | token == EqualToken # (field_expr, pState) = wantExpression cIsNotAPattern pState @@ -2765,6 +2885,16 @@ skipToEndOfDefinition pState // SemicolonToken -> (token, pState) // might be useful in non layout mode. _ -> skipToEndOfDefinition pState -->> (token,"skipped") +wantEndCodeRhs :: !ParseState -> ParseState +wantEndCodeRhs pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + = wantEndOfDefinition "code rhs" pState + # (token, pState) = nextToken FunctionContext pState + | token == SemicolonToken + = pState + = tokenBack pState + wantEndOfDefinition :: String !ParseState -> ParseState wantEndOfDefinition msg pState=:{ps_skipping} | ps_skipping @@ -2826,6 +2956,7 @@ wantEndRootExpression pState=:{ps_skipping} -> case token of NewDefinitionToken -> pState _ -> tokenBack pState + CurlyCloseToken -> tokenBack pState // PK token -> wantEndOfDefinition "root expression" (parseError "root expression" (Yes token) "end of root expression" pState) // otherwise // ~ ss_useLayout = case token of @@ -2934,6 +3065,7 @@ wantEndCase pState CommaToken -> tokenBack (appScanState dropOffsidePosition pState) ColonToken -> tokenBack (appScanState dropOffsidePosition pState) InToken -> tokenBack (appScanState dropOffsidePosition pState) + CurlyCloseToken -> tokenBack (appScanState dropOffsidePosition pState) // PK _ -> parseError "case expression" (Yes token) "end of case with layout" pState // ~ ss_useLayout | token == CurlyCloseToken @@ -3024,7 +3156,7 @@ parseWarning act msg pState = pState | otherwise // not pState.ps_skipping # (pos,pState) = getPosition pState - (filename,pState=:{ps_error={pea_file,pea_ok}}) = accScanState getFilename pState + (filename,pState=:{ps_error={pea_file,pea_ok}}) = getFilename pState pea_file = pea_file <<< "Parse warning [" <<< filename <<< "," @@ -3042,7 +3174,7 @@ parseError act opt_token msg pState = pState | otherwise // not pState.ps_skipping # (pos,pState) = getPosition pState - (filename,pState=:{ps_error={pea_file}}) = accScanState getFilename pState + (filename,pState=:{ps_error={pea_file}}) = getFilename pState pea_file = pea_file <<< "Parse error [" <<< filename <<< "," @@ -3102,19 +3234,19 @@ tryTypeVar pState tryTypeVarT :: !Token !ParseState -> (!Bool, TypeVar, !ParseState) tryTypeVarT (IdentToken name) pState - | isUpperCaseName name - = (False, abort "no UC ident", tokenBack pState) + | isLowerCaseName name NoUnderscores # (id, pState) = stringToIdent name IC_Type pState = (True, MakeTypeVar id, pState) + = (False, abort "no UC ident", tokenBack pState) tryTypeVarT token pState = (False, abort "no type variable", tokenBack pState) wantUpperCaseName :: !String !ParseState -> (!String, !ParseState) -wantUpperCaseName string pState +wantUpperCaseName string pState=:{ps_underscoreModule} # (token, pState) = nextToken GeneralContext pState = case token of IdentToken name - | isUpperCaseName name + | isUpperCaseName name ps_underscoreModule -> (name, pState) _ -> ("dummy uppercase name", parseError string (Yes token) "upper case ident" pState) /* @@ -3128,60 +3260,25 @@ wantNonUpperCaseName string pState _ -> ("dummy non uppercase name", parseError string (Yes token) "non upper case ident" pState) */ wantLowerCaseName :: !String !ParseState -> (!String, !ParseState) -wantLowerCaseName string pState +wantLowerCaseName string pState=:{ps_underscoreModule} # (token, pState) = nextToken GeneralContext pState = case token of IdentToken name - | isLowerCaseName name + | isLowerCaseName name ps_underscoreModule -> (name, pState) _ -> ("dummy lowercase name", parseError string (Yes token) "lower case ident" pState) wantConstructorName :: !String !ParseState -> (!String, !ParseState) -wantConstructorName string pState +wantConstructorName string pState=:{ps_underscoreModule} # (token, pState) = nextToken GeneralContext pState = case token of IdentToken name - | isUpperCaseName name || isFunnyIdName name + | isUpperCaseName name ps_underscoreModule || isFunnyIdName name -> (name, pState) _ - -> ("", parseError string (Yes token) "upper case or funny ident" pState) + -> ("", parseError string (Yes token) "upper case ident" pState) -/* -isTypeStartToken :: ! Token -> Bool -isTypeStartToken (IdentToken id) = True -isTypeStartToken SquareOpenToken = True -isTypeStartToken CurlyOpenToken = True -isTypeStartToken OpenToken = True -isTypeStartToken IntTypeToken = True -isTypeStartToken CharTypeToken = True -isTypeStartToken BoolTypeToken = True -isTypeStartToken VoidTypeToken = True -isTypeStartToken StringTypeToken = True -isTypeStartToken RealTypeToken = True -isTypeStartToken DynamicTypeToken = True -isTypeStartToken ExclamationToken = True -isTypeStartToken DotToken = True -isTypeStartToken AsteriskToken = True -isTypeStartToken token = False - -isIdentToken :: ! Token -> Bool -isIdentToken (IdentToken id) = True -isIdentToken t = False - -isTypeDefToken :: ! Token -> Bool -isTypeDefToken DoubleColonToken = True -isTypeDefToken token = False - -isDefinesTypeToken :: !Token -> Bool -isDefinesTypeToken EqualToken = True -isDefinesTypeToken ColonDefinesToken = True -isDefinesTypeToken token = False - -isUpperCaseIdent :: ! Token -> Bool -isUpperCaseIdent (IdentToken name) = isUpperCaseName name -isUpperCaseIdent token = False -*/ isDefinesFieldToken :: ! Token -> Bool isDefinesFieldToken EqualToken = True isDefinesFieldToken CurlyCloseToken = True diff --git a/frontend/scanner.dcl b/frontend/scanner.dcl index 6ec95bf..d001d0e 100644 --- a/frontend/scanner.dcl +++ b/frontend/scanner.dcl @@ -103,7 +103,9 @@ instance <<< FilePosition | GenericOpenToken // {| | GenericCloseToken // |} - + | ExistsToken // E. + | ForAllToken // A. + :: Context = GeneralContext | TypeContext diff --git a/frontend/scanner.icl b/frontend/scanner.icl index 78c8c32..25ebe79 100644 --- a/frontend/scanner.icl +++ b/frontend/scanner.icl @@ -57,7 +57,7 @@ instance getPosition ScanState where getPosition (ScanState scan_state) # (position,scan_state) = getPosition scan_state - = (position,ScanState scan_state) + = (position,ScanState scan_state) :: * RScanState = { ss_input :: ScanInput @@ -67,7 +67,7 @@ where } :: * ScanInput - = Input Input + = Input Input | PushedToken LongToken ScanInput :: * Input = @@ -79,9 +79,7 @@ where :: * InputStream = InFile * File - | OldLine !Int !{#Char} !InputStream -// | OldChar ! Char ! FilePosition ! InputStream -// | OldChars ! *[Char] ! InputStream + | OldLine !Int !{#Char} !InputStream :: FilePosition = { fp_line :: ! Int @@ -90,9 +88,9 @@ where :: LongToken = { lt_position :: ! FilePosition // Start position of this token + , lt_index :: ! Int // The index in the current line , lt_token :: ! Token // The token itself -// , lt_chars :: ! [Char] // The chars in this token -// , lt_context :: ! Context // The context of the scanning of this token + , lt_context :: ! Context // The context of the token } :: Buffer x @@ -189,6 +187,9 @@ where | GenericOpenToken // {| | GenericCloseToken // |} + | ExistsToken // E. + | ForAllToken // A. + :: Context = GeneralContext @@ -215,7 +216,6 @@ where ScanErrIllegal :== "illegal char in input" ScanErrCharErr :== "wrong character denotation" ScanErrNLString :== "new line in string denotation" -ScanErrWild :== "ident should not start with _" class getFilename state :: !*state -> (!String,!*state) @@ -261,11 +261,52 @@ where instance getCharPosition Input where getCharPosition input=:{inp_pos} = (inp_pos, input) +class getIndex input :: !*input -> (!Int, !*input) + +instance getIndex InputStream +where + getIndex input=:(OldLine index _ _) = (index-1,input) + getIndex input = (0,input) + +instance getIndex Input +where + getIndex input=:{inp_stream=stream} + # (index,stream) = getIndex stream + = (index,{input & inp_stream=stream}) + class nextToken state :: !Context !*state -> (!Token, !*state) instance nextToken RScanState where -// nextToken newContext {ss_input=PushedToken token=:{lt_position,lt_token} rest,ss_tokenBuffer,ss_offsides,ss_useLayout} +/* RWS ... rolled back from Pieter's version + + this fixes the bug funny_id_after_type, but failes on + g = let x = 1 in x + + nextToken newContext (scanState=:{ss_input=inp=:PushedToken token=:{lt_position,lt_token,lt_context,lt_index} rest_inp,ss_tokenBuffer,ss_offsides,ss_useLayout}) + | lt_context == newContext || notContextDependent lt_token + = ( lt_token + , { scanState & ss_input = rest_inp , ss_tokenBuffer = store token ss_tokenBuffer } + ) //-->> ("nextToken: pushed token", lt_token) + = token_back rest_inp + where + token_back input=:(Input {inp_pos,inp_stream=OldLine _ string stream,inp_filename,inp_tabsize}) // one old token in wrong context. + | inp_pos.fp_line == lt_position.fp_line + # old_input + = { inp_stream = OldLine lt_index string stream + , inp_filename = inp_filename + , inp_pos = lt_position + , inp_tabsize = inp_tabsize + } -->> ("token_back in input", lt_token) + = nextToken newContext {ss_input = Input old_input, ss_offsides=ss_offsides, ss_useLayout=ss_useLayout, ss_tokenBuffer=ss_tokenBuffer} + = ( lt_token + , {ss_input = input , ss_tokenBuffer = store token ss_tokenBuffer, ss_offsides=ss_offsides, ss_useLayout=ss_useLayout} + ) -->> ("unable to push token_back in input; line is lost",(inp_pos.fp_line,lt_position.fp_line), lt_token) + token_back input + = ( lt_token + , {ss_input = input , ss_tokenBuffer = store token ss_tokenBuffer, ss_offsides=ss_offsides, ss_useLayout=ss_useLayout} + ) -->> ("unable to push token_back in input; generated token", lt_token) +*/ nextToken newContext scanState=:{ss_input=input=:PushedToken token=:{lt_position,lt_token/*,lt_context*/} rest,ss_tokenBuffer} // | lt_context == newContext || ~ (contextDependent lt_token) || isGeneratedToken lt_token @@ -284,17 +325,20 @@ where & inp_stream = OldToken token inp_stream } //-->> ("pushTokensBack",token) */ +// ... RWS + nextToken context {ss_input=Input inp,ss_tokenBuffer,ss_offsides,ss_useLayout} # (error, c, inp) = SkipWhites inp + (pos, inp) = inp!inp_pos + (index,inp) = getIndex inp = case error of Yes string - #! (pos, inp) = inp!inp_pos -> ( ErrorToken string , { ss_tokenBuffer = store { lt_position = pos + , lt_index = index , lt_token = ErrorToken string - // , lt_chars = [] - // , lt_context = context + , lt_context = context } ss_tokenBuffer, ss_input=Input inp, @@ -303,86 +347,36 @@ where ) -->> ("Error token generated",string) no # (eof, inp) = EndOfInput inp - #! (pos, inp) = inp!inp_pos | eof && c == NewLineChar # newToken = EndOfFileToken - -> checkOffside pos newToken + -> checkOffside pos index newToken { ss_tokenBuffer = store { lt_position = pos + , lt_index = index , lt_token = newToken - // , lt_chars = [] - // , lt_context = context + , lt_context = context } ss_tokenBuffer , ss_input = Input inp, ss_offsides=ss_offsides, ss_useLayout=ss_useLayout } // -->> ("Token", EndOfFileToken,pos) // otherwise // ~ (eof && c == NewLineChar) - # (token, inp) = Scan c inp /* {inp & inp_curToken = [c]}*/ context - // # (chars, inp) = inp!inp_curToken - -> checkOffside pos token + # (token, inp) = Scan c inp context + -> checkOffside pos index token { ss_input = Input inp , ss_tokenBuffer = store { lt_position = pos + , lt_index = index , lt_token = token - // , lt_chars = reverse chars - // , lt_context = context + , lt_context = context } ss_tokenBuffer, ss_offsides=ss_offsides, ss_useLayout=ss_useLayout } //-->> (token,pos) - -/* - #! (pos, inp) = inp!inp_pos - #! scanState = {scanState & ss_input = Input inp } -// #! scanState = {ss_input=Input inp, ss_offsides=ss_offsides, ss_useLayout=ss_useLayout, ss_tokenBuffer=ss_tokenBuffer } - = case error of - Yes string - -> ( ErrorToken string - , { scanState - & ss_tokenBuffer = store - { lt_position = pos - , lt_token = ErrorToken string - // , lt_chars = [] - // , lt_context = context - } - scanState.ss_tokenBuffer - } - ) -->> ("Error token generated",string) - no - -> determineToken c pos scanState where - determineToken c pos scanState=:{ss_input=Input inp} - # (eof, inp) = EndOfInput inp - // #! (pos, inp) = inp!inp_pos - | eof && c == NewLineChar - # newToken = EndOfFileToken - = checkOffside pos newToken - { scanState - & ss_tokenBuffer = store - { lt_position = pos - , lt_token = newToken - // , lt_chars = [] - // , lt_context = context - } - scanState.ss_tokenBuffer - , ss_input = Input inp - } // -->> ("Token", EndOfFileToken,pos) - // otherwise // ~ (eof && c == NewLineChar) - # (token, inp) = Scan c inp /* {inp & inp_curToken = [c]}*/ context - // # (chars, inp) = inp!inp_curToken - = checkOffside pos token - { scanState - & ss_input = Input inp - , ss_tokenBuffer = store - { lt_position = pos - , lt_token = token - // , lt_chars = reverse chars - // , lt_context = context - } - ss_tokenBuffer - } //-->> (token,pos) -*/ + mark_position {inp_stream=input=:(OldLine i _ _),inp_filename,inp_pos,inp_tabsize} + = {inp_stream=input, inp_filename=inp_filename, inp_pos={inp_pos &fp_col=1}, inp_tabsize=inp_tabsize} + mark_poistion input = input nextToken _ _ = abort "Scanner: Error in nextToken" class tokenBack state :: !*state -> !*state @@ -410,26 +404,24 @@ class insertToken state :: !Token !Context !*state -> *state instance insertToken RScanState where insertToken t c scanState -/* # chars = if (isGeneratedToken t) - [] - (fromString (toString t)) -*/ # (pos, scanState=:{ss_input}) = getPosition scanState + # (pos, scanState=:{ss_input}) = getPosition scanState = { scanState & ss_input = PushedToken { lt_position = pos + , lt_index = pos.fp_col , lt_token = t - // , lt_chars = chars - // , lt_context = c + , lt_context = c } ss_input } -/* -isGeneratedToken :: !Token -> Bool -isGeneratedToken NewDefinitionToken = True -isGeneratedToken EndGroupToken = True -isGeneratedToken (CodeBlockToken _) = True -isGeneratedToken _ = False -*/ + +notContextDependent :: !Token -> Bool +notContextDependent NewDefinitionToken = True +notContextDependent EndGroupToken = True +notContextDependent EndOfFileToken = True +notContextDependent (ErrorToken _) = True +notContextDependent (CodeBlockToken _) = True +notContextDependent _ = False class replaceToken state :: !Token !*state -> *state @@ -447,7 +439,7 @@ SkipWhites {inp_stream=OldLine i line stream,inp_pos={fp_line,fp_col},inp_tabsiz = skip_whites_in_line i fp_col fp_line line inp_tabsize stream inp_filename SkipWhites input # (eof, c, input) = ReadChar input - | eof = (No, NewLineChar, input) // -->> "EOF in SkipWhites" + | eof = (No, NewLineChar, input) | IsWhiteSpace c = SkipWhites input = TryScanComment c input @@ -490,7 +482,6 @@ TryScanComment c1=:'/' input (No,input) -> SkipWhites input (er,input) -> (er, c1, input) _ -> (No, c1, charBack input) - TryScanComment c input = (No, c, input) @@ -566,7 +557,6 @@ SkipToEndOfLine input = SkipToEndOfLine input Scan :: !Char !Input !Context -> (!Token, !Input) - Scan '(' input co = (OpenToken, input) Scan ')' input co = (CloseToken, input) Scan '{' input CodeContext = ScanCodeBlock input @@ -607,7 +597,7 @@ Scan c0=:'&' input co | eof = (AndToken, input) | isSpecialChar c1 = ScanOperator 1 input [c1, c0] co = (AndToken, charBack input) -Scan c0=:'.' input co +Scan c0=:'.' input co // PK incorrect ? = case co of TypeContext -> (DotToken, input) @@ -628,6 +618,23 @@ Scan '\\' input co | eof = (BackSlashToken, input) | c == '\\' = (DoubleBackSlashToken, input) = (BackSlashToken, charBack input) +Scan c0=:'_' input=:{inp_stream=OldLine i line stream,inp_pos} co //PK .. + # size = size line + # end_i = scan_underscores i size line + with + scan_underscores :: !Int !Int !{#Char} -> Int + scan_underscores i size line + | i<size && line.[i] == '_' + = scan_underscores (i+1) size line + = i + | end_i<size && IsIdentChar line.[end_i] co + = ScanIdentFast (end_i-i+1) {input & inp_stream=OldLine end_i line stream} co + | end_i==i + = (WildCardToken, input) + # pos = {inp_pos & fp_col = inp_pos.fp_col + (end_i-i)} + # input = {input & inp_stream=OldLine end_i line stream,inp_pos=pos} + = (ErrorToken (line % (i-1,end_i-1)+++" is an illegal token"),input) +/* PK Scan c0=:'_' input co # (eof, c1, input) = ReadNormalChar input | eof = (WildCardToken, input) @@ -636,6 +643,7 @@ Scan c0=:'_' input co = ScanIdentFast 2 input co // | isSpecialChar c1 = ScanOperator 1 input [c1, c0] co = (WildCardToken, charBack input) +*/ Scan c0=:'<' input TypeContext # (eof, c1, input) = ReadNormalChar input | eof = (ErrorToken "< just before end of file in TypeContext", input) @@ -677,12 +685,8 @@ Scan c0=:'+' input co # (eof, c1, input) = ReadNormalChar input | eof = (IdentToken "+", input) -// # new = newExp input.inp_charBuffer -// | IsDigit c1 && new = ScanNumeral 1 input [c1,c0] - | IsDigit c1 && new_exp_char previous_char = ScanNumeral 1 input [c1,c0] - = ScanOperator 0 (charBack input) [c0] co Scan c0=:'=' input co # (eof, c, input) = ReadNormalChar input @@ -703,8 +707,21 @@ Scan c0=:':' input co | c2 == '=' = (ColonDefinesToken, input) = ScanOperator 1 (charBack input) [c1, c0] co Scan c0=:'\'' input co = ScanChar input [c0] -Scan c0=:'\"' input co = ScanString 0 input [c0] - +Scan c0=:'\"' input co = ScanString 0 [c0] input +// PK .. +Scan 'E' input TypeContext + # (eof,c1,input) = ReadNormalChar input + | eof = (IdentToken "E", input) + | c1 == '.' = (ExistsToken, input) +// = ScanIdent 1 (charBack input) TypeContext + = ScanIdentFast 1 (charBack input) TypeContext +Scan 'A' input TypeContext + # (eof,c1,input) = ReadNormalChar input + | eof = (IdentToken "A", input) + | c1 == '.' = (ForAllToken, input) +// = ScanIdent 1 (charBack input) TypeContext + = ScanIdentFast 1 (charBack input) TypeContext +// .. PK Scan c input co | IsDigit c = ScanNumeral 0 input [c] | IsIdentChar c co @@ -712,18 +729,11 @@ Scan c input co // = ScanIdent 0 input [c] co | isSpecialChar c = ScanOperator 0 input [c] co = (ErrorToken ScanErrIllegal, input) -/* -newExp :: !(Buffer (Char,FilePosition)) -> Bool -newExp buffer - # (c, _) = case buffer of - Buffer3 _ _ cp -> cp - _ -> (' ',{fp_line=0,fp_col=0}) - = new_exp_char c -where -*/ + new_exp_char ',' = True new_exp_char '[' = True new_exp_char '(' = True +new_exp_char '{' = True new_exp_char '/' = True // to handle end of comment symbol: */ new_exp_char c = isSpace c @@ -739,18 +749,11 @@ ScanIdentFast n input=:{inp_stream=OldLine i line stream,inp_pos} co # pos = {inp_pos & fp_col = inp_pos.fp_col + (end_i-i)} # input = {input & inp_stream=OldLine end_i line stream,inp_pos=pos} = CheckReserved co (line % (i-n,end_i-1)) input -/* -ScanIdent :: !Int !Input ![Char] !Context -> (!Token, !Input) -ScanIdent n input token co - # (eof, c, input) = ReadNormalChar input - | eof = CheckReserved co (revCharListToString n token) input - | IsIdentChar c co = ScanIdent (n + 1) input [c:token] co - = CheckReserved co (revCharListToString n token) (charBack input) -*/ + ScanOperator :: !Int !Input ![Char] !Context -> (!Token, !Input) ScanOperator n input token co # (eof, c, input) = ReadNormalChar input - | eof = (IdentToken (revCharListToString n token), input) + | eof = CheckReserved co (revCharListToString n token) input | isSpecialChar c = ScanOperator (n + 1) input [c:token] co = CheckReserved co (revCharListToString n token) (charBack input) @@ -930,8 +933,8 @@ ScanFraction n input chars # (eof, c, input) = ReadNormalChar input | eof = (RealToken (revCharListToString n chars), input) | c == 'E' = case chars of - [c:_] | IsDigit c -> ScanExponentSign (n + 1) input ['E':chars] /* Sjaak, was [c:chars] */ - _ -> ScanExponentSign (n + 2) input ['E','0':chars] /* Sjaak, idem */ + [c:_] | IsDigit c -> ScanExponentSign (n + 1) input ['E':chars] + _ -> ScanExponentSign (n + 2) input ['E','0':chars] | IsDigit c = ScanFraction (n + 1) input [c:chars] = case chars of [c:_] | IsDigit c -> (RealToken (revCharListToString n chars), charBack input) @@ -973,65 +976,57 @@ ScanChar input chars # (eof, c, input) = ReadNormalChar input | eof = (ErrorToken "End of file inside Char denotation", input) | '\\' <> c = ScanEndOfChar 1 [c: chars] input - # (chars, n, input) = ScanBSChar 0 chars input - = ScanEndOfChar n chars input + = ScanBSChar 0 chars input ScanEndOfChar -ScanBSChar :: !Int ![Char] !Input -> (![Char], !Int, !Input) -ScanBSChar n chars input +ScanBSChar :: !Int ![Char] !Input (!Int ![Char] !Input -> (!Token, !Input)) -> (!Token, !Input) +ScanBSChar n chars input cont # (eof, c, input) = ReadNormalChar input - | eof = (chars, n, input) + | eof = cont n chars input = case c of - 'n' -> (['n','\\':chars], n + 2, input) - 'r' -> (['r','\\':chars], n + 2, input) - 'f' -> (['f','\\':chars], n + 2, input) -// RWS ... 'b' -> (['b','\\':chars], n + 2, input) - 'b' -> to_chars '\b' n input -// ... RWS - 't' -> (['t','\\':chars], n + 2, input) -// RWS ... 'v' -> (['v','\\':chars], n + 2, input) - 'v' -> to_chars '\v' n input -// ... RWS - '\\' -> (['\\','\\':chars], n + 2, input) - '"' -> (['"' ,'\\':chars], n + 2, input) - '\'' -> (['\'','\\':chars], n + 2, input) - 'x' # (cc,input) = ScanNumChar Hex isHexDigit 2 0 input // max 2 characters - -> to_chars cc n input - 'd' # (cc,input) = ScanNumChar Dec isDigit 3 0 input // max 3 characters - -> to_chars cc n input + 'n' -> cont (n+2) ['n','\\':chars] input // (['n','\\':chars], n + 2, input) + 'r' -> cont (n+2) ['r','\\':chars] input // (['r','\\':chars], n + 2, input) + 'f' -> cont (n+2) ['f','\\':chars] input // (['f','\\':chars], n + 2, input) + 'b' -> to_chars '\b' input + 't' -> cont (n+2) ['t','\\':chars] input // (['t','\\':chars], n + 2, input) + 'v' -> to_chars '\v' input + '\\' -> cont (n+2) ['\\','\\':chars] input // (['\\','\\':chars], n + 2, input) + '"' -> cont (n+2) ['"','\\':chars] input // (['"' ,'\\':chars], n + 2, input) + '\'' -> cont (n+2) ['\'','\\':chars] input // (['\'','\\':chars], n + 2, input) + 'x' -> ScanNumChar Hex isHexDigit 2 0 input // max 2 characters + 'X' -> ScanNumChar Hex isHexDigit 2 0 input // max 2 characters + 'd' -> ScanNumChar Dec isDigit 3 0 input // max 3 characters + 'D' -> ScanNumChar Dec isDigit 3 0 input // max 3 characters + '0' -> ScanNumChar Oct IsOct 3 0 input // max 3 characters c | IsOct c - # (cc,input) = ScanNumChar Oct IsOct 2 (digitToInt c) input // max 3 characters, including current - -> to_chars cc n input - -> ([c:chars], n + 1, input) + -> ScanNumChar Oct IsOct 2 (digitToInt c) input // max 2 more characters, 3 including current + -> cont (n+1) [c:chars] input where ScanNumChar base valid 0 acc input - = (acc, input) + = to_chars acc input ScanNumChar base valid n acc input # (eof, c, input) = ReadNormalChar input - | eof = (acc, input) -// RWS ... | valid c = ScanNumChar base valid (n-1) (base*acc+digitToInt c) input + | eof = to_chars acc input | valid c = ScanNumChar base valid (n-1) (base*acc+hexDigitToInt c) input -// ... RWS - = (acc, charBack input) + = to_chars acc (charBack input) Hex = 16 Oct = 8 Dec = 10 - to_chars cc n input + to_chars cc input + | toInt cc > 255 + = (ErrorToken "invalid char, value > 255", input) = case toChar cc of - '\n' -> (['n','\\':chars], n + 2, input) - '\r' -> (['r','\\':chars], n + 2, input) - '\f' -> (['f','\\':chars], n + 2, input) -// RWS \b not accepted in abc '\b' -> (['b','\\':chars], n + 2, input) - '\t' -> (['t','\\':chars], n + 2, input) -// RWS \v not accepted in abc '\v' -> (['v','\\':chars], n + 2, input) - '\\' -> (['\\','\\':chars], n + 2, input) - '"' -> (['"' ,'\\':chars], n + 2, input) - '\'' -> (['\'','\\':chars], n + 2, input) - -// RWS ... + '\n' -> cont (n+2) ['n','\\':chars] input // (['n','\\':chars], n + 2, input) + '\r' -> cont (n+2) ['r','\\':chars] input // (['r','\\':chars], n + 2, input) + '\f' -> cont (n+2) ['f','\\':chars] input // (['f','\\':chars], n + 2, input) + '\t' -> cont (n+2) ['t','\\':chars] input // (['t','\\':chars], n + 2, input) + '\\' -> cont (n+2) ['\\','\\':chars] input // (['\\','\\':chars], n + 2, input) + '"' -> cont (n+2) ['"','\\':chars] input // (['"' ,'\\':chars], n + 2, input) + '\'' -> cont (n+2) ['\'','\\':chars] input // (['\'','\\':chars], n + 2, input) + // '\b' and '\v' not accepted in abc // escape non-printable characters c | not (IsPrint c) - -> (more_chars, n+4, input) + -> cont (n+4) more_chars input with more_chars = [ toChar (48 + (toInt c bitand 7)) @@ -1040,8 +1035,7 @@ where , '\\' : chars ] -// ... RWS - c -> ([c:chars], n + 1, input) + c -> cont (n+1) [c:chars] input ScanEndOfChar :: !Int ![Char] !Input -> (!Token, !Input) ScanEndOfChar n chars input @@ -1058,21 +1052,19 @@ ScanCharList n chars input = case c of '\'' # charList = revCharListToString n chars % (1,n) // without '\'' -> (CharListToken charList, input) - '\\' # (chars, n, input) = ScanBSChar n chars input - -> ScanCharList n chars input + '\\' -> ScanBSChar n chars input ScanCharList NewLineChar -> (ErrorToken "newline in char list", input) _ -> ScanCharList (n+1) [c:chars] input -ScanString :: !Int !Input ![Char] -> (!Token, !Input) -ScanString n input chars +ScanString :: !Int ![Char] !Input -> (!Token, !Input) +ScanString n chars input # (eof, c, input) = ReadChar input | eof = (ErrorToken "End of file inside String denotation", input) = case c of - '\\' # (chars, n, input) = ScanBSChar n chars input - -> ScanString n input chars + '\\' -> ScanBSChar n chars input ScanString '\"' -> (StringToken (revCharListToString (n + 1) [c:chars]), input) NewLineChar -> (ErrorToken ScanErrNLString, input) - _ -> ScanString (n + 1) input [c:chars] + _ -> ScanString (n + 1) [c:chars] input /* some predicates on tokens @@ -1096,12 +1088,6 @@ isEndGroupToken EndGroupToken = True isEndGroupToken CurlyCloseToken = True isEndGroupToken token = False /* -contextDependent :: !Token -> Bool -contextDependent HashToken = True -//contextDependent (SeqLetToken _) = True // Do not do this XXXXXX -contextDependent _ = False -*/ -/* character functions */ @@ -1113,28 +1099,9 @@ IsDigit c :== isDigit c IsOct c :== '0' <= c && c <= '7' -// RWS ... -//IsDigit :: Char -> Bool -// this assumes all 8 bit characters (>127) are not printable +// IsPrint assumes all 8 bit characters (>127) are not printable IsPrint c :== c >= ' ' && c <= '~' -// ... RWS - -//IsHex c :== isDigit c || ('A' <= c && c <= 'F') || ('a' <= c && c <= 'f') -/* -isHexDigit :: !Char -> Bool // Defined in StdChar -isHexDigit c - | isDigit c - = True - | c < 'g' - = c >= 'a' - | c < 'G' - = c >= 'A' - = False -*/ -//IsIdentChar :: !Char !Context -> Bool -//IsIdentChar c co -// :== isAlphanum c || c == '_' || c == '`' || (c == '^' && co == TypeContext) hexDigitToInt :: !Char -> Int hexDigitToInt 'a' = 10 @@ -1263,145 +1230,8 @@ ReadChar {inp_stream = InFile file, inp_pos, inp_tabsize, inp_filename} inp_tabsize=inp_tabsize,inp_filename=inp_filename,inp_pos=inp_pos, inp_stream = OldLine 0 s (InFile file) } -/* - // otherwise // s <> "" - // # chars = fromString s - # chars = string_to_list s - = ReadChar { - // input & - inp_tabsize=inp_tabsize,inp_filename=inp_filename,inp_pos=inp_pos, - inp_stream = OldChars chars (InFile file) - } -*/ - - /* - #! (eof, file) = fend file // old, too slow - | eof - # c = NewLineChar - pos = NextPos c inp_pos inp_tabsize - = ( eof - , c - , { input - & inp_stream = InFile file - , inp_pos = pos - } - ) // -->> ("EOF in " + input.inp_filename + " found in ReadChar") - #! (ok, c, file) = freadc file - | ok - # pos = NextPos c inp_pos inp_tabsize - (c,input`) = correctNewline c pos inp_tabsize (InFile file) - = ( False - , c - , { input - & inp_stream = input` - , inp_pos = pos - } - ) - = abort "ReadChar failure" - */ -/* - ReadChar input=:{inp_stream = InFile file, inp_pos, inp_tabsize, inp_filename} - #! (ok, c, file) = freadc file - | ok - | c==LFChar || c==CRChar || c=='\t' - # pos = NextPos c inp_pos inp_tabsize - (c,input`) = correctNewline c pos inp_tabsize (InFile file) - = ( False - , c - , { - // input & - inp_filename=inp_filename,inp_tabsize=inp_tabsize, - inp_stream = input` - , inp_pos = pos - } - ) - # pos = {inp_pos & fp_col = inp_pos.fp_col + 1} - = ( False - , c - , { - // input & - inp_filename=inp_filename,inp_tabsize=inp_tabsize, - inp_stream = InFile file - , inp_pos = pos - } - ) - # c = NewLineChar - pos = NextPos c inp_pos inp_tabsize - = ( True - , c - , { - // input & - inp_filename=inp_filename,inp_tabsize=inp_tabsize, - inp_stream = InFile file - , inp_pos = pos - } - ) - //ReadChar input =: {inp_stream = OldChars [c] stream, inp_pos, inp_tabsize, /*, inp_curToken*/} - ReadChar {inp_stream = OldChars [c] stream, inp_pos, inp_tabsize, inp_filename} - # pos = NextPos c inp_pos inp_tabsize - (c,input`) = correctNewline_OldChars c pos inp_tabsize[] stream - = ( False - , c - , { - // input & - inp_filename=inp_filename,inp_tabsize=inp_tabsize, - inp_stream = input` - , inp_pos = pos - } - ) - //ReadChar input =: {inp_stream = OldChars [c:rest] stream,inp_pos,inp_tabsize} - ReadChar {inp_stream = OldChars [c:rest] stream,inp_pos,inp_tabsize,inp_filename} - | c==LFChar || c==CRChar || c=='\t' - # pos = NextPos c inp_pos inp_tabsize - (c,input`) = correctNewline_OldChars c pos inp_tabsize rest stream - = ( False - , c - , { - // input & - inp_filename=inp_filename,inp_tabsize=inp_tabsize, - inp_stream = input` - , inp_pos = pos - } - ) - # pos = {inp_pos & fp_col = inp_pos.fp_col + 1} - = ( False - , c - , { - // input & - inp_filename=inp_filename,inp_tabsize=inp_tabsize, - inp_stream = OldChars rest stream - , inp_pos = pos - } - ) - - // ReadChar input =: {inp_stream = OldChars [] stream, inp_pos} - ReadChar {inp_stream = OldChars [] stream, inp_pos,inp_filename,inp_tabsize} - // = ReadChar {input & inp_stream = stream} - = ReadChar {inp_filename=inp_filename,inp_tabsize=inp_tabsize,inp_pos=inp_pos, - inp_stream = stream} -*/ - -/* - //ReadChar input =: {inp_stream = OldChar c pos oldfile} - ReadChar {inp_stream = OldChar c pos oldfile, inp_tabsize,inp_filename} - = ( False - , c - , { - // input & - inp_filename=inp_filename,inp_tabsize=inp_tabsize, - inp_stream = oldfile - , inp_pos = pos - } - ) -*/ ReadLine :: !Input -> (!String, !Input) -/* -ReadLine input=:{inp_stream = OldChars cs oldfile, inp_pos} - # input = {input & inp_stream = oldfile, inp_pos = NextPos CRChar inp_pos 0} - | isEmpty cs = ReadLine input - | otherwise = (toString cs, input) -*/ ReadLine input=:{inp_stream = OldLine i line oldfile, inp_pos} # input = {input & inp_stream = oldfile, inp_pos = NextPos CRChar inp_pos 0} | i<size line @@ -1415,13 +1245,6 @@ ReadLine input=:{inp_stream = InFile infile,inp_pos} //MW8 was # (l, file ) = freadline file # (l, file ) = (SwitchPreprocessor freadPreprocessedLine freadline) file = (l, {input & inp_stream = InFile file, inp_pos = NextPos CRChar inp_pos 0}) -/* - ReadLine input=:{inp_stream = OldChar c p oldfile} - # input = {input & inp_stream = oldfile} - | c==NewLineChar= ("\n", input) - # (line, input) = ReadLine input - = (toString c + line, input) -*/ ReadLine input = ("", input) NextPos :: !Char !FilePosition !Int -> FilePosition @@ -1432,44 +1255,6 @@ NextPos c pos=:{fp_line, fp_col} t '\t' -> {pos & fp_col = t * (fp_col / t + 1)} _ -> {pos & fp_col = fp_col + 1} -/* - correctNewline :: !Char !FilePosition !Int !InputStream -> (!Char, !InputStream) - correctNewline c pos tab_size (InFile file) // Correct newline convention: Mac: CR, Unix: LF, DOS CR LF - = case c of - LFChar -> (NewLineChar,InFile file) //-->> "UNIX newline" - CRChar - # (ok,c2,file) = freadc file - | ok - | c2 == LFChar -> (NewLineChar,InFile file) // -->> "DOS newline corrected" - -> (NewLineChar,OldChar c2 (NextPos c2 pos tab_size) (InFile file)) - -> (NewLineChar, InFile file) - _ -> (c, InFile file) - correctNewline c pos tab_size (OldChars [] input) - = correctNewline c pos tab_size input - correctNewline c pos tab_size (OldChars chars input) - = case c of - LFChar -> (NewLineChar,OldChars chars input) //-->> "UNIX newline" - CRChar - # [c2:rest] = chars - | c2 == LFChar -> (NewLineChar,OldChars rest input) // -->> "DOS newline corrected" - -> (NewLineChar,OldChars [c2:rest]/*chars*/ input) - _ -> (c,OldChars chars input) - correctNewline c _ _ input = (c, input) - - correctNewline_OldChars :: !Char !FilePosition !Int ! *[Char] ! InputStream -> (!Char, !InputStream) - correctNewline_OldChars c pos tab_size [] input - = correctNewline c pos tab_size input - correctNewline_OldChars c pos tab_size chars input - = case c of - LFChar - -> (NewLineChar,OldChars chars input) //-->> "UNIX newline" - CRChar - # [c2:rest] = chars - | c2 == LFChar - -> (NewLineChar,OldChars rest input) // -->> "DOS newline corrected" - -> (NewLineChar,OldChars [c2:rest]/*chars*/ input) - _ -> (c,OldChars chars input) -*/ correctNewline_OldLine :: !Char !Int !Int !{#Char} ! InputStream -> (!Char, !InputStream) correctNewline_OldLine c i tab_size line input = case c of @@ -1488,16 +1273,6 @@ charBack {inp_stream=OldLine i line stream,inp_pos,inp_tabsize,inp_filename} inp_pos = {inp_pos & fp_col = inp_pos.fp_col - 1}, inp_tabsize=inp_tabsize,inp_filename=inp_filename } -/* -charBack input=:{inp_stream,inp_charBuffer} - | isEmptyBuffer inp_charBuffer - = abort "charBack with empty character buffer" - # ((c,p),rest) = get inp_charBuffer - = { input - & inp_stream = OldChar c p inp_stream - , inp_charBuffer = rest - } -*/ GetPreviousChar :: !Input -> (!Char,!Input) GetPreviousChar input=:{inp_stream=OldLine i line stream} @@ -1536,6 +1311,8 @@ where toString CurlyCloseToken = "}" toString SquareOpenToken = "[" toString SquareCloseToken = "]" + toString ExistsToken = "E." + toString ForAllToken = "A." toString GenericOpenToken = "{|" toString GenericCloseToken = "|}" toString DotToken = "." @@ -1572,6 +1349,9 @@ where toString RealTypeToken = "Real" toString BoolTypeToken = "Bool" toString StringTypeToken = "String" + toString FileTypeToken = "File" + toString WorldTypeToken = "World" + toString VoidTypeToken = "Void" toString LeftAssocToken = "left" toString RightAssocToken = "right" toString ClassToken = "class" @@ -1736,8 +1516,6 @@ closeScanner_ {ss_input=Input {inp_stream}} files No -> files where get_file (InFile file) = Yes file -// get_file (OldChar _ _ stream) = get_file stream -// get_file (OldChars _ stream) = get_file stream get_file (OldLine _ _ stream) = get_file stream NewLineChar :== '\n' @@ -1768,8 +1546,8 @@ setUseLayout b (ScanState ss) = ScanState { ss & ss_useLayout = b } 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} +checkOffside :: !FilePosition !Int !Token !RScanState -> (Token,RScanState) +checkOffside pos index token scanState=:{ss_offsides,ss_useLayout,ss_input} | ~ ss_useLayout = (token, scanState) //-->> (token,pos,"No layout rule applied") | isEmpty ss_offsides @@ -1784,9 +1562,9 @@ checkOffside pos token scanState=:{ss_offsides,ss_useLayout,ss_input} & ss_tokenBuffer = store { lt_position = pos + , lt_index = index , lt_token = newToken - // , lt_chars = [] - // , lt_context = FunctionContext + , lt_context = FunctionContext } scanState.ss_tokenBuffer } @@ -1803,14 +1581,14 @@ checkOffside pos token scanState=:{ss_offsides,ss_useLayout,ss_input} & ss_tokenBuffer = store { lt_position = pos + , lt_index = index , lt_token = newToken - // , lt_chars = [] - // , lt_context = FunctionContext + , lt_context = FunctionContext } scanState.ss_tokenBuffer } -->> ("new definition generated",token) - False - -> scanState + False + -> scanState = gen_end_groups n scanState with newToken = EndGroupToken @@ -1826,9 +1604,9 @@ checkOffside pos token scanState=:{ss_offsides,ss_useLayout,ss_input} & ss_tokenBuffer = store { lt_position = pos + , lt_index = index , lt_token = newToken - // , lt_chars = [] - // , lt_context = FunctionContext + , lt_context = FunctionContext } scanState.ss_tokenBuffer } -->> ("end group generated",pos) // insert EndGroupToken @@ -1846,7 +1624,6 @@ checkOffside pos token scanState=:{ss_offsides,ss_useLayout,ss_input} = store { lt_position = pos , lt_token = newToken - // , lt_chars = [] // , lt_context = FunctionContext } scanState.ss_tokenBuffer @@ -1869,9 +1646,9 @@ where & ss_tokenBuffer = store { lt_position = pos + , lt_index = index , lt_token = newToken - // , lt_chars = ['groups should not start in column 1'] - // , lt_context = FunctionContext + , lt_context = FunctionContext } scanState.ss_tokenBuffer } @@ -1900,13 +1677,7 @@ needsNewDefinitionToken OfToken = True //needsNewDefinitionToken WithToken = True needsNewDefinitionToken SpecialToken = True needsNewDefinitionToken _ = False -/* -repeatedOffside :: !Token -> Bool -repeatedOffside BarToken = True -repeatedOffside EqualToken = True -repeatedOffside (SeqLetToken _) = True -repeatedOffside _ = False -*/ + canBeOffside :: !Token -> Bool canBeOffside EqualToken = False canBeOffside ColonDefinesToken = False @@ -1926,23 +1697,6 @@ dropOffsidePosition (ScanState s) = ScanState (dropOffsidePosition_ s) dropOffsidePosition_ :: !RScanState -> RScanState dropOffsidePosition_ scanState=:{ss_offsides} = { scanState & ss_offsides = drop 1 ss_offsides } -/* -addOffsidePosition :: !RScanState -> (Int, RScanState) -addOffsidePosition scanState=:{ss_useLayout} - | ss_useLayout - # (position,scanState=:{ss_offsides}) = getPosition scanState - new_offside = position.fp_col - = (new_offside, { scanState & ss_offsides = [(new_offside,False): ss_offsides] }) - | otherwise - = (1, scanState) - -atOffsidePosition :: !RScanState -> (!Bool, !RScanState) -atOffsidePosition scanState=:{ss_offsides=[(col,_):_]} - # (position, scanState) = getPosition scanState - = (position.fp_col == col, scanState) -->> ("atOffsidePosition",position.fp_col,col) -atOffsidePosition scanState - = (False, scanState) -*/ //-----------------------// //--- Buffer handling ---// //-----------------------// diff --git a/frontend/utilities.dcl b/frontend/utilities.dcl index 965f872..6eaa0b4 100644 --- a/frontend/utilities.dcl +++ b/frontend/utilities.dcl @@ -18,8 +18,11 @@ stringToCharList :: !String -> [Char] charListToString :: ![Char] -> String revCharListToString :: !Int ![Char] -> String -isUpperCaseName :: ! String -> Bool -isLowerCaseName :: ! String -> Bool +NoUnderscores :== False +UnderscoresAllowed :== True + +isUpperCaseName :: ! String !Bool -> Bool +isLowerCaseName :: ! String !Bool -> Bool isFunnyIdName :: ! String -> Bool isSpecialChar :: ! Char -> Bool diff --git a/frontend/utilities.icl b/frontend/utilities.icl index 50dd8d2..15d1a90 100644 --- a/frontend/utilities.icl +++ b/frontend/utilities.icl @@ -38,17 +38,28 @@ revCharListToString [hd:tl] = revCharListToString tl +++ toString hd revCharListToString [] = "" */ -isUpperCaseName :: ! String -> Bool -isUpperCaseName id - = ('A' <= c && c <= 'Z') || c == '_' - where - c =: id.[0] - -isLowerCaseName :: ! String -> Bool -isLowerCaseName id +NoUnderscores :== False +UnderscoresAllowed :== True + +skipUnderscores :: !Int !Int !String -> Char +skipUnderscores i size s + | i < size + #! c = s.[i] + | c == '_' + = skipUnderscores (i+1) size s + = c + // otherwise: i >= size + = '_' + +isUpperCaseName :: ! String !Bool -> Bool +isUpperCaseName id underscoresAllowed + #! c = if underscoresAllowed (skipUnderscores 0 (size id) id) (id.[0]) + = 'A' <= c && c <= 'Z' + +isLowerCaseName :: ! String !Bool -> Bool +isLowerCaseName id underscoresAllowed + #! c = if underscoresAllowed (skipUnderscores 0 (size id) id) (id.[0]) = 'a' <= c && c <= 'z' - where - c =: id.[0] isFunnyIdName :: ! String -> Bool isFunnyIdName id |