explicitimports.icl 42.6 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
implementation module explicitimports
2
// compile using the "reuse unique nodes" option
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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

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)

31
32
::	OptimizeInfo	:==	Optional Index

33
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];
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
34
35
36
37
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
38
	#!	ident_pos	=	{	ip_ident= { id_name="", id_info=nilPtr }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
39
40
41
42
43
44
45
46
47
48
49
50
						,	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
51
52
	#	undefined = -1
		atoms = flatten (map toAtom import_symbols)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
53
54
		structures = flatten (map toStructure import_symbols)
		(checked_atoms, cs)	= checkAtoms atoms cs
55
		unimported = (checked_atoms, structures)
56
57
58
				
		(dcls_import,unimported, modules, cs) = filter_decl_array 0 dcls_import unimported undefined modules cs

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
59
		((dcls_local,unimported), modules, cs)	
60
61
62
			= 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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
63
		cs	= { cs & cs_error=cs_error }
64
	|	isEmpty dcls_import && isEmpty dcls_local && size dcls_explicit==0
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
65
		= filter_explicitly_imported_decl import_symbols new_decls akku line_nr modules cs
66
67
68
69
70
71
72
73
74
	#	local_imports	= [ { declaration & dcl_kind = STE_Imported declaration.dcl_kind index } \\ declaration <- dcls_local]
		new_dcls_explicit	= [ ExplicitImport dcls line_nr \\ dcls<-dcls_import++local_imports ]

		dcls_import = {dcls_import\\dcls_import<-dcls_import}

		newAkku	= [(index, { dcls_import=dcls_import, dcls_local=dcls_local ,
										dcls_local_for_import = {local_declaration_for_import decl index \\ decl<-dcls_local},
//										 dcls_explicit=new_dcls_explicit}) : akku]
										 dcls_explicit={new_dcls_explicit\\new_dcls_explicit<-new_dcls_explicit}}) : akku]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
75
76
	= filter_explicitly_imported_decl import_symbols new_decls newAkku line_nr modules cs
  where
77
78
79
80
81
82
83
 	local_declaration_for_import decl=:{dcl_kind=STE_FunctionOrMacro _} module_n
		= decl
	local_declaration_for_import decl=:{dcl_kind=STE_Imported _ _} module_n
		= abort "local_declaration_for_import"
	local_declaration_for_import decl=:{dcl_kind} module_n
		= {decl & dcl_kind = STE_Imported dcl_kind module_n}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
	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
123
		= [(ident, SI_DotDot, structureType, No)]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
124
	to_structure ident (Yes elements) structureType
125
126
		# element_idents	= removeDup [ ii_ident \\ {ii_ident}<-elements]
		= [(ident, (SI_Elements element_idents True),structureType, No)]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
127
128
129

	checkAtoms l cs
		#	groups	= grouped l
130
			wrong	= filter isErroneous groups
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
131
			unique	= map hd groups
132
		| isEmpty wrong
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
133
134
135
			= (unique, cs)
		= (unique, foldSt error wrong cs)
	  where
136
137
138
139
		isErroneous l=:[(_,AT_Type),_:_]		= True
		isErroneous l=:[(_,AT_AlgType),_:_]		= True
		isErroneous l=:[(_,AT_RecordType),_:_]	= True
		isErroneous _							= False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
		
		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

212
NoPosition :== -1
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
213

clean's avatar
clean committed
214
filter_decl :: [.Declaration] ([(Ident,AtomType)],[(Ident,StructureInfo,StructureType,Optional Int)]) Int *{#DclModule} *CheckState -> (!(!.[Declaration],!([(Ident,AtomType)],![(Ident,StructureInfo,StructureType,Optional Int)])),!.{#DclModule},!.CheckState);
215
216
217
218
219
filter_decl [] unimported _ modules cs
	= (([], unimported), modules, cs)
filter_decl [decl:decls] unimported index modules cs
	# ((appears,unimported), modules, cs) = decl_appears decl unimported index modules cs
	| appears
220
221
		# ((recurs, unimported), modules, cs) = filter_decl decls unimported index modules cs

222
		= (([decl:recurs],unimported), modules, cs)
223
	= 	filter_decl decls unimported index modules cs
224
225
226
227
228
229
230
231
232
233
234

filter_decl_array :: !Int {!.Declaration} ([(Ident,AtomType)],[(Ident,StructureInfo,StructureType,Optional Int)]) Int *{#DclModule} *CheckState -> (!.[Declaration],!([(Ident,AtomType)],![(Ident,StructureInfo,StructureType,Optional Int)]),!.{#DclModule},!.CheckState);
filter_decl_array decl_index decls unimported index modules cs
	| decl_index<size decls
		# (decl,decls) = decls![decl_index]
		# ((appears,unimported), modules, cs) = decl_appears decl unimported index modules cs
		| appears
			# (recurs, unimported, modules, cs) = filter_decl_array (decl_index+1) decls unimported index modules cs
			= ([decl:recurs],unimported, modules, cs)
		= 	filter_decl_array (decl_index+1) decls unimported index modules cs
		= ([], unimported, modules, cs)
235
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
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

280
elementAppears :: .StructureType Ident !.Int !(.a,![(Ident,.StructureInfo,.StructureType,Optional .Int)]) !.Int !*{#.DclModule} !*CheckState -> (!(!Bool,(!.a,![(Ident,StructureInfo,StructureType,Optional Int)])),!.{#DclModule},!.CheckState);
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
281
282
elementAppears imported_st dcl_ident dcl_index (atomicImports, structureImports) index modules cs
	#	((result, structureImports), modules, cs)
283
			=  element_appears imported_st dcl_ident dcl_index structureImports structureImports 0 index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
284
285
286
287
	= ((result, (atomicImports, structureImports)), modules, cs)

atomAppears dcl_ident dcl_index (atomicImports, structureImports) index modules cs
	#	((result, atomicImports), modules, cs)
288
			= atom_appears dcl_ident dcl_index atomicImports atomicImports 0 index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
289
290
	= ((result, (atomicImports, structureImports)), modules, cs)

291
atom_appears :: Ident !.Int [(Ident,.AtomType)] w:[y:(Ident,u1:AtomType)] !Int !.Int !u:{#u3:DclModule} !*CheckState -> (!(.Bool,x:[z:(Ident,u2:AtomType)]),!v:{#DclModule},!.CheckState) , [u <= v, u1 <= u2, y <= z, w <= x, u <= u3];
292
293
294
atom_appears _ _ [] atomic_imports _ _ modules cs
  	= ((False, atomic_imports), modules, cs)
atom_appears ident dcl_index [h=:(import_ident, atomType):t] atomic_imports unimp_index index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
295
296
297
298
299
// 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)
300
		=  ((True, [new_h: removeAt unimp_index atomic_imports]), modules, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
301
302
// ..MW2
	|	ident==import_ident
303
304
		# (modules, cs) = checkRecordError atomType import_ident dcl_index index modules cs
		= ((True, removeAt unimp_index atomic_imports), modules, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
	// 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 })
321
322
atom_appears ident dcl_index [h:t] atomic_imports unimp_index index modules cs
	= atom_appears ident dcl_index t atomic_imports (inc unimp_index) index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
323
324
325
326
327
328
329
330

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

331
element_appears :: StructureType Ident !Int [(Ident,.StructureInfo,u2:StructureType,z:Optional .Int)] u:[w:(Ident,u5:StructureInfo,u3:StructureType,y:Optional Int)] !Int !Int !*{#DclModule} !*CheckState -> (!(!Bool,!v:[x:(Ident,u6:StructureInfo,u4:StructureType,u1:Optional Int)]),!.{#DclModule},!.CheckState), [y z <= u1, u3 <= u4, u5 <= u6, w <= x, u <= v, u2 <= u3];
332
333
334
element_appears _ _ _ [] atomic_imports _ _ modules cs
	= ((False, atomic_imports), modules, cs)
// MW2 remove this later ..
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
335
element_appears imported_st element_ident dcl_index
336
				[(_, SI_DotDot, ST_stomm_stomm_stomm type_name_string, optInfo):t] atomic_imports unimp_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
337
338
339
340
341
				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
342
343
			= ((appears, atomic_imports), modules, cs)
		= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
344
	// otherwise go further with next alternative
345
// ..MW2
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
346
element_appears imported_st element_ident dcl_index
347
				[(_, _, st, _):t] atomic_imports unimp_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
348
349
				index modules cs
	|	imported_st<>st
350
		= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
351
352
	// goes further with next alternative
element_appears imported_st element_ident dcl_index
353
				[(_, _, _, (Yes notDefinedHere)):t] atomic_imports unimp_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
354
355
				index modules cs
	|	notDefinedHere==dcl_index 
356
		= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
357
358
	// goes further with next alternative
element_appears	imported_st element_ident dcl_index
359
				[(struct_id, (SI_Elements elements explicit), st, optInfo):t] atomic_imports unimp_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
360
				index modules cs
361
362
	| not (isMember element_ident elements)
		= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
363
	#	(l,r)	= span ((<>) element_ident) elements
364
365
366
		oneLess	= l++(tl r)
		newStructure = (struct_id, (SI_Elements oneLess explicit), st, optInfo)
		atomic_imports_1 = removeAt unimp_index atomic_imports
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
367
	|	not explicit
368
		= ((True, [newStructure: atomic_imports_1]), modules, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
369
370
371
372
	// 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
373
		= ((True, [newStructure: atomic_imports_1]), modules, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
374
375
376
377
	#	message	= "does not belong to specified "+++(case st of
														ST_Class	-> "class."
														_			-> "type.")
		cs	= { cs & cs_error= checkError element_ident message  cs.cs_error}
378
	= ((False, atomic_imports_1), modules, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
379
element_appears imported_st element_ident dcl_index
380
				[(struct_id, SI_DotDot, st, optInfo):t] atomic_imports unimp_index
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
381
				index modules cs
382
383
384
385
	| (case st of
			ST_stomm_stomm_stomm _
				-> True
			_ 	-> False) && (False->>"element_appears weird case")
386
		= undef
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
387
388
389
390
391
392
	#	(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)
393
			newStructure	= (struct_id, structureInfo, st, (if defined No (Yes dcl_index)))
394
395
			new_atomic_imports = [newStructure : removeAt unimp_index atomic_imports]
		= element_appears imported_st element_ident dcl_index t new_atomic_imports (inc unimp_index) index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
396
397
	#	(Yes element_idents)	= opt_element_idents
		oneLess	= filter ((<>) element_ident) element_idents
398
399
400
401
402
		newStructure = (struct_id, (SI_Elements oneLess False), st, No)
		new_atomic_imports = [newStructure : removeAt unimp_index atomic_imports]
	= ((True,new_atomic_imports), modules, cs)
element_appears imported_st element_ident dcl_index [h:t] atomic_imports unimp_index index modules cs
	= element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
403
404

lookup_type dcl_index index modules cs
405
406
	#	(dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index]
		(module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
407
408
409
410
411
412
413
414
415
416
		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)

417
element_appears_in_stomm_struct :: .StructureType Ident .Int .Int .String *{#DclModule} !*CheckState -> (!Bool,!.{#DclModule},!.CheckState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
418
419
420
421
422
423
// 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
424
	#!	cs	= { cs & cs_symbol_table=cs_symbol_table }
clean's avatar
clean committed
425
426
//	= continuation imported_st module_entry.ste_kind dcl_module modules cs
	= (appears imported_st module_entry.ste_kind dcl_module.dcl_common,modules,cs);
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
427
  where
clean's avatar
clean committed
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
	appears ST_RecordType (STE_OpenModule _ modul) _
		//	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
		#	{td_rhs}	= hd search
		|	not (isRecordType td_rhs)
			= False
		#	element_idents	= getElements td_rhs
		= isMember element_ident element_idents
	appears ST_RecordType STE_ClosedModule dcl_common
		// lookup the type of the constructor and compare
		#	type_index		= dcl_common.com_selector_defs.[dcl_index].sd_type_index
			com_type_def	= dcl_common.com_type_defs.[type_index]
			appears	= com_type_def.td_name.id_name==type_name_string
		= appears
	appears ST_Class (STE_OpenModule _ modul) _
		//	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
		#	{class_members}	= hd search
			element_idents	= [ ds_ident \\ {ds_ident} <-:class_members ]
		= isMember element_ident element_idents
	appears ST_Class STE_ClosedModule dcl_common
		// lookup the class and compare
		#	com_member_def	= dcl_common.com_member_defs.[dcl_index]
			{glob_object}	= com_member_def.me_class
			com_class_def	= dcl_common.com_class_defs.[glob_object]
			appears	= com_class_def.class_name.id_name==type_name_string
		= appears
	appears _ _ _
		= False
463

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
	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 _
		= []

531
532
533
534
535
536
537
538
539
:: CheckCompletenessState =
	{	ccs_dcl_modules				:: !.{#DclModule}
	,	ccs_icl_functions			:: !.{#FunDef}
	,	ccs_set_of_visited_icl_funs	:: !.{#Bool}		// ccs_set_of_visited_icl_funs.[i] <=> function nr i has been considered
	,	ccs_expr_heap				:: !.ExpressionHeap
	,	ccs_symbol_table			:: !.SymbolTable
	,	ccs_error					:: !.ErrorAdmin
	,	ccs_heap_changes_accu		:: ![SymbolPtr]
	}
540

541
542
543
544
545
546
:: *CheckCompletenessStateBox = { box_ccs :: !*CheckCompletenessState }

:: CheckCompletenessInput =
	{	cci_line_nr				:: !Int
	,	cci_filename			:: !String
	,	cci_expl_imported_ident	:: !Ident
547
	,	cci_main_dcl_module_n::!Int
548
	}
549

550
551
:: CheckCompletenessInputBox = { box_cci :: !CheckCompletenessInput }

552
553
554
checkExplicitImportCompleteness :: !String !Int ![ExplicitImport] !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState 
				-> (!.{#DclModule},!.{#FunDef},!.ExpressionHeap,!.CheckState)
checkExplicitImportCompleteness filename main_dcl_module_n dcls_explicit dcl_modules icl_functions expr_heap 
555
556
557
558
559
560
561
562
563
564
565
566
567
								cs=:{cs_symbol_table, cs_error}
	#! nr_icl_functions = size icl_functions
	   box_ccs = { ccs_dcl_modules = dcl_modules, ccs_icl_functions = icl_functions,
	   			ccs_set_of_visited_icl_funs = createArray nr_icl_functions False,
				ccs_expr_heap = expr_heap, ccs_symbol_table = cs_symbol_table,
				ccs_error = cs_error, ccs_heap_changes_accu = [] }
	   ccs = foldSt (checkCompleteness filename) dcls_explicit { box_ccs = box_ccs }
	   { ccs_dcl_modules, ccs_icl_functions, ccs_expr_heap, ccs_symbol_table, ccs_error, ccs_heap_changes_accu }
	   		= ccs.box_ccs
	// repair heap contents
	   ccs_symbol_table = foldSt replace_ste_with_previous ccs_heap_changes_accu ccs_symbol_table
	   cs = { cs & cs_symbol_table = ccs_symbol_table, cs_error = ccs_error }
	= (ccs_dcl_modules, ccs_icl_functions, ccs_expr_heap, cs)
568
  where
569
570
571
572
573
574
	checkCompleteness :: !String !ExplicitImport *CheckCompletenessStateBox -> *CheckCompletenessStateBox
	checkCompleteness filename (ExplicitImport {dcl_ident, dcl_index, dcl_kind=STE_FunctionOrMacro _} line_nr) ccs 
		= checkCompletenessOfMacro filename dcl_ident dcl_index main_dcl_module_n line_nr ccs
	checkCompleteness filename (ExplicitImport {dcl_ident, dcl_index, dcl_kind=STE_Imported (STE_FunctionOrMacro _) mod_index} line_nr) ccs 
		= checkCompletenessOfMacro filename dcl_ident dcl_index main_dcl_module_n line_nr ccs
	checkCompleteness filename (ExplicitImport {dcl_ident, dcl_index, dcl_kind=STE_Imported expl_imp_kind mod_index} line_nr) ccs 
575
		#! ({dcl_common,dcl_functions}, ccs) = ccs!box_ccs.ccs_dcl_modules.[mod_index]
576
577
		   cci = { box_cci = { cci_line_nr = line_nr, cci_filename = filename, cci_expl_imported_ident = dcl_ident,cci_main_dcl_module_n=main_dcl_module_n }}
	/* XXX
578
579
	this case expression causes the compiler to be not self compilable anymore (12.7.2000). The bug is probably
	in module refmark. The corresponding continuation function can be compiled
580
581
582
583
584
585
586
587
		= case expl_imp_kind of
			STE_Type			-> check_completeness dcl_common.com_type_defs.[dcl_index] cci ccs
			STE_Constructor		-> check_completeness dcl_common.com_cons_defs.[dcl_index] cci ccs
			(STE_Field _)		-> check_completeness dcl_common.com_selector_defs.[dcl_index] cci ccs
			STE_Class			-> check_completeness dcl_common.com_class_defs.[dcl_index] cci ccs
			STE_Member			-> check_completeness dcl_common.com_member_defs.[dcl_index] cci ccs
			STE_Instance		-> check_completeness dcl_common.com_instance_defs.[dcl_index] cci ccs
			STE_DclFunction		-> check_completeness dcl_functions.[dcl_index] cci ccs
588
	*/
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
		= continuation expl_imp_kind dcl_common dcl_functions cci ccs
	  where
		continuation STE_Type dcl_common dcl_functions cci ccs
			= check_completeness dcl_common.com_type_defs.[dcl_index] cci ccs
		continuation STE_Constructor dcl_common dcl_functions cci ccs
			= check_completeness dcl_common.com_cons_defs.[dcl_index] cci ccs
		continuation (STE_Field _) dcl_common dcl_functions cci ccs
			= check_completeness dcl_common.com_selector_defs.[dcl_index] cci ccs
		continuation STE_Class dcl_common dcl_functions cci ccs
			= check_completeness dcl_common.com_class_defs.[dcl_index] cci ccs
		continuation STE_Member dcl_common dcl_functions cci ccs
			= check_completeness dcl_common.com_member_defs.[dcl_index] cci ccs
		continuation STE_Instance dcl_common dcl_functions cci ccs
			= check_completeness dcl_common.com_instance_defs.[dcl_index] cci ccs
		continuation STE_DclFunction dcl_common dcl_functions cci ccs
			= check_completeness dcl_functions.[dcl_index] cci ccs
605
606
607

	checkCompletenessOfMacro :: !String !Ident !Index !Int !Int *CheckCompletenessStateBox -> *CheckCompletenessStateBox
	checkCompletenessOfMacro filename dcl_ident dcl_index main_dcl_module_n line_nr ccs
608
609
		#! ({fun_body}, ccs) = ccs!box_ccs.ccs_icl_functions.[dcl_index]
		   ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[dcl_index] = True }
610
		   cci = { box_cci = { cci_line_nr = line_nr, cci_filename = filename, cci_expl_imported_ident = dcl_ident,cci_main_dcl_module_n=main_dcl_module_n }}
611
612
613
614
615
616
		= check_completeness fun_body cci ccs

	replace_ste_with_previous :: !SymbolPtr !*SymbolTable -> .SymbolTable
	replace_ste_with_previous changed_ste_ptr symbol_table
		#! ({ste_previous}, symbol_table) = readPtr changed_ste_ptr symbol_table
		= writePtr changed_ste_ptr ste_previous symbol_table
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
instance toString STE_Kind where
	toString (STE_FunctionOrMacro _)	= "function/macro"
	toString STE_Type 					= "type"
	toString STE_Constructor 			= "constructor"
	toString (STE_Field _) 				= "field"
	toString STE_Class 					= "class"
	toString STE_Member 				= "class member"

check_whether_ident_is_imported :: !Ident !STE_Kind !CheckCompletenessInputBox !*CheckCompletenessStateBox 
								-> *CheckCompletenessStateBox
check_whether_ident_is_imported ident wanted_ste_kind cci ccs=:{box_ccs=box_ccs=:{ccs_symbol_table}}
	#! (ste=:{ste_kind}, ccs_symbol_table) = readPtr ident.id_info ccs_symbol_table
	   ccs = { ccs & box_ccs = { box_ccs & ccs_symbol_table = ccs_symbol_table } }
	| is_imported ste_kind wanted_ste_kind
		= ccs
	#! (ccs=:{box_ccs=box_ccs=:{ccs_symbol_table, ccs_error, ccs_heap_changes_accu}}) = ccs
	   {box_cci={cci_line_nr, cci_filename, cci_expl_imported_ident}} = cci
	   ident_pos = {ip_ident= { id_name="import", id_info=nilPtr }, ip_line=cci_line_nr, ip_file=cci_filename}
	   ccs_error = checkErrorWithIdentPos ident_pos
	  				(cci_expl_imported_ident.id_name+++" explicitly imported without importing "
	  				 +++toString wanted_ste_kind+++" "+++ident.id_name)
	  				ccs_error
	   // pretend that the unimported symbol was imported to prevent doubling error mesages
	   ccs_symbol_table = writePtr ident.id_info { ste & ste_kind = wanted_ste_kind, ste_previous = ste } ccs_symbol_table
	= { ccs & box_ccs = { box_ccs & ccs_error = ccs_error, ccs_symbol_table = ccs_symbol_table, 
									ccs_heap_changes_accu = [ident.id_info:ccs_heap_changes_accu] }}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
644
  where
645
646
647
648
	is_imported (STE_Imported ste_kind _) wanted_ste_kind
		= ste_kind==wanted_ste_kind
	is_imported ste_kind wanted_ste_kind
		= ste_kind==wanted_ste_kind
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
649

650
class check_completeness x :: !x !CheckCompletenessInputBox !*CheckCompletenessStateBox -> *CheckCompletenessStateBox
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
instance check_completeness App where
	check_completeness {app_symb, app_args}	cci ccs
		= check_completeness app_symb cci
		  (check_completeness app_args cci ccs)
	
instance check_completeness AlgebraicPattern where
	check_completeness {ap_symbol, ap_expr} cci ccs
		= check_completeness ap_expr cci
		  (check_whether_ident_is_imported ap_symbol.glob_object.ds_ident STE_Constructor cci ccs)

instance check_completeness AType where
	check_completeness {at_type} cci ccs
		= check_completeness at_type cci ccs

instance check_completeness BasicPattern where
	check_completeness {bp_expr} cci ccs
		= check_completeness bp_expr cci ccs

instance check_completeness (Bind Expression FreeVar) where
	check_completeness {bind_src} cci ccs
		= check_completeness bind_src cci ccs

instance check_completeness Case where
	check_completeness { case_expr, case_guards, case_default } cci ccs
		= ( (check_completeness case_expr cci)
		  o (check_completeness case_guards cci)
		  o (check_completeness case_default cci)
		  ) ccs

instance check_completeness CasePatterns where
	check_completeness (AlgebraicPatterns _ algebraicPatterns) cci ccs
		= check_completeness algebraicPatterns cci ccs
	check_completeness (BasicPatterns _ basicPatterns) cci ccs
		= check_completeness basicPatterns cci ccs
	check_completeness (DynamicPatterns dynamicPatterns) cci ccs
		= check_completeness dynamicPatterns cci ccs
	check_completeness NoPattern _ ccs
		= ccs

691
692
693
694
instance check_completeness CheckedAlternative where
	check_completeness {ca_rhs} cci ccs
		= check_completeness ca_rhs cci ccs

695
696
697
698
699
700
701
702
703
704
705
706
707
instance check_completeness CheckedBody where
	check_completeness {cb_rhs} cci ccs
		= check_completeness cb_rhs cci ccs

instance check_completeness ClassDef where
	check_completeness {class_context} cci ccs
		= check_completeness class_context cci ccs

instance check_completeness ClassInstance where
	check_completeness {ins_type} cci ccs
		= check_completeness ins_type cci ccs

instance check_completeness ConsDef
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
708
  where
709
710
	check_completeness {cons_type} cci ccs
		= check_completeness cons_type cci ccs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
instance check_completeness DynamicPattern where
	check_completeness { dp_rhs, dp_type } cci ccs
		= check_completeness dp_rhs cci
		  (check_completeness_of_dyn_expr_ptr dp_type cci ccs)
	
instance check_completeness DynamicExpr where
	check_completeness { dyn_expr, dyn_opt_type } cci ccs
		= check_completeness dyn_expr cci
		  (check_completeness dyn_opt_type cci ccs)

instance check_completeness DynamicType where
	check_completeness { dt_type } cci ccs
		= check_completeness dt_type cci ccs

instance check_completeness Expression where
	check_completeness (Var _) cci ccs
		= ccs
	check_completeness (App app) cci ccs
		= check_completeness app cci ccs
	check_completeness (expression @ expressions) cci ccs
		= check_completeness expression cci
		  (check_completeness expressions cci ccs)
	check_completeness (Let lad) cci ccs
		= check_completeness lad cci ccs
	check_completeness (Case keesje) cci ccs
		= check_completeness keesje cci ccs
	check_completeness (Selection _ expression selections) cci ccs
		= check_completeness expression cci
		  (check_completeness selections cci ccs)
	check_completeness (TupleSelect _ _ expression) cci ccs
		= check_completeness expression cci ccs
	check_completeness (BasicExpr _ _) _ ccs
		= ccs
	check_completeness (AnyCodeExpr _ _ _) _ ccs
		= ccs
	check_completeness (ABCCodeExpr _ _) _ ccs
		= ccs
	check_completeness (MatchExpr _ constructor expression) cci ccs
		= check_completeness expression cci
		  (check_whether_ident_is_imported constructor.glob_object.ds_ident STE_Constructor cci ccs)
	check_completeness (FreeVar _) _ ccs
		= ccs
	check_completeness (DynamicExpr dynamicExpr) cci ccs
		= check_completeness dynamicExpr cci ccs
	check_completeness EE _ ccs
		= ccs
	check_completeness (Update expr1 selections expr2) cci ccs
		= ( (check_completeness expr1 cci)
		  o (check_completeness selections cci)
		  o (check_completeness expr2) cci
		  ) ccs
	check_completeness expr _ _
		= abort "explicitimports:check_completeness (Expression) does not match" <<- expr

instance check_completeness FunctionBody where
	check_completeness (CheckedBody body) cci ccs
		= check_completeness body cci ccs
	check_completeness (TransformedBody body) cci ccs
		= check_completeness body cci ccs
	check_completeness (RhsMacroBody body) cci ccs
		= check_completeness body cci ccs
			
instance check_completeness FunDef where
	check_completeness {fun_type, fun_body, fun_info} cci ccs
		= ( (check_completeness fun_type cci)
		  o (check_completeness fun_body cci)
		  o (foldSt (flipM check_completeness_of_dyn_expr_ptr cci) fun_info.fi_dynamics)
		  ) ccs

instance check_completeness FunType where
	check_completeness {ft_type} cci ccs
		= check_completeness ft_type cci ccs

instance check_completeness (Global x) | check_completeness x where
	check_completeness { glob_object } cci ccs
		= check_completeness glob_object cci ccs

instance check_completeness InstanceType where
	check_completeness {it_types, it_context} cci ccs
		= check_completeness it_types cci
		  (check_completeness it_context cci ccs)

instance check_completeness Let where
	check_completeness { let_strict_binds, let_lazy_binds, let_expr } cci ccs
  		= ( (check_completeness let_expr cci)
  		  o (check_completeness let_strict_binds cci)
  		  o (check_completeness let_lazy_binds cci)
  		  ) ccs

instance check_completeness MemberDef where
  	check_completeness {me_type} cci ccs 
  		= check_completeness me_type cci ccs

instance check_completeness (Optional x) | check_completeness x where
	check_completeness (Yes x) cci ccs
		= check_completeness x cci ccs
	check_completeness No _ ccs
		= ccs

instance check_completeness Selection where
	check_completeness (RecordSelection {glob_object,glob_module} _) cci ccs
		#! ({dcl_common}, ccs)	= ccs!box_ccs.ccs_dcl_modules.[glob_module]	// the selector's filed has to be looked up
		   ({sd_field}) = dcl_common.com_selector_defs.[glob_object.ds_index]
		= check_whether_ident_is_imported sd_field ste_field cci ccs
	check_completeness (ArraySelection _ _ index_expr) cci ccs
		= check_completeness index_expr cci ccs
	check_completeness (DictionarySelection _ selections _ index_expr) cci ccs
		= check_completeness selections cci
		  (check_completeness index_expr cci ccs)

instance check_completeness SelectorDef where
	check_completeness {sd_type} cci ccs
		= check_completeness sd_type cci ccs

instance check_completeness SymbIdent where
	check_completeness {symb_name, symb_kind} cci ccs
		= case symb_kind of
			SK_Constructor _
				-> check_whether_ident_is_imported symb_name STE_Constructor cci ccs
			SK_Function global_index
				-> check_completeness_for_function symb_name global_index ste_fun_or_macro cci ccs
833
834
			SK_LocalMacroFunction function_index
				-> check_completeness_for_local_macro_function symb_name function_index ste_fun_or_macro cci ccs
835
836
837
838
839
840
			SK_OverloadedFunction global_index
				-> check_completeness_for_function symb_name global_index STE_Member cci ccs
  			SK_Macro global_index
  				-> check_completeness_for_function symb_name global_index ste_fun_or_macro cci ccs
  	  where
		check_completeness_for_function symb_name {glob_object,glob_module} wanted_ste_kind cci ccs
841
			| glob_module<>cci.box_cci.cci_main_dcl_module_n
842
843
844
845
846
847
848
849
850
851
852
853
				// the function that is referred from within a macro is a DclFunction
				// -> must be global -> has to be imported
				= check_whether_ident_is_imported symb_name wanted_ste_kind cci ccs
			#! (fun_def, ccs)	= ccs!box_ccs.ccs_icl_functions.[glob_object]
			// otherwise the function was defined locally in a macro
			// it is not a consequence, but it's type and body are consequences !
			#! (already_visited, ccs) = ccs!box_ccs.ccs_set_of_visited_icl_funs.[glob_object]
			| already_visited
				= ccs
			#! ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[glob_object] = True }
			= check_completeness fun_def cci ccs

854
855
856
857
858
859
860
861
862
863
		check_completeness_for_local_macro_function symb_name glob_object wanted_ste_kind cci ccs
			#! (fun_def, ccs)	= ccs!box_ccs.ccs_icl_functions.[glob_object]
			// otherwise the function was defined locally in a macro
			// it is not a consequence, but it's type and body are consequences !
			#! (already_visited, ccs) = ccs!box_ccs.ccs_set_of_visited_icl_funs.[glob_object]
			| already_visited
				= ccs
			#! ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[glob_object] = True }
			= check_completeness fun_def cci ccs

864
865
866
867
868
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
902
903
instance check_completeness SymbolType where
	check_completeness {st_args, st_result, st_context} cci ccs
		= ( (check_completeness st_args cci)
		  o (check_completeness st_result cci)
		  o (check_completeness st_context cci)
		  ) ccs

instance check_completeness TransformedBody where
	check_completeness {tb_rhs} cci ccs
		= check_completeness tb_rhs cci ccs

instance check_completeness Type where
	check_completeness (TA {type_name} arguments) cci ccs
		= check_completeness arguments cci
		  (check_whether_ident_is_imported type_name STE_Type cci ccs)
	check_completeness (l --> r) cci ccs
		= check_completeness l cci
		  (check_completeness r cci ccs)
	check_completeness (_ :@: arguments) cci ccs
		= check_completeness arguments cci ccs
	check_completeness _ _ ccs
		= ccs

instance check_completeness TypeContext where
	check_completeness {tc_class, tc_types} cci ccs
		= check_completeness tc_types cci
		  (check_whether_ident_is_imported tc_class.glob_object.ds_ident STE_Class cci ccs)

instance check_completeness (TypeDef TypeRhs) where
	check_completeness {td_rhs, td_context}	cci ccs
		= check_completeness td_rhs cci 
		  (check_completeness td_context cci ccs)

instance check_completeness TypeRhs where
	check_completeness (SynType aType) cci ccs
		= check_completeness aType cci ccs
	check_completeness _ _ ccs
		= ccs

instance check_completeness [a]	| check_completeness a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
904
  where
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
	check_completeness [] _ ccs
		= ccs
	check_completeness [h:t] cci ccs
		= check_completeness h cci
		  (check_completeness t cci ccs)

check_completeness_of_dyn_expr_ptr :: !ExprInfoPtr !CheckCompletenessInputBox !*CheckCompletenessStateBox
								-> *CheckCompletenessStateBox 
check_completeness_of_dyn_expr_ptr dyn_expr_ptr cci ccs=:{box_ccs=box_ccs=:{ccs_expr_heap}}
	#! (expr_info, ccs_expr_heap) = readPtr dyn_expr_ptr ccs_expr_heap
	   ccs = { ccs & box_ccs = { box_ccs & ccs_expr_heap = ccs_expr_heap }}
 	= case expr_info of
		(EI_Dynamic No)	
			-> ccs
		(EI_Dynamic (Yes dynamic_type))
			-> check_completeness dynamic_type cci ccs
		(EI_DynamicType dynamic_type further_dynamic_ptrs)
			-> check_completeness dynamic_type cci
			   (foldSt (flipM check_completeness_of_dyn_expr_ptr cci) further_dynamic_ptrs ccs)
		(EI_DynamicTypeWithVars _ dynamic_type further_dynamic_ptrs)
			-> check_completeness dynamic_type cci
			   (foldSt (flipM check_completeness_of_dyn_expr_ptr cci) further_dynamic_ptrs ccs)

flipM f a b :== f b a

// STE_Kinds just for comparision
ste_field =: STE_Field { id_name="", id_info=nilPtr }
ste_fun_or_macro =: STE_FunctionOrMacro []