main.icl 14.8 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
4
5
module main

import scanner, parse, postparse, check, type, trans, convertcases, utilities, convertDynamics

import StdEnv
6
7
// XXX
import RWSDebug
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
8
9
10
11
12
13
14
15
16
17
18
19
20

Start world
	# (std_io, world) = stdio world
	  (_, ms_out, world) = fopen "out" FWriteText world
	  (ms_out,world) = accFiles (
	  		\files -> 
				(let
				    (ms_paths, ms_files, ms_error) = converFileToListOfStrings "mainPrefs" files stderr
					ms = CommandLoop No { ms_io = std_io, ms_out = ms_out, ms_error = ms_error, ms_files = ms_files, ms_paths = ms_paths }
				in
					(ms.ms_out, ms.ms_files))) world
	= fclose ms_out world

21
22
23
24
25
26
27
28
29
30
31
CommandLoop proj ms=:{ms_io}
	# answer = "c t5"
	  (command, argument)	= SplitAtLayoutChar (dropWhile isSpace (fromString answer))
	| command == []
		= CommandLoop proj { ms & ms_io = ms_io}
		# (ready, proj, ms) = DoCommand command argument proj { ms & ms_io = ms_io}
		| ready
			= ms
		= ms

/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
32
33
34
35
36
37
38
39
40
CommandLoop proj ms=:{ms_io}
	# (answer, ms_io)		= freadline (ms_io <<< "> ")
	  (command, argument)	= SplitAtLayoutChar (dropWhile isSpace (fromString answer))
	| command == []
		= CommandLoop proj { ms & ms_io = ms_io}
		# (ready, proj, ms) = DoCommand command argument proj { ms & ms_io = ms_io}
		| ready
			= ms
			= CommandLoop proj ms
41
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159

::	MainStateDefs funs funtypes types conses classes instances members selectors =
	{	msd_funs		:: !funs
	,	msd_funtypes	:: !funtypes
	,	msd_types		:: !types
	,	msd_conses		:: !conses
	,	msd_classes		:: !classes
	,	msd_instances	:: !instances
	,	msd_members		:: !members
	,	msd_selectors	:: !selectors
	,	msd_genfuns		:: ![FunDef]
	}
	

::	*MainState funs funtypes types conses classes instances members selectors =
	{	ms_io			:: !*File
	,	ms_error		:: !*File
	,	ms_out			:: !*File
	,	ms_paths		:: !SearchPaths
	,	ms_files		:: !*Files
	}	

::	ModuleTree = ModuleNode !InterMod !ModuleTree !ModuleTree | NoModules

containsModule name (ModuleNode {inter_name = {id_name}} left right)
	# cmp = id_name =< name
	| cmp == Equal
		= True
	| cmp == Smaller
		= containsModule name right
		= containsModule name left
containsModule name NoModules
	= False

addModule name mod tree=:(ModuleNode this_mod=:{inter_name = {id_name}} left right)
	# cmp = id_name =< name
	| cmp == Equal
		= tree
	| cmp == Smaller
		= ModuleNode this_mod left (addModule name mod right)
		= ModuleNode this_mod (addModule name mod left) right
addModule _ mod NoModules
	= ModuleNode mod NoModules NoModules

::	Project =
	{	proj_main_module	:: !Ident
	,	proj_hash_table		:: !.HashTable
	,	proj_predef_symbols	:: !.PredefinedSymbols
	,	proj_modules		:: !ModuleTree
	}

::	InterMod =
	{	inter_name					:: Ident
	,	inter_modules				:: !{# Ident}
	,	inter_fun_defs				:: !{# FunDef}
	,	inter_icl_dcl_conversions	:: !Optional {# Index}
	,	inter_dcl_icl_conversions	:: !Optional {# Index}
	}


DoCommand ['c':_] argument proj ms 
	# (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument)
	  (opt_mod, ms) = compileModule (toString file_name) ms
	= (False, proj, ms)
DoCommand ['s':_] argument proj ms=:{ms_io, ms_files} 
	# (file_name, rest_input)	= SplitAtLayoutChar (dropWhile isSpace argument)
	  file_name 				= toString (file_name++['.icl'])
	  (ok,file,files)			= fopen file_name FReadText ms_files
	  (lines,file)				= freadlines file
	  (ok,files)				= fclose file files
	= (False, proj, {ms & ms_io = ms_io <<< ("file "+++file_name+++" "+++toString (length lines)+++" lines\n") <<< lines <<< "\n", ms_files = files})
DoCommand ['t':_] argument proj ms=:{ms_files, ms_io}
	# (file_names, ms_files, ms_io) = converFileToListOfStrings "testfiles" ms_files ms_io
	= (False, proj, foldSt check_module file_names { ms & ms_files = ms_files, ms_io = ms_io })
where
	check_module file_name ms
  		# (opt_mod, ms) = compileModule file_name (ms ---> file_name)
		= case opt_mod of
			No
				-> { ms & ms_io = ms.ms_io <<< file_name <<< " is not OK\n" }
			_
				-> ms
DoCommand ['p':_] argument proj ms=:{ms_io, ms_files}
	# (file_name, rest_input)		= SplitAtLayoutChar (dropWhile isSpace argument)
	  (predef_symbols, hash_table) 	= buildPredefinedSymbols newHashTable
	  (mod_ident, hash_table) 		= putIdentInHashTable (toString file_name) IC_Module hash_table
	= (False, Yes { proj_main_module = mod_ident, proj_hash_table = hash_table, proj_predef_symbols = predef_symbols, proj_modules = NoModules }, ms)
DoCommand ['q':_] argument proj ms
	= (True, proj, ms)
DoCommand ['h':_] argument proj  ms=:{ms_io}
	= (False, proj, {ms & ms_io = ms_io <<< "No help available. Sorry.\n"})
DoCommand command argument proj  ms=:{ms_io}
	= (False, proj, {ms & ms_io = ms_io <<< toString command <<< "?\n"})

freadlines file
    |   sfend file
        =   ([],file)
	    #   (line, file)    = freadline file
   		#   (lines,file)    = freadlines file
        =   ([line:lines],file)

SplitAtLayoutChar [] = ([], [])
SplitAtLayoutChar [x:xs]
	| x == ' ' || x == '\t' || x == '\n'
		= ([], xs)
	| otherwise
		= ([x:word], rest_input)
where
	(word, rest_input) = SplitAtLayoutChar xs

compileModule mod_name ms
	# (predef_symbols, hash_table) = buildPredefinedSymbols newHashTable
	  (mod_ident, hash_table) = putIdentInHashTable mod_name IC_Module hash_table
	  (opt_module, predef_symbols, hash_table, ms) = loadModule mod_ident predef_symbols hash_table ms
	= (opt_module, ms)

loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_out,ms_paths}
	# (ok, mod, hash_table, ms_error, predef_symbols, ms_files)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
160
		= wantModule cWantIclFile mod_ident (hash_table ---> ("Parsing:", mod_ident)) ms_error ms_paths predef_symbols ms_files
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
	| not ok
		= (No,  predef_symbols, hash_table, { ms & ms_files = ms_files, ms_io = ms_io, ms_error = ms_error })
	# (ok, mod, nr_of_global_funs, mod_functions, dcl_mod, predef_mod, modules, hash_table, ms_error, predef_symbols, ms_files)
		= scanModule (mod ---> "Scanning") hash_table ms_error ms_paths predef_symbols ms_files
	| not ok
		= (No,  predef_symbols, hash_table, { ms & ms_files = ms_files, ms_io = ms_io, ms_error = ms_error })
  	# symbol_table = hash_table.hte_symbol_heap
  	  (ok, icl_mod, dcl_mods, components, dcl_icl_conversions, heaps, predef_symbols, symbol_table, ms_error)
  	  	= checkModule mod nr_of_global_funs mod_functions dcl_mod predef_mod modules predef_symbols (symbol_table ---> "Checking") ms_error
	| not ok
		= (No,  predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io })
	# {icl_functions,icl_instances,icl_specials,icl_common,icl_declared={dcls_import}} = icl_mod
//	  (components, icl_functions, ms_error) = showComponents components 0 True icl_functions ms_error
	  (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, ms_error)
		= typeProgram (components ---> "Typing") icl_functions icl_specials icl_common dcls_import dcl_mods heaps predef_symbols ms_error
	| not ok
		= (No,  predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out })

	# (components, fun_defs) = partitionateFunctions (fun_defs ---> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials]
180
181
//	  (components, fun_defs, ms_error) = showTypes components 0 fun_defs ms_error
	  (components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
182
	  (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
183
184
		 = analyseGroups common_defs (components ---> "Transform") fun_defs imported_funs heaps.hp_var_heap heaps.hp_expression_heap
	#!(components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
185
	  		= transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs var_heap heaps.hp_type_heaps expression_heap
186
187
	  (components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
//	  (components, fun_defs, ms_error) = showTypes components 0 fun_defs ms_error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
188
189
190
191
192
	  (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps
	  (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps
	  (components, fun_defs, predef_symbols, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
	  		= convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols
					dcl_types used_conses var_heap type_heaps expression_heap
193
//	  (components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
	  (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
	  		= convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses var_heap type_heaps expression_heap
	  (dcl_types, var_heap, type_heaps)
			= convertImportedTypeSpecifications dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap		
//	  (components, fun_defs, ms_out) = showComponents components 0 False fun_defs ms_out
	= (Yes (buildInterMod mod_ident dcl_mods fun_defs dcl_icl_conversions),  predef_symbols,
		{ hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out })


makeProject (Yes proj=:{proj_main_module,proj_hash_table,proj_predef_symbols}) ms
	# (main_mod, proj_predef_symbols, proj_hash_table, ms) = loadModule proj_main_module proj_predef_symbols proj_hash_table ms
	  proj = { proj & proj_hash_table = proj_hash_table, proj_predef_symbols = proj_predef_symbols }
	= case main_mod of
		Yes main_mod=:{inter_modules}
			# (proj_modules, ms) = collect_modules [ mod \\ mod <-: inter_modules ] (ModuleNode main_mod NoModules NoModules) ms
			-> (Yes { proj & proj_modules = proj_modules }, ms)
		_
			-> (Yes proj, ms)
where
	collect_modules [{id_name} : modules] collected_modules ms
		| containsModule id_name collected_modules
			= collect_modules modules collected_modules ms
			# (this_mod, ms) = compileModule id_name ms
			= case this_mod of
				Yes new_mod
					-> collect_modules (modules ++ [ mod \\ mod <-: new_mod.inter_modules ]) (addModule id_name new_mod collected_modules) ms
				_
					-> (NoModules, ms)
	collect_modules [{id_name} : modules] collected_modules ms
		= (collected_modules, ms)

buildInterMod name dcl_modules fun_defs dcl_icl_conversions
	=	{	inter_name					= name
		,	inter_modules				= { dcl_name \\ {dcl_name} <-: dcl_modules }
		,	inter_fun_defs				= fun_defs
		,	inter_icl_dcl_conversions	= build_icl_dcl_conversions (size fun_defs) dcl_icl_conversions
		,	inter_dcl_icl_conversions	= dcl_icl_conversions
		}
where
	build_icl_dcl_conversions table_size (Yes conversion_table)
		# dcl_table_size = size conversion_table
		  icl_dcl_conversions = update_conversion_array 0 dcl_table_size conversion_table (createArray table_size NoIndex)
		= Yes (fill_empty_positions 0 table_size dcl_table_size icl_dcl_conversions)
	build_icl_dcl_conversions table_size No
		= No
		
	update_conversion_array	dcl_index dcl_table_size conversion_table icl_conversions
		| dcl_index < dcl_table_size
			#  icl_index = conversion_table.[dcl_index]
			= update_conversion_array (inc dcl_index) dcl_table_size conversion_table
					{ icl_conversions & [icl_index] = dcl_index }
			= icl_conversions

	fill_empty_positions next_index table_size next_new_index icl_conversions
		| next_index < table_size
			| icl_conversions.[next_index] == NoIndex
				= fill_empty_positions (inc next_index) table_size (inc next_new_index) { icl_conversions & [next_index] = next_new_index }
				= fill_empty_positions (inc next_index) table_size next_new_index icl_conversions
			= icl_conversions
			
showComponents :: !*{! Group} !Int !Bool !*{# FunDef} !*File  -> (!*{! Group}, !*{# FunDef},!*File)
showComponents comps comp_index show_types fun_defs file
	| comp_index >= size comps
		= (comps, fun_defs, file)
		# (comp, comps) = comps![comp_index]
		# (fun_defs, file) = show_component comp.group_members show_types fun_defs (file <<< "component " <<< comp_index <<< '\n')
		= showComponents comps (inc comp_index) show_types fun_defs file
where
	show_component [] show_types fun_defs file
		= (fun_defs, file <<< '\n')
	show_component [fun:funs] show_types fun_defs file
265
266
		| fun>=size fun_defs
			= abort ("YYY "+++toString fun+++" "+++toString (size fun_defs))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
		#! fun_def = fun_defs.[fun]
		| show_types
			= show_component funs show_types fun_defs (file <<< '\n' <<< fun_def)
			= show_component funs show_types fun_defs (file <<< fun_def)
//		= show_component funs show_types fun_defs (file <<< fun_def.fun_symb)

	
showComponents2 :: !{! Group} !Int !*{# FunDef} !{! ConsClasses} !*File  -> (!*{# FunDef},!*File)
showComponents2 comps comp_index fun_defs acc_args file
	| comp_index >= (size comps)
		= (fun_defs, file)
	# (fun_defs, file) = show_component comps.[comp_index].group_members fun_defs acc_args file
	= showComponents2 comps (inc comp_index) fun_defs acc_args file
where
	show_component [] fun_defs _ file
		= (fun_defs, file <<< '\n')
	show_component [fun:funs] fun_defs acc_args file
		#! fd = fun_defs.[fun]
		# file = show_accumulating_arguments acc_args.[fun].cc_args (file <<< fd.fun_symb <<< '.' <<< fun <<< " (")
		= show_component funs fun_defs acc_args (file <<< ") ")
	
	show_accumulating_arguments [ cc : ccs] file
		| cc == cPassive
			= show_accumulating_arguments ccs (file <<< 'p')
		| cc == cActive
			= show_accumulating_arguments ccs (file <<< 'c')
		| cc == cAccumulating
			= show_accumulating_arguments ccs (file <<< 'a')
			= show_accumulating_arguments ccs (file <<< '?')
	show_accumulating_arguments [] file
		= file


show_components comps fun_defs = map (show_component fun_defs) comps

show_component fun_defs [] = []
show_component fun_defs [fun:funs] = [fun_defs.[fun ---> fun] : show_component fun_defs funs]

showTypes :: !*{! Group} !Int !*{# FunDef} !*File  -> (!*{! Group}, !*{# FunDef},!*File)
showTypes comps comp_index fun_defs file
	| comp_index >= size comps
		= (comps, fun_defs, file)
		# (comp, comps) = comps![comp_index]
		# (fun_defs, file) = show_types comp.group_members fun_defs (file <<< "component " <<< comp_index <<< '\n')
		= showTypes comps (inc comp_index) fun_defs file
where
	show_types [] fun_defs file
		= (fun_defs, file <<< '\n')
	show_types [fun:funs] fun_defs file
		#! fun_def = fun_defs.[fun]
317
		= show_types funs fun_defs (file <<< '\n' <<< fun_def.fun_type)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337

converFileToListOfStrings file_name files error
	# (ok, file, files) = fopen file_name FReadText files
	| ok
		# (lines, file) = read_lines file
		= (lines, snd (fclose file files), error)
		= ([], files, error <<< "Could not open \"" <<< file_name <<< "\"\n")
where
	read_lines file
		# (line, file) = freadline file
		  last_char_index = size line - 1
		| last_char_index < 0
			= ([], file)
		| line.[last_char_index] == '\n'
			| last_char_index == 0 || line.[0] == '|'
				= read_lines file
				# (lines, file) = read_lines file
				= ([line % (0, last_char_index - 1) : lines ], file)
		// otherwise
			= ([line], file)