1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 /* procedure to compile I/O operators
 12 
 13    Initial Version: 19 October 1971 by BLW
 14           Modified:  3 October 1972 by BLW
 15           Modified: 28 February 1973 by RAB
 16           Modified: 18 June 1973 by RAB
 17           Modified: 30 December 1974 by RAB to fix 1282
 18           Modified: 25 February 1975 by RAB for quick put list
 19           Modified: 12 January 1976 by RAB to fix 1455
 20           Modified: 10 January 1978 by RAB to fix 1697
 21           Modified: 1 May 1979 by PCK to implement 4-bit decimal */
 22 
 23 io_op:    proc(pt);
 24 
 25 dcl       pt ptr;             /* points at operator node */
 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                /* set ptr to OK list */
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;         /* KLUDGE to find out original number of operands */
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                /* process subscript list */
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                /* put symtab offset into ps */
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           /* get|put list|edit */
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           /* This entry is called to initialize the ps space */
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 /*        NOT PRESENTLY USED
330 
331 get_temp: proc() returns(ptr);
332 
333 dcl       r ptr;
334 
335      */   /* returns reference to a char(256) varying temporary */    /*
336 
337           r = declare_temporary(char_mask | varying_mask | aligned_mask,256,0,null);
338           r = copy_temp(r);
339           r -> reference.c_length = r -> reference.symbol -> symbol.c_dcl_size;
340           r = prepare_operand(r,1,atomic);
341           call stack_temp$assign_temp(r);
342           return(r);
343 
344           end;
345 
346           MAYBE SOMEDAY AGAIN */
347 
348 protect_areg:  proc;
349 
350           /* makes sure that long_op does not clobber the a_register by
351              calling base_man (fixes bug 1282) */
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;