assorted parse/scan bug fixes

frontend/checkFunctionBodies.icl

@@ -2109,12 +2109,30 @@ checkLhssOfLocalDefs def_level mod_index (CollectedLocalDefs {loc_functions={ir_
 		= (loc_defs, accus, { e_state & es_fun_defs = ps_fun_defs, es_var_heap = ps_var_heap }, {e_info & ef_macro_defs=macro_defs}, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })
 where
 	check_patterns [ node_def : node_defs ] p_input accus var_store e_info cs
-		# (pattern, accus, var_store, e_info, cs) = checkPattern node_def.nd_dst No p_input accus var_store e_info cs
+		# (pattern, accus, var_store, e_info, cs) = check_local_lhs_pattern node_def.nd_dst No p_input accus var_store e_info cs
 		  (patterns, accus, var_store, e_info, cs) = check_patterns node_defs p_input accus var_store e_info cs
 		= ([{ node_def & nd_dst = pattern } : patterns], accus, var_store, e_info, cs)
 	check_patterns [] p_input accus var_store e_info cs
 		= ([], accus, var_store, e_info, cs)
 
+	/* RWS: FIXME
+		This is a patch for the case
+			...
+			where
+				X = 10
+		in which X should be a node-id (a.k.a. AP_Variable) and not a pattern.
+		I think the distinction between node-ids and constructors should be done
+		in an earlier phase, but this will need a larger rewrite.
+	*/
+	check_local_lhs_pattern (PE_Ident 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
+		# (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)
+	check_local_lhs_pattern pattern opt_var p_input accus var_store e_info cs
+		=	checkPattern pattern opt_var p_input accus var_store e_info cs
+
 addArraySelections [] rhs_expr free_vars e_input e_state e_info cs
 	= (rhs_expr, free_vars, e_state, e_info, cs)
 addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs

frontend/parse.icl

@@ -489,7 +489,7 @@ where
 			# (lhs, pState) = want_lhs_of_def token pState
 		      (token, pState) = nextToken FunctionContext pState
 		      (def, pState) = want_rhs_of_def parseContext lhs token (determine_position lhs pos) pState
-			= (True, def, pState) -->>  def
+			= (True, def, pState)
 			with
 				determine_position (Yes (name, _), _)	(LinePos f l) = FunPos f l name.id_name
 		 		determine_position lhs           		pos           = pos
@@ -544,20 +544,20 @@ where
 		# pState			= want_node_def_token pState token
 		# (ss_useLayout, pState) = accScanState UseLayout pState
 		  localsExpected	= ~ ss_useLayout
-		  (rhs, pState)		= wantRhs isEqualToken localsExpected (tokenBack pState)
+		  (rhs, pState)		= wantRhs (isRhsStartToken parseContext) localsExpected (tokenBack pState)
 		| isGlobalContext parseContext
  			= (PD_NodeDef pos (combine_args args) rhs, parseError "RHS" No "<global definition>" pState)
  			= (PD_NodeDef pos (combine_args args) rhs, pState)
 	where		
 		want_node_def_token s EqualToken		= s
-		want_node_def_token s DefinesColonToken = replaceToken EqualToken s
+		want_node_def_token s DefinesColonToken = s // PK replaceToken EqualToken s
 		want_node_def_token s token				= parseError "RHS" (Yes token) "defines token (= or =:)" s
 
 		combine_args [arg]	= arg
 		combine_args args	= PE_List args
 	want_rhs_of_def parseContext (Yes (name, False), []) token pos pState
-		| isIclContext parseContext && isLocalContext parseContext && token == EqualToken &&
-		  isLowerCaseName name.id_name && not (isClassOrInstanceDefsContext parseContext)
+		| isIclContext parseContext && isLocalContext parseContext && (token == EqualToken || token == DefinesColonToken) &&
+		/* PK isLowerCaseName name.id_name && */ not (isClassOrInstanceDefsContext parseContext)
 			# (rhs, pState) = wantRhs (\_ -> True) False (tokenBack pState)
 			= (PD_NodeDef pos (PE_Ident name) rhs, pState)
 
@@ -567,9 +567,9 @@ where
 		| isIclContext parseContext && token == CodeToken
 			# (rhs, pState) = wantCodeRhs pState
 			| code_allowed
-  				= (PD_Function pos name is_infix args rhs fun_kind, pState)
-  			// otherwise // ~ code_allowed
-  				= (PD_Function pos name is_infix args rhs fun_kind, parseError "rhs of def" No "no code" pState)
+				= (PD_Function pos name is_infix args rhs fun_kind, pState)
+			// 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)
 		  (ss_useLayout, pState) = accScanState UseLayout pState
 		  localsExpected = isNotEmpty args || isGlobalContext parseContext || ~ ss_useLayout
@@ -579,7 +579,7 @@ where
 				->	(PD_Function pos name is_infix args rhs fun_kind, parseError "RHS" No "<type specification>" pState)
 			FK_Caf | isNotEmpty args
 				->	(PD_Function pos name is_infix []   rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState)
-  			_	->	(PD_Function pos name is_infix args rhs fun_kind, pState)
+			_	->	(PD_Function pos name is_infix args rhs fun_kind, pState)
 	where
 		token_to_fun_kind s BarToken			= (FK_Function cNameNotLocationDependent, False,  s)
 		token_to_fun_kind s (SeqLetToken _)		= (FK_Function cNameNotLocationDependent, False,  s)
@@ -602,8 +602,9 @@ isEqualToken _					= False
 
 isRhsStartToken :: !ParseContext !Token -> Bool
 isRhsStartToken parseContext EqualToken			= True
-isRhsStartToken parseContext ColonDefinesToken	= True
-isRhsStartToken parseContext DefinesColonToken	= True // RWS test isGlobalContext parseContext
+isRhsStartToken parseContext ColonDefinesToken	= isGlobalOrClassOrInstanceDefsContext parseContext
+isRhsStartToken parseContext DefinesColonToken	= True
+isRhsStartToken parseContext DoubleArrowToken	= True // PK
 isRhsStartToken parseContext _					= False
 
 optionalSpecials :: !ParseState -> (!Specials, !ParseState)
@@ -753,25 +754,25 @@ where
 
 wantRhs :: !(!Token -> Bool) !Bool !ParseState -> (Rhs, !ParseState) // FunctionAltDefRhs
 wantRhs separator localsExpected pState
-	# (alts, pState)	= want_LetsFunctionBody separator pState
+	# (alts, pState)	= want_LetsFunctionBody pState
 	  (locals, pState)	= optionalLocals WhereToken localsExpected pState
 	= ({ rhs_alts = alts, rhs_locals = locals}, pState)
 where
-	want_LetsFunctionBody :: !(!Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) 
-	want_LetsFunctionBody sep pState
+	want_LetsFunctionBody :: !ParseState -> (!OptGuardedAlts, !ParseState) 
+	want_LetsFunctionBody pState
 		# (token, pState)			= nextToken FunctionContext pState
 		  (nodeDefs, token, pState)	= want_LetBefores token pState
-		= want_FunctionBody token nodeDefs [] sep pState
+		= want_FunctionBody token nodeDefs [] pState
 
-	want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState)
-	want_FunctionBody BarToken nodeDefs alts sep pState
+	want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !ParseState -> (!OptGuardedAlts, !ParseState)
+	want_FunctionBody BarToken nodeDefs alts pState
 //		#	(lets, pState)				= want_StrictLet pState // removed from 2.0
 		#	(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 = ..
+			= want_FunctionBody token (nodeDefs ++ nodeDefs2) alts pState // to allow | otherwise | c1 = .. | c2 = ..
 /* PK ??? 
 			=	case token of
 				BarToken
@@ -780,36 +781,36 @@ where
 				_	->	root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState
 */		|	token == LetToken True
 			#	pState	= parseError "RHS" No "No 'let!' in this version of Clean" pState
-			=	root_expression True token nodeDefs (reverse alts) sep pState
+			=	root_expression True token nodeDefs (reverse alts) pState
 		#	(guard, pState)				= wantRhsExpressionT token pState
 			(token, pState)				= nextToken FunctionContext pState
 			(nodeDefs2, token, pState)	= want_LetBefores token pState
 		|	token == BarToken // nested guard
 			#	(position, pState)			= getPosition pState
 				offside						= position.fp_col
-				(expr, pState)				= want_FunctionBody token nodeDefs2 [] sep pState
+				(expr, pState)				= want_FunctionBody token nodeDefs2 [] pState
 				pState						= wantEndNestedGuard (default_found expr) offside pState
 				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
+			=	want_FunctionBody token nodeDefs [alt:alts] pState
 		// otherwise
-			#	(expr, pState)				= root_expression True token nodeDefs2 [] sep pState
+			#	(expr, pState)				= root_expression True token nodeDefs2 [] pState
 				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
+			=	want_FunctionBody token nodeDefs [alt:alts] pState
 	  where
 	  	guard_ident line_nr
 			= { id_name = "_g;" +++ toString line_nr +++ ";", id_info = nilPtr }
-	want_FunctionBody token nodeDefs alts sep pState
-		=	root_expression localsExpected token nodeDefs (reverse alts) sep pState
+	want_FunctionBody token nodeDefs alts pState
+		=	root_expression localsExpected token nodeDefs (reverse alts) pState
 	
-	root_expression :: !Bool !Token ![NodeDefWithLocals] ![GuardedExpr] !(Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState)
-	root_expression withExpected token nodeDefs alts sep pState
-		# (optional_expr,pState) = want_OptExprWithLocals withExpected token nodeDefs sep pState
+	root_expression :: !Bool !Token ![NodeDefWithLocals] ![GuardedExpr] !ParseState -> (!OptGuardedAlts, !ParseState)
+	root_expression withExpected token nodeDefs alts pState
+		# (optional_expr,pState) = want_OptExprWithLocals withExpected token nodeDefs pState
 		= build_root token optional_expr alts nodeDefs pState
 	where
 		build_root :: !Token !(Optional ExprWithLocalDefs) ![GuardedExpr] ![NodeDefWithLocals] !ParseState -> (!OptGuardedAlts, !ParseState)
@@ -829,11 +830,11 @@ where
 	default_found (GuardedAlts _ No)	= False
 	default_found _						= True
 
-	want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !(Token -> Bool) !ParseState -> (!Optional !ExprWithLocalDefs, !ParseState)
-	want_OptExprWithLocals withExpected DoubleArrowToken nodeDefs sep pState
-		= want_OptExprWithLocals True EqualToken nodeDefs sep (replaceToken EqualToken pState)
-	want_OptExprWithLocals withExpected token nodeDefs sep pState
-		| sep token
+	want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !ParseState -> (!Optional !ExprWithLocalDefs, !ParseState)
+//	want_OptExprWithLocals withExpected DoubleArrowToken nodeDefs pState
+//		= want_OptExprWithLocals True EqualToken nodeDefs (replaceToken EqualToken pState)
+	want_OptExprWithLocals withExpected token nodeDefs pState
+		| separator token
 		# (file_name, line_nr, pState)	= getFileAndLineNr pState
 		  (expr, pState)	= wantExpression cIsNotAPattern pState
 		  pState			= wantEndRootExpression pState
@@ -899,6 +900,14 @@ where
 				)
 		// otherwise // ~ succ
 			= (False, abort "no definition", pState)
+	
+	try_let_lhs pState
+		# (succ, lhs_exp, pState) = trySimpleLhsExpression pState
+		| succ
+			= (True, lhs_exp, pState)
+			# (token,pState) = nextToken FunctionContext pState
+			= case token of
+				_ -> (False, lhs_exp, tokenBack pState)
 
 optionalLocals :: !Token !Bool !ParseState -> (!LocalDefs, !ParseState)
 optionalLocals dem_token localsExpected pState
@@ -2352,21 +2361,21 @@ wantListExp is_pattern pState
 	# pState=appScanState setNoNewOffsideForSeqLetBit pState
 	# (token, pState) = nextToken FunctionContext pState
 	# pState=appScanState clearNoNewOffsideForSeqLetBit pState	
-	# (head_strictness,token,pState) = wantHeadStrictness token pState
+	# (head_strictness,token,pState) = want_head_strictness token pState
 		with
-			wantHeadStrictness :: Token *ParseState -> *(!Int,!Token,!*ParseState)
-			wantHeadStrictness ExclamationToken pState
+			want_head_strictness :: Token *ParseState -> *(!Int,!Token,!*ParseState)
+			want_head_strictness ExclamationToken pState
 				# (token,pState) = nextToken FunctionContext pState
 				= (HeadStrict,token,pState)
-			wantHeadStrictness (SeqLetToken strict) pState
+			want_head_strictness (SeqLetToken strict) pState
 				# (token,pState) = nextToken FunctionContext pState
 				| strict
 					= (HeadUnboxedAndTailStrict,token,pState);
 					= (HeadUnboxed,token,pState)
-			wantHeadStrictness BarToken pState
+			want_head_strictness BarToken pState
 				# (token,pState) = nextToken FunctionContext pState
 				= (HeadOverloaded,token,pState)
-			wantHeadStrictness token pState
+			want_head_strictness token pState
 				= (HeadLazy,token,pState)
 	| token==ExclamationToken && (head_strictness<>HeadOverloaded && head_strictness<>HeadUnboxedAndTailStrict)
 		# (token, pState) = nextToken FunctionContext pState
@@ -2426,7 +2435,9 @@ wantListExp is_pattern pState
 						| token==ExclamationToken && head_strictness<>HeadOverloaded
 							# pState = wantToken FunctionContext "list" SquareCloseToken pState
 							-> gen_tail_strict_cons_nodes acc exp pState
-							# pState = parseError "list" (Yes token) (toString SquareCloseToken) pState
+						| token==ColonToken // to allow [1:2:[]] etc.
+							-> want_list [exp:acc] (tokenBack pState)
+							# pState = parseError "list" (Yes token) "] or :" pState
 							-> gen_cons_nodes acc exp pState
 					DotDotToken
 						| is_pattern
@@ -2468,7 +2479,7 @@ wantListExp is_pattern pState
 			gen_cons_nodes [e:r] exp pState
 				# (exp, pState) = makeConsExpression head_strictness is_pattern e exp pState
 				= gen_cons_nodes r exp pState
-
+	
 			gen_tail_strict_cons_nodes [] exp pState
 				= (exp, pState)
 			gen_tail_strict_cons_nodes [e:r] exp pState
@@ -2638,7 +2649,7 @@ where
 				= (False, abort "no case alt", pState)
 			= (False, abort "no case alt", tokenBack pState)
 
-	caseSeperator t = t == EqualToken || t == ArrowToken // to enable Clean 1.x case expressions
+	caseSeperator t = t == EqualToken || t == ArrowToken // to enable Clean 1.3.x case expressions
 
 	try_pattern :: !ParseState -> (!Bool, ParsedExpr, !ParseState)
 	try_pattern pState
@@ -3289,11 +3300,11 @@ where
 instance currentToken ParseState
 where
 	currentToken pState = accScanState currentToken pState
-*/	
+	
 instance replaceToken ParseState
 where
 	replaceToken t pState = appScanState (replaceToken t) pState
-
+*/
 instance tokenBack ParseState
 where
 	tokenBack pState=:{ps_skipping}

frontend/postparse.icl

@@ -2,7 +2,7 @@ implementation module postparse
 
 import StdEnv
 import syntax, parse, utilities, StdCompare
-// import RWSDebug
+//import RWSDebug
 
 :: *CollectAdmin =
 	{	ca_error		:: !*ParseErrorAdmin
@@ -303,7 +303,10 @@ where
 			= ([ fun : fun_defs ], node_defs, ca)
 		reorganiseLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca
 			= case defs of
-				[PD_Function pos name is_infix args rhs fun_kind : _]
+				[PD_Function pos name is_infix args rhs fun_kind : othe] // PK ..
+					| fun_kind == FK_Caf 
+						# ca = postParseError pos "No typespecification for local graph definitions allowed" ca // .. PK
+						-> reorganiseLocalDefinitions (tl defs) ca
 					| belongsToTypeSpec name1 prio name is_infix
 						# fun_arity = determineArity args type
 						# (bodies, fun_kind, defs, ca) = collectFunctionBodies name1 fun_arity prio fun_kind defs ca

frontend/scanner.dcl

@@ -134,13 +134,13 @@ instance nextToken ScanState
 
 class currentToken state :: !*state -> (!Token, !*state)
 instance currentToken ScanState
-
+/*
 class insertToken state :: !Token !ScanContext !*state -> *state
 instance insertToken ScanState
 
 class replaceToken state :: !Token !*state -> *state
 instance replaceToken ScanState
-
+*/
 class getPosition state :: !*state -> (!FilePosition,!*state)  // Position of current Token (or Char)
 instance getPosition ScanState
 

frontend/scanner.icl

@@ -46,7 +46,7 @@ where
 	currentToken (ScanState scan_state)
 		# (token,scan_state) = currentToken scan_state
 		= (token,ScanState scan_state) 
-
+/*
 instance insertToken ScanState
 where
 	insertToken token context (ScanState scan_state) = ScanState (insertToken token context scan_state)
@@ -54,7 +54,7 @@ where
 instance replaceToken ScanState
 where
 	replaceToken token (ScanState scan_state) = ScanState (replaceToken token scan_state)
-
+*/
 instance getPosition ScanState
 where
 	getPosition (ScanState scan_state)
@@ -396,7 +396,7 @@ where currentToken scanState=:{ss_tokenBuffer}
 		| isEmptyBuffer ss_tokenBuffer
 			= (ErrorToken "dummy", scanState)
 			= ((head ss_tokenBuffer).lt_token, scanState)
-
+/*
 class insertToken state :: !Token !ScanContext !*state -> *state
 
 instance insertToken RScanState
@@ -412,7 +412,7 @@ where
 							}
 							ss_input
 			}
-
+*/
 notContextDependent :: !Token -> Bool
 notContextDependent token
  = case token of
@@ -438,7 +438,7 @@ notContextDependent token
 	WhereToken			-> True
 	WithToken			-> True
 	_					-> False
-
+/*
 class replaceToken state :: !Token !*state -> *state
 
 instance replaceToken RScanState
@@ -448,7 +448,7 @@ where
 		= { scanState
 		  & ss_tokenBuffer = store { longToken & lt_token = tok } buffer
 		  }
-
+*/
 SkipWhites :: !Input -> (!Optional String, !Char, !Input)
 SkipWhites {inp_stream=OldLine i line stream,inp_pos={fp_line,fp_col},inp_tabsize,inp_filename}
 	| i<size line
@@ -608,11 +608,11 @@ Scan c0=:'#' input co
 	// otherwise
 		= (SeqLetToken strict, charBack input)
 Scan '*' input TypeContext	= (AsteriskToken, input)
-Scan c0=:'&' input co
-	# (eof, c1, input)		= ReadNormalChar input
+Scan c0=:'&' input co		= possibleKeyToken AndToken [c0] co input
+/*	# (eof, c1, input)		= ReadNormalChar input
 	| eof					= (AndToken, input)
 	| isSpecialChar c1		= ScanOperator 1 input [c1, c0] co
-							= (AndToken, charBack input)
+							= (AndToken, charBack input) */
 Scan c0=:'.' input co	// PK incorrect ?
 	= case co of
 		TypeContext
@@ -723,7 +723,7 @@ Scan c0=:':' input co
 	| c1 == ':'
 		# (eof, c2, input)	= ReadNormalChar input
 		| eof				= (DoubleColonToken, input)
-		| isSpecialChar c2	&& ~(c2=='!' || c2=='*') // for type rules and the like
+		| isSpecialChar c2	&& ~(c2=='!' || c2=='*' || c2=='.') // for type rules and the like
 							= ScanOperator 2 input [c2, c1, c0] co
 							= (DoubleColonToken, charBack input)
 	| c1 == '='
@@ -758,7 +758,7 @@ possibleKeyToken :: !Token ![Char] !ScanContext !Input -> (!Token, !Input)
 possibleKeyToken token reversedPrefix context input
 	# (eof, c, input)		= ReadNormalChar input
 	| eof					= (token, input)
-	| isSpecialChar c		= ScanOperator 2 input [c : reversedPrefix] context
+	| isSpecialChar c		= ScanOperator (length reversedPrefix) input [c : reversedPrefix] context
 							= (token, charBack input)
 
 new_exp_char ',' = True
@@ -1003,7 +1003,7 @@ ScanOctNumeral n input
 
 ScanChar :: !Input ![Char] -> (!Token, !Input)
 ScanChar input chars
-	# (eof, c, input)		= ReadNormalChar input
+	# (eof, c, input)		= ReadChar input // PK: was ReadNormalChar input
 	| eof					= (ErrorToken "End of file inside Char denotation", input)
 	| '\'' == c				= (CharListToken "", input)
 	| '\\' == c				= ScanBSChar 0 chars input ScanEndOfChar
@@ -1226,17 +1226,15 @@ ReadChar {inp_stream = OldLine i line stream,inp_pos,inp_tabsize,inp_filename}
 			#	pos = NextPos c inp_pos inp_tabsize
 				(c,stream)	= correctNewline_OldLine c i inp_tabsize line stream
 			=	(	False,	c
-				,	{
-						inp_filename=inp_filename,inp_tabsize=inp_tabsize,
-						inp_stream = stream
+				,	{	inp_filename = inp_filename, inp_tabsize = inp_tabsize
+					,	inp_stream = stream
 					,	inp_pos	= pos
 					}
 				)
 			#	pos = {inp_pos & fp_col = inp_pos.fp_col + 1}
 			=	(	False, c
-				,	{
-						inp_filename=inp_filename,inp_tabsize=inp_tabsize,
-						inp_stream = OldLine (i+1) line stream
+				,	{	inp_filename = inp_filename, inp_tabsize = inp_tabsize
+					,	inp_stream = OldLine (i+1) line stream
 					,	inp_pos	= pos
 					}
 				)