1
2
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
31
32
33
34
35
36
37
38
39
40
41
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
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
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
265
266
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
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
|
module main
import scanner, parse, postparse, check, type, trans, convertcases, utilities, convertDynamics
import StdEnv
// RWS ...
import frontend
// ... RWS
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 (init_identifiers newHeap) { 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
CommandLoop symbol_heap ms=:{ms_io}
# (answer, ms_io) = freadline (ms_io <<< "> ")
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
| command == []
= CommandLoop symbol_heap { ms & ms_io = ms_io}
# (ready, symbol_heap, ms) = DoCommand command argument symbol_heap { ms & ms_io = ms_io}
| ready
= ms
= CommandLoop symbol_heap ms
:: 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 =
{ ms_io :: !*File
, ms_error :: !*File
, ms_out :: !*File
, ms_paths :: ![{#Char}]
, ms_files :: !*Files
}
:: InterMod =
{ inter_name :: !String
, inter_modules :: !{# String}
/* , inter_fun_defs :: !{# FunDef}
, inter_icl_dcl_conversions :: !Optional {# Index}
*/
}
:: ModuleTree = ModuleNode !String !ModuleTree !ModuleTree | NoModules
containsModule name (ModuleNode inter_name left right)
| inter_name == name
= True
| inter_name < name
= containsModule name right
= containsModule name left
containsModule name NoModules
= False
addModule name mod tree=:(ModuleNode this_mod left right)
| this_mod == name
= tree
| this_mod < name
= ModuleNode this_mod left (addModule name mod right)
= ModuleNode this_mod (addModule name mod left) right
addModule _ mod NoModules
= ModuleNode mod NoModules NoModules
:: DclCache = {
dcl_modules::!{#DclModule},
cached_macros::!.{#.{#FunDef}},
predef_symbols::!.PredefinedSymbols,
hash_table::!.HashTable,
heaps::!.Heaps
};
:: Project =
{ proj_main_module :: !String
, proj_modules :: !ModuleTree
, proj_cache :: !.DclCache
}
empty_cache :: *SymbolTable -> *DclCache
empty_cache symbol_heap
# heaps = {hp_var_heap = newHeap, hp_expression_heap = newHeap, hp_type_heaps = {th_vars = newHeap, th_attrs = newHeap}}
# (predef_symbols, hash_table) = buildPredefinedSymbols (newHashTable symbol_heap)
= {dcl_modules={},cached_macros={},predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps}
DoCommand ['c':_] argument symbol_heap ms
# (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument)
(opt_mod,dcl_cache,ms) = compileModule (toString file_name) (empty_cache symbol_heap) ms
= (False, dcl_cache.hash_table.hte_symbol_heap, ms)
DoCommand ['m':_] argument symbol_heap ms
# (file_name, rest_input) = SplitAtLayoutChar (dropWhile isSpace argument)
# mod_name = toString file_name
# dcl_cache=empty_cache symbol_heap
# (proj, ms) = makeProject { proj_main_module=mod_name,
proj_modules=NoModules,
proj_cache=dcl_cache} ms
= (False, proj.proj_cache.hash_table.hte_symbol_heap, ms)
DoCommand ['s':_] argument symbol_heap 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, symbol_heap, {ms & ms_io = ms_io <<< ("file "+++file_name+++" "+++toString (length lines)+++" lines\n") <<< lines <<< "\n", ms_files = files})
DoCommand ['t':_] argument symbol_heap ms=:{ms_files, ms_io}
# (file_names, ms_files, ms_io) = converFileToListOfStrings "testfiles" ms_files ms_io
# (dcl_cache,ms) = foldSt check_module file_names ((empty_cache symbol_heap),{ ms & ms_files = ms_files, ms_io = ms_io })
= (False, dcl_cache.hash_table.hte_symbol_heap, ms)
where
check_module file_name (dcl_cache,ms)
# ms = {ms & ms_io = ms.ms_io <<< "Compiling " <<< file_name <<< "\n"}
# (opt_mod, dcl_cache,ms) = compileModule file_name dcl_cache ms
= case opt_mod of
No
-> (dcl_cache,{ ms & ms_io = ms.ms_io <<< file_name <<< " is not OK\n" })
_
-> (dcl_cache,ms)
DoCommand ['q':_] argument symbol_heap ms
= (True, symbol_heap, ms)
DoCommand ['h':_] argument symbol_heap ms=:{ms_io}
= (False, symbol_heap, {ms & ms_io = ms_io <<< "No help available. Sorry.\n"})
DoCommand command argument symbol_heap ms=:{ms_io}
= (False, symbol_heap, {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 :: String *DclCache *MainState -> *(!Optional InterMod,!*DclCache,!*MainState);
compileModule mod_name dcl_cache ms
# (mod_ident, hash_table) = putIdentInHashTable mod_name IC_Module dcl_cache.hash_table
dcl_cache = {dcl_cache & hash_table=hash_table}
= loadModule mod_ident.boxed_ident dcl_cache ms
dummyModTime :: {#Char} .f -> ({#Char}, .f)
dummyModTime _ f
= ("", f)
loadModule :: Ident *DclCache *MainState -> *(!Optional InterMod,!*DclCache,!*MainState);
loadModule mod_ident {dcl_modules,cached_macros,predef_symbols,hash_table,heaps} ms=:{ms_files,ms_error,ms_io,ms_out,ms_paths}
# (optional_syntax_tree,cached_cached_macros,cached_dcl_mods,_,main_dcl_module_n,predef_symbols, hash_table, ms_files, ms_error, ms_io, ms_out,_,heaps)
= frontEndInterface { feo_up_to_phase = FrontEndPhaseAll, feo_generics = False, feo_fusion = False} mod_ident {sp_locations = [], sp_paths = ms_paths} dcl_modules cached_macros No predef_symbols hash_table dummyModTime ms_files ms_error ms_io ms_out No heaps
# ms = {ms & ms_files=ms_files, ms_error=ms_error,ms_io=ms_io,ms_out=ms_out}
= case optional_syntax_tree of
Yes {fe_icl={/*icl_functions,*/icl_used_module_numbers}, fe_dcls}
# dcl_modules={{dcl_module \\ dcl_module<-:cached_dcl_mods} & [main_dcl_module_n].dcl_macro_conversions=No}
# var_heap = remove_expanded_types_from_dcl_modules 0 dcl_modules icl_used_module_numbers heaps.hp_var_heap
# heaps = {heaps & hp_var_heap = var_heap }
-> (Yes (buildInterMod mod_ident icl_used_module_numbers fe_dcls),
{dcl_modules=dcl_modules,cached_macros=cached_cached_macros,predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps}, ms)
No
-> (No, {dcl_modules=dcl_modules,cached_macros=cached_cached_macros,predef_symbols=predef_symbols,hash_table=hash_table,heaps=heaps},ms)
remove_expanded_types_from_dcl_modules :: Int {#DclModule} NumberSet *VarHeap -> *VarHeap
remove_expanded_types_from_dcl_modules module_n dcls used_module_numbers var_heap
| module_n<size dcls
| module_n==cPredefinedModuleIndex || not (inNumberSet module_n used_module_numbers)
= remove_expanded_types_from_dcl_modules (module_n+1) dcls used_module_numbers var_heap
# var_heap = remove_expanded_types_from_dcl_module 0 dcls.[module_n].dcl_functions var_heap
with
remove_expanded_types_from_dcl_module :: Int {#FunType} *VarHeap -> *VarHeap
remove_expanded_types_from_dcl_module function_n dcl_functions var_heap
| function_n<size dcl_functions
# {ft_type_ptr} = dcl_functions.[function_n]
# (ft_type,var_heap) = readPtr ft_type_ptr var_heap
= case ft_type of
VI_ExpandedType expandedType
# var_heap = writePtr ft_type_ptr VI_Empty var_heap
-> remove_expanded_types_from_dcl_module (function_n+1) dcl_functions var_heap
_
-> remove_expanded_types_from_dcl_module (function_n+1) dcl_functions var_heap
= var_heap
= remove_expanded_types_from_dcl_modules (module_n+1) dcls used_module_numbers var_heap
= var_heap
choose_random_module random_n modules
# n_modules = length modules;
# module_n = toInt (random_n*toReal n_modules)
# module_n = if (module_n<0) 0 (if (module_n>=n_modules) (n_modules-1) module_n)
# r = find_and_remove_module 0 modules;
with
find_and_remove_module n [modjule:modules]
| n==module_n
= (modjule,modules);
# (found_module,modules) = find_and_remove_module (n+1) modules;
= (found_module,[modjule:modules]);
= r;
//import MersenneTwister
makeProject :: *Project *MainState -> *(!*Project,!*MainState);
makeProject proj=:{proj_main_module,proj_cache} ms
# (main_mod,dcl_cache,ms) = compileModule proj_main_module proj_cache ms
# proj = {proj & proj_cache=dcl_cache}
= case main_mod of
Yes main_mod=:{inter_modules}
// # random_numbers = genRandReal 100;
# random_numbers = []
# (proj_modules,proj,ms) = collect_modules [ mod \\ mod <-: inter_modules ] (ModuleNode main_mod.inter_name NoModules NoModules) random_numbers proj ms
-> ({ proj & proj_modules = proj_modules }, ms)
_
-> (proj,ms)
where
collect_modules :: [String] ModuleTree [Real] *Project *MainState -> *(!ModuleTree,!*Project,!*MainState);
collect_modules [] collected_modules random_numbers proj ms
= (collected_modules,proj,ms)
collect_modules [id_name : modules] collected_modules random_numbers proj ms
// collect_modules modules collected_modules [random_number:random_numbers] proj ms
// # (id_name,modules) = choose_random_module random_number modules
| id_name=="_predefined"
= collect_modules modules collected_modules random_numbers proj ms
| containsModule id_name collected_modules
= collect_modules modules collected_modules random_numbers proj ms
# ms = {ms & ms_io = ms.ms_io <<< "Compiling " <<< id_name <<< "\n"}
# dcl_cache = proj.proj_cache
// # dcl_cache = (empty_cache proj.proj_cache.hash_table.hte_symbol_heap)
# (this_mod,dcl_cache,ms) = compileModule id_name dcl_cache ms
# proj = {proj & proj_cache=dcl_cache}
= case this_mod of
Yes new_mod
# collected_modules = addModule id_name new_mod.inter_name collected_modules
# modules = modules ++ [ mod \\ mod <-: new_mod.inter_modules | not (containsModule mod collected_modules) && not (isMember mod modules)]
-> collect_modules modules collected_modules random_numbers proj ms
_
# ms = {ms & ms_io = ms.ms_io <<< "Compiling " <<< id_name <<< " failed \n"}
-> collect_modules modules collected_modules random_numbers proj ms
// -> (NoModules, ms)
buildInterMod name icl_used_module_numbers dcl_modules // fun_defs dcl_icl_conversions icl_dcl_conversions
# used_dcl_modules = [modjule \\ modjule <-: dcl_modules & module_n<-[0..] | inNumberSet module_n icl_used_module_numbers ]
= { inter_name = name.id_name
, inter_modules = { dcl_name.id_name \\ {dcl_name} <- used_dcl_modules }
/*
, inter_fun_defs = fun_defs
, inter_icl_dcl_conversions = icl_dcl_conversions
*/
}
/* RWS
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
#! 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]
# properties = { form_properties = cAttributed bitor cAnnotated, form_attr_position = No }
(Yes ftype) = fun_def.fun_type
= show_types funs fun_defs (file <<< fun_def.fun_symb <<< " :: " <:: (properties, ftype) <<< '\n' )
*/
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)
|
