aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--frontend/checkFunctionBodies.icl10
-rw-r--r--frontend/parse.icl343
-rw-r--r--frontend/scanner.dcl4
-rw-r--r--frontend/scanner.icl602
-rw-r--r--frontend/utilities.dcl7
-rw-r--r--frontend/utilities.icl31
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