1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23 io_op: proc(pt);
24
25 dcl pt ptr;
26
27 dcl (cg_stat$cur_block,cg_stat$cur_statement,cg_stat$text_base) ptr ext,
28 cg_stat$generate_symtab bit(1) ext,
29 cg_stat$star_symbol_up_zero bit(18) ext;
30
31 dcl (p,psp,psr,sslp,q,p2,p3,p4,arg(3),rand(3)) ptr,
32 (psloc,i,n,macro,ok) fixed bin(15),
33 quick_stream_op bit(1) aligned init("0"b),
34 (atomic,useless) bit(1) aligned;
35
36 dcl odd_bases bit(19) int static aligned init("0000000000000001111"b);
37
38 dcl (addr,bit,fixed,null,substr) builtin;
39
40 dcl expmac entry(fixed bin(15),ptr),
41 expmac$many entry(fixed bin(15),ptr,fixed bin),
42 long_op$io entry(ptr,fixed bin(15)),
43 generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr),
44 load entry(ptr,fixed bin),
45 base_man$load_var entry(fixed bin,ptr,fixed bin);
46 dcl base_man$load_linkage entry returns(bit(3) aligned);
47 dcl (compile_exp, fortran_$fortran_io_op) entry(ptr),
48 compile_exp$save_exp entry(ptr) returns(ptr),
49 prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr),
50 xr_man$load_var entry(ptr,fixed bin(17)),
51 xr_man$super_lock entry(fixed bin(17)),
52 c_a entry(fixed bin(18),fixed bin) returns(ptr),
53 base_man$store_ptr_to entry(ptr,ptr),
54 state_man$erase_reg entry(bit(19) aligned),
55 state_man$flush_ref entry(ptr),
56 state_man$flush entry();
57 dcl m_a entry(ptr,bit(2) aligned);
58 dcl expmac$zero entry(fixed bin(15)),
59 aq_man$lock entry(ptr,fixed bin);
60 dcl copy_temp entry(ptr) returns(ptr);
61 dcl stack_temp$assign_temp entry(ptr),
62 declare_temporary entry(bit(36) aligned,fixed bin(31),fixed bin(15),ptr) returns(ptr);
63
64 dcl ( get_term_mac init(313),
65 put_data_mac init(328),
66 lda init(1),
67 ldfx1 init(7),
68 stfx1 init(15),
69 zero_mac init(308),
70 symtab_mac init(320),
71 init_ps_mac init(339),
72 init_sslp init(340),
73 io_macro(0:15) init(495,499,0,503,507,(8)0,587,498,506),
74 put_field_mac init(502),
75 stream_prep_mac init(396),
76 recio_mac init(485),
77 form_desc init(513),
78 load_pt init(60)) fixed bin(15) int static;
79
80 dcl fixbin fixed bin based aligned;
81
82 %include ps_map;
83 %include block;
84 %include symbol;
85 %include reference;
86 %include statement;
87 %include operator;
88 %include list;
89 %include op_codes;
90 %include statement_types;
91 %include bases;
92 %include machine_state;
93 %include relocation_bits;
94 %include data_types;
95 %include boundary;
96 %include mask;
97
98 p = pt;
99
100 if p -> operator.op_code > record_io
101 then if p -> operator.op_code < put_control
102 then do;
103 call fortran_$fortran_io_op(p);
104 return;
105 end;
106 else quick_stream_op = "1"b;
107
108 psp = cg_stat$cur_block -> block.plio_ps -> element(1);
109 psr = psp -> symbol.reference;
110
111 rand(1) = p -> operand(1);
112 rand(2) = p -> operand(2);
113 rand(3) = p -> operand(3);
114 if p -> op_code = stream_prep
115 then do;
116 arg(1) = rand(1);
117 arg(2) = prepare_operand(rand(2),-1,atomic);
118 call ma_and_flush(2);
119 call expmac$many((stream_prep_mac),addr(arg),2);
120 arg(1) -> reference.perm_address = "0"b;
121 arg(2) -> reference.perm_address = "0"b;
122 return;
123 end;
124
125 if p -> op_code = record_io
126 then do;
127 arg(1) = rand(1);
128 call ma_and_flush(1);
129
130 if p -> operator.number = 2
131 then do;
132 arg(2) = prepare_operand(rand(2),-1,atomic);
133 call base_man$load_var(2,arg(2),1);
134 end;
135
136 call expmac((recio_mac),arg(1));
137 arg(1) -> reference.perm_address = "0"b;
138 return;
139 end;
140
141 if p -> op_code = terminate_trans
142 then do;
143 call ma_and_flush(0);
144 call expmac$zero(get_term_mac + fixed(cg_stat$cur_statement -> statement_type = put_statement,1));
145 return;
146 end;
147
148 psloc = psp -> symbol.location;
149
150 if p -> op_code = get_data_trans
151 then do;
152
153
154
155 if rand(1) -> operator.number = 0
156 then do;
157 q = generate_constant$real_fix_bin_1(0);
158 call state_man$flush;
159 end;
160 else do;
161 ok = rand(1) -> operator.number;
162 q = c_a((ok),10);
163 do i = 1 to addrel(cg_stat$text_base,ok) -> fixbin;
164 call state_man$flush_ref((rand(1) -> operand(i)));
165 end;
166 end;
167
168 call base_man$store_ptr_to(q,c_a(psloc + ps_special_list,4));
169 return;
170 end;
171
172 if p -> op_code = put_data_trans
173 then do;
174
175
176
177 sslp = cg_stat$cur_block -> block.plio_ssl;
178 n = sslp -> symbol.location;
179 sslp = sslp -> symbol.reference;
180
181 sslp -> reference.perm_address = "0"b;
182
183 if rand(1) = null then call expmac((zero_mac),sslp);
184 else do;
185 call expmac((ldfx1),c_a((rand(1) -> list.number),2));
186 call expmac((stfx1),sslp);
187 sslp -> reference.perm_address = "1"b;
188
189 do i = 1 to rand(1) -> list.number;
190 sslp -> address.offset = bit(fixed(n+i,15),15);
191
192 p2 = rand(1) -> element(i);
193 p3 = prepare_operand(p2,1,atomic);
194 if atomic then call load(p3,0); else call compile_exp(p2);
195
196 call expmac((stfx1),sslp);
197 end;
198 end;
199
200 p2 = prepare_operand(rand(2),-1,atomic);
201
202
203
204 call protect_areg;
205 q = c_a(fixed(rand(2) -> reference.symbol -> symbol.runtime,18),2);
206 q -> reference.relocation = rc_s;
207 call expmac((lda),q);
208
209 macro = put_data_mac;
210 goto l2;
211 end;
212
213 if p->op_code = put_control
214 then do;
215 p2 = prepare_operand(rand(2),-1,atomic);
216
217 p3 = prepare_operand(rand(1),-1,atomic);
218 call compile_exp(rand(2));
219 call xr_man$load_var(rand(1),6);
220
221 call expmac$zero((io_macro(13)));
222 return;
223 end;
224
225
226
227 p2 = prepare_operand(rand(2),-1,atomic);
228
229 if ^ atomic then p2 = compile_exp$save_exp(rand(2));
230
231 if rand(1) ^= null
232 then p3 = prepare_operand(rand(1),-1,atomic);
233 else do;
234 p3 = c_a(0,2);
235 p3 -> reference.data_type = real_fix_bin_1;
236 atomic = "1"b;
237 end;
238
239 if p->op_code = put_field_chk
240 then do;
241 p4 =prepare_operand(rand(3),-1,useless);
242 call xr_man$load_var(rand(3),6);
243 call xr_man$super_lock(6);
244 end;
245
246 if atomic
247 then call load(p3,0);
248 else if quick_stream_op
249 then call compile_exp(rand(1));
250 else do;
251 q = rand(1) -> operand(3);
252 p3 = prepare_operand(q,1,atomic);
253 if atomic then call load(p3,0); else call compile_exp(q);
254 call expmac((form_desc),prepare_operand((rand(1) -> operand(2)),-1,atomic));
255 end;
256
257 macro = io_macro(fixed(substr(p -> op_code,6,4),4));
258
259 p3 = p2 -> reference.symbol;
260 if p3 -> symbol.picture
261 then if ^quick_stream_op
262 then do;
263 p3 = c_a((p3 -> symbol.general -> reference.symbol -> symbol.location),3);
264 p3 -> reference.relocation = rc_t;
265 call protect_areg;
266 call expmac((lda),p3);
267 end;
268
269 l2: call long_op$io(p2,macro);
270 if p -> op_code = get_list_trans | p -> op_code = get_edit_trans
271 then call state_man$flush_ref(p2);
272 return;
273
274 io_op$init_ps: entry;
275
276
277
278 psp = cg_stat$cur_block -> block.plio_ps -> element(1);
279 arg(1) = psp -> symbol.reference;
280 arg(1) -> reference.units = word_;
281
282 call expmac((init_ps_mac),arg(1));
283 arg(1) -> reference.perm_address = "0"b;
284
285 base_regs(1).type = 0;
286 arg(1) -> reference.address_in.b(1) = "0"b;
287
288 if cg_stat$generate_symtab
289 then do;
290 arg(2) = c_a(fixed(cg_stat$star_symbol_up_zero,18),9);
291 arg(2) -> address.base = base_man$load_linkage();
292
293 arg(3) = c_a((cg_stat$cur_block -> block.symbol_block),3);
294 arg(3) -> reference.relocation = rc_s;
295
296 call expmac$many((symtab_mac),addr(arg),3);
297 end;
298
299 sslp = cg_stat$cur_block -> block.plio_ssl;
300 if sslp ^= null
301 then do;
302 arg(2) = sslp -> symbol.reference;
303 arg(2) -> reference.units = word_;
304 call expmac$many((init_sslp),addr(arg),2);
305 end;
306
307 sslp = cg_stat$cur_block -> block.plio_fa;
308 if sslp ^= null
309 then do;
310 sslp -> symbol.reference -> reference.units = word_;
311 call base_man$store_ptr_to((sslp -> symbol.reference),
312 c_a(psp -> symbol.location + ps_format_area,4));
313 end;
314
315
316
317 ma_and_flush: proc(n);
318 dcl (i,n) fixed bin;
319
320 do i = 1 to n;
321 call m_a(arg(i),"0"b);
322 arg(i) -> reference.perm_address = "1"b;
323 end;
324
325 call state_man$erase_reg((odd_bases));
326
327 end;
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348 protect_areg: proc;
349
350
351
352
353 if p2 -> reference.units < word_ | p2 -> reference.big_offset
354 then do;
355 call aq_man$lock(null,2);
356 if ^ p2 -> reference.shared
357 then p2 -> reference.ref_count = p2 -> reference.ref_count + 1;
358 call base_man$load_var(2,p2,1);
359 end;
360
361 end;
362
363 end;