type_io.icl 14.6 KB
Newer Older
1
2
implementation module type_io

Martijn Vervoort's avatar
Martijn Vervoort committed
3
import StdEnv, compare_constructor
4
import scanner, general, Heap, typeproperties, utilities, checksupport
5
from expand_types import convertSymbolTypeWithoutCollectingImportedConstructors
Martijn Vervoort's avatar
Martijn Vervoort committed
6
import type_io_common
John van Groningen's avatar
John van Groningen committed
7
from genericsupport import kind_to_short_string
8

Martijn Vervoort's avatar
Martijn Vervoort committed
9
10
11
12
13
14
// normal form:
// -	type variables in type definitions are normalized by checkTypeDef in the
//		module checktypes.icl. The position of a type variable in the left-hand
//		side of a type constructor is used.
// -	algebraic datatypes; constructors are alphabetically ordered in this 
//		module
15
//
Martijn Vervoort's avatar
Martijn Vervoort committed
16
17
// unsupported:
// - 	ADTs
18

19
:: WriteTypeInfoState
20
21
22
23
24
25
	= {	wtis_n_type_vars		:: !Int
	,	wtis_common_defs		:: !{#CommonDefs}	
	,	wtis_type_defs			:: !.{#{#CheckedTypeDef}}
	,	wtis_type_heaps			:: !.TypeHeaps
	,	wtis_var_heap			:: !.VarHeap
	,	wtis_main_dcl_module_n	:: !Int
John van Groningen's avatar
John van Groningen committed
26
	,	wtis_icl_generic_defs	:: !{#GenericDef}
27
	};
John van Groningen's avatar
John van Groningen committed
28
29
30
31
32
33
34
35

write_type_info_of_types_and_constructors :: !CommonDefs !Int !Int !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
write_type_info_of_types_and_constructors {com_type_defs,com_cons_defs} n_types_with_type_functions n_constructors_with_type_functions tcl_file wtis
	# tcl_file = fwritei n_types_with_type_functions tcl_file
	# (tcl_file,wtis) = write_type_info_of_array 0 n_types_with_type_functions com_type_defs tcl_file wtis
	# tcl_file = fwritei n_constructors_with_type_functions tcl_file
	= write_type_info_of_array 0 n_constructors_with_type_functions com_cons_defs tcl_file wtis

36
37
class WriteTypeInfo a 
where
38
	write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
39

40
instance WriteTypeInfo ConsDef
41
where
42
	write_type_info {cons_ident,cons_type,cons_type_index,cons_exi_vars} tcl_file wtis=:{wtis_n_type_vars,wtis_type_heaps}
43
 		// normalize ...
44
45
46
 		# (_,th_vars)
 			= foldSt normalize_atype_var cons_exi_vars (wtis_n_type_vars,wtis_type_heaps.th_vars)
  		# wtis & wtis_type_heaps = {wtis_type_heaps & th_vars = th_vars}
47
48
 		// ... normalize
		# (tcl_file,wtis)
49
			= write_type_info cons_ident tcl_file wtis
50
		# (tcl_file,wtis)
51
			= write_type_info cons_type tcl_file wtis						
52
53
54
55
56
		# (tcl_file,wtis)
			= write_type_info cons_type_index tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info cons_exi_vars tcl_file wtis
		= (tcl_file,wtis)
John van Groningen's avatar
John van Groningen committed
57

58
instance WriteTypeInfo (TypeDef TypeRhs)
59
where
60
	write_type_info {td_ident,td_arity,td_args,td_rhs,td_fun_index} tcl_file wtis=:{wtis_type_heaps}
61
		// normalize ...
62
63
64
 		# (n_type_vars,th_vars)
 			= foldSt normalize_atype_var td_args (0,wtis_type_heaps.th_vars)
  		# wtis & wtis_n_type_vars = n_type_vars, wtis_type_heaps = {wtis_type_heaps & th_vars = th_vars}
65
66
 		// ... normalize
 		# (tcl_file,wtis)
67
 			= write_type_info td_ident tcl_file wtis
68
		# (tcl_file,wtis)
69
 			= write_type_info td_arity tcl_file wtis
70
 		# (tcl_file,wtis)
71
 			= write_type_info td_args tcl_file wtis
John van Groningen's avatar
John van Groningen committed
72
		| td_fun_index<>NoIndex
73
 			= write_type_info td_rhs tcl_file wtis
74
			// currently not used
John van Groningen's avatar
John van Groningen committed
75
76
77
78
79
			# (RecordType {rt_constructor,rt_fields}) = td_rhs
			  tcl_file = fwritec GenericDictionaryTypeCode tcl_file;
			  (tcl_file,wtis) = write_type_info rt_constructor tcl_file wtis
			= write_type_info rt_fields tcl_file wtis

80
normalize_atype_var :: !ATypeVar (!Int,!*TypeVarHeap) -> (!Int,!*TypeVarHeap)
John van Groningen's avatar
John van Groningen committed
81
82
normalize_atype_var td_arg=:{atv_variable={tv_info_ptr}} (id,th_vars)
	# th_vars = writePtr tv_info_ptr (TVI_Normalized id) th_vars
83
	= (inc id,th_vars)
John van Groningen's avatar
John van Groningen committed
84

85
normalize_type_var :: !TypeVar (!Int,!*TypeVarHeap) -> (!Int,!*TypeVarHeap)
John van Groningen's avatar
John van Groningen committed
86
87
normalize_type_var {tv_info_ptr} (id,th_vars)
	# th_vars = writePtr tv_info_ptr (TVI_Normalized id) th_vars
88
	= (inc id,th_vars)
89
 
90
91
instance WriteTypeInfo ATypeVar
where 
92
	write_type_info {atv_variable} tcl_file wtis
93
94
95
 		# (tcl_file,wtis)
 			= write_type_info atv_variable tcl_file wtis
 		= (tcl_file,wtis)
96

97
98
instance WriteTypeInfo TypeVar
where
99
100
101
	write_type_info {tv_info_ptr} tcl_file wtis=:{wtis_type_heaps}
		# (v,th_vars)
			= readPtr tv_info_ptr wtis_type_heaps.th_vars
102
103
104
		# tcl_file
			= fwritei (get_type_var_nf_number v) tcl_file

105
  		# wtis & wtis_type_heaps = {wtis_type_heaps & th_vars = th_vars}
106
107
108
109
 		= (tcl_file,wtis)
 	where
 		get_type_var_nf_number (TVI_Normalized i) = i
 
110
111
instance WriteTypeInfo TypeRhs
where 
112
	write_type_info (AlgType defined_symbols) tcl_file wtis
113
114
115
 		# tcl_file = fwritec AlgTypeCode tcl_file
		# defined_symbols = sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols
		= write_type_info defined_symbols tcl_file wtis
116
	write_type_info (SynType _) tcl_file wtis
117
118
		# tcl_file = fwritec SynTypeCode tcl_file;
  		= (tcl_file,wtis)
119
	write_type_info (RecordType {rt_constructor,rt_fields}) tcl_file wtis
120
121
122
 		#! tcl_file = fwritec RecordTypeCode tcl_file;
		#! (tcl_file,wtis) = write_type_info rt_constructor tcl_file wtis
		= write_type_info rt_fields tcl_file wtis
123
	write_type_info (AbstractType _) tcl_file wtis
124
 		#! tcl_file = fwritec AbstractTypeCode tcl_file;
125
126
127
128
 		// unimplemented
		= (tcl_file,wtis)
	write_type_info (AbstractSynType _ _) tcl_file wtis
 		#! tcl_file	= fwritec AbstractTypeCode tcl_file;
129
 		// unimplemented
130
		= (tcl_file,wtis)
131
132
133
134
135
136
	write_type_info (ExtensibleAlgType _) tcl_file wtis
 		// unimplemented
		= (tcl_file,wtis)
	write_type_info (AlgConses _ _) tcl_file wtis
 		// unimplemented
		= (tcl_file,wtis)
137
138
139
140
	write_type_info (NewType _) tcl_file wtis
 		#! tcl_file = fwritec AbstractTypeCode tcl_file;
 		// unimplemented
		= (tcl_file,wtis)
141

142
143
instance WriteTypeInfo DefinedSymbol 
where
144
145
146
147
148
149
150
151
	write_type_info {ds_ident,ds_arity,ds_index} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info ds_ident tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info ds_arity tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info ds_index tcl_file wtis
		= (tcl_file,wtis)
152
153
154

instance WriteTypeInfo Ident 
where
155
	write_type_info {id_name} tcl_file wtis
156
157
		# tcl_file
			= fwritei (size id_name) tcl_file
158
		= (fwrites id_name tcl_file,wtis)
159

160
161
instance WriteTypeInfo FieldSymbol
where
162
163
	write_type_info {fs_ident} tcl_file wtis
		= write_type_info fs_ident tcl_file wtis
164

Martijn Vervoort's avatar
Martijn Vervoort committed
165
166
instance WriteTypeInfo SymbolType
where
167
168
169
	write_type_info symbol_type tcl_file wtis
		#! ({st_vars,st_args,st_args_strictness,st_arity,st_result},wtis)
			= expand_symbol_type symbol_type wtis
170
171
172
		# (tcl_file,wtis)
			= write_type_info st_vars tcl_file wtis
		# (tcl_file,wtis)
173
174
175
			= write_type_info st_args tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info st_args_strictness tcl_file wtis
176
177
178
179
180
		# (tcl_file,wtis)
			= write_type_info st_arity tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info st_result tcl_file wtis
		= (tcl_file,wtis)
181
	where
182
		expand_symbol_type symbol_type wtis=:{wtis_common_defs,wtis_type_defs,wtis_main_dcl_module_n,wtis_type_heaps,wtis_var_heap}
183
184
			# (expanded_symbol_type,wtis_type_defs,wtis_type_heaps,wtis_var_heap)
				= convertSymbolTypeWithoutCollectingImportedConstructors False wtis_common_defs symbol_type wtis_main_dcl_module_n wtis_type_defs wtis_type_heaps wtis_var_heap;
185
			# wtis = {wtis & wtis_type_defs = wtis_type_defs, wtis_type_heaps = wtis_type_heaps, wtis_var_heap = wtis_var_heap};
186
			= (expanded_symbol_type,wtis)
187

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
instance WriteTypeInfo StrictnessList
where
	write_type_info NotStrict tcl_file wtis
		# tcl_file
			= fwritec NotStrictCode tcl_file
		= (tcl_file,wtis)
	write_type_info (Strict i) tcl_file wtis
		# tcl_file
			= fwritec StrictCode tcl_file
		# tcl_file
			= fwritei i tcl_file
		= (tcl_file,wtis)
	write_type_info (StrictList i tail) tcl_file wtis
		# tcl_file
			= fwritec StrictListCode tcl_file
		# tcl_file
			= fwritei i tcl_file
		= write_type_info tail tcl_file wtis
				
Martijn Vervoort's avatar
Martijn Vervoort committed
207
208
instance WriteTypeInfo AType
where
209
	write_type_info {at_type} tcl_file wtis
210
211
212
		# (tcl_file,wtis)
			= write_type_info at_type tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
213
		
Martijn Vervoort's avatar
Martijn Vervoort committed
214
215
instance WriteTypeInfo Type
where
216
	write_type_info (TA type_symb_ident atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
217
		# tcl_file
218
			= fwritec TypeTASCode tcl_file
219
220
221
222
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atypes tcl_file wtis
223
224
		# (tcl_file,wtis)
			= write_type_info NotStrict tcl_file wtis			
225
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
226

227
228
	write_type_info (TAS type_symb_ident atypes strictness) tcl_file wtis
		# tcl_file
229
			= fwritec TypeTASCode tcl_file
230
231
232
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
233
234
235
			= write_type_info atypes tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info strictness tcl_file wtis			
236
237
		= (tcl_file,wtis)

238
	write_type_info (atype1 --> atype2) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
239
240
		# tcl_file
			= fwritec TypeArrowCode tcl_file
241
242
243
244
245
		# (tcl_file,wtis)
			= write_type_info atype1 tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atype2 tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
246
		
247
	write_type_info (cons_variable :@: atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
248
249
		# tcl_file
			= fwritec TypeConsApplyCode tcl_file
250
251
252
253
254
		# (tcl_file,wtis)
			= write_type_info cons_variable tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atypes tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
255
		
256
257
	write_type_info tb=:(TB basic_type) tcl_file wtis
		# (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
258
			= case basic_type of
259
260
261
262
263
264
265
				BT_Int		-> (fwritec BT_IntCode tcl_file,wtis)
				BT_Char		-> (fwritec BT_CharCode tcl_file,wtis)
				BT_Real		-> (fwritec BT_RealCode tcl_file,wtis)
				BT_Bool		-> (fwritec BT_BoolCode tcl_file,wtis)
				BT_Dynamic	-> (fwritec BT_DynamicCode tcl_file,wtis)
				BT_File		-> (fwritec BT_FileCode tcl_file,wtis)
				BT_World	-> (fwritec BT_WorldCode tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
266
267
268
				BT_String type
					# tcl_file
						= fwritec BT_StringCode tcl_file
269
270
271
272
					# (tcl_file,wtis)
						= write_type_info type tcl_file wtis
					-> (tcl_file,wtis)
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
273
	
274
	write_type_info (GTV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
275
276
		# tcl_file
			= fwritec TypeGTVCode tcl_file
277
278
279
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
280

281
	write_type_info (TV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
282
283
		# tcl_file
			= fwritec TypeTVCode tcl_file
284
285
286
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
287

288
	write_type_info (TQV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
289
290
		# tcl_file
			= fwritec TypeTQVCode tcl_file
291
292
293
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
294

295
296
297
	// FIXME: the universally quantifier and type vars are ignored here
	// this is really just a hack to prevent the compiler from crashing
	// on rank>1 types
298
299
300
301
	write_type_info (TFA uni_vars type) tcl_file wtis=:{wtis_type_heaps}
 		# (_,th_vars) = foldSt normalize_atype_var uni_vars (0,wtis_type_heaps.th_vars)
  		# wtis & wtis_type_heaps = {wtis_type_heaps & th_vars = th_vars}
		= write_type_info type tcl_file wtis
302

303
304
305
306
307
	write_type_info (TFAC uni_vars type _) tcl_file wtis=:{wtis_type_heaps}
 		# (_,th_vars) = foldSt normalize_atype_var uni_vars (0,wtis_type_heaps.th_vars)
  		# wtis & wtis_type_heaps = {wtis_type_heaps & th_vars = th_vars}
		= write_type_info type tcl_file wtis

308
	write_type_info TE tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
309
310
		# tcl_file
			= fwritec TypeTECode tcl_file
311
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
312

John van Groningen's avatar
John van Groningen committed
313
314
315
316
317
318
	write_type_info (TGenericFunctionInDictionary {glob_module,glob_object={ds_index}} type_kind generict_dict) tcl_file wtis
		# ({gen_type},wtis)
			= if (glob_module==wtis.wtis_main_dcl_module_n)
				wtis!wtis_icl_generic_defs.[ds_index]
				wtis!wtis_common_defs.[glob_module].com_generic_defs.[ds_index]
		  {wtis_type_heaps,wtis_n_type_vars} = wtis
319
320
 		  (n_type_vars,th_vars)
 			= foldSt normalize_type_var gen_type.st_vars (0,wtis_type_heaps.th_vars)
John van Groningen's avatar
John van Groningen committed
321
322
323
324
325
326
327
328
329
  		  wtis = {wtis & wtis_type_heaps={wtis_type_heaps & th_vars = th_vars}, wtis_n_type_vars = n_type_vars}
		  tcl_file = fwritec GenericFunctionTypeCode tcl_file
		  kind_string = kind_to_short_string type_kind;
		  tcl_file = fwritei (size kind_string) tcl_file
		  tcl_file = fwrites kind_string tcl_file
		  (tcl_file,wtis) = write_type_info gen_type tcl_file wtis
		  wtis = {wtis & wtis_n_type_vars=wtis_n_type_vars}
		= (tcl_file,wtis)

Martijn Vervoort's avatar
Martijn Vervoort committed
330
331
instance WriteTypeInfo ConsVariable
where
332
	write_type_info (CV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
333
334
		# tcl_file
			= fwritec ConsVariableCVCode tcl_file
335
336
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
337
		= (tcl_file,wtis)
338
	write_type_info (TempCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
339
340
		# tcl_file
			= fwritec ConsVariableTempCVCode tcl_file
341
342
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
343
		= (tcl_file,wtis)
344
	write_type_info (TempQCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
345
346
		# tcl_file
			= fwritec ConsVariableTempQCVCode tcl_file
347
348
349
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
350
351
352
353
354
355
	write_type_info (TempQCDV temp_var_id) tcl_file wtis
		# tcl_file
			= fwritec ConsVariableTempQCVCode tcl_file
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
356
357
358

instance WriteTypeInfo TypeSymbIdent
where
359
	write_type_info tsi=:{type_ident,type_arity,type_index={glob_module,glob_object}} tcl_file wtis
360
		# is_type_without_definition = glob_module==cPredefinedModuleIndex
Martijn Vervoort's avatar
Martijn Vervoort committed
361
362
		# tcl_file
			= fwritec (if is_type_without_definition TypeSymbIdentWithoutDefinition TypeSymbIdentWithDefinition) tcl_file
363
		# (tcl_file,wtis)
364
			= write_type_info type_ident tcl_file wtis
365
		# (tcl_file,wtis)		 
366
			= write_type_info type_arity tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
367
368
369
		# (tcl_file,wtis)
			= write_type_info tsi.type_index tcl_file wtis
		= (tcl_file,wtis)
370

Martijn Vervoort's avatar
Martijn Vervoort committed
371
372
373
374
375
376
377
instance WriteTypeInfo (Global object) | WriteTypeInfo object
where
	write_type_info {glob_object,glob_module} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info glob_object tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info glob_module tcl_file wtis
378
		= (tcl_file,wtis)
379
 
380
381
382
// basic and structural write_type_info's
instance WriteTypeInfo Int 
where
383
384
	write_type_info i tcl_file wtis
		= (fwritei i tcl_file,wtis)
385

386
instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b
387
where
388
	write_type_info unboxed_array tcl_file wtis
389
390
		# s_unboxed_array = size unboxed_array
		# tcl_file = fwritei s_unboxed_array tcl_file			
John van Groningen's avatar
John van Groningen committed
391
		= write_type_info_of_array 0 s_unboxed_array unboxed_array tcl_file wtis
392

John van Groningen's avatar
John van Groningen committed
393
394
395
396
397
398
write_type_info_of_array i limit array tcl_file wtis
	| i == limit
		= (tcl_file,wtis)
	# (tcl_file,wtis)
		= write_type_info array.[i] tcl_file wtis
	= write_type_info_of_array (inc i) limit array tcl_file wtis
399

400
401
instance WriteTypeInfo [a] | WriteTypeInfo a
where
402
	write_type_info l tcl_file wtis
403
404
		# tcl_file
			= fwritei (length l) tcl_file
405
		= write_type_info_loop l tcl_file wtis
406
	where
407
408
409
410
411
412
		write_type_info_loop []	tcl_file wtis
			= (tcl_file,wtis)
		write_type_info_loop [x:xs] tcl_file wtis
			# (tcl_file,wtis)
				= write_type_info x tcl_file wtis
			= write_type_info_loop xs tcl_file wtis
413
414
415
			
instance WriteTypeInfo Char
where
416
	write_type_info c tcl_file wtis
417
418
		# tcl_file
			= fwritec c tcl_file;
419
		= (tcl_file,wtis);
Martijn Vervoort's avatar
Martijn Vervoort committed
420

421
422
423
424
425
426
427
428
instance WriteTypeInfo (a,b) | WriteTypeInfo a & WriteTypeInfo b
where
	write_type_info (c1,c2) tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info c1 tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info c2 tcl_file wtis
		= (tcl_file,wtis)