parse.icl 175 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
implementation module parse
Pieter Koopman's avatar
Pieter Koopman committed
2

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
3
import StdEnv
4
import scanner, syntax, hashtable, utilities, predef, containers, compilerSwitches
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
5
6

ParseOnly :== False
7

8
9
10
toLineAndColumn {fp_line, fp_col}
	=	{lc_line = fp_line, lc_column = fp_col}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
// +++ move to utilities?

groupBy :: (a a -> Bool) [a] -> [[a]]
groupBy eq []
    =   []
groupBy eq [h : t]
    =   [[h : this] : groupBy eq other]
    where
        (this, other)
            =   span (eq h) t

/*

Parser for Clean 2.0

Conventions:

- Parsing funtions with a name of the form try.. can fail without generating an error.
  The parser will try an other alternative.
- Parsing functions with a name of the form want.. should succeed. If these functions
  fail an error message is generated.
- Functions with names containing the character '_' are local functions.
- All functions should consume the tokens taken form the state or given as argument,
  or put these tokens back themselves.
*/

::	*ParseErrorAdmin = 
	{	pea_file	:: !*File
	,	pea_ok		:: !Bool
	}

:: *ParseState =
	{	ps_scanState		:: !ScanState
	,	ps_error			:: !*ParseErrorAdmin
	,	ps_skipping			:: !Bool
	,	ps_hash_table		:: !*HashTable
47
	,	ps_support_generics :: !Bool // AA: compiler option "-generics"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
48
	}
49

clean's avatar
clean committed
50
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
51
52
53
54
appScanState :: (ScanState -> ScanState) !ParseState -> ParseState
appScanState f pState=:{ps_scanState}
	#	ps_scanState = f ps_scanState
	=	{	pState & ps_scanState = ps_scanState }
clean's avatar
clean committed
55
56
57
58
59
60
*/
appScanState f pState:==appScanState pState
	where
	appScanState pState=:{ps_scanState}
		#	ps_scanState = f ps_scanState
		=	{	pState & ps_scanState = ps_scanState }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
61

clean's avatar
clean committed
62
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
63
64
65
66
accScanState :: (ScanState -> (.t,ScanState)) !ParseState -> (.t,ParseState)
accScanState f pState=:{ps_scanState}
	#	( x, ps_scanState) = f ps_scanState
	=	( x, {pState & ps_scanState = ps_scanState })
clean's avatar
clean committed
67
68
69
70
71
72
*/
accScanState f pState:== accScanState pState
	where
		accScanState pState=:{ps_scanState}
			#	( x, ps_scanState) = f ps_scanState
			=	( x, {pState & ps_scanState = ps_scanState })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
73

74
75
76
77
instance getFilename ParseState
where
	getFilename pState = accScanState getFilename pState

78
79
80
makeStringType
	#! string_ident = predefined_idents.[PD_StringType]
	=: TA (MakeNewTypeSymbIdent string_ident 0) []
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
81

82
83
84
85
86
87
HeadLazy:==0
HeadStrict:==1
HeadUnboxed:==2
HeadOverloaded:==3;
HeadUnboxedAndTailStrict:==4;

88
89
makeListTypeSymbol :: Int Int -> TypeSymbIdent
makeListTypeSymbol head_strictness arity
90
91
92
93
94
	# pre_def_list_index=if (head_strictness==HeadLazy)
							PD_ListType
						(if (head_strictness==HeadStrict)
							PD_StrictListType
							PD_UnboxedListType)
95
96
	#! list_ident = predefined_idents.[pre_def_list_index]
	= MakeNewTypeSymbIdent list_ident arity
97

98
99
makeTailStrictListTypeSymbol :: Int Int -> TypeSymbIdent
makeTailStrictListTypeSymbol head_strictness arity
100
101
102
103
104
	# pre_def_list_index=if (head_strictness==HeadLazy)
							PD_TailStrictListType
						(if (head_strictness==HeadStrict)
							PD_StrictTailStrictListType
							PD_UnboxedTailStrictListType)
105
106
	#! list_ident = predefined_idents.[pre_def_list_index]
	= MakeNewTypeSymbIdent list_ident arity
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
107

108
109
110
makeLazyArraySymbol arity
	#! lazy_array_ident = predefined_idents.[PD_LazyArrayType]
	= MakeNewTypeSymbIdent lazy_array_ident arity
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
111

112
113
114
makeStrictArraySymbol arity
	#! strict_array_ident = predefined_idents.[PD_StrictArrayType]
	= MakeNewTypeSymbIdent strict_array_ident arity
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
115

116
117
118
makeUnboxedArraySymbol arity
	#! unboxed_array_ident = predefined_idents.[PD_UnboxedArrayType]
	= MakeNewTypeSymbIdent unboxed_array_ident arity
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
119

120
121
122
makeTupleTypeSymbol form_arity act_arity
	#! tuple_ident = predefined_idents.[GetTupleTypeIndex form_arity]
	= MakeNewTypeSymbIdent tuple_ident act_arity
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
123
124
125
126
	
class try a	 :: !Token !*ParseState -> (!Optional a, !*ParseState)
class want a :: !*ParseState -> (!a, !*ParseState)

127
128
129
130
131
132
stringToIdent s i p :== (ident,parse_state)
	where
		({boxed_ident=ident},parse_state) = stringToBoxedIdent s i p

stringToBoxedIdent :: !String !IdentClass !*ParseState -> (!BoxedIdent, !*ParseState)
stringToBoxedIdent ident ident_class pState=:{ps_hash_table}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
133
134
135
	# (ident, ps_hash_table) = putIdentInHashTable ident ident_class ps_hash_table
	= (ident, { pState & ps_hash_table = ps_hash_table } )

136
137
internalIdent s p :== (ident,parse_state)
	where
138
		({boxed_ident=ident},parse_state) = internalBoxedIdent s p
139

140
141
internalBoxedIdent :: !String !*ParseState -> (!BoxedIdent, !*ParseState)
internalBoxedIdent prefix pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
142
	# ({fp_line,fp_col},pState=:{ps_hash_table})	= getPosition pState
143
	  case_string									= prefix +++ ";" +++ toString fp_line +++ ";" +++ toString fp_col
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
144
145
146
147
148
149
150
151
152
	  (case_ident, ps_hash_table)					= putIdentInHashTable case_string IC_Expression ps_hash_table
	= (case_ident, { pState & ps_hash_table = ps_hash_table } )

erroneousIdent = { id_name = "", id_info = nilPtr }

/*
	Some general overloaded parsing routines
*/

Pieter Koopman's avatar
Pieter Koopman committed
153
154
wantSequence :: !Token !ScanContext !*ParseState -> (!.[a],!*ParseState) | want a
wantSequence separator scanContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
155
	# (first, pState) = want pState
Pieter Koopman's avatar
Pieter Koopman committed
156
	  (token, pState) = nextToken scanContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
157
	| separator == token
Pieter Koopman's avatar
Pieter Koopman committed
158
		# (rest, pState) = wantSequence separator scanContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
159
160
161
162
		= ([first : rest], pState)
	// otherwise // separator <> token
	= ([first], tokenBack pState)
/*
Pieter Koopman's avatar
Pieter Koopman committed
163
164
optionalSequence start_token separator scanContext pState
	# (token, pState) = nextToken scanContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
165
	| token == start_token
Pieter Koopman's avatar
Pieter Koopman committed
166
		= wantSequence separator scanContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
167
168
169
170
171
172
173
174
175
176
177
178
179
		= ([], tokenBack pState)
*/
parseList try_fun pState :== parse_list pState // try_fun *
//parseList try_fun pState = parse_list pState
	where
	//	parse_list :: !*ParseState -> (tree, *ParseState)
		parse_list pState
			# (succ, tree, pState) = try_fun pState
			| succ
				# (trees, pState) = parse_list pState
				= ([tree : trees], pState)
			= ([], pState)

Pieter Koopman's avatar
Pieter Koopman committed
180
181
//wantSepList msg sep_token scanContext try_fun pState = want_list msg pState
wantSepList msg sep_token scanContext try_fun pState :== want_list msg pState // try_fun (sep_token tryfun)*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
182
183
184
185
	where
		want_list msg pState
			# (succ, tree, pState) = try_fun pState
			| succ
Pieter Koopman's avatar
Pieter Koopman committed
186
			 	# (token, pState) = nextToken scanContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
187
			 	| token == sep_token
Pieter Koopman's avatar
Pieter Koopman committed
188
					# (trees, pState) = optSepList sep_token scanContext try_fun pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
189
190
191
192
					= ([tree : trees], pState)
				// otherwise // token <> sep_token
					= ([tree], tokenBack pState)
				# (token, pState) = nextToken GeneralContext pState
193
				= ([tree], parseError ("wantList of "+msg) (Yes token) msg pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
194

Pieter Koopman's avatar
Pieter Koopman committed
195
196
//optSepList sep_token scanContext try_fun pState = want_list msg pState
optSepList sep_token scanContext try_fun pState :== want_list pState // [ try_fun (sep_token tryfun)* ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
197
198
199
200
	where
		want_list pState
			# (succ, tree, pState) = try_fun pState
			| succ
Pieter Koopman's avatar
Pieter Koopman committed
201
			 	# (token, pState) = nextToken scanContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
			 	| token == sep_token
					# (trees, pState) = want_list pState
					= ([tree : trees], pState)
				// otherwise // token <> sep_token
					= ([tree], tokenBack pState)
			= ([], pState)

//wantList msg try_fun pState = want_list msg pState
wantList msg try_fun pState :== want_list msg pState // try_fun +
	where
		want_list msg pState
			# (succ, tree, pState) = try_fun pState
			| succ
				# (trees, pState) = parseList try_fun pState
				= ([tree : trees], pState)
				# (token, pState) = nextToken GeneralContext pState
218
				= ([tree], parseError ("wantList of "+msg) (Yes token) msg pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
219
220
221
222
223
224
225
226
/*
instance want (a,b) | want a & want b
where
	want pState
		# (x, pState) = want pState
		  (y, pState) = want pState
		= ((x,y), pState)
*/
Pieter Koopman's avatar
Pieter Koopman committed
227
228
wantModuleIdents :: !ScanContext !IdentClass !ParseState -> (![Ident], !ParseState)
wantModuleIdents scanContext ident_class pState
229
	# (first_name, pState) = wantModuleName pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
230
	  (first_ident, pState) = stringToIdent first_name ident_class pState
Pieter Koopman's avatar
Pieter Koopman committed
231
	  (token, pState) = nextToken scanContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
232
	| token == CommaToken
Pieter Koopman's avatar
Pieter Koopman committed
233
		# (rest, pState) = wantModuleIdents scanContext ident_class pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
		= ([first_ident : rest], pState)
	= ([first_ident], tokenBack pState)

optionalPriority :: !Bool !Token !ParseState -> (Priority, !ParseState)
optionalPriority isinfix (PriorityToken prio) pState
	= (prio, pState)
optionalPriority isinfix token pState
	| isinfix
		= (DummyPriority, tokenBack pState)
		= (NoPrio, tokenBack pState)

/*
	Modules
*/

249
::	ParseContext			:== Int
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
250

251
252
253
254
255
cICLContext					:== 1
cGlobalContext				:== 2
cDCLContext					:== 0
cLocalContext				:== 1
cClassOrInstanceDefsContext	:== 4
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
256

257
258
259
260
261
262
263
264
/*
	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.
*/

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
265
266
267
268
SetGlobalContext iclmodule
	| iclmodule
		= cICLContext bitor cGlobalContext
		= cDCLContext bitor cGlobalContext
269

270
271
SetLocalContext					parseContext :== parseContext bitand (bitnot cGlobalContext)
SetClassOrInstanceDefsContext	parseContext :== SetLocalContext (parseContext bitor cClassOrInstanceDefsContext)
272

273
274
isLocalContext	parseContext	:== parseContext bitand cGlobalContext == 0
isGlobalContext	parseContext	:== parseContext bitand cGlobalContext <> 0 // not (isLocalContext parseContext)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
275

276
277
isDclContext	parseContext	:== parseContext bitand cICLContext == 0
isIclContext	parseContext	:== parseContext bitand cICLContext <> 0	// not (isDclContext parseContext)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
278

279
280
isClassOrInstanceDefsContext parseContext			:== parseContext bitand cClassOrInstanceDefsContext <> 0
isGlobalOrClassOrInstanceDefsContext parseContext	:== parseContext bitand (cGlobalContext bitor cClassOrInstanceDefsContext) <> 0
281

282
283
cWantIclFile :== True
cWantDclFile :== False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
284

285
286
287
wantModule :: !Bool !Ident !Position !Bool !*HashTable !*File !SearchPaths (ModTimeFunction *Files) !*Files
	-> (!Bool, !ParsedModule, !*HashTable, !*File, !*Files)
wantModule iclmodule file_id=:{id_name} import_file_position support_generics hash_table error searchPaths modtimefunction files
288
289
	= case openScanner file_name searchPaths modtimefunction files of
		(Yes (scanState, modification_time), files)
290
			# hash_table=set_hte_mark (if iclmodule 1 0) hash_table
291
			# (ok,mod,hash_table,file,files) = initModule file_name modification_time scanState hash_table error files
292
			# hash_table=set_hte_mark 0 hash_table
293
			->(ok,mod,hash_table,file,files)
294
		(No, files)
295
			-> let mod = { mod_ident = file_id,  mod_modification_time = "", mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in
296
			  (False, mod, hash_table, error <<< "Error " <<< import_file_position <<< ": "  <<< file_name <<< " could not be imported\n", files)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
297
where
298
	file_name = if iclmodule (id_name +++ ".icl") (id_name +++ ".dcl")
299
300
301
302

	initModule :: String String ScanState !*HashTable !*File *Files
				-> (!Bool, !ParsedModule, !*HashTable, !*File, !*Files)
	initModule file_name modification_time scanState hash_table error files
303
		# (succ, mod_type, mod_name, scanState) = try_module_header iclmodule scanState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
304
305
306
307
308
		| succ
			# pState				=	{ ps_scanState = scanState
										, ps_error = { pea_file = error, pea_ok = True }
										, ps_skipping = False
										, ps_hash_table = hash_table
309
										, ps_support_generics = support_generics
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
310
										}
311
312
			  pState				= verify_name mod_name id_name file_name pState
		  	  (mod_ident, pState)	= stringToIdent mod_name IC_Module pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
313
314
		  	  pState				= check_layout_rule pState
		  	  (defs, pState)		= want_definitions (SetGlobalContext iclmodule) pState
315
			  {ps_scanState,ps_hash_table,ps_error}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
316
			  						= pState
317
			  defs = if (ParseOnly && id_name <> "StdOverloaded" && id_name <> "StdArray" && id_name <> "StdEnum" && id_name <> "StdBool" && id_name <> "StdDynamics" && id_name <> "StdGeneric")
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
318
319
						[PD_Import imports \\ PD_Import imports <- defs]
						defs
320
			  mod					= { mod_ident = mod_ident, mod_modification_time = modification_time, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = defs }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
321
322
323
324
325
326
			= ( ps_error.pea_ok
			  , mod, ps_hash_table
			  , ps_error.pea_file
			  , closeScanner ps_scanState files
			  )
		// otherwise // ~ succ
327
		# ({fp_line}, scanState) = getPosition scanState
328
		  mod = { mod_ident = file_id,  mod_modification_time = modification_time, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_defs = [] }
Martin Wierich's avatar
Martin Wierich committed
329
		= (False, mod, hash_table, error <<< "Error [" <<< file_name <<< ',' <<< fp_line <<< "]: incorrect module header",
330
			closeScanner scanState files)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349

	try_module_header :: !Bool !ScanState -> (!Bool,!ModuleKind,!String,!ScanState)
	try_module_header is_icl_mod scanState
		# (token, scanState) = nextToken GeneralContext scanState
		| is_icl_mod
			| token == ModuleToken
				# (token, scanState) = nextToken GeneralContext scanState
				= try_module_name token MK_Main scanState
			| token == ImpModuleToken 
				= try_module_token MK_Module scanState
			| token == SysModuleToken
				= try_module_token MK_System scanState
				= (False, MK_None, "", tokenBack scanState)
		| token == DefModuleToken
		  	= try_module_token MK_Module scanState
		| token == SysModuleToken
		  	= try_module_token MK_System scanState
			= (False, MK_None, "", tokenBack scanState)

John van Groningen's avatar
John van Groningen committed
350
	try_module_token :: !ModuleKind !ScanState -> (!Bool,!ModuleKind,!String,!ScanState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
351
352
353
354
355
356
357
358
	try_module_token mod_type scanState
		# (token, scanState) = nextToken GeneralContext scanState
		| token == ModuleToken
			# (token, scanState) = nextToken GeneralContext scanState
 			= try_module_name token mod_type scanState
			= (False, mod_type, "", tokenBack scanState)

	try_module_name (IdentToken name) mod_type scanState
Pieter Koopman's avatar
Pieter Koopman committed
359
		= (True, mod_type, name, scanState)
360
	try_module_name (UnderscoreIdentToken name) mod_type scanState
Pieter Koopman's avatar
Pieter Koopman committed
361
		= (True, mod_type, name, setUseUnderscoreIdents True scanState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
362
363
364
	try_module_name token mod_type scanState
		= (False, mod_type, "", tokenBack scanState)
	
365
	verify_name name id_name file_name pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
366
367
		| name == id_name
	  		= pState
368
			# ({fp_line}, pState=:{ps_error={pea_file}}) = getPosition pState
369
 			  pea_file = pea_file <<< "Error [" <<< file_name <<< ',' <<< fp_line <<< "]: module name \"" <<< name 
370
	  						<<< "\" does not match file name: \"" <<< file_name <<<"\"\n"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
371
372
373
374
375
376
377
378
379
			= { pState & ps_error = { pea_file = pea_file, pea_ok = False }}

	check_layout_rule pState
		# (token, pState)	= nextToken GeneralContext pState
		  use_layout		= token <> SemicolonToken && token <> EndOfFileToken // '&& token <> EndOfFileToken' to handle end groups of empty modules
		| use_layout		= appScanState (setUseLayout use_layout) (tokenBack pState)
							= appScanState (setUseLayout use_layout) pState

	want_definitions :: !ParseContext !ParseState -> (![ParsedDefinition], !ParseState)
Pieter Koopman's avatar
Pieter Koopman committed
380
	want_definitions parseContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
381
382
383
384
		= want_acc_definitions [] pState
	where
		want_acc_definitions :: ![ParsedDefinition] !ParseState -> (![ParsedDefinition], !ParseState)
		want_acc_definitions acc pState
Pieter Koopman's avatar
Pieter Koopman committed
385
			# (defs, pState)	= wantDefinitions parseContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
386
387
388
389
390
391
392
393
394
395
396
397
398
			  acc				= acc ++ defs
			  pState			= wantEndModule pState
			  (token, pState)	= nextToken FunctionContext pState
			| token == EndOfFileToken
				= (acc,  pState)
				# pState		= parseError "want definitions" (Yes token) "End of file" pState
				  pState		= wantEndOfDefinition "definitions" pState
				= want_acc_definitions acc pState
/*
	[Definition] on local and global level
*/

wantDefinitions :: !ParseContext !ParseState -> (![ParsedDefinition], !ParseState)
Pieter Koopman's avatar
Pieter Koopman committed
399
400
wantDefinitions parseContext pState
	= parseList (tryDefinition parseContext) pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
401
402
403
404
405
406
407

DummyPriority	:== Prio LeftAssoc 9

cHasPriority 	:== True
cHasNoPriority	:== False

tryDefinition :: !ParseContext !ParseState -> (!Bool, ParsedDefinition, !ParseState)
Pieter Koopman's avatar
Pieter Koopman committed
408
tryDefinition parseContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
409
410
	# (token, pState)			= nextToken GeneralContext pState
	  (fname, linenr, pState)	= getFileAndLineNr pState
Pieter Koopman's avatar
Pieter Koopman committed
411
	= try_definition parseContext token (LinePos fname linenr) pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
412
413
where
	try_definition :: !ParseContext !Token !Position !ParseState -> (!Bool, ParsedDefinition, !ParseState)
Pieter Koopman's avatar
Pieter Koopman committed
414
415
	try_definition parseContext DoubleColonToken pos pState
		| ~(isGlobalContext parseContext)
416
			= (False,abort "no def(3)",parseError "definition" No "type definitions only at the global level" (tokenBack pState))
Pieter Koopman's avatar
Pieter Koopman committed
417
			# (def, pState) = wantTypeDef parseContext pos pState
Pieter Koopman's avatar
Pieter Koopman committed
418
			= (True, def, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
419
	try_definition _ ImportToken pos pState
Pieter Koopman's avatar
Pieter Koopman committed
420
		| ~(isGlobalContext parseContext)
421
			= (False,abort "no def(3)",parseError "definition" No "imports only at the global level" pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
422
		# (token, pState) = nextToken FunctionContext pState
Pieter Koopman's avatar
Pieter Koopman committed
423
		| token == CodeToken && isIclContext parseContext
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
424
425
426
427
428
429
		# (importedObjects, pState) = wantCodeImports pState
		= (True, PD_ImportedObjects importedObjects, pState)
		# pState = tokenBack pState
		# (imports, pState) = wantImports pState
   		= (True, PD_Import imports, pState)
	try_definition _ FromToken pos pState
Pieter Koopman's avatar
Pieter Koopman committed
430
		| ~(isGlobalContext parseContext)
431
			= (False,abort "no def(3)",parseError "definition" No "imports only at the global level" pState)
Pieter Koopman's avatar
Pieter Koopman committed
432
433
			# (imp, pState) = wantFromImports pState
	   		= (True, PD_Import [imp], pState) -->> imp
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
434
435
436
437
438
/*	try_definition _ ExportToken pos pState
		# (exports, pState) = wantExportDef pState
   		= (True, PD_Export exports, pState)
	try_definition _ ExportAllToken pos pState
   		= (True, PD_Export ExportAll, pState)
Pieter Koopman's avatar
Pieter Koopman committed
439
440
*/	try_definition parseContext ClassToken pos pState
		| ~(isGlobalContext parseContext)
Pieter Koopman's avatar
Pieter Koopman committed
441
			= (False,abort "no def(2)",parseError "definition" No "class definitions are only at the global level" pState)
Pieter Koopman's avatar
Pieter Koopman committed
442
	   		# (classdef, pState) = wantClassDefinition parseContext pos pState
Pieter Koopman's avatar
Pieter Koopman committed
443
	   		= (True, classdef, pState)
444
	// AA..
Pieter Koopman's avatar
Pieter Koopman committed
445
446
	try_definition parseContext GenericToken pos pState
		| ~(isGlobalContext parseContext)
447
			= (False,abort "no def(2)",parseError "definition" No "generic definitions are only at the global level" pState)
Pieter Koopman's avatar
Pieter Koopman committed
448
	   		# (gendef, pState) = wantGenericDefinition parseContext pos pState
449
450
451
452
453
454
455
456
457
	   		= (True, gendef, pState)
	
	try_definition parseContext DeriveToken pos pState
		| ~(isGlobalContext parseContext)
			= (False,abort "no def(2)",parseError "definition" No "derive declarations are only at the global level" pState)   		
	   		# (gendef, pState) = wantDeriveDefinition parseContext pos pState
	   		= (True, gendef, pState)
	// ..AA 
	 		
Pieter Koopman's avatar
Pieter Koopman committed
458
459
	try_definition parseContext InstanceToken pos pState
		| ~(isGlobalContext parseContext)
Pieter Koopman's avatar
Pieter Koopman committed
460
			= (False,abort "no def(2)",parseError "definition" No "instance declarations are only at the global level" pState)
Pieter Koopman's avatar
Pieter Koopman committed
461
	   		# (instdef, pState) = wantInstanceDeclaration parseContext pos pState
Pieter Koopman's avatar
Pieter Koopman committed
462
	   		= (True, instdef, pState)
463
464
465
466
467
468

// AA : new syntax for generics ...
	try_definition parseContext (IdentToken name) pos pState
		# (token, pState) = nextToken FunctionContext pState
		= case token of
			GenericOpenToken // generic function
469
470
				//# (type, pState) = wantType pState
				# (ok, {at_type=type}, pState) = trySimpleType TA_None pState
471
472
473
				# (ident, pState) = stringToIdent name (IC_GenericCase type) pState				
				# (type_CONS_ident, pState) = stringToIdent "CONS" IC_Type pState
				# (type_FIELD_ident, pState)= stringToIdent "FIELD" IC_Type pState
Artem Alimarine's avatar
Artem Alimarine committed
474
				# (type_OBJECT_ident, pState)= stringToIdent "OBJECT" IC_Type pState
475
476
				# (generic_ident, pState) = stringToIdent name IC_Generic pState					

477
478
				# (type_cons, pState) = get_type_cons type pState
					with
479
480
481
482
483
						get_type_cons (TA type_symb []) pState
								= (TypeConsSymb type_symb, pState)							
						get_type_cons (TA type_symb _) pState
							# pState = parseError "generic type, no constructor arguments allowed" No " |}" pState
							= (abort "no TypeCons", pState)
484
485
486
487
488
489
490
						get_type_cons (TB tb) pState 
							= (TypeConsBasic tb, pState)
						get_type_cons TArrow pState
							= (TypeConsArrow, pState)				 
						get_type_cons (TV tv) pState
							= (TypeConsVar tv, pState)				 
						get_type_cons _ pState 
491
							# pState = parseError "generic type" No " |}" pState
492
493
							= (abort "no TypeCons", pState)

494
495
496
497
498
499
500
				# (token, pState) = nextToken GenericContext pState
				# (geninfo_arg, pState) = case token of
					GenericOfToken
						# (ok, geninfo_arg, pState) = trySimpleLhsExpression pState
						# pState = wantToken FunctionContext "type argument" GenericCloseToken pState
						| ok 
							-> case type_cons of
501
502
								(TypeConsSymb {type_ident})
									| type_ident == type_CONS_ident
503
504
										# (cons_CONS_ident, pState) = stringToIdent "GenericConsInfo" IC_Expression pState 
										-> (PE_List [PE_Ident cons_CONS_ident, geninfo_arg], pState)
505
									| type_ident == type_FIELD_ident 
506
										# (cons_FIELD_ident, pState) = stringToIdent "GenericFieldInfo" IC_Expression pState 
John van Groningen's avatar
John van Groningen committed
507
										-> (PE_List [PE_Ident cons_FIELD_ident, geninfo_arg], pState)
Artem Alimarine's avatar
Artem Alimarine committed
508
509
510
									| type_ident == type_OBJECT_ident 
										# (cons_OBJECT_ident, pState) = stringToIdent "GenericTypeDefInfo" IC_Expression pState 
										-> (PE_List [PE_Ident cons_OBJECT_ident, geninfo_arg], pState)
John van Groningen's avatar
John van Groningen committed
511
								_
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
									| otherwise
										-> (geninfo_arg, pState)
						| otherwise
							# pState = parseError "generic case" No "simple lhs expression" pState
							-> (PE_Empty, pState)
						 
					GenericCloseToken
						# (geninfo_ident, pState) =  stringToIdent "geninfo" IC_Expression pState
						-> (PE_Ident geninfo_ident, pState)
					_ 	
						# pState = parseError "generic type" (Yes token) "of or |}" pState
						# (geninfo_ident, pState) =  stringToIdent "geninfo" IC_Expression pState
						-> (PE_Ident geninfo_ident, pState)
																						
				//# pState = wantToken FunctionContext "type argument" GenericCloseToken pState
527
528
				# (args, pState) = parseList trySimpleLhsExpression pState

529
530
531
				//# (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState
				# args = SwitchGenericInfo [geninfo_arg :  args] args

532
533
534
535
				// must be EqualToken or HashToken or ???
				//# pState = wantToken FunctionContext "generic definition" EqualToken pState
				//# pState = tokenBack pState

536
			  	# (ss_useLayout, pState) = accScanState UseLayout pState
537
538
539
540
			    # localsExpected = isNotEmpty args || isGlobalContext parseContext || ~ ss_useLayout
			    # (rhs, _, pState) = wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) pState

				# generic_case = 
541
542
					{ gc_ident = ident
					, gc_gident = generic_ident
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
					, gc_generic = {gi_module=NoIndex,gi_index=NoIndex}
					, gc_arity = length args
					, gc_pos = pos
					, gc_type = type
					, gc_type_cons = type_cons
					, gc_body = GCB_ParsedBody args rhs
					, gc_kind = KindError	
					}					
				-> (True, PD_GenericCase generic_case, pState)
			_   // normal function
				# pState = tokenBack pState
				# (lhs, pState) = want_lhs_of_def (IdentToken name) pState
			      (token, pState) = nextToken FunctionContext pState
			      (def, pState) = want_rhs_of_def parseContext lhs token (determine_position lhs pos) pState
				-> (True, def, pState)
// ... AA
	   		
Pieter Koopman's avatar
Pieter Koopman committed
560
	try_definition parseContext token pos pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
561
562
563
		| isLhsStartToken token
			# (lhs, pState) = want_lhs_of_def token pState
		      (token, pState) = nextToken FunctionContext pState
Pieter Koopman's avatar
Pieter Koopman committed
564
		      (def, pState) = want_rhs_of_def parseContext lhs token (determine_position lhs pos) pState
565
			= (True, def, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
566
567
		= (False, abort "no def(1)", tokenBack pState)

568
569
570
	determine_position (Yes (name, _), _)	(LinePos f l) = FunPos f l name.id_name
	determine_position lhs           		pos           = pos

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
	want_lhs_of_def :: !Token !ParseState -> (!(Optional (Ident, Bool), ![ParsedExpr]), !ParseState)
	want_lhs_of_def token pState
		# (succ, fname, is_infix, pState) = try_function_symbol token pState
		| succ
			# (args, pState) = parseList trySimpleLhsExpression pState
			= ((Yes (fname, is_infix), args), pState)
			# (_, exp, pState) = trySimpleLhsExpression pState
			= ((No, [exp]), pState)
	where
		try_function_symbol :: !Token !ParseState -> (!Bool, Ident, !Bool, !ParseState) // (Success, Ident, Infix, ParseState)
		try_function_symbol (IdentToken name) pState
			# (id, pState) = stringToIdent name IC_Expression pState
			= (True, id, False, pState)
		try_function_symbol OpenToken pState
			# (token, pState) = nextToken FunctionContext pState
			= case token of
				(IdentToken name)
					# (token, pState) = nextToken FunctionContext pState
					| CloseToken == token
						# (id, pState) = stringToIdent name IC_Expression pState
						-> (True, id, True, pState)
						-> (False, abort "no name", False, tokenBack (tokenBack (tokenBack pState)))
				_
					-> (False,  abort "no name", False, tokenBack (tokenBack pState))
		try_function_symbol token pState
			= (False, abort "name", False, tokenBack pState)

	want_rhs_of_def :: !ParseContext !(Optional (Ident, Bool), [ParsedExpr]) !Token !Position !ParseState -> (ParsedDefinition, !ParseState)
Pieter Koopman's avatar
Pieter Koopman committed
599
	want_rhs_of_def parseContext (opt_name, args) DoubleColonToken pos pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
600
601
		# (name, is_infix, pState) = check_name_and_fixity opt_name cHasNoPriority pState
		  (tspec, pState) = want pState		//	SymbolType
Pieter Koopman's avatar
Pieter Koopman committed
602
		| isDclContext parseContext
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
603
604
605
			# (specials, pState) = optionalSpecials pState
			= (PD_TypeSpec pos name (if is_infix DummyPriority NoPrio) (Yes tspec) specials, wantEndOfDefinition "type definition (1)" pState)
			= (PD_TypeSpec pos name (if is_infix DummyPriority NoPrio) (Yes tspec) SP_None, wantEndOfDefinition "type definition (2)" pState)
Pieter Koopman's avatar
Pieter Koopman committed
606
	want_rhs_of_def parseContext (opt_name, args) (PriorityToken prio) pos pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
607
608
609
610
		# (name, _, pState) = check_name_and_fixity opt_name cHasPriority pState
		  (token, pState) = nextToken TypeContext pState
		| token == DoubleColonToken
		  	# (tspec, pState) = want pState
Pieter Koopman's avatar
Pieter Koopman committed
611
			| isDclContext parseContext
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
612
613
614
615
				# (specials, pState) = optionalSpecials pState
				= (PD_TypeSpec pos name prio (Yes tspec) specials, wantEndOfDefinition "type definition (3)" pState)
				= (PD_TypeSpec pos name prio (Yes tspec) SP_None, wantEndOfDefinition "type definition (4)" pState)
			= (PD_TypeSpec pos name prio No SP_None, wantEndOfDefinition "type defenition (5)" (tokenBack pState))
Pieter Koopman's avatar
Pieter Koopman committed
616
	want_rhs_of_def parseContext (No, args) token pos pState
Pieter Koopman's avatar
Pieter Koopman committed
617
		# pState			= want_node_def_token pState token
618
		# (ss_useLayout, pState) = accScanState UseLayout pState
Pieter Koopman's avatar
Pieter Koopman committed
619
		  localsExpected	= ~ ss_useLayout
620
		  (rhs, _, pState)		= wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) (tokenBack pState)
Pieter Koopman's avatar
Pieter Koopman committed
621
		| isGlobalContext parseContext
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
622
623
624
625
 			= (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
626
		want_node_def_token s DefinesColonToken = s // PK replaceToken EqualToken s
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
627
628
629
630
		want_node_def_token s token				= parseError "RHS" (Yes token) "defines token (= or =:)" s

		combine_args [arg]	= arg
		combine_args args	= PE_List args
631
632
633
	want_rhs_of_def parseContext (Yes (name, False), []) definingToken pos pState
		# code_allowed  = definingToken == EqualToken
		| isIclContext parseContext && isLocalContext parseContext && (definingToken == EqualToken || definingToken == DefinesColonToken) &&
634
		/* PK isLowerCaseName name.id_name && */ not (isClassOrInstanceDefsContext parseContext)
635
636
637
638
639
		  	# (token, pState) = nextToken FunctionContext pState
			| code_allowed && token == CodeToken
				# (rhs, pState) = wantCodeRhs pState
				= (PD_Function pos name False [] rhs (FK_Function cNameNotLocationDependent), pState)
			# pState = tokenBack pState
640
			# (rhs, _, pState) = wantRhs False (RhsDefiningSymbolExact definingToken) (tokenBack pState)
641
642
643
644
645
646
647
			| token == EqualToken
				= (PD_Function pos name False [] rhs FK_NodeDefOrFunction, pState)
			// otherwise // token == DefinesColonToken
 				| isGlobalContext parseContext
					= (PD_Function pos name False [] rhs FK_Caf, pState)
				// otherwise
					= (PD_NodeDef pos (PE_Ident name) rhs, pState)
Pieter Koopman's avatar
Pieter Koopman committed
648
	want_rhs_of_def parseContext (Yes (name, is_infix), args) token pos pState
649
		# code_allowed  = token == EqualToken || token == DoubleArrowToken
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
650
		  (token, pState) = nextToken FunctionContext pState
Pieter Koopman's avatar
Pieter Koopman committed
651
		| isIclContext parseContext && token == CodeToken
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
652
653
			# (rhs, pState) = wantCodeRhs pState
			| code_allowed
654
				= (PD_Function pos name is_infix args rhs (FK_Function cNameNotLocationDependent), pState)
655
			// otherwise // ~ code_allowed
656
				= (PD_Function pos name is_infix args rhs (FK_Function cNameNotLocationDependent), parseError "rhs of def" No "no code" pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
657
		# pState = tokenBack (tokenBack pState)
658
		  (ss_useLayout, pState) = accScanState UseLayout pState
Pieter Koopman's avatar
Pieter Koopman committed
659
		  localsExpected = isNotEmpty args || isGlobalContext parseContext || ~ ss_useLayout
660
661
662
		  (rhs, defining_symbol, pState)
		  		= wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) pState
		  fun_kind = definingSymbolToFunKind defining_symbol
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
663
		= case fun_kind of
Pieter Koopman's avatar
Pieter Koopman committed
664
			FK_Function _  | isDclContext parseContext
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
665
				->	(PD_Function pos name is_infix args rhs fun_kind, parseError "RHS" No "<type specification>" pState)
Pieter Koopman's avatar
Pieter Koopman committed
666
			FK_Caf | isNotEmpty args
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
667
				->	(PD_Function pos name is_infix []   rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState)
668
			_	->	(PD_Function pos name is_infix args rhs fun_kind, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
669
670
671
	check_name_and_fixity No hasprio pState
		= (erroneousIdent, False, parseError "Definition" No "identifier" pState)
	check_name_and_fixity (Yes (name,is_infix)) hasprio pState
672
		| not is_infix	&& hasprio
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
673
674
			= (name, False, parseError "Definition" No "Infix operator should be inside parentheses; no infix" pState)
			= (name, is_infix, pState)
675
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
676
677
678
isEqualToken :: !Token -> Bool
isEqualToken EqualToken			= True
isEqualToken _					= False
679
680
*/
/*
Pieter Koopman's avatar
Pieter Koopman committed
681
682
isRhsStartToken :: !ParseContext !Token -> Bool
isRhsStartToken parseContext EqualToken			= True
683
684
685
isRhsStartToken parseContext ColonDefinesToken	= isGlobalOrClassOrInstanceDefsContext parseContext
isRhsStartToken parseContext DefinesColonToken	= True
isRhsStartToken parseContext DoubleArrowToken	= True // PK
Pieter Koopman's avatar
Pieter Koopman committed
686
isRhsStartToken parseContext _					= False
687
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
688
689
690
691
692

optionalSpecials :: !ParseState -> (!Specials, !ParseState)
optionalSpecials pState
	# (token, pState) = nextToken TypeContext pState
	| token == SpecialToken
693
694
		# (token, pState) = nextToken GeneralContext pState
		  pState = begin_special_group token pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
695
		# (specials, pState) = wantList "<special statement>" try_substitutions pState
696
		= (SP_ParsedSubstitutions specials, end_special_group pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
	// otherwise // token <> SpecialToken
		= (SP_None, tokenBack pState)
where
	try_substitutions pState
		# (succ, type_var, pState) = tryTypeVar pState
		| succ
			# (subst, pState) = want_rest_substitutions type_var pState
			= (True, subst, wantEndOfDefinition "substitution" pState)
			= (False, [], pState)
	
	want_rest_substitutions type_var pState
		# pState = wantToken GeneralContext "specials" EqualToken pState
		  (type, pState) = want pState
		  (token, pState) = nextToken GeneralContext pState
		| token == CommaToken
			# (next_type_var, pState) = want pState
			  (substs, pState) = want_rest_substitutions next_type_var pState
			= ([{ bind_src = type, bind_dst = type_var } : substs], pState)
			= ([{ bind_src = type, bind_dst = type_var }], tokenBack pState)
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748

	begin_special_group token pState // For JvG layout
		# (token, pState)
			= case token of
				SemicolonToken	->	nextToken TypeContext pState
				_				->	(token, pState)
		# (ss_useLayout, pState) = accScanState UseLayout pState
		| ss_useLayout
			| token == CurlyOpenToken 
				= parseError "substitution" (Yes CurlyOpenToken) "in layout mode the keyword where is" pState
			// otherwise
				= tokenBack pState
		// not ss_useLayout
			| token == CurlyOpenToken 
				= pState
			// otherwise
				= tokenBack (parseError "substitution" (Yes token) "{" pState) 

	end_special_group pState
		# (ss_useLayout, pState) = accScanState UseLayout pState
		  (token, pState) = nextToken FunctionContext pState
		| token == EndOfFileToken && ss_useLayout
			= tokenBack pState
		| ss_useLayout
			= case token of
				EndGroupToken	->	pState
				_				->	parseError "substitution" (Yes token) "end of substitution with layout" pState
		// ~ ss_useLayout
		| token == CurlyCloseToken
			= pState
		// otherwise // token <> CurlyCloseToken
			= parseError "substitution" (Yes token) "end of substitution with layout, }," pState

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
749
750
751
752
753
754
755
/*
	For parsing right-hand sides of functions only
*/

wantCodeRhs :: !ParseState -> (Rhs, !ParseState)
wantCodeRhs pState
	# (expr, pState)	= want_code_expr pState
756
	  (file_name, line_nr, pState)	= getFileAndLineNr pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
757
758
759
760
	= (	{ rhs_alts		= UnGuardedExpr
							{ ewl_nodes		= []
							, ewl_locals	= LocalParsedDefs []
							, ewl_expr		= expr
761
							, ewl_position	= LinePos file_name line_nr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
762
763
764
							}
		, rhs_locals	= LocalParsedDefs []
		}
765
	  , wantEndCodeRhs pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
	  )
where
	want_code_expr :: !ParseState -> (!ParsedExpr, !ParseState)
	want_code_expr pState
		# (token, pState) = nextToken CodeContext pState
		= case token of
			OpenToken
				#	(input, pState)	= want_bindings [] True pState
					pState			= wantToken CodeContext "input bindings of code block" CloseToken pState
					pState			= wantToken CodeContext "output bindings of code block" OpenToken pState
					(out, pState)	= want_bindings [] False pState
					pState			= wantToken CodeContext "output bindings of code block" CloseToken pState
					(token, pState)	= nextToken CodeContext pState
				->	case token of
						CodeBlockToken the_code
							-> (PE_Any_Code input out the_code, pState)
						_	-> (PE_Any_Code input out []  , parseError "code rhs (any code)" (Yes token) "code block" pState)
			InlineToken
			 	#	(token, pState) = nextToken CodeContext pState
			 	->	case token of
			 			CodeBlockToken the_code
			 				-> (PE_ABC_Code the_code True, pState)
			 			token
			 				-> (PE_ABC_Code [] True,  parseError "inline code" (Yes token) "code block" pState)
			CodeBlockToken the_code
				-> (PE_ABC_Code the_code False, pState)
			token
				-> (PE_Empty, parseError "code rhs" (Yes token) "<code rhs>" pState)

	want_bindings :: !(CodeBinding Ident) !Bool !ParseState -> (!CodeBinding Ident, !ParseState)
	want_bindings acc mayBeEmpty pState
		# (token, pState)	= nextToken CodeContext pState
		= case token of
			IdentToken name
				#	(token, pState)	= nextToken CodeContext pState
				|	token == EqualToken || token == DefinesColonToken
					#	(token, pState)	= nextToken CodeContext pState
					->	case token of
							IdentToken value
								#	(ident, pState)	= stringToIdent name IC_Expression pState
									acc				= [{ bind_dst = ident, bind_src = value }: acc]
									(token, pState)	= nextToken CodeContext pState
								|	token == CommaToken
									->	want_bindings acc mayBeEmpty pState
								//	token <> CommaToken
									->	(reverse acc, tokenBack pState)
							token
								-> (acc, parseError "bindings in code block" (Yes token) "value" pState)
				//	token <> EqualToken && token <> DefinesColonToken
					->	(acc, parseError "bindings in code block" (Yes token) "= or =:" pState)
			CloseToken
				| mayBeEmpty
					-> (acc, tokenBack pState) // to handle empty input bindings
					-> (acc, parseError "code bindings" (Yes token) "output bindings" pState)
			token
				-> (acc, parseError "bindings in code block" (Yes token) "identifier" pState)
/*
	For parsing right-hand sides of functions and case expressions
*/
/* Syntax:
	FunctionAltDefRhs	=	FunctionBody						// Rhs
							[ LocalFunctionAltDefs ]
	FunctionBody		=	exprWithLocals						// OptGuardedAlts	: GuardedAlts
						|	GuardedAlts 						//					: UnGuardedExpr
	GuardedAlts			=	{ [ LetBefore ] '|' [ StrictLet ] Guard FunctionBody }+ [ ExprWithLocals ]
	ExprWithLocals		=	[ LetBefore ] sep RootExpression endOfDefinition [ LocalFunctionDefs ]
*/

834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866

isRhsStartToken :: !ParseContext !Token -> Bool
isRhsStartToken parseContext EqualToken			= True
isRhsStartToken parseContext ColonDefinesToken	= isGlobalOrClassOrInstanceDefsContext parseContext
isRhsStartToken parseContext DefinesColonToken	= True
isRhsStartToken parseContext DoubleArrowToken	= True // PK
isRhsStartToken parseContext _					= False

:: RhsDefiningSymbol
	=	RhsDefiningSymbolExact Token
	|	RhsDefiningSymbolCase			// '->' or '='
	|	RhsDefiningSymbolRule			// '=', '=:', '=>'
	|	RhsDefiningSymbolRuleOrMacro	// '=', '=:', '=>', ':=='

ruleDefiningRhsSymbol :: !ParseContext -> RhsDefiningSymbol
ruleDefiningRhsSymbol parseContext
	| isGlobalOrClassOrInstanceDefsContext parseContext
		=	RhsDefiningSymbolRuleOrMacro
	// otherwise
		=	RhsDefiningSymbolRule

isDefiningSymbol :: RhsDefiningSymbol Token -> Bool
isDefiningSymbol (RhsDefiningSymbolExact wanted) observed
	=	wanted == observed
isDefiningSymbol RhsDefiningSymbolCase observed
	=	observed == EqualToken || observed == ArrowToken
isDefiningSymbol RhsDefiningSymbolRule observed
	=	observed == EqualToken || observed == DefinesColonToken || observed == DoubleArrowToken
isDefiningSymbol RhsDefiningSymbolRuleOrMacro observed
	=	observed == ColonDefinesToken || isDefiningSymbol RhsDefiningSymbolRule observed

definingSymbolToFunKind :: RhsDefiningSymbol -> FunKind
definingSymbolToFunKind (RhsDefiningSymbolExact defining_token)
867
	=	definingTokenToFunKind defining_token
868
869
870
definingSymbolToFunKind _
	=	FK_Unknown

871
872
873
874
875
876
877
878
879
880
881
882
definingTokenToFunKind :: Token -> FunKind
definingTokenToFunKind ColonDefinesToken
	=	FK_Macro
definingTokenToFunKind EqualToken
	=	FK_Function cNameNotLocationDependent
definingTokenToFunKind DoubleArrowToken
	=	FK_Function cNameNotLocationDependent
definingTokenToFunKind DefinesColonToken
	=	FK_Caf
definingTokenToFunKind _
	=	FK_Unknown

883
884
885
wantRhs :: !Bool !RhsDefiningSymbol !ParseState -> (!Rhs, !RhsDefiningSymbol, !ParseState) // FunctionAltDefRhs
wantRhs localsExpected definingSymbol pState
	# (alts, definingSymbol, pState)	= want_LetsFunctionBody definingSymbol pState
Pieter Koopman's avatar
Pieter Koopman committed
886
	  (locals, pState)	= optionalLocals WhereToken localsExpected pState
887
	= ({ rhs_alts = alts, rhs_locals = locals}, definingSymbol, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
888
where
889
890
	want_LetsFunctionBody :: !RhsDefiningSymbol  !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState) 
	want_LetsFunctionBody definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
891
892
		# (token, pState)			= nextToken FunctionContext pState
		  (nodeDefs, token, pState)	= want_LetBefores token pState
893
		= want_FunctionBody token nodeDefs [] definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
894

895
896
	want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState)
	want_FunctionBody BarToken nodeDefs alts definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
897
//		#	(lets, pState)				= want_StrictLet pState // removed from 2.0
898
		#	(file_name, line_nr, pState)= getFileAndLineNr pState
899
			(token, pState)				= nextToken FunctionContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
900
901
902
		|	token == OtherwiseToken
			#	(token, pState)				= nextToken FunctionContext pState
				(nodeDefs2, token, pState)	= want_LetBefores token pState
903
			= want_FunctionBody token (nodeDefs ++ nodeDefs2) alts definingSymbol pState // to allow | otherwise | c1 = .. | c2 = ..
904
/* PK ??? 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
905
906
907
			=	case token of
				BarToken
					#	pState = parseError "RHS: default alternative" No "root expression instead of guarded expression" pState
Pieter Koopman's avatar
Pieter Koopman committed
908
909
					->	root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState
				_	->	root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState
910
*/		|	token == LetToken True
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
911
			#	pState	= parseError "RHS" No "No 'let!' in this version of Clean" pState
912
			=	root_expression True token nodeDefs (reverse alts) definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
913
914
915
916
917
918
		#	(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
919
920
				(expr, definingSymbol, pState)
											= want_FunctionBody token nodeDefs2 [] definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
921
				pState						= wantEndNestedGuard (default_found expr) offside pState
922
				alt							= { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
923
												alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
924
925
				(token, pState)				= nextToken FunctionContext pState
				(nodeDefs, token, pState)	= want_LetBefores token pState
926
			=	want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
927
		// otherwise
928
929
			#	(expr, definingSymbol, pState)
											= root_expression True token nodeDefs2 [] definingSymbol pState
930
				alt							= { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
931
												alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
932
933
				(token, pState)				= nextToken FunctionContext pState
				(nodeDefs, token, pState)	= want_LetBefores token pState
934
			=	want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState
935
936
937
	  where
	  	guard_ident line_nr
			= { id_name = "_g;" +++ toString line_nr +++ ";", id_info = nilPtr }
938
939
940
941
942
943
944
	want_FunctionBody token nodeDefs alts definingSymbol pState
		=	root_expression localsExpected token nodeDefs (reverse alts) definingSymbol pState

	root_expression :: !Bool !Token ![NodeDefWithLocals] ![GuardedExpr] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState)
	root_expression withExpected token nodeDefs alts definingSymbol pState
		# (optional_expr,definingSymbol,pState) = want_OptExprWithLocals withExpected token nodeDefs definingSymbol pState
		= build_root token optional_expr alts nodeDefs definingSymbol pState
945
	where
946
947
948
949
950
951
952
953
		build_root :: !Token !(Optional ExprWithLocalDefs) ![GuardedExpr] ![NodeDefWithLocals] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState)
		build_root _ (Yes expr) [] _ definingSymbol pState
			= ( UnGuardedExpr expr, definingSymbol, pState)
		build_root _ No alts=:[_:_] [] definingSymbol pState
			= (GuardedAlts alts No, definingSymbol, pState)
		build_root _ optional_expr alts=:[_:_] _ definingSymbol pState
			= (GuardedAlts alts optional_expr, definingSymbol, pState)
		build_root token _ _ _ definingSymbol pState
954
			# (file_name, line_nr, pState)	= getFileAndLineNr pState
955
			=	(UnGuardedExpr {ewl_nodes = [], ewl_expr = PE_Empty, ewl_locals = LocalParsedDefs [],
956
												ewl_position = LinePos file_name line_nr}
957
							, definingSymbol
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
958
959
							, parseError "RHS: root expression" (Yes token) "= <ExprWithLocals>" pState
							)
960

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
961
962
963
	default_found (GuardedAlts _ No)	= False
	default_found _						= True

John van Groningen's avatar
John van Groningen committed
964
	want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !RhsDefiningSymbol !ParseState -> (!Optional ExprWithLocalDefs, !RhsDefiningSymbol, !ParseState)
965
966
//	want_OptExprWithLocals withExpected DoubleArrowToken nodeDefs pState
//		= want_OptExprWithLocals True EqualToken nodeDefs (replaceToken EqualToken pState)
967
968
	want_OptExprWithLocals withExpected token nodeDefs definingSymbol pState
		| isDefiningSymbol definingSymbol token
969
		# (file_name, line_nr, pState)	= getFileAndLineNr pState
970
		  (expr, pState)	= wantExpression cIsNotAPattern pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
971
		  pState			= wantEndRootExpression pState
Pieter Koopman's avatar
Pieter Koopman committed
972
		  (locals,pState)	= optionalLocals WithToken withExpected pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
973
974
975
		= ( Yes	{ ewl_nodes		= nodeDefs
				, ewl_expr		= expr
				, ewl_locals	= locals
976
				, ewl_position	= LinePos file_name line_nr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
977
				}
978
		  , RhsDefiningSymbolExact token
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
979
980
		  , pState
		  )
981
982
983
		= (No, definingSymbol, tokenBack pState)


Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/*	want_StrictLet :: !ParseState -> ([NodeDefWithLocals] , !ParseState) // Removed from the language !?
	want_StrictLet pState
		# (token, pState)	= nextToken FunctionContext pState
		| token == LetToken True
			# (let_defs, pState)	= wantList "<sequential node defs>" (try_LetDef True) pState
			  pState				= wantToken FunctionContext "strict let" InToken pState
			= (let_defs, pState)
		= ([], tokenBack pState)
*/ 
	want_LetBefores :: !Token !ParseState -> (![NodeDefWithLocals], !Token, !ParseState)
	want_LetBefores (SeqLetToken strict) pState
		# (let_defs, pState)				= wantList "<sequential node defs>" (try_LetDef strict) pState
		  (token, pState)					= nextToken FunctionContext pState
		  (token, pState)					= opt_End_Group token pState
		  (more_let_defs, token, pState)	= want_LetBefores token pState
		= (let_defs ++ more_let_defs, token, pState)
		where
For faster browsing, not all history is shown. View entire blame