type_io.icl 14.7 KB
Newer Older
1
2
3
/*
	module owner: Martijn Vervoort
*/
4
5
implementation module type_io

Martijn Vervoort's avatar
Martijn Vervoort committed
6
7
8
// 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.
9

Martijn Vervoort's avatar
Martijn Vervoort committed
10
import StdEnv, compare_constructor
11
12
import scanner, general, Heap, typeproperties, utilities, checksupport

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

Martijn Vervoort's avatar
Martijn Vervoort committed
25
26
//import DebugUtilities;
F a b :== b;
Martijn Vervoort's avatar
Martijn Vervoort committed
27

28
29
:: WriteTypeInfoState
	= { 
Martijn Vervoort's avatar
Martijn Vervoort committed
30
31
32
33
		wtis_type_heaps				:: !.TypeHeaps
	,	wtis_n_type_vars			:: !Int
	,	wtis_predefined_module_def	:: !Index

34
	};
Martijn Vervoort's avatar
Martijn Vervoort committed
35
	
36
37
class WriteTypeInfo a 
where
38
	write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
39
40
41
	
instance WriteTypeInfo CommonDefs
where 
42
43
44
45
46
47
48
49
	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
50
51
52
		
instance WriteTypeInfo SelectorDef
where
53
54
55
56
	write_type_info {sd_type} tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info sd_type tcl_file wtis
		= (tcl_file,wtis)
57
58
59
	
instance WriteTypeInfo ConsDef
where 
60
61
62
63
64
65
66
67
68
69
70
	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
71

72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
		# (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
87
	
88
		= (tcl_file,wtis)
89
		
90
/*
91
92
instance WriteTypeInfo Priority
where 
93
	write_type_info (Prio assoc i) tcl_file wtis
94
95
		# tcl_file
			= fwritec PrioCode tcl_file
96
97
98
99
100
101
102
103
104
		# (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)
105
106
107
		
instance WriteTypeInfo Assoc
where 
108
	write_type_info LeftAssoc tcl_file wtis
109
		# tcl_file
110
111
			= fwritec LeftAssocCode tcl_file 
		= (tcl_file,wtis)
112

113
	write_type_info RightAssoc tcl_file wtis
114
115
		# tcl_file
			= fwritec RightAssocCode tcl_file
116
		= (tcl_file,wtis)	
117

118
	write_type_info NoAssoc tcl_file wtis
119
		# tcl_file
120
121
122
			= fwritec NoAssocCode tcl_file 
		= (tcl_file,wtis)	
*/
123
		
124
//1.3
125
instance WriteTypeInfo TypeDef TypeRhs
126
127
128
129
//3.1
/*2.0
instance WriteTypeInfo (TypeDef TypeRhs)
0.2*/
130
where 
131
132
133
134
135
136
137
138
139
140
141
142
	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
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
 		# (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 } )
 
171
172
instance WriteTypeInfo ATypeVar
where 
173
	write_type_info {atv_variable} tcl_file wtis
174
175
176
 		# (tcl_file,wtis)
 			= write_type_info atv_variable tcl_file wtis
 		= (tcl_file,wtis)
177

178
179
instance WriteTypeInfo TypeVar
where
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
	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

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

207
		= (tcl_file,wtis)
208
		
209
210
	write_type_info (SynType _) tcl_file wtis
		# tcl_file
211
212
213
 			= fwritec SynTypeCode tcl_file;
 			
 		// unimplemented
214
 		= (tcl_file,wtis) 
215
		
216
	write_type_info (RecordType {rt_constructor,rt_fields}) tcl_file wtis
217
218
 		#! tcl_file
 			= fwritec RecordTypeCode tcl_file;
219
220
221
222
223
		#! (tcl_file,wtis)
			= write_type_info rt_constructor tcl_file wtis
		#! (tcl_file,wtis)
			= write_type_info rt_fields tcl_file wtis
		= (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
	write_type_info {st_vars,st_args,st_args_strictness,st_arity,st_result} tcl_file wtis
265
266
267
		# (tcl_file,wtis)
			= write_type_info st_vars tcl_file wtis
		# (tcl_file,wtis)
268
269
270
			= write_type_info st_args tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info st_args_strictness tcl_file wtis
271
272
273
274
275
		# (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)
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
	
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
296
297
instance WriteTypeInfo AType
where
298
	write_type_info {at_type} tcl_file wtis
299
300
301
		# (tcl_file,wtis)
			= write_type_info at_type tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
302
		
Martijn Vervoort's avatar
Martijn Vervoort committed
303
304
instance WriteTypeInfo Type
where
305
	write_type_info (TA type_symb_ident atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
306
		# tcl_file
307
			= fwritec TypeTASCode tcl_file
308
309
310
311
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info atypes tcl_file wtis
312
313
314
315
		# (tcl_file,wtis)
			= write_type_info NotStrict tcl_file wtis			
//		# (tcl_file,wtis)
//			= write_annotated_type_info atypes strictness tcl_file wtis
316
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
317

318
319
	write_type_info (TAS type_symb_ident atypes strictness) tcl_file wtis
		# tcl_file
320
			= fwritec TypeTASCode tcl_file
321
322
323
		# (tcl_file,wtis)
			= write_type_info type_symb_ident tcl_file wtis
		# (tcl_file,wtis)
324
325
326
327
328
			= write_type_info atypes tcl_file wtis
		# (tcl_file,wtis)
			= write_type_info strictness tcl_file wtis			
//		# (tcl_file,wtis)
//			= write_annotated_type_info atypes strictness tcl_file wtis
329
330
		= (tcl_file,wtis)

331
	write_type_info (atype1 --> atype2) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
332
333
		# tcl_file
			= fwritec TypeArrowCode tcl_file
334
335
336
337
338
		# (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
339
		
340
	write_type_info (cons_variable :@: atypes) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
341
342
		# tcl_file
			= fwritec TypeConsApplyCode tcl_file
343
344
345
346
347
		# (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
348
		
349
350
	write_type_info tb=:(TB basic_type) tcl_file wtis
		# (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
351
			= case basic_type of
352
353
354
355
356
357
358
				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
359
360
361
				BT_String type
					# tcl_file
						= fwritec BT_StringCode tcl_file
362
363
364
365
					# (tcl_file,wtis)
						= write_type_info type tcl_file wtis
					-> (tcl_file,wtis)
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
366
	
367
	write_type_info (GTV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
368
369
		# tcl_file
			= fwritec TypeGTVCode tcl_file
370
371
372
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
373

374
	write_type_info (TV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
375
376
		# tcl_file
			= fwritec TypeTVCode tcl_file
377
378
379
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)
Martijn Vervoort's avatar
Martijn Vervoort committed
380
		
381
	write_type_info (TQV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
382
383
		# tcl_file
			= fwritec TypeTQVCode tcl_file
384
385
386
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
387

388
	write_type_info TE tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
389
390
		# tcl_file
			= fwritec TypeTECode tcl_file
391
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
392
393
394

instance WriteTypeInfo ConsVariable
where
395
	write_type_info (CV type_var) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
396
397
		# tcl_file
			= fwritec ConsVariableCVCode tcl_file
398
399
400
		# (tcl_file,wtis)
			= write_type_info type_var tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
401

402
	write_type_info (TempCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
403
404
		# tcl_file
			= fwritec ConsVariableTempCVCode tcl_file
405
406
407
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
408
		
409
	write_type_info (TempQCV temp_var_id) tcl_file wtis
Martijn Vervoort's avatar
Martijn Vervoort committed
410
411
		# tcl_file
			= fwritec ConsVariableTempQCVCode tcl_file
412
413
414
		# (tcl_file,wtis)
			= write_type_info temp_var_id tcl_file wtis
		= (tcl_file,wtis)	
Martijn Vervoort's avatar
Martijn Vervoort committed
415
416
417

instance WriteTypeInfo TypeSymbIdent
where
Martijn Vervoort's avatar
Martijn Vervoort committed
418
419
420
421
422
423
	write_type_info {type_name,type_arity,type_index={glob_module}} tcl_file wtis=:{wtis_predefined_module_def}
		# is_type_without_definition
			= glob_module == wtis_predefined_module_def
		# tcl_file
			= fwritec (if is_type_without_definition TypeSymbIdentWithoutDefinition TypeSymbIdentWithDefinition) tcl_file

424
425
426
427
428
		# (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)
429

430
431
432
// basic and structural write_type_info's
instance WriteTypeInfo Int 
where
433
434
	write_type_info i tcl_file wtis
		= (fwritei i tcl_file,wtis)
435

436
437
438
439
//1.3
instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b
//3.1
/*2.0
440
instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b
441
0.2*/
442
where
443
	write_type_info unboxed_array tcl_file wtis
444
445
446
447
448
		# s_unboxed_array
			= size unboxed_array
		# tcl_file
			= fwritei s_unboxed_array tcl_file
			
449
		= write_type_info_loop 0 s_unboxed_array tcl_file wtis
450
	where 
451

452
		write_type_info_loop i limit tcl_file wtis
453
			| i == limit
454
455
456
457
				= (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
458
459
460
			
instance WriteTypeInfo [a] | WriteTypeInfo a
where
461
	write_type_info l tcl_file wtis
462
463
		# tcl_file
			= fwritei (length l) tcl_file
464
		= write_type_info_loop l tcl_file wtis
465
	where
466
467
468
469
470
471
		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
472
473
474
			
instance WriteTypeInfo Char
where
475
	write_type_info c tcl_file wtis
476
477
		# tcl_file
			= fwritec c tcl_file;
478
		= (tcl_file,wtis);
Martijn Vervoort's avatar
Martijn Vervoort committed
479

480
481
482
483
484
485
486
487
488
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)

Martijn Vervoort's avatar
Martijn Vervoort committed
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
// MV ...
from CoclSystemDependent import DirectorySeparator, ensureCleanSystemFilesExists

openTclFile :: !Bool !String !*Files -> (Optional !.File, !*Files)
openTclFile False icl_mod_pathname files
	= (No,files)
openTclFile compile_for_dynamics icl_mod_pathname files
	# csf_path
		= directoryName icl_mod_pathname +++ "Clean System Files"
	# tcl_path
		= csf_path +++ {DirectorySeparator} +++ baseName icl_mod_pathname +++ ".tcl"
	# (opened, tcl_file, files)
		= fopen tcl_path FWriteData files
	| opened
		= (Yes tcl_file, files)
	// try again after creating Clean System Files folder
	# (ok, files)
		= ensureCleanSystemFilesExists csf_path files
	| not ok
		= abort ("can't create folder \"" +++ csf_path +++"\"\n")
	# (opened, tcl_file, files)
		= fopen tcl_path FWriteData files
	| opened
		=(Yes tcl_file, files)
	= abort ("couldn't open file \"" +++ tcl_path +++ "\"\n")
514

Martijn Vervoort's avatar
Martijn Vervoort committed
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
closeTclFile :: !*(Optional *File) *Files -> *(!Bool,*Files)
closeTclFile (Yes tcl_file) files
	= fclose tcl_file files
closeTclFile _ files
	= (True,files);

// copy from compile.icl ...	
baseName :: {#Char} -> {#Char}
baseName path
	=	last (splitBy DirectorySeparator path)

directoryName :: {#Char} -> {#Char}
directoryName path
	=	foldr (\p ps -> p +++ {DirectorySeparator} +++ ps) "" (init (splitBy DirectorySeparator path))
	
splitBy :: Char {#Char} -> [{#Char}]
splitBy char string
	=	splitBy` 0 0
	where
		splitBy` frm to
			| to >= stringSize
				=	[string % (frm, to-1)]
			| string.[to] == char
				=	[string % (frm, to-1) : splitBy` (to+1) (to+1)]
			// otherwise
				=	splitBy` frm (to+1)
		stringSize
			=	size string

// ... copy from compile.icl
// ... MV