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

Martijn Vervoort's avatar
Martijn Vervoort committed
3
4
5
// WARNING: It is essential to report changes in this module to martijnv@cs.kun.nl
//			because the binary format for type-files is used by the dynamic run-time
//			system.
6

Martijn Vervoort's avatar
Martijn Vervoort committed
7
import StdEnv, compare_constructor
8
9
import scanner, general, Heap, typeproperties, utilities, checksupport

Martijn Vervoort's avatar
Martijn Vervoort committed
10
import type_io_common
Martijn Vervoort's avatar
Martijn Vervoort committed
11
12
13
14
15
16
// 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
17
//
Martijn Vervoort's avatar
Martijn Vervoort committed
18
19
20
// unsupported:
// - 	type synonyms
// - 	ADTs
21

Martijn Vervoort's avatar
Martijn Vervoort committed
22
23
//import DebugUtilities;
F a b :== b;
Martijn Vervoort's avatar
Martijn Vervoort committed
24

25
26
27
28
29
:: WriteTypeInfoState
	= { 
		wtis_type_heaps			:: !.TypeHeaps
	,	wtis_n_type_vars		:: !Int
	};
Martijn Vervoort's avatar
Martijn Vervoort committed
30
	
31
32
class WriteTypeInfo a 
where
33
	write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
34
35
36
	
instance WriteTypeInfo CommonDefs
where 
37
38
39
40
41
42
43
44
	write_type_info {com_type_defs,com_cons_defs,com_selector_defs} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info com_type_defs tcl_file wtis
		# (tcl_file,wtis)
 			= write_type_info com_cons_defs tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info com_selector_defs tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
45
46
47
		
instance WriteTypeInfo SelectorDef
where
48
49
50
51
	write_type_info {sd_type} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info sd_type tcl_file wtis
		= (tcl_file,wtis)
52
53
54
	
instance WriteTypeInfo ConsDef
where 
55
56
57
58
59
60
61
62
63
64
65
	write_type_info {cons_symb,cons_type,cons_arg_vars,cons_priority,cons_index,cons_type_index,cons_exi_vars} tcl_file wtis=:{wtis_n_type_vars}
 		// normalize ...
 		# (th_vars,wtis)
 			= sel_type_var_heap wtis
 		# (_,(_,th_vars))
 			= mapSt normalize_type_var cons_exi_vars (wtis_n_type_vars,th_vars)
  		# wtis
 			= { wtis &
 				wtis_type_heaps		=  { wtis.wtis_type_heaps & th_vars = th_vars }
 			}
 		// ... normalize
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
		# (tcl_file,wtis)
			= write_type_info cons_symb tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info cons_type tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info cons_arg_vars tcl_file wtis
//		# (tcl_file,wtis)
//			= write_type_info cons_priority tcl_file wtis

		# (tcl_file,wtis)
			= write_type_info cons_index tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info cons_type_index tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info cons_exi_vars tcl_file wtis
82
	
83
		= (tcl_file,wtis)
84
		
85
/*
86
87
instance WriteTypeInfo Priority
where 
88
	write_type_info (Prio assoc i) tcl_file wtis
89
90
		# tcl_file
			= fwritec PrioCode tcl_file
91
92
93
94
95
96
97
98
99
		# (tcl_file,wtis)
			= write_type_info assoc tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info i tcl_file wtis
		= (tcl_file,wtis)
	write_type_info NoPrio tcl_file wtis
		# tcl_file
			= fwritec NoPrioCode tcl_file 
		= (tcl_file,wtis)
100
101
102
		
instance WriteTypeInfo Assoc
where 
103
	write_type_info LeftAssoc tcl_file wtis
104
		# tcl_file
105
106
			= fwritec LeftAssocCode tcl_file 
		= (tcl_file,wtis)
107

108
	write_type_info RightAssoc tcl_file wtis
109
110
		# tcl_file
			= fwritec RightAssocCode tcl_file
111
		= (tcl_file,wtis)	
112

113
	write_type_info NoAssoc tcl_file wtis
114
		# tcl_file
115
116
117
			= fwritec NoAssocCode tcl_file 
		= (tcl_file,wtis)	
*/
118
		
119
//1.3
120
instance WriteTypeInfo TypeDef TypeRhs
121
122
123
124
//3.1
/*2.0
instance WriteTypeInfo (TypeDef TypeRhs)
0.2*/
125
where 
126
127
128
129
130
131
132
133
134
135
136
137
	write_type_info {td_name,td_arity,td_args,td_rhs} tcl_file wtis
		// normalize ...
 		# (th_vars,wtis)
 			= sel_type_var_heap wtis
 		# (_,(n_type_vars,th_vars))
 			= mapSt normalize_type_var td_args (0,th_vars)
  		# wtis
 			= { wtis &
 				wtis_type_heaps		=  { wtis.wtis_type_heaps & th_vars = th_vars }
 			,	wtis_n_type_vars		= n_type_vars
 			}
 		// ... normalize
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
 		# (tcl_file,wtis)
 			= write_type_info td_name tcl_file wtis
		# (tcl_file,wtis)
 			= write_type_info td_arity tcl_file wtis 				
 		# (tcl_file,wtis)
 			= write_type_info td_args tcl_file wtis
		# (tcl_file,wtis)
 			= write_type_info td_rhs tcl_file wtis
 			
 		= (tcl_file,wtis)
 	
normalize_type_var :: !ATypeVar (!Int,!*TypeVarHeap) -> (!Int,(!Int,!*TypeVarHeap))
normalize_type_var td_arg=:{atv_variable={tv_info_ptr}} (id,th_vars)
	# th_vars
		= writePtr tv_info_ptr (TVI_Normalized id) th_vars
	= (id,(inc id,th_vars));
		
sel_type_var_heap :: !*WriteTypeInfoState -> (!*TypeVarHeap,!*WriteTypeInfoState)
sel_type_var_heap wtis=:{wtis_type_heaps}
	# (th_vars,wtis_type_heaps)
		= sel wtis_type_heaps
	= (th_vars,{ wtis & wtis_type_heaps = wtis_type_heaps} )
	
	where
		sel wtis_type_heaps=:{th_vars}
			= (th_vars,{ wtis_type_heaps & th_vars = newHeap } )
 
166
167
instance WriteTypeInfo ATypeVar
where 
168
169
170
171
172
173
	write_type_info {atv_annotation,atv_variable} tcl_file wtis
 		# (tcl_file,wtis) 
 			= write_type_info atv_annotation tcl_file wtis
 		# (tcl_file,wtis)
 			= write_type_info atv_variable tcl_file wtis
 		= (tcl_file,wtis)
174
175
176
 		
instance WriteTypeInfo Annotation
where 
177
178
179
180
	write_type_info AN_Strict tcl_file wtis	
		= (fwritec '!' tcl_file,wtis)
	write_type_info AN_None tcl_file wtis
		= (fwritec ' ' tcl_file,wtis)
181
182
183
		
instance WriteTypeInfo TypeVar
where
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
	write_type_info {tv_info_ptr} tcl_file wtis
		# (th_vars,wtis)
			= sel_type_var_heap wtis
		# ( v,th_vars)
			= readPtr tv_info_ptr th_vars
		# tcl_file
			= fwritei (get_type_var_nf_number v) tcl_file

  		# wtis 
 			= { wtis &
 				wtis_type_heaps		=  { wtis.wtis_type_heaps & th_vars = th_vars }
 			}
 		= (tcl_file,wtis)	
 	where 
 		get_type_var_nf_number (TVI_Normalized i)	= i

200
201
instance WriteTypeInfo TypeRhs
where 
202
203
204
	write_type_info (AlgType defined_symbols) tcl_file wtis
 		# tcl_file
 			= fwritec AlgTypeCode tcl_file
205
		
Martijn Vervoort's avatar
Martijn Vervoort committed
206
207
		# defined_symbols
			= (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols)
208
209
		# (tcl_file,wtis)
			= write_type_info defined_symbols tcl_file wtis
210

211
		= (tcl_file,wtis)
212
		
213
214
	write_type_info (SynType _) tcl_file wtis
		# tcl_file
215
216
217
 			= fwritec SynTypeCode tcl_file;
 			
 		// unimplemented
218
 		= (tcl_file,wtis) 
219
		
220
	write_type_info (RecordType {rt_fields}) tcl_file wtis
221
222
 		#! tcl_file
 			= fwritec RecordTypeCode tcl_file;
223
		= write_type_info rt_fields tcl_file wtis
224

225
	write_type_info (AbstractType _) tcl_file wtis
226
227
228
229
 		#! tcl_file
 			= fwritec AbstractTypeCode tcl_file;
 			
 		// unimplemented
230
		= (tcl_file,wtis)
231
232
233
		
instance WriteTypeInfo DefinedSymbol 
where
234
235
236
237
238
239
240
241
	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)
242
243
244

instance WriteTypeInfo Ident 
where
245
	write_type_info {id_name} tcl_file wtis
246
247
		# tcl_file
			= fwritei (size id_name) tcl_file
248
		= (fwrites id_name tcl_file,wtis)
249
250
251
		
instance WriteTypeInfo FieldSymbol
where
252
253
254
255
256
257
258
259
	write_type_info {fs_name,fs_var,fs_index} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info fs_name tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info fs_var tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info fs_index tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
260
261
262
263
		
// NEW ->
instance WriteTypeInfo SymbolType
where
264
265
266
267
268
269
270
271
272
273
	write_type_info {st_vars,st_args,st_arity,st_result} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info st_vars tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info st_args tcl_file wtis
		# (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)
Martijn Vervoort's avatar
Martijn Vervoort committed
274
275
276
		
instance WriteTypeInfo AType
where
277
278
279
280
281
282
	write_type_info {at_annotation,at_type} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info at_annotation tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info at_type tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
283
		
Martijn Vervoort's avatar
Martijn Vervoort committed
284
285
instance WriteTypeInfo Type
where
286
	write_type_info (TA type_symb_ident atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
287
288
		# tcl_file
			= fwritec TypeTACode tcl_file
289
290
291
292
293
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atypes tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
294

295
	write_type_info (atype1 --> atype2) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
296
297
		# tcl_file
			= fwritec TypeArrowCode tcl_file
298
299
300
301
302
		# (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
303
		
304
	write_type_info (cons_variable :@: atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
305
306
		# tcl_file
			= fwritec TypeConsApplyCode tcl_file
307
308
309
310
311
		# (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
312
		
313
314
	write_type_info tb=:(TB basic_type) tcl_file wtis
		# (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
315
			= case basic_type of
316
317
318
319
320
321
322
				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
323
324
325
				BT_String type
					# tcl_file
						= fwritec BT_StringCode tcl_file
326
327
328
329
					# (tcl_file,wtis)
						= write_type_info type tcl_file wtis
					-> (tcl_file,wtis)
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
330
	
331
	write_type_info (GTV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
332
333
		# tcl_file
			= fwritec TypeGTVCode tcl_file
334
335
336
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
337

338
	write_type_info (TV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
339
340
		# tcl_file
			= fwritec TypeTVCode tcl_file
341
342
343
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
344
		
345
	write_type_info (TQV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
346
347
		# tcl_file
			= fwritec TypeTQVCode tcl_file
348
349
350
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
351

352
	write_type_info TE tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
353
354
		# tcl_file
			= fwritec TypeTECode tcl_file
355
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
356
357
358

instance WriteTypeInfo ConsVariable
where
359
	write_type_info (CV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
360
361
		# tcl_file
			= fwritec ConsVariableCVCode tcl_file
362
363
364
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
365

366
	write_type_info (TempCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
367
368
		# tcl_file
			= fwritec ConsVariableTempCVCode tcl_file
369
370
371
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
372
		
373
	write_type_info (TempQCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
374
375
		# tcl_file
			= fwritec ConsVariableTempQCVCode tcl_file
376
377
378
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
379
380
381

instance WriteTypeInfo TypeSymbIdent
where
382
383
384
385
386
387
	write_type_info {type_name,type_arity} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info type_name tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info type_arity tcl_file wtis
		= (tcl_file,wtis)
388
389
390
391
		
/*2.0
instance WriteTypeInfo String
where
392
	write_type_info s tcl_file wtis
393
394
395
396
397
398
399
		# tcl_file
			= fwritei (size s) tcl_file
		= fwrites s tcl_file
	// warning:
	// Should be identical to the code in Ident

0.2*/
Martijn Vervoort's avatar
Martijn Vervoort committed
400

401
402
403
// basic and structural write_type_info's
instance WriteTypeInfo Int 
where
404
405
	write_type_info i tcl_file wtis
		= (fwritei i tcl_file,wtis)
406

407
408
409
410
411
412
//1.3
instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b
//3.1
/*2.0
instance WriteTypeInfo {#b} | WriteTypeInfo b & Array {#} b
0.2*/
413
where
414
	write_type_info unboxed_array tcl_file wtis
415
416
417
418
419
		# s_unboxed_array
			= size unboxed_array
		# tcl_file
			= fwritei s_unboxed_array tcl_file
			
420
		= write_type_info_loop 0 s_unboxed_array tcl_file wtis
421
	where 
422

423
		write_type_info_loop i limit tcl_file wtis
424
			| i == limit
425
426
427
428
				= (tcl_file,wtis)
			# (tcl_file,wtis)
				= write_type_info unboxed_array.[i] tcl_file wtis
			= write_type_info_loop (inc i) limit tcl_file wtis
429
430
431
			
instance WriteTypeInfo [a] | WriteTypeInfo a
where
432
	write_type_info l tcl_file wtis
433
434
		# tcl_file
			= fwritei (length l) tcl_file
435
		= write_type_info_loop l tcl_file wtis
436
	where
437
438
439
440
441
442
		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
443
444
445
			
instance WriteTypeInfo Char
where
446
	write_type_info c tcl_file wtis
447
448
		# tcl_file
			= fwritec c tcl_file;
449
		= (tcl_file,wtis);