parse.icl 176 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
		= ([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
242
		= (DefaultPriority, tokenBack pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
243
244
245
246
247
248
		= (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
isNotClassOrInstanceDefsContext parseContext		:== parseContext bitand cClassOrInstanceDefsContext == 0
280
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)
John van Groningen's avatar
John van Groningen committed
295
			-> let mod = { mod_ident = file_id,  mod_modification_time = "", mod_type = MK_None, mod_imports = [], mod_imported_objects = [],mod_foreign_exports=[],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
John van Groningen's avatar
John van Groningen committed
320
			  mod	= { mod_ident = mod_ident, mod_modification_time = modification_time, mod_type = mod_type, mod_imports = [], mod_imported_objects = [], mod_foreign_exports=[],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
John van Groningen's avatar
John van Groningen committed
328
		  mod = { mod_ident = file_id,  mod_modification_time = modification_time, mod_type = mod_type, mod_imports = [], mod_imported_objects = [],mod_foreign_exports=[],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

cHasPriority 	:== True
cHasNoPriority	:== False

tryDefinition :: !ParseContext !ParseState -> (!Bool, ParsedDefinition, !ParseState)
Pieter Koopman's avatar
Pieter Koopman committed
406
tryDefinition parseContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
407
408
	# (token, pState)			= nextToken GeneralContext pState
	  (fname, linenr, pState)	= getFileAndLineNr pState
Pieter Koopman's avatar
Pieter Koopman committed
409
	= try_definition parseContext token (LinePos fname linenr) pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
410
411
where
	try_definition :: !ParseContext !Token !Position !ParseState -> (!Bool, ParsedDefinition, !ParseState)
Pieter Koopman's avatar
Pieter Koopman committed
412
413
	try_definition parseContext DoubleColonToken pos pState
		| ~(isGlobalContext parseContext)
414
			= (False,abort "no def(3)",parseError "definition" No "type definitions only at the global level" (tokenBack pState))
Pieter Koopman's avatar
Pieter Koopman committed
415
			# (def, pState) = wantTypeDef parseContext pos pState
Pieter Koopman's avatar
Pieter Koopman committed
416
			= (True, def, pState)
John van Groningen's avatar
John van Groningen committed
417
418
419
420
421
422
423
424
425
426
427
428
	try_definition parseContext (IdentToken name) pos pState
		# (token, pState) = nextToken FunctionContext pState
		= case token of
			GenericOpenToken
				// generic function
				-> wantGenericFunctionDefinition name pos 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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
429
	try_definition _ ImportToken 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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
432
		# (token, pState) = nextToken FunctionContext pState
Pieter Koopman's avatar
Pieter Koopman committed
433
		| token == CodeToken && isIclContext parseContext
John van Groningen's avatar
John van Groningen committed
434
435
436
437
438
			# (importedObjects, pState) = wantCodeImports pState
			= (True, PD_ImportedObjects importedObjects, pState)
			# pState = tokenBack pState
			# (imports, pState) = wantImports pState
	   		= (True, PD_Import imports, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
439
	try_definition _ FromToken pos pState
Pieter Koopman's avatar
Pieter Koopman committed
440
		| ~(isGlobalContext parseContext)
441
			= (False,abort "no def(3)",parseError "definition" No "imports only at the global level" pState)
Pieter Koopman's avatar
Pieter Koopman committed
442
443
			# (imp, pState) = wantFromImports pState
	   		= (True, PD_Import [imp], pState) -->> imp
John van Groningen's avatar
John van Groningen committed
444
	try_definition parseContext ClassToken pos pState
Pieter Koopman's avatar
Pieter Koopman committed
445
		| ~(isGlobalContext parseContext)
Pieter Koopman's avatar
Pieter Koopman committed
446
			= (False,abort "no def(2)",parseError "definition" No "class definitions are only at the global level" pState)
Pieter Koopman's avatar
Pieter Koopman committed
447
	   		# (classdef, pState) = wantClassDefinition parseContext pos pState
Pieter Koopman's avatar
Pieter Koopman committed
448
	   		= (True, classdef, pState)
Pieter Koopman's avatar
Pieter Koopman committed
449
450
	try_definition parseContext GenericToken pos pState
		| ~(isGlobalContext parseContext)
451
			= (False,abort "no def(2)",parseError "definition" No "generic definitions are only at the global level" pState)
Pieter Koopman's avatar
Pieter Koopman committed
452
	   		# (gendef, pState) = wantGenericDefinition parseContext pos pState
453
454
455
456
457
458
	   		= (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)
Pieter Koopman's avatar
Pieter Koopman committed
459
460
	try_definition parseContext InstanceToken pos pState
		| ~(isGlobalContext parseContext)
Pieter Koopman's avatar
Pieter Koopman committed
461
			= (False,abort "no def(2)",parseError "definition" No "instance declarations are only at the global level" pState)
Pieter Koopman's avatar
Pieter Koopman committed
462
	   		# (instdef, pState) = wantInstanceDeclaration parseContext pos pState
Pieter Koopman's avatar
Pieter Koopman committed
463
	   		= (True, instdef, pState)
John van Groningen's avatar
John van Groningen committed
464
465
466
467
468
469
	try_definition parseContext ForeignToken pos pState
		| not (isGlobalContext parseContext)
			= (False,abort "no def",parseErrorSimple "definition" "foreign export definitions are only allowed at the global level" pState)
		| isDclContext parseContext
			= (False,abort "no def",parseErrorSimple "definition" "foreign export definitions are only allowed in implementation modules" pState)
			= wantForeignExportDefinition pState
Pieter Koopman's avatar
Pieter Koopman committed
470
	try_definition parseContext token pos pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
471
472
473
		| isLhsStartToken token
			# (lhs, pState) = want_lhs_of_def token pState
		      (token, pState) = nextToken FunctionContext pState
Pieter Koopman's avatar
Pieter Koopman committed
474
		      (def, pState) = want_rhs_of_def parseContext lhs token (determine_position lhs pos) pState
475
			= (True, def, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
476
477
		= (False, abort "no def(1)", tokenBack pState)

478
479
480
	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
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
	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)
509
	want_rhs_of_def parseContext (opt_name, []) DoubleColonToken pos pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
510
511
		# (name, is_infix, pState) = check_name_and_fixity opt_name cHasNoPriority pState
		  (tspec, pState) = want pState		//	SymbolType
Pieter Koopman's avatar
Pieter Koopman committed
512
		| isDclContext parseContext
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
513
			# (specials, pState) = optionalSpecials pState
514
515
			= (PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) specials, wantEndOfDefinition "type definition (1)" pState)
			= (PD_TypeSpec pos name (if is_infix DefaultPriority NoPrio) (Yes tspec) SP_None, wantEndOfDefinition "type definition (2)" pState)
Pieter Koopman's avatar
Pieter Koopman committed
516
	want_rhs_of_def parseContext (opt_name, args) (PriorityToken prio) pos pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
517
518
519
520
		# (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
521
			| isDclContext parseContext
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
522
523
524
525
				# (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
526
	want_rhs_of_def parseContext (No, args) token pos pState
Pieter Koopman's avatar
Pieter Koopman committed
527
		# pState			= want_node_def_token pState token
528
		# (ss_useLayout, pState) = accScanState UseLayout pState
Pieter Koopman's avatar
Pieter Koopman committed
529
		  localsExpected	= ~ ss_useLayout
530
		  (rhs, _, pState)		= wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) (tokenBack pState)
531
532
533
534
535
		| isLocalContext parseContext
			| isNotClassOrInstanceDefsContext parseContext
 				= (PD_NodeDef pos (combine_args args) rhs, pState)
	 			= (PD_NodeDef pos (combine_args args) rhs, parseError "RHS" No "<class or instance definition>" pState)
			= (PD_NodeDef pos (combine_args args) rhs, parseError "RHS" No "<global definition>" pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
536
537
	where		
		want_node_def_token s EqualToken		= s
538
		want_node_def_token s DefinesColonToken = s // PK replaceToken EqualToken s
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
539
540
541
542
		want_node_def_token s token				= parseError "RHS" (Yes token) "defines token (= or =:)" s

		combine_args [arg]	= arg
		combine_args args	= PE_List args
543
544
545
	want_rhs_of_def parseContext (Yes (name, False), []) definingToken pos pState
		# code_allowed  = definingToken == EqualToken
		| isIclContext parseContext && isLocalContext parseContext && (definingToken == EqualToken || definingToken == DefinesColonToken) &&
546
		/* PK isLowerCaseName name.id_name && */ isNotClassOrInstanceDefsContext parseContext
547
548
549
550
551
		  	# (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
552
			# (rhs, _, pState) = wantRhs False (RhsDefiningSymbolExact definingToken) (tokenBack pState)
553
554
555
556
557
558
559
			| 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
560
	want_rhs_of_def parseContext (Yes (name, is_infix), args) token pos pState
561
		# code_allowed  = token == EqualToken || token == DoubleArrowToken
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
562
		  (token, pState) = nextToken FunctionContext pState
Pieter Koopman's avatar
Pieter Koopman committed
563
		| isIclContext parseContext && token == CodeToken
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
564
565
			# (rhs, pState) = wantCodeRhs pState
			| code_allowed
566
				= (PD_Function pos name is_infix args rhs (FK_Function cNameNotLocationDependent), pState)
567
			// otherwise // ~ code_allowed
568
				= (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
569
		# pState = tokenBack (tokenBack pState)
570
		  (ss_useLayout, pState) = accScanState UseLayout pState
Pieter Koopman's avatar
Pieter Koopman committed
571
		  localsExpected = isNotEmpty args || isGlobalContext parseContext || ~ ss_useLayout
572
573
574
		  (rhs, defining_symbol, pState)
		  		= wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) pState
		  fun_kind = definingSymbolToFunKind defining_symbol
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
575
		= case fun_kind of
Pieter Koopman's avatar
Pieter Koopman committed
576
			FK_Function _  | isDclContext parseContext
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
577
				->	(PD_Function pos name is_infix args rhs fun_kind, parseError "RHS" No "<type specification>" pState)
Pieter Koopman's avatar
Pieter Koopman committed
578
			FK_Caf | isNotEmpty args
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
579
				->	(PD_Function pos name is_infix []   rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState)
580
			_	->	(PD_Function pos name is_infix args rhs fun_kind, pState)
581

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
582
583
584
	check_name_and_fixity No hasprio pState
		= (erroneousIdent, False, parseError "Definition" No "identifier" pState)
	check_name_and_fixity (Yes (name,is_infix)) hasprio pState
585
		| not is_infix	&& hasprio
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
586
587
			= (name, False, parseError "Definition" No "Infix operator should be inside parentheses; no infix" pState)
			= (name, is_infix, pState)
John van Groningen's avatar
John van Groningen committed
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681

	wantGenericFunctionDefinition name pos pState
		//# (type, pState) = wantType pState
		# (ok, {at_type=type}, pState) = trySimpleType TA_None pState
		# (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
		# (type_OBJECT_ident, pState)= stringToIdent "OBJECT" IC_Type pState
		# (generic_ident, pState) = stringToIdent name IC_Generic pState					
	
		# (type_cons, pState) = get_type_cons type pState
			with
				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)
				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 
					# pState = parseError "generic type" No " |}" pState
					= (abort "no TypeCons", pState)
	
		# (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
						(TypeConsSymb {type_ident})
							| type_ident == type_CONS_ident
								# (cons_CONS_ident, pState) = stringToIdent "GenericConsInfo" IC_Expression pState 
								-> (PE_List [PE_Ident cons_CONS_ident, geninfo_arg], pState)
							| type_ident == type_FIELD_ident 
								# (cons_FIELD_ident, pState) = stringToIdent "GenericFieldInfo" IC_Expression pState 
								-> (PE_List [PE_Ident cons_FIELD_ident, geninfo_arg], pState)
							| type_ident == type_OBJECT_ident 
								# (cons_OBJECT_ident, pState) = stringToIdent "GenericTypeDefInfo" IC_Expression pState 
								-> (PE_List [PE_Ident cons_OBJECT_ident, geninfo_arg], pState)
						_
							| 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
		# (args, pState) = parseList trySimpleLhsExpression pState
	
		//# (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState
		# args = SwitchGenericInfo [geninfo_arg :  args] args
	
		// must be EqualToken or HashToken or ???
		//# pState = wantToken FunctionContext "generic definition" EqualToken pState
		//# pState = tokenBack pState
	
	  	# (ss_useLayout, pState) = accScanState UseLayout pState
	    # localsExpected = isNotEmpty args || isGlobalContext parseContext || ~ ss_useLayout
	    # (rhs, _, pState) = wantRhs localsExpected (ruleDefiningRhsSymbol parseContext) pState
	
		# generic_case = 
			{ gc_ident = ident
			, gc_gident = generic_ident
			, 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)

	wantForeignExportDefinition pState
		# (token, pState) = nextToken GeneralContext pState
		# (file_name,line_nr,pState) = getFileAndLineNr pState
		= case token of
			IdentToken "export"
				# (token, pState) = nextToken FunctionContext pState
				-> case token of
					IdentToken function_name
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
						| function_name=="ccall"
							# (token2, pState) = nextToken FunctionContext pState
							-> case token2 of
								IdentToken function_name
									-> accept_foreign_export function_name line_nr False pState
								_
									-> accept_foreign_export function_name line_nr False (tokenBack pState)
						| function_name=="stdcall"
							# (token2, pState) = nextToken FunctionContext pState
							-> case token2 of 
								IdentToken function_name
									-> accept_foreign_export function_name line_nr True pState
								_
									-> accept_foreign_export function_name line_nr False (tokenBack pState)
							-> accept_foreign_export function_name line_nr False pState
John van Groningen's avatar
John van Groningen committed
697
698
					_
						-> foreign_export_error "function name" pState
699
700
701
702
703
				where
					accept_foreign_export function_name line_nr stdcall pState
						# pState = wantEndOfDefinition "foreign export" pState
						# (ident,pState) = stringToIdent function_name IC_Expression pState
						= (True,PD_ForeignExport ident file_name line_nr stdcall,pState)
John van Groningen's avatar
John van Groningen committed
704
705
706
707
708
709
			_
				-> foreign_export_error "export" pState
		where
			foreign_export_error s pState
				= (True,PD_Erroneous,tokenBack (parseError "foreign export" No s pState))

710
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
711
712
713
isEqualToken :: !Token -> Bool
isEqualToken EqualToken			= True
isEqualToken _					= False
714
715
*/
/*
Pieter Koopman's avatar
Pieter Koopman committed
716
717
isRhsStartToken :: !ParseContext !Token -> Bool
isRhsStartToken parseContext EqualToken			= True
718
719
720
isRhsStartToken parseContext ColonDefinesToken	= isGlobalOrClassOrInstanceDefsContext parseContext
isRhsStartToken parseContext DefinesColonToken	= True
isRhsStartToken parseContext DoubleArrowToken	= True // PK
Pieter Koopman's avatar
Pieter Koopman committed
721
isRhsStartToken parseContext _					= False
722
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
723
724
725
726
727

optionalSpecials :: !ParseState -> (!Specials, !ParseState)
optionalSpecials pState
	# (token, pState) = nextToken TypeContext pState
	| token == SpecialToken
728
729
		# (token, pState) = nextToken GeneralContext pState
		  pState = begin_special_group token pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
730
		# (specials, pState) = wantList "<special statement>" try_substitutions pState
731
		= (SP_ParsedSubstitutions specials, end_special_group pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
	// 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)
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783

	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
784
785
786
787
788
789
790
/*
	For parsing right-hand sides of functions only
*/

wantCodeRhs :: !ParseState -> (Rhs, !ParseState)
wantCodeRhs pState
	# (expr, pState)	= want_code_expr pState
791
	  (file_name, line_nr, pState)	= getFileAndLineNr pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
792
793
794
795
	= (	{ rhs_alts		= UnGuardedExpr
							{ ewl_nodes		= []
							, ewl_locals	= LocalParsedDefs []
							, ewl_expr		= expr
796
							, ewl_position	= LinePos file_name line_nr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
797
798
799
							}
		, rhs_locals	= LocalParsedDefs []
		}
800
	  , wantEndCodeRhs pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
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
867
868
	  )
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 ]
*/

869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901

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)
902
	=	definingTokenToFunKind defining_token
903
904
905
definingSymbolToFunKind _
	=	FK_Unknown

906
907
908
909
910
911
912
913
914
915
916
917
definingTokenToFunKind :: Token -> FunKind
definingTokenToFunKind ColonDefinesToken
	=	FK_Macro
definingTokenToFunKind EqualToken
	=	FK_Function cNameNotLocationDependent
definingTokenToFunKind DoubleArrowToken
	=	FK_Function cNameNotLocationDependent
definingTokenToFunKind DefinesColonToken
	=	FK_Caf
definingTokenToFunKind _
	=	FK_Unknown

918
919
920
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
921
	  (locals, pState)	= optionalLocals WhereToken localsExpected pState
922
	= ({ rhs_alts = alts, rhs_locals = locals}, definingSymbol, pState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
923
where
924
925
	want_LetsFunctionBody :: !RhsDefiningSymbol  !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState) 
	want_LetsFunctionBody definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
926
927
		# (token, pState)			= nextToken FunctionContext pState
		  (nodeDefs, token, pState)	= want_LetBefores token pState
928
		= want_FunctionBody token nodeDefs [] definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
929

930
931
	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
932
//		#	(lets, pState)				= want_StrictLet pState // removed from 2.0
933
		#	(file_name, line_nr, pState)= getFileAndLineNr pState
934
			(token, pState)				= nextToken FunctionContext pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
935
936
937
		|	token == OtherwiseToken
			#	(token, pState)				= nextToken FunctionContext pState
				(nodeDefs2, token, pState)	= want_LetBefores token pState
938
			= want_FunctionBody token (nodeDefs ++ nodeDefs2) alts definingSymbol pState // to allow | otherwise | c1 = .. | c2 = ..
939
/* PK ??? 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
940
941
942
			=	case token of
				BarToken
					#	pState = parseError "RHS: default alternative" No "root expression instead of guarded expression" pState
Pieter Koopman's avatar
Pieter Koopman committed
943
944
					->	root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState
				_	->	root_expression True token (nodeDefs ++ nodeDefs2) (reverse alts) sep pState
945
*/		|	token == LetToken True
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
946
			#	pState	= parseError "RHS" No "No 'let!' in this version of Clean" pState
947
			=	root_expression True token nodeDefs (reverse alts) definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
948
949
950
951
952
953
		#	(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
954
955
				(expr, definingSymbol, pState)
											= want_FunctionBody token nodeDefs2 [] definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
956
				pState						= wantEndNestedGuard (default_found expr) offside pState
957
				alt							= { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
958
												alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
959
960
				(token, pState)				= nextToken FunctionContext pState
				(nodeDefs, token, pState)	= want_LetBefores token pState
961
			=	want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
962
		// otherwise
963
964
			#	(expr, definingSymbol, pState)
											= root_expression True token nodeDefs2 [] definingSymbol pState
965
				alt							= { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr,
966
												alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
967
968
				(token, pState)				= nextToken FunctionContext pState
				(nodeDefs, token, pState)	= want_LetBefores token pState
969
			=	want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState
970
971
972
	  where
	  	guard_ident line_nr
			= { id_name = "_g;" +++ toString line_nr +++ ";", id_info = nilPtr }
973
974
975
976
977
978
979
	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
980
	where
981
982
983
984
985
986
987
988
		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
989
			# (file_name, line_nr, pState)	= getFileAndLineNr pState
990
			=	(UnGuardedExpr {ewl_nodes = [], ewl_expr = PE_Empty, ewl_locals = LocalParsedDefs [],
991
												ewl_position = LinePos file_name line_nr}
992
							, definingSymbol
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
993
994
							, parseError "RHS: root expression" (Yes token) "= <ExprWithLocals>" pState
							)
995

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
996
997
998
	default_found (GuardedAlts _ No)	= False
	default_found _						= True

John van Groningen's avatar
John van Groningen committed
999
	want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !RhsDefiningSymbol !ParseState -> (!Optional ExprWithLocalDefs, !RhsDefiningSymbol, !ParseState)
1000
1001
//	want_OptExprWithLocals withExpected DoubleArrowToken nodeDefs pState
//		= want_OptExprWithLocals True EqualToken nodeDefs (replaceToken EqualToken pState)
1002
1003
	want_OptExprWithLocals withExpected token nodeDefs definingSymbol pState
		| isDefiningSymbol definingSymbol token
1004
		# (file_name, line_nr, pState)	= getFileAndLineNr pState
1005
		  (expr, pState)	= wantExpression cIsNotAPattern pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1006
		  pState			= wantEndRootExpression pState
Pieter Koopman's avatar
Pieter Koopman committed
1007
		  (locals,pState)	= optionalLocals WithToken withExpected pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1008
1009
1010
		= ( Yes	{ ewl_nodes		= nodeDefs
				, ewl_expr		= expr
				, ewl_locals	= locals
1011
				, ewl_position	= LinePos file_name line_nr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1012
				}
1013
		  , RhsDefiningSymbolExact token
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1014
1015
		  , pState
		  )
1016
1017
1018
		= (No, definingSymbol, tokenBack pState)


Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
/*	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
			opt_End_Group token pState
			 #	(ss_useLayout, pState) = accScanState UseLayout pState
			 |	ss_useLayout
			 	| token == EndGroupToken
			 		= nextToken FunctionContext pState
			 	// otherwise // token <> EndGroupToken
			 		= (ErrorToken "End group missing in let befores", parseError "RHS: Let befores" (Yes token) "Generated End Group (due to layout)" pState)
			 |	otherwise // not ss_useLayout
			 =	(token, pState)
	want_LetBefores token pState
		= ([], token, pState)
	
	try_LetDef :: !Bool !ParseState -> (!Bool, NodeDefWithLocals, !ParseState)
	try_LetDef strict pState
		# (succ, lhs_exp, pState)	= trySimpleLhsExpression pState
		| succ
			# pState			= wantToken FunctionContext "let definition" EqualToken pState
1053
			  (file_name, line_nr, pState)
1054
			  					= getFileAndLineNr pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1055
1056
			  (rhs_exp, pState) = wantExpression cIsNotAPattern pState
			  pState			= wantEndRootExpression pState -->> ("#",lhs_exp,"=",rhs_exp)
Pieter Koopman's avatar
Pieter Koopman committed
1057
	  	  	  (locals , pState) = optionalLocals WithToken localsExpected pState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1058
1059
1060
1061
1062
1063
			=	( True
				, {	ndwl_strict	= strict
				  ,	ndwl_def	= { bind_dst = lhs_exp
				  				  , bind_src = rhs_exp
				  				  }
				  , ndwl_locals	= locals
1064
				  , ndwl_position
1065
				  				= LinePos file_name line_nr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1066
1067
1068