explicitimports.icl 37.9 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
4
5
6
7
8
9
10
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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
implementation module explicitimports

import StdEnv

import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug


temporary_import_solution_XXX yes no :== yes
// to switch between importing modes.
// iff this is yes, then explicit imports happen in the old Clean 1.3 fashion.
// This feature will be removed, when all programs are ported to Clean 2.0. The last Constructors of AtomType
// and StructureType should then be removed also
do_temporary_import_solution_XXX :== temporary_import_solution_XXX True False

::	ExplicitImports	:==	(![AtomicImport], ![StructureImport])
::	AtomicImport	:==	(!Ident, !AtomType)
::	StructureImport	:==	(!Ident, !StructureInfo, !StructureType, !OptimizeInfo)

::	AtomType		=	AT_Function | AT_Class | AT_Instance | AT_RecordType | AT_AlgType | AT_Type
						| AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen Bool // XXX
::	StructureInfo	= SI_DotDot
					// The .. notation was used for the structure
					// (currently nothing is known about the elements)
					| SI_Elements ![Ident] !Bool
					// list of elements, that were not imported yet.
					// Bool: the elements were listed explicitly in the structure
::	StructureType	= ST_AlgType | ST_RecordType | ST_Class
					| ST_stomm_stomm_stomm String
::	IdentWithKind	:==	(!Ident, !STE_Kind)
::	IdentWithCKind	:==	(!Ident, !ConsequenceKind)

::	OptimizeInfo	:==	(Optional !Index)

::	ConsequenceKind	= CK_Function !(Global Index)
					| CK_DynamicPatternType ExprInfoPtr
					| CK_Macro
					| CK_Constructor
					| CK_Selector !(Global DefinedSymbol)
					| CK_Type
					| CK_Class

::	FunctionConsequence	:==	Optional !(!Int, !Optional ![IdentWithCKind])
	// Int i: The consequences of this function/macro have already been considered for all dcl modules with indices <= i

check_completeness_of_all_dcl_modules	:: !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState
									-> (!Int, !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap, !*CheckState))
check_completeness_of_all_dcl_modules modules icl_functions expr_heap cs
	#	(nr_modules, modules)	= usize modules
		(nr_functions, icl_functions)	= usize icl_functions
		f_consequences	= f_consequences nr_functions
		result
			= iFoldSt check_completeness_of_dcl_module 0 (nr_modules) (f_consequences, modules, icl_functions, expr_heap, cs)
	= (nr_modules, result)
  where
	f_consequences :: !Int -> *{!FunctionConsequence}
	f_consequences i = createArray i No

check_completeness_of_dcl_module mod_index (f_consequences, modules, icl_functions, expr_heap, cs=:{cs_predef_symbols})
	#	pre_mod = cs_predef_symbols.[PD_PredefinedModule]
	|	pre_mod.pds_def == mod_index
		= (f_consequences, modules, icl_functions, expr_heap, cs)	// predefined module should not be checked for completeness of explicit imports
	#	(modul=:{ dcl_name, dcl_declared=dcl_declared=:{dcls_import,dcls_local, dcls_explicit}}, modules)
			= modules![mod_index]
		cs	= addDeclaredSymbolsToSymbolTable cIsADclModule mod_index dcls_local dcls_import cs
		(f_consequences, modules, icl_functions, expr_heap, cs)
			= check_completeness_of_module mod_index dcls_explicit (dcl_name.id_name+++".dcl") (f_consequences, modules, icl_functions, expr_heap, cs)
		(_, cs_symbol_table) = retrieveAndRemoveImportsFromSymbolTable [(mod_index, dcl_declared)] [] cs.cs_symbol_table
		cs	= { cs & cs_symbol_table=cs_symbol_table }
	= (f_consequences, modules, icl_functions, expr_heap, cs)

possibly_filter_decls :: .[ImportDeclaration] u:[w:(.Index,y:Declarations)] (.FileName,.LineNr) *{#.DclModule} *CheckState -> (v:[x:(Index,z:Declarations)],.{#DclModule},.CheckState), [y <= z, w <= x, u <= v];
possibly_filter_decls [] decls_of_imported_module	_ modules cs // implicit import can't go wrong
	= (decls_of_imported_module, modules, cs)
possibly_filter_decls listed_symbols decls_of_imported_module (file_name, line_nr) modules cs
	// explicit import
	#!	
		ident_pos	=	{	ip_ident= { id_name="", id_info=nilPtr }
						,	ip_line	= line_nr
						,	ip_file	= file_name
						}
		cs	= { cs & cs_error	= pushErrorAdmin ident_pos cs.cs_error }
		(result, modules, cs)	= filter_explicitly_imported_decl listed_symbols decls_of_imported_module [] line_nr modules cs
		cs	= { cs & cs_error	= popErrorAdmin cs.cs_error }
	= (result, modules, cs)

filter_explicitly_imported_decl _ [] akku _ modules cs
	= (akku, modules, cs)
filter_explicitly_imported_decl import_symbols [(index,{dcls_import,dcls_local,dcls_explicit}):new_decls] akku
								line_nr modules cs
	#	undefined	= -1
		atoms	= flatten (map toAtom import_symbols)
		structures = flatten (map toStructure import_symbols)
		(checked_atoms, cs)	= checkAtoms atoms cs
		unimported	= (checked_atoms, structures)
		((dcls_import,unimported), modules, cs)	
			= filter_decl dcls_import [] unimported undefined modules cs
		((dcls_local,unimported), modules, cs)	
			= filter_decl dcls_local [] unimported index modules cs
		cs_error	= foldSt checkAtomError (fst unimported) cs.cs_error
		cs_error	= foldSt checkStructureError (snd unimported) cs_error
		cs	= { cs & cs_error=cs_error }
	|	(isEmpty dcls_import && isEmpty dcls_local && isEmpty dcls_explicit)
		= filter_explicitly_imported_decl import_symbols new_decls akku line_nr modules cs
	#	local_imports	= [ { declaration & dcl_kind = STE_Imported declaration.dcl_kind index }
							 \\ declaration <- dcls_local]
		new_dcls_explicit	= [ (dcls, line_nr) \\ dcls<-dcls_import++local_imports ]
		newAkku	= [(index, { dcls_import=dcls_import, dcls_local=dcls_local , dcls_explicit=new_dcls_explicit}) : akku]
	= filter_explicitly_imported_decl import_symbols new_decls newAkku line_nr modules cs
  where
	toAtom (ID_Function {ii_ident})				
		= [(ii_ident, temporary_import_solution_XXX 
							(AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen False)
							AT_Function)]
	toAtom (ID_Class {ii_ident} _)
		= [(ii_ident, AT_Class)]
	toAtom (ID_Type {ii_ident} (Yes _))
		= [(ii_ident, AT_AlgType)]
	toAtom (ID_Type {ii_ident} No)
		= [(ii_ident, AT_Type)]
	toAtom (ID_Record {ii_ident} yesOrNo)
		= [(ii_ident, AT_RecordType)]
	toAtom (ID_Instance _ ident _)
		= [(ident, AT_Instance)]
	toAtom _
		= []

	atomTypeString	AT_Function		= "function"
	atomTypeString	AT_Class		= "class"
	atomTypeString	AT_Instance		= "instance"
	atomTypeString	_				= "type"

	toStructure (ID_Class {ii_ident} yesOrNo)
		= to_structure ii_ident yesOrNo ST_Class
	toStructure (ID_Type {ii_ident} yesOrNo)
		= to_structure ii_ident yesOrNo ST_AlgType
	toStructure (ID_Record {ii_ident} yesOrNo)
		= to_structure ii_ident yesOrNo ST_RecordType
// MW added
	toStructure (ID_Function {ii_ident})
		| do_temporary_import_solution_XXX
			= [(ii_ident, SI_DotDot, ST_stomm_stomm_stomm ii_ident.id_name, No)]
// ..MW
	toStructure _
		= []
		
	to_structure _ No _
		= []
	to_structure ident (Yes []) structureType
		=	[(ident, SI_DotDot, structureType, No)]
	to_structure ident (Yes elements) structureType
		#	element_idents	= removeDup [ ii_ident \\ {ii_ident}<-elements]
		=	[(ident, (SI_Elements element_idents True),structureType, No)]

	checkAtoms l cs
		#	groups	= grouped l
		#	wrong	= filter isErrornous groups
			unique	= map hd groups
		|	isEmpty wrong
			= (unique, cs)
		= (unique, foldSt error wrong cs)
	  where
		isErrornous l=:[(_,AT_Type),_:_]		= True
		isErrornous l=:[(_,AT_AlgType),_:_]		= True
		isErrornous l=:[(_,AT_RecordType),_:_]	= True
		isErrornous _							= False
		
		error [(ident, atomType):_] cs
			= { cs & cs_error = checkError ("type "+++ident.id_name) "imported more than once in one from statement"
										cs.cs_error }

	checkAtomError (id, AT_Instance) cs_error
		= checkError ("specified instance of class "+++id.id_name) "not exported by the specified module" cs_error
	checkAtomError (id, AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen was_imported_at_least_once) cs_error
		| do_temporary_import_solution_XXX
			= case was_imported_at_least_once of
				True -> cs_error
				_    -> checkError id ("not exported by the specified module") cs_error
	checkAtomError (id, atomType) cs_error
		= checkError id ("not exported as a "+++atomTypeString atomType+++" by the specified module") cs_error

// MW remove this later..
	checkStructureError (_,_, ST_stomm_stomm_stomm _, _) cs_error
		| do_temporary_import_solution_XXX
			= cs_error
		// further with next alternative
// ..MW
	checkStructureError (struct_id, (SI_Elements wrong_elements _), st, _) cs_error
		= foldSt err wrong_elements cs_error
	  where
		err element_id cs_error
			#	(element_type, structure_type)	= case st of
													ST_AlgType		->	("constructor",	"algebraic type")
													ST_RecordType	->	("field",		"record type")
													ST_Class		->	("member",		"class")
			= checkError element_id (	"not a "+++element_type+++" of "+++structure_type
									 +++" "+++struct_id.id_name) cs_error
	checkStructureError _ cs_error
		= cs_error
	
	// collect groups, e.g. grouped [3,5,1,3,1] = [[1,1],[3,3],[5]]
	grouped []
		= []
	grouped l
		#	sorted	= qsort l
		= grouped_ [hd sorted] (tl sorted) []
	  where
		grouped_ group [] akku
			= [group:akku]
		grouped_ group=:[x:_] [h:t] akku
			|	x==h	= grouped_ [h:group] t akku
						= grouped_ [h] t [group:akku]
	
	qsort []	= []
	qsort [h:t] = qsort left++[h: qsort right]
	  where
		left	= [x \\ x<-t | greater x h]
		right	= [x \\ x<-t | not (greater x h) || x==h]
		greater ({id_name=id_name_l}, atomType_l) ({id_name=id_name_r}, atomType_r)
			|	id_name_l >id_name_r 	= True
			|	id_name_l==id_name_r 	= toInt atomType_l > toInt atomType_r
										= False

instance == AtomType
  where
	(==) l r = toInt l==toInt r
	
instance toInt AtomType
  where
	toInt AT_Function	= 0
	toInt AT_Class		= 1
	toInt AT_Instance	= 2
	toInt AT_RecordType	= 3
	toInt AT_AlgType	= 3
	toInt AT_Type		= 3	// AT_RecordType, AT_AlgType & AT_Type are in one class !!!
	toInt (AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen _)
						= 0

instance == ConsequenceKind
  where
	(==) CK_Type		c = case c of	CK_Type	-> True
										_		-> False
	(==) CK_Constructor	c = case c of	CK_Constructor	-> True
										_		-> False
	(==) (CK_Selector globDefinedSymb1)
						c = case c of	CK_Selector globDefinedSymb2 -> globDefinedSymb1==globDefinedSymb2
										_		-> False
	(==) CK_Class		c = case c of	CK_Class-> True
										_		-> False
	(==) (CK_Function globIndex1)
						c = case c of	(CK_Function	globIndex2) -> globIndex1==globIndex2
										_		-> False
	(==) CK_Macro		c = case c of	CK_Macro-> True
										_		-> False

filter_decl [] akku unimported _ modules cs
	= ((akku, unimported), modules, cs)
filter_decl [decl:decls] akku unimported index modules cs
	#	((appears,unimported), modules, cs)	= decl_appears decl unimported index modules cs
	= filter_decl decls (if appears [decl:akku] akku) unimported index modules cs

decl_appears :: !Declaration !ExplicitImports !Index !*{#DclModule} !*CheckState
			 -> (!(!Bool, !ExplicitImports), !*{#DclModule}, !*CheckState)
decl_appears dec=:{dcl_kind=STE_Imported ste_Kind def_index} unimported _ modules cs
	= decl_appears {dec & dcl_kind=ste_Kind} unimported def_index modules cs
/* MW2 was:
decl_appears {dcl_ident,dcl_kind=STE_Constructor,dcl_index} unimported index modules cs
	= elementAppears ST_AlgType dcl_ident dcl_index unimported index modules cs
*/
decl_appears {dcl_ident,dcl_kind=STE_Constructor,dcl_index} unimported index modules cs
	# (result=:((appears, unimported), modules, cs))
		 = elementAppears ST_AlgType dcl_ident dcl_index unimported index modules cs
	| appears || not do_temporary_import_solution_XXX
		= result
	= atomAppears dcl_ident dcl_index unimported index modules cs
/* MW2 was
decl_appears { dcl_ident,dcl_kind=(STE_Field _),dcl_index} unimported index modules cs 
	= elementAppears ST_RecordType dcl_ident dcl_index unimported index modules cs
*/
decl_appears { dcl_ident,dcl_kind=(STE_Field _),dcl_index} unimported index modules cs 
	# (result=:((appears, unimported), modules, cs))
		= elementAppears ST_RecordType dcl_ident dcl_index unimported index modules cs
	| appears || not do_temporary_import_solution_XXX
		= result
	= atomAppears dcl_ident dcl_index unimported index modules cs
/* MW2 was
decl_appears { dcl_ident,dcl_kind=STE_Member,dcl_index} unimported index modules cs 
	= elementAppears ST_Class dcl_ident dcl_index unimported index modules cs
*/
decl_appears { dcl_ident,dcl_kind=STE_Member,dcl_index} unimported index modules cs 
	# (result=:((appears, unimported), modules, cs))
		= elementAppears ST_Class dcl_ident dcl_index unimported index modules cs
	| appears || not do_temporary_import_solution_XXX
		= result
	= atomAppears dcl_ident dcl_index unimported index modules cs
decl_appears {dcl_ident, dcl_kind, dcl_index} unimported index modules cs 
	| isAtom dcl_kind
		=  atomAppears dcl_ident dcl_index unimported index modules cs
  where
	isAtom STE_DclFunction			= True
	isAtom (STE_FunctionOrMacro	_)	= True
	isAtom STE_Class				= True
	isAtom STE_Type					= True
	isAtom STE_Instance				= True


// CommonDefs CollectedDefinitions

elementAppears imported_st dcl_ident dcl_index (atomicImports, structureImports) index modules cs
	#	((result, structureImports), modules, cs)
			=  element_appears imported_st dcl_ident dcl_index structureImports [] index modules cs
	= ((result, (atomicImports, structureImports)), modules, cs)

atomAppears dcl_ident dcl_index (atomicImports, structureImports) index modules cs
	#	((result, atomicImports), modules, cs)
			= atom_appears dcl_ident dcl_index atomicImports [] index modules cs
	= ((result, (atomicImports, structureImports)), modules, cs)


atom_appears _ _ [] akku _ modules cs
  	= ((False, akku), modules, cs)
atom_appears ident dcl_index [h=:(import_ident, atomType):t] akku index modules cs
// MW2..
	|		do_temporary_import_solution_XXX
		&&	ident.id_name==import_ident.id_name 
		&&	atomType==(AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True) // True or False doesn't matter in this line
		#	new_h = (import_ident, AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True)
		=  ((True, [new_h:t]++akku), modules, cs)
// ..MW2
	|	ident==import_ident
		#	(modules, cs)	=  checkRecordError atomType import_ident dcl_index index modules cs
		= ((True, t++akku), modules, cs)
	// goes further with next alternative
  where
	checkRecordError atomType import_ident dcl_index index modules cs
		#	(td_rhs, modules, cs) = lookup_type dcl_index index modules cs
			cs_error	= cs.cs_error
			cs_error	= case atomType of
							AT_RecordType
								-> case td_rhs of
									RecordType _	-> cs_error
									_				-> checkError import_ident "imported as a record type" cs_error
							AT_AlgType
								-> case td_rhs of
									AlgType _		-> cs_error
									_				-> checkError import_ident "imported as an algebraic type" cs_error
							_	-> cs_error
		= (modules, { cs & cs_error=cs_error })
atom_appears ident dcl_index [h:t] akku index modules cs
	= atom_appears ident dcl_index t [h:akku] index modules cs

instance == StructureType
  where
	(==) ST_AlgType		ST_AlgType		= True
	(==) ST_RecordType	ST_RecordType	= True
	(==) ST_Class		ST_Class		= True
	(==) _ _							= False

element_appears _ _ _ [] akku _ modules cs
	= ((False, akku), modules, cs)
// MW remove this later ..
element_appears imported_st element_ident dcl_index
				[h=:(_, SI_DotDot, ST_stomm_stomm_stomm type_name_string, optInfo):t] akku
				index modules cs
	| do_temporary_import_solution_XXX
		#	(appears, modules, cs)
			= element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs
		| appears
			= ((appears,[h:t]++akku), modules, cs)
		= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
	// otherwise go further with next alternative
// ..MW
element_appears imported_st element_ident dcl_index
				[h=:(_, _, st, _):t] akku
				index modules cs
	|	imported_st<>st
		= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
	// goes further with next alternative
element_appears imported_st element_ident dcl_index
				[h=:(_, _, _, (Yes notDefinedHere)):t] akku
				index modules cs
	|	notDefinedHere==dcl_index 
		= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
	// goes further with next alternative
element_appears	imported_st element_ident dcl_index
				[h=:(struct_id, (SI_Elements elements explicit), st, optInfo):t] akku
				index modules cs
	#	(l,r)	= span ((<>) element_ident) elements
	|	isEmpty r
		= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
	#	oneLess	= l++(tl r)
		newStructure	= (struct_id, (SI_Elements oneLess explicit), st, optInfo)
	|	not explicit
		= ((True, [newStructure: t]++akku), modules, cs)
	// the found element was explicitly specified by the programmer: check it
	#	(appears, _, _, modules, cs)
			= element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs
	|	appears
		= ((True, [newStructure: t]++akku), modules, cs)
	#	message	= "does not belong to specified "+++(case st of
														ST_Class	-> "class."
														_			-> "type.")
		cs	= { cs & cs_error= checkError element_ident message  cs.cs_error}
	= ((False, t++akku), modules, cs)
element_appears imported_st element_ident dcl_index
				[h=:(struct_id, SI_DotDot, st, optInfo):t] akku
				index modules cs
	#	(appears, defined, opt_element_idents, modules, cs)
			= element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs
	|	not appears
		#	structureInfo	= case opt_element_idents of
								No					-> SI_DotDot
								Yes element_idents	-> (SI_Elements element_idents False)
413
			newStructure	= (struct_id, structureInfo, st, (if defined No (Yes dcl_index)))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
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
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
		= element_appears imported_st element_ident dcl_index t [newStructure:akku] index modules cs
	#	(Yes element_idents)	= opt_element_idents
		oneLess	= filter ((<>) element_ident) element_idents
		newStructure	= (struct_id, (SI_Elements oneLess False), st, No)
	= ((True,[newStructure:t]++akku), modules, cs)
element_appears imported_st element_ident dcl_index [h:t] akku index modules cs
	= element_appears imported_st element_ident dcl_index t [h:akku] index modules cs

lookup_type dcl_index index modules cs
	#	(dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules)		= modules ! [index]
		(module_entry, cs_symbol_table)				= readPtr id_info cs.cs_symbol_table
		cs	= { cs & cs_symbol_table=cs_symbol_table }
	= continuation module_entry.ste_kind dcl_module modules cs
  where
	continuation (STE_OpenModule _ modul) _ modules cs
		#	allTypes	= modul.mod_defs.def_types
		= ((allTypes !! dcl_index).td_rhs, modules, cs)
	continuation STE_ClosedModule dcl_module modules cs
		#	com_type_def	= dcl_module.dcl_common.com_type_defs.[dcl_index]
		= (com_type_def.td_rhs, modules, cs)

// MW remove this later CCC
element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs
	| not do_temporary_import_solution_XXX
		= abort "element_appears_in_stomm_struct will be never called, when the above guard holds. This statement is only to remind people to remove this function."
	#	(dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules)		= modules ! [index]
		(module_entry, cs_symbol_table)				= readPtr id_info cs.cs_symbol_table
		cs	= { cs & cs_symbol_table=cs_symbol_table }
	= continuation imported_st module_entry.ste_kind dcl_module modules cs
  where
	continuation ST_RecordType (STE_OpenModule _ modul) _ modules cs
		//	lookup the constructors/fields for the algebraic type/record
		#	allTypes	= modul.mod_defs.def_types
			search		= dropWhile (\{td_name} -> td_name.id_name<>type_name_string) allTypes
		|	isEmpty search
			= (False, modules, cs)
		#	{td_rhs}	= hd search
		|	not (isRecordType td_rhs)
			= (False, modules, cs)
		#	element_idents	= getElements td_rhs
		= (isMember element_ident element_idents, modules, cs)
	continuation ST_RecordType STE_ClosedModule dcl_module modules cs
		// lookup the type of the constructor and compare
		#	type_index		= dcl_module.dcl_common.com_selector_defs.[dcl_index].sd_type_index
			com_type_def	= dcl_module.dcl_common.com_type_defs.[type_index]
			appears	= com_type_def.td_name.id_name==type_name_string
		= (appears, modules, cs)
	continuation ST_Class (STE_OpenModule _ modul) _ modules cs
		//	lookup the members for the class
		#	allClasses	= modul.mod_defs.def_classes
			search		= dropWhile (\{class_name} -> class_name.id_name<>type_name_string) allClasses
		|	isEmpty search
			= (False, modules, cs)
		#	{class_members}	= hd search
			element_idents	= [ ds_ident \\ {ds_ident} <-:class_members ]
		= (isMember element_ident element_idents, modules, cs)
	continuation ST_Class STE_ClosedModule dcl_module modules cs
		// lookup the class and compare
		#	com_member_def	= dcl_module.dcl_common.com_member_defs.[dcl_index]
			{glob_object}	= com_member_def.me_class
			com_class_def	= dcl_module.dcl_common.com_class_defs.[glob_object]
			appears	= com_class_def.class_name.id_name==type_name_string
		= (appears, modules, cs)
	continuation _ _ _ modules cs
		= (False, modules, cs)
	getElements (RecordType {rt_fields})
		= [ fs_name \\ {fs_name}<-:rt_fields ]
	getElements _
		= []
	isRecordType (RecordType _)	= True
	isRecordType _				= False
// ..MW

/*	1st result: whether the element appears in the structure
	2nd result: whether the structure is defined at all in the module
	3rd result: Yes: a list of all idents of the elements of the structure
the first bool implies the second
*/
element_appears_in_struct imported_st element_ident dcl_index struct_ident index modules cs
	#	(dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules)		= modules ! [index]
		(module_entry, cs_symbol_table)				= readPtr id_info cs.cs_symbol_table
		cs	= { cs & cs_symbol_table=cs_symbol_table }
	= continuation imported_st module_entry.ste_kind dcl_module modules cs
  where
	continuation ST_Class (STE_OpenModule _ modul) _ modules cs
		//	lookup the members for the class
		#	allClasses	= modul.mod_defs.def_classes
			search		= dropWhile (\{class_name} -> class_name<>struct_ident) allClasses
		|	isEmpty search
			= (False, False, No, modules, cs)
		#	{class_members}	= hd search
			element_idents	= [ ds_ident \\ {ds_ident} <-:class_members ]
		= (isMember element_ident element_idents, True, Yes element_idents, modules, cs)
	continuation imported_st (STE_OpenModule _ modul) _ modules cs
		//	lookup the constructors/fields for the algebraic type/record
		#	allTypes	= modul.mod_defs.def_types
			search		= dropWhile (\{td_name} -> td_name<>struct_ident) allTypes
		|	isEmpty search
			= (False, False, No, modules, cs)
		#	{td_rhs}	= hd search
		|	not (isAlgOrRecordType td_rhs)
			= (False, True, No, modules, cs)
		#	element_idents	= getElements td_rhs
		= (isMember element_ident element_idents, True, Yes element_idents, modules, cs)
	continuation ST_Class STE_ClosedModule dcl_module modules cs
		// lookup the class and compare
		#	com_member_def	= dcl_module.dcl_common.com_member_defs.[dcl_index]
			{glob_object}	= com_member_def.me_class
			com_class_def	= dcl_module.dcl_common.com_class_defs.[glob_object]
			allMembers		= com_class_def.class_members
			member_idents	= [ ds_ident \\ {ds_ident} <-: allMembers]
			appears	= com_class_def.class_name==struct_ident
		= (appears, True, if appears (Yes member_idents) No, modules, cs)
	continuation imported_st STE_ClosedModule dcl_module modules cs
		// lookup the type of the constructor and compare
		#	type_index	= if (imported_st==ST_AlgType)
								 dcl_module.dcl_common.com_cons_defs.[dcl_index].cons_type_index 
								 dcl_module.dcl_common.com_selector_defs.[dcl_index].sd_type_index
			com_type_def	= dcl_module.dcl_common.com_type_defs.[type_index]
			element_idents	= getElements com_type_def.td_rhs
			appears	= com_type_def.td_name==struct_ident
		= (appears, True, if appears (Yes element_idents) No, modules, cs)
	isAlgOrRecordType (AlgType _)		= True
	isAlgOrRecordType (RecordType _)	= True
	isAlgOrRecordType _					= False
	getElements (AlgType constructor_symbols)
		= [ds_ident \\ {ds_ident} <- constructor_symbols]
	getElements (RecordType {rt_fields})
		= [ fs_name \\ {fs_name}<-:rt_fields ]
	getElements _
		= []

check_completeness_of_module :: .Index [(.Declaration,.Int)] .String *(*{!.FunctionConsequence},*{#.DclModule},*{#FunDef},*ExpressionHeap,*CheckState) -> (.{!FunctionConsequence},.{#DclModule},.{#FunDef},.ExpressionHeap,.CheckState);
check_completeness_of_module mod_index dcls_explicit file_name (f_consequences, modules, icl_functions, expr_heap, cs)
	#	dcls_imp	= [((dcl_ident, kind), (dcl_index, mod_index), (file_name, line_nr))
						\\ ({dcl_ident, dcl_index, dcl_kind=STE_Imported kind mod_index}, line_nr) <- dcls_explicit]
		(conseqs, (f_consequences, modules, icl_functions, expr_heap))
				= seqList (map (consequences_of mod_index) dcls_imp) (f_consequences, modules, icl_functions, expr_heap)
		conseqs	= flatten conseqs
	#!	(modules, cs)	= seq (map checkConsequenceError conseqs) (modules, cs)
	= (f_consequences, modules, icl_functions, expr_heap, cs)

consequences_of ::	!Index
					(!IdentWithKind, !(!Index,!Index), !(!String, !Int)) !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap)
 				->	(![(!IdentWithKind, !IdentWithCKind, !(!String, !Int))], !(*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap))
consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_index), errMsgInfo) 
				(f_consequences, modules, icl_functions, expr_heap)
	#	(modul, modules)	= modules![mod_index]
		(consequences, (f_consequences, icl_functions, expr_heap))
			= case expl_imp_kind of
					STE_FunctionOrMacro _
						-> consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
					_
						-> (consequences_of_simple_symbol expl_imp_kind modul dcl_index, (f_consequences, icl_functions,expr_heap))
		conseqs	= removeDup consequences
	= ([(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-conseqs], (f_consequences, modules, icl_functions, expr_heap))
	
consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
	#	(icl_function, icl_functions)	= icl_functions![dcl_index]
573
		{fun_body}	= icl_function
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
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
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
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
749
750
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
784
785
786
787
788
789
790
		result = consequences fun_body
	= expand_functions_and_dynamics result [] (f_consequences, icl_functions, expr_heap)
  where
	expand_functions_and_dynamics [] akku unique_stuff
		= (akku, unique_stuff)
	expand_functions_and_dynamics [(_,CK_DynamicPatternType exprInfoPtr):t] akku (f_consequences, icl_functions, expr_heap)
		#	(conseqs, expr_heap)	= expand_dynamic exprInfoPtr expr_heap
		= expand_functions_and_dynamics t (conseqs++akku) (f_consequences, icl_functions, expr_heap)
	expand_functions_and_dynamics [(ident,(CK_Function globIndex)):t] akku unique_stuff
		#	(conseqs, unique_stuff) = expand_function ident globIndex unique_stuff
		= expand_functions_and_dynamics t (conseqs++akku) unique_stuff
	expand_functions_and_dynamics [h:t] akku unique_stuff
		= expand_functions_and_dynamics t [h:akku] unique_stuff

	expand_dynamic :: ExprInfoPtr *ExpressionHeap -> ([IdentWithCKind], *ExpressionHeap)
	expand_dynamic exprInfoPtr expr_heap
	// it is assumed, that the pointer structure from the fi_dynamics field (of record FunInfo)
	// is a tree
		#	(exprInfo, expr_heap)	= readPtr exprInfoPtr expr_heap
			(conseqs, expr_heap)
			 	= case exprInfo of
							(EI_Dynamic No)	
								-> ([], expr_heap)
							(EI_Dynamic (Yes dynamicType))
								-> (consequences dynamicType, expr_heap)
							(EI_DynamicType dynamicType further_dynamic_ptrs)
								#	(further_conseqs, expr_heap)	= expand_dynamics further_dynamic_ptrs [] expr_heap
								-> (further_conseqs++consequences dynamicType, expr_heap)
							(EI_DynamicTypeWithVars _ dynamicType further_dynamic_ptrs)
								#	(further_conseqs, expr_heap)	= expand_dynamics further_dynamic_ptrs [] expr_heap
								-> (further_conseqs++consequences dynamicType, expr_heap)
		= (conseqs, expr_heap)
	
	expand_dynamics [] akku expr_heap
		= (akku, expr_heap)
	expand_dynamics [h:t] akku expr_heap
		#	(dyn, expr_heap)	= expand_dynamic h expr_heap
		= expand_dynamics t (dyn++akku) expr_heap


	expand_function ident globIndex=:{glob_object,glob_module} (f_consequences, icl_functions, expr_heap)
		|	glob_module<>cIclModIndex	// the function that is referred from within a macro is a DclFunction
										// -> must be global -> is a consequence
			= ([(ident, CK_Function globIndex)], (f_consequences, icl_functions, expr_heap))
		#	(fun_def, icl_functions)	= icl_functions![glob_object]
		|	fun_def.fun_info.fi_def_level==cGlobalScope	// the function is defined in the icl module in the global scope
														// -> it's not a consequence
			= ([], (f_consequences, icl_functions, expr_heap))
		// otherwise the function was defined locally in a macro and stored in the IclModule object.
		// it is not a consequence, but it's type and body are consequences !
		#	(opt_f_consequences, f_consequences)	= f_consequences![glob_object]
		= case opt_f_consequences of
			No 	#	type_consequences	= consequences fun_def.fun_type
					body_consequences	= consequences fun_def.fun_body
					dynamic_pointers	= fun_def.fun_info.fi_dynamics
				#	(dynamic_consequences, expr_heap)
										= expand_dynamics dynamic_pointers [] expr_heap
					f_consequences		= { f_consequences & [glob_object]=Yes (count, No) }
					(cons, (f_consequences, icl_functions, expr_heap))
										= expand_functions_and_dynamics body_consequences [] (f_consequences, icl_functions,expr_heap)
					cons_of_function	= type_consequences++cons++dynamic_consequences
					f_consequences		= { f_consequences & [glob_object]=Yes (count, Yes cons_of_function) }
				-> (cons_of_function, (f_consequences, icl_functions, expr_heap))
			Yes (j, opt_consequences)
				|	j==count	// the consequences of the function are already considered
				-> ([], (f_consequences, icl_functions, expr_heap))
			Yes (j, Yes cons)
				|	j<count	// always True
				-> (cons, (f_consequences, icl_functions, expr_heap))

consequences_of_simple_symbol STE_Type {dcl_common} dcl_index
	= consequences dcl_common.com_type_defs.[dcl_index]
consequences_of_simple_symbol STE_Constructor {dcl_common} dcl_index
	= consequences dcl_common.com_cons_defs.[dcl_index]
consequences_of_simple_symbol STE_DclFunction {dcl_functions} dcl_index
	= consequences dcl_functions.[dcl_index]
consequences_of_simple_symbol (STE_Field _) {dcl_common} dcl_index
	= consequences dcl_common.com_selector_defs.[dcl_index]
consequences_of_simple_symbol STE_Class {dcl_common} dcl_index
	= consequences dcl_common.com_class_defs.[dcl_index]
consequences_of_simple_symbol STE_Member {dcl_common} dcl_index
	= consequences dcl_common.com_member_defs.[dcl_index]
consequences_of_simple_symbol STE_Instance {dcl_common} dcl_index
	= consequences dcl_common.com_instance_defs.[dcl_index]

checkConsequenceError (expl_imp_ident_kind, conseq_ident_kind=:(conseq_ident, conseq_kind), (file_name, line_nr))
					 (modules, cs=:{cs_symbol_table, cs_error})
	#	(c_ident, modules)
			= case conseq_kind of
				CK_Selector {glob_object,glob_module}				// if a selector is a consequence of an imported macro the
					#	(modul, modules)	= modules![glob_module]	// it's FIELD has to be looked up
						com_selector_def	= modul.dcl_common.com_selector_defs.[glob_object.ds_index]
					-> (com_selector_def.sd_field, modules)
				_	-> (conseq_ident, modules)
		({ste_kind}, cs_symbol_table)				= readPtr c_ident.id_info cs_symbol_table
		cs_error
			= case ste_kind of
				STE_Empty
							-> cError expl_imp_ident_kind
									  (   "explicitly imported without importing "
									   +++cIdent_kind_to_string conseq_ident_kind)
									  cs_error
				_			-> cs_error
	= (modules, { cs & cs_symbol_table=cs_symbol_table, cs_error=cs_error })
  where
	ident_kind_to_string ({id_name}, kind)
		= kind_to_string kind+++" "+++id_name
	cIdent_kind_to_string ({id_name}, cKind)
		= cKind_to_string cKind+++" "+++id_name
	cError expl_imp_ident_kind=:(expl_ident,_) s2 cs_error
		#	identPos	= {	ip_ident = expl_ident, ip_line = line_nr, ip_file = file_name } 
			cs_error	= pushErrorAdmin identPos cs_error
			cs_error	= checkError (ident_kind_to_string expl_imp_ident_kind) s2 cs_error
			cs_error	= popErrorAdmin cs_error
		= cs_error

kind_to_string (STE_FunctionOrMacro _)	= "function"
kind_to_string STE_Type					= "type"
kind_to_string STE_Constructor			= "constructor"
kind_to_string (STE_Field _)			= "field"
kind_to_string STE_Class				= "class"
kind_to_string STE_Member				= "member"
kind_to_string STE_Instance				= "instance"
kind_to_string STE_DclFunction			= "function"

cKind_to_string (CK_Function _)			= "function"
cKind_to_string CK_Macro				= "macro"
cKind_to_string CK_Type					= "type"
cKind_to_string CK_Constructor			= "constructor"
cKind_to_string (CK_Selector _)			= "appropriate record field"
cKind_to_string CK_Class				= "class"

class consequences x :: x -> [IdentWithCKind]

instance consequences App
  where consequences {app_symb, app_args}	= consequences app_symb++consequences app_args
	
instance consequences AlgebraicPattern
  where consequences {ap_symbol, ap_expr} = [ (ap_symbol.glob_object.ds_ident, CK_Constructor) : consequences ap_expr]

instance consequences AType
  where
	consequences {at_type}	= consequences at_type

instance consequences BasicPattern
  where consequences {bp_expr} = consequences bp_expr

instance consequences Case
  where	consequences { case_expr, case_guards, case_default, case_ident }
		= consequences case_expr++consequences case_guards++consequences case_default

instance consequences CasePatterns
  where
	consequences (AlgebraicPatterns _ algebraicPatterns)	= consequences algebraicPatterns
	consequences (BasicPatterns _ basicPatterns)	= consequences basicPatterns
	consequences (DynamicPatterns dynamicPatterns)	= consequences dynamicPatterns
	consequences NoPattern	= []

instance consequences CheckedBody
  where consequences {cb_rhs} = consequences cb_rhs

instance consequences ClassDef
  where
	consequences {class_context}	= consequences class_context	

instance consequences ClassInstance
  where
	consequences {ins_type}	= consequences ins_type	

instance consequences ConsDef
  where
	consequences {cons_type}	= consequences cons_type	

instance consequences DynamicPattern // the types, that are found via dp_type are checked later
  where	consequences { dp_rhs, dp_type } = [({ id_name="", id_info=nilPtr}, CK_DynamicPatternType dp_type): consequences dp_rhs]

instance consequences DynamicExpr
  where	consequences { dyn_expr, dyn_opt_type } = consequences dyn_expr++consequences dyn_opt_type

instance consequences DynamicType
  where	consequences { dt_type } = consequences dt_type

instance consequences Expression
  where
	consequences (Var _)	= []
	consequences (App app)	= consequences app
	consequences (expression @ expressions)	= consequences expression++consequences expressions
	consequences (Let let_)	= consequences let_
	consequences (Case case_)	= consequences case_
	consequences (Selection _ expression selections)	= consequences expression++consequences selections
	consequences (TupleSelect _ _ expression)	= consequences expression
	consequences (BasicExpr _ _)		= []
	consequences (AnyCodeExpr _ _ _)	= []
	consequences (ABCCodeExpr _ _)	= []
	consequences (MatchExpr _ constructor expression)
		= [(constructor.glob_object.ds_ident,CK_Constructor):consequences expression]
	consequences (FreeVar _) 	= []
	consequences (DynamicExpr dynamicExpr)	= consequences dynamicExpr
	consequences EE	= []

instance consequences FunctionBody
  where	consequences (CheckedBody body) = consequences body
		consequences (TransformedBody body) = consequences body
		// other alternatives should not occur

instance consequences FunType
  where
	consequences {ft_type}	= consequences ft_type	

instance consequences (Global x) | consequences x
  where	consequences { glob_object } = consequences glob_object

instance consequences InstanceType
  where
	consequences {it_types, it_context}	= consequences it_types++consequences it_context	

instance consequences Let
Sjaak Smetsers's avatar
Sjaak Smetsers committed
791
792
  where	consequences { let_strict_binds, let_lazy_binds, let_expr }
  			= consequences let_expr++(flatten [consequences bind_src \\ {bind_src}<-let_strict_binds ++ let_lazy_binds] )
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
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

instance consequences MemberDef
  where
	consequences {me_type}	= consequences me_type	

instance consequences (Optional x) | consequences x
  where	consequences (Yes x) = consequences x
  		consequences No = []

instance consequences Selection
  where consequences (RecordSelection globDefinedSymbol=:{glob_object={ds_ident}} _)
  			= [(ds_ident, CK_Selector globDefinedSymbol)]
		consequences (ArraySelection {glob_object={ds_ident={id_name}}} _ _)
  			= []

instance consequences SelectorDef
  where consequences {sd_type}	= consequences sd_type	

instance consequences SymbIdent
  where consequences {symb_name, symb_kind}
  			= case symb_kind of
  					SK_Constructor _		-> [(symb_name, CK_Constructor)]
  			  		SK_Function	globalIndex	-> [(symb_name, CK_Function globalIndex)]
  			  		SK_OverloadedFunction globalIndex
  			  								-> [(symb_name, CK_Function globalIndex)]
  			  		SK_Macro globalIndex	-> [(symb_name, CK_Macro)]
  			  		_						-> []

instance consequences SymbolType
  where
	consequences {st_args, st_result, st_context}
		= consequences st_args++consequences st_result++consequences st_context

instance consequences TransformedBody
  where consequences {tb_rhs} = consequences tb_rhs

instance consequences Type
  where
	consequences (TA {type_name} arguments)
		= [(type_name, CK_Type):consequences arguments]
	consequences (l --> r)
		= consequences l++consequences r
	consequences (_ :@: arguments)
		= consequences arguments
	consequences _
		= []


instance consequences TypeContext
  where
	consequences {tc_class= {glob_object={ds_ident}}, tc_types}
		= [(ds_ident,CK_Class):consequences tc_types]

instance consequences (TypeDef TypeRhs)  // ==CheckedTypeDef
  where
	consequences {td_rhs, td_context}	= consequences td_rhs++consequences td_context

instance consequences TypeRhs
  where
	consequences (SynType aType)	= consequences aType
	consequences _					= []

instance consequences [a]	| consequences a
  where
	consequences l	= flatten (map consequences l)