1 ^L
  2 /* BEGIN INCLUDE FILE ...   cobol_arith_util.incl.pl1 */
  3 /*     <<<   LAST MODIFIED ON 9-08-76 by bc    >>>     */
  4 /*     <<<   LAST MODIFIED ON 9-23-75 by tlf   >>>     */
  5 /*   <<<   NAME OF INCLUDE FILE:     cobol_arith_util.incl.pl1   >>>     */
  6 
  7 
  8 /**************************************************/
  9 /*        INTERNAL PROCEDURE                      */
 10 /*        get_size_error_flag                     */
 11 /**************************************************/
 12 
 13 get_size_error_flag:proc(size_error_token_ptr,size_error_inst_ptr);
 14 
 15 /*
 16 FUNCTION
 17 
 18 The function of this procedure is to:
 19 
 20           1. allocate a fixed bin (35) variable in the COBOL
 21           program's run-time stack.
 22           2. build a data name token for the fixed binary variable.
 23           3. Emit code that stores zero into the fixed binary.
 24           4. Return a pointer to the data name token for the fixed
 25           binary variable.
 26           5. Return a 36 bit non-eis instruction word that
 27           contains the address of the fixed binary variable.
 28 
 29 */
 30 
 31 /*  DECLARATION OF THE PARAMETERS  */
 32 
 33 dcl size_error_token_ptr ptr;
 34 dcl size_error_inst_ptr ptr;
 35 
 36 /*  DESCRIPTION OF THE PARAMETERS  */
 37 
 38 /*
 39 PARAMETER                     DESCRIPTION
 40 
 41 size_error_token_ptr          Points to the data name token
 42                               that describes the fixed binary
 43                               in the stack. (output)
 44 size_error_inst_ptr           Points to a 36 bit field in which
 45                               the non-eix address is constructed.
 46                               (output)
 47 
 48 */
 49 
 50 /*  DECLARATION OF INTERNAL STATIC VARIABLES  */
 51 
 52 dcl stz_op bit (10) int static                              init ("1001010000"b /*450(0)*/);
 53 
 54 /*  DECLARATION OF INTERNAL VARIABLES  */
 55 
 56 dcl ret_offset fixed bin;
 57 dcl size_error_inst_word bit (36) based (size_error_inst_ptr);
 58 dcl input_buffer (1:10) fixed bin;
 59 dcl reloc_buffer (1:10) bit (5) aligned;
 60 
 61 
 62 
 63 /*************************************************/
 64 /*        START OF EXECUTION                      */
 65 /*        INTERNAL PROCEDURE get_size_error_flag  */
 66 /**************************************************/
 67 
 68           /*  Allocate a 4 byte fixed binary number on a word boundary in the stack  */
 69           call   cobol_alloc$stack(4,0,ret_offset);
 70 
 71           /*  Make a data name token for the fixed binary number.  */
 72           size_error_token_ptr = null();  /*  The utility will provide the buffer.  */
 73           call   cobol_make_type9$fixed_bin_35(size_error_token_ptr,1000 /*STACK*/,ret_offset);
 74 
 75           /*  Generate code to store zero in the stack temporary  */
 76           input_ptr = addr(input_buffer(1));
 77           reloc_ptr = addr(reloc_buffer(1));
 78 
 79           input_struc_basic.type = 1;
 80           input_struc_basic.operand_no = 0;
 81           input_struc_basic.lock = 0;
 82           input_struc_basic.segno = 1000;  /*  STACK  */
 83           input_struc_basic.char_offset = ret_offset;  /*  From   cobol_alloc$stack  */
 84 
 85           size_error_inst_word = "0"b;
 86 
 87           /*  Get the non-eis instruction  */
 88           call   cobol_addr(input_ptr,size_error_inst_ptr,reloc_ptr);
 89 
 90           /*  Set the STZ opcode into the instruction word  */
 91           size_error_inst_ptr -> inst_struc_basic.fill1_op = stz_op;
 92 
 93           /*  Emit the stz instruction  */
 94           call   cobol_emit(size_error_inst_ptr,reloc_ptr,1);
 95 
 96           /*  Set the opcode in the non-eis instruction to "0"b  */
 97           size_error_inst_ptr -> inst_struc_basic.fill1_op = "0"b;
 98 
 99 end get_size_error_flag;
100 ^L
101 
102 /**************************************************/
103 /*        INTERNAL PROCEDURE                      */
104 /*        receiving_field                         */
105 /**************************************************/
106 
107 receiving_field:proc(receiving_token_ptr,stored_token_ptr,function_code);
108 
109 /*  THIS IS NOT A VALID ENTRY POINT  */
110 
111 /*  DECLARATION OF THE PARAMETERS  */
112 
113 dcl receiving_token_ptr ptr;
114 dcl stored_token_ptr ptr;
115 dcl function_code fixed bin;
116 
117 /*  DESCRIPTION OF THE PARAMETERS  */
118 
119 /*
120 PARAMETER           DESCRIPTION
121 
122 receiving_token_ptr Points to the data name token of the receiving
123                     operand to be stored. (input)
124 stored_token_ptr    Points to the data name token of the
125                     temporary in which the receiving operand
126                     is to be stored.  (output)
127 function_code       Code that indicates the function to perform
128 
129                     value     | function
130                     =============================
131                       1       | store
132                       2       | restore
133 
134 */
135 
136 /*  DECLARATION OF INTERNAL STATIC VARIABLES  */
137 
138 /*  Definition of an EOS token used in calls to   cobol_arith_move_gen  */
139 
140 dcl       1 move_eos int static,
141                     2 size fixed bin (15)                   init (32),
142                     2 line fixed bin (15)                   init (0),
143                     2 column fixed bin (15)                 init (0),
144                     2 type fixed bin (15)                   init (19),  /*  EOS  */
145                     2 verb fixed bin (15)                   init (18),  /*  MOVE  */
146                     2 e fixed bin (15)                      init (0),
147                     2 h fixed bin (15)                      init (0),
148                     2 i fixed bin (15)                      init (0),
149                     2 j fixed bin (15)                      init (0),
150                     2 a bit (16)                            init ("0"b);
151 dcl always_an bit (1) static  init ("0"b);
152 
153 /*  DECLARATIONS OF INTERNAL AUTOMATIC VARIABLES  */
154 
155 dcl temp_in_token (1:10) ptr;
156 dcl move_eos_ptr ptr;
157 dcl tin_ptr ptr;
158 dcl temp_save_ptr ptr;
159 dcl ret_offset fixed bin;
160 
161           if function_code = 1 then call store;
162           else call restore;
163 
164 ^L
165 
166 /*************************************************/
167 /*        STORE ENTRY POINT                       */
168 /***************************************************/
169 
170 store:proc;
171 
172 /*  This entry point is used to generate code that stores the
173 contents of a receiving operand into a temporary.  */
174 
175           /*  Modify the token for the receiving variable that is being stored, so that it
176           looks like an alphanumeric instead of a numeric.  This is done so that the move
177           generator generates an alphanumeric (MLR) move to store the data.  */
178           if receiving_token_ptr->data_name.ascii_packed_dec_h="0"b then do;
179                receiving_token_ptr -> data_name.numeric = "0"b;
180                receiving_token_ptr -> data_name.alphanum = "1"b;
181           end;
182           else always_an="1"b;
183 
184           temp_save_ptr = null();  /*  Utility will provide the buffer for data name token  */
185           call   cobol_make_type9$copy(temp_save_ptr,receiving_token_ptr);
186 
187           /*  Allocate space on the stack to hold the contents of the receiving field  */
188           call   cobol_alloc$stack(fixed(temp_save_ptr -> data_name.item_length,17),0,ret_offset);
189 
190           /*  Update the data name for the temporary  */
191           temp_save_ptr -> data_name.seg_num = 1000;  /*  Stack  */
192           temp_save_ptr -> data_name.offset = ret_offset;  /*  From   cobol_alloc$stack  */
193           temp_save_ptr -> data_name.subscripted = "0"b;
194           temp_save_ptr -> data_name.variable_length = "0"b;
195           temp_save_ptr -> data_name.occurs_ptr = 0;
196 
197 /*  Build the in_token structure for calling the move generator  */
198 
199           tin_ptr = addr(temp_in_token(1));
200           move_eos_ptr = addr(move_eos);
201           stored_token_ptr = temp_save_ptr;
202 
203           tin_ptr -> in_token.n = 4;
204           tin_ptr -> in_token.token_ptr(1) = null();
205           tin_ptr -> in_token.token_ptr(2) = receiving_token_ptr;  /*  operand to be stored  */
206           tin_ptr -> in_token.token_ptr(3) = stored_token_ptr;  /*  Temp in which to store  */
207           tin_ptr -> in_token.token_ptr(4) = move_eos_ptr;
208 
209 
210           if always_an="1"b then  move_eos_ptr->end_stmt.e=10001;
211           else
212           move_eos_ptr -> end_stmt.e = 1;  /*  Set the number of receiving operands into the EOS  */
213 
214           /*  Call the move generator to move the contents  */
215           call   cobol_move_gen(tin_ptr);
216 
217           /*  Reset the token for the variable being stored.  */
218           receiving_token_ptr -> data_name.numeric = "1"b;
219           receiving_token_ptr -> data_name.alphanum = "0"b;
220           always_an="0"b;
221 
222 end store;
223 
224 ^L
225 
226 /**************************************************/
227 /*        RESTORE ENTRY POIENT                    */
228 /**************************************************/
229 
230 restore:proc;
231 
232 /*  This entry point is used to restore the contents of a
233 receiving operand from the contents of a temporary.  */
234 
235           /*  Set up the in_token structure for calling the move generator  */
236 
237           tin_ptr = addr(temp_in_token(1));
238           move_eos_ptr = addr(move_eos);
239 
240           tin_ptr -> in_token.n = 4;
241           tin_ptr -> in_token.token_ptr(1) = null();
242           tin_ptr -> in_token.token_ptr(2) = stored_token_ptr;  /*  source  */
243           tin_ptr -> in_token.token_ptr (3) = receiving_token_ptr;  /*  Receiving field  */
244           tin_ptr -> in_token.token_ptr(4) = move_eos_ptr;  /*  move EOS token  */
245 
246           /*  Set the number of receiving fields into the move EOS  */
247           move_eos_ptr -> end_stmt.e = 1;
248 
249           /*  Modify the token for the receiving variable that is being stored, so that it
250           looks like an alphanumeric instead of a numeric.  This is done so that the move
251           generator generates an alphanumeric (MLR) move to store the data.  */
252           if receiving_token_ptr->data_name.ascii_packed_dec_h="0"b then do;
253                receiving_token_ptr -> data_name.numeric = "0"b;
254                receiving_token_ptr -> data_name.alphanum = "1"b;
255           end;
256 
257           /*  Call the move generator  */
258 
259           call   cobol_move_gen(tin_ptr);
260 
261           /*  Reset the token for the variable being stored.  */
262           receiving_token_ptr -> data_name.numeric = "1"b;
263           receiving_token_ptr -> data_name.alphanum = "0"b;
264 
265 end restore;
266 
267 end receiving_field;
268 ^L
269 /**************************************************/
270 /* INTERNAL PROCEDURE                             */
271 /*        test_for_overflow                       */
272 /**************************************************/
273 
274 test_for_overflow:proc(no_overflow_tag,size_error_inst_ptr,move_in_token_ptr);
275 
276 /*
277 FUNCTION
278 The function of this procedure is to generate the following
279 sequence of code:
280 
281           tov 2,ic
282           tra no_overflow_tag
283           aos size_error_flag
284 */
285 
286 /*  DECLARATION OF THE PARAMETERS  */
287 
288 dcl no_overflow_tag fixed bin;
289 dcl size_error_inst_ptr ptr;
290 dcl move_in_token_ptr ptr;
291 
292 /*  DESCRIPTION OF THE PARAMETERS  */
293 
294 /*
295 PARAMETER           DESCRIPTION
296 
297 no_overflow_tag     Contains the compiler generated tag to which
298                     to transfer if there is no overflow. (input)
299 size_error_inst_ptr Points to a 36 bit field that contains a
300                     non-eis instruction, which contains the address
301                     of the size error flag. (input)
302 
303 */
304 
305 /*  DECLARATIONS OF INTERNAL STATIC VARIABLES  */
306 
307 dcl tov_op bit (10) int static                              init ("1100011110"b /*617(0)*/);
308 dcl tra_op bit (10) int static                              init ("1110010000"b /*710(0)*/);
309 dcl aos_op bit (10) int static                              init ("0001011000"b /*054(0)*/);
310 
311 /*  DECLARATIONS OF INTERNAL AUTOMATIC VARIABLES.  */
312 
313 dcl temp_inst_word bit (36);
314 dcl temp_inst_ptr ptr;
315 
316 dcl reloc_buffer (1:10) bit (5) aligned;
317 dcl reloc_ptr ptr;
318 
319 dcl save_locno fixed bin;
320 dcl overflow_tag fixed bin;
321 
322 /**************************************************/
323 /*        START OF EXECUTION                      */
324 /*        test_for_overflow                       */
325 /**************************************************/
326 
327 
328           temp_inst_word = "0"b;
329           temp_inst_ptr = addr(temp_inst_word);
330 
331           /*  Insert tov opcode  */
332           temp_inst_ptr -> inst_struc_basic.fill1_op = tov_op;
333 
334           /*  Reserve a tag to which to transfer if overflow occurs.  */
335           overflow_tag =   cobol_$next_tag;
336 
337             cobol_$next_tag =   cobol_$next_tag + 1;
338 
339 
340           reloc_ptr = addr(reloc_buffer(1));
341           reloc_buffer(1) = "0"b;
342           reloc_buffer(2) = "0"b;
343 
344           /*  Emit the instruction  */
345           call   cobol_emit(temp_inst_ptr,reloc_ptr,1);
346 
347           /*  Make a tagref to the overflow tag at the instruction just emitted.  */
348           call   cobol_make_tagref(overflow_tag,  cobol_$text_wd_off - 1,null());
349 
350 
351           if move_in_token_ptr ^= null() then
352           if move_in_token_ptr -> in_token.code ^= 0
353           then call   cobol_move_gen(move_in_token_ptr);  /*  Move a temp result into a numeric edited.  */
354 
355 
356           /*  Generate the tra to no_overflow_tag  */
357           temp_inst_word = "0"b;
358           temp_inst_ptr -> inst_struc_basic.fill1_op = tra_op;
359 
360           save_locno =   cobol_$text_wd_off;
361 
362           /*  Emit the tra instruction  */
363           call   cobol_emit(temp_inst_ptr,reloc_ptr,1);
364 
365           /*  Make a tagref to the no_overflow_tag at the tra instruction just emitted.  */
366           call   cobol_make_tagref(no_overflow_tag,save_locno,null());
367 
368           /*  Generate aos instruction which increments the size error flag  */
369           /*  Define the overflow_tag at the aos instruction  */
370           call   cobol_define_tag(overflow_tag);
371           size_error_inst_ptr -> inst_struc_basic.fill1_op = aos_op;
372 
373           /*  Emit the instruction  */
374           call   cobol_emit(size_error_inst_ptr,reloc_ptr,1);
375 
376           /*  Reset the opcode field of the non-eis instruction  */
377           size_error_inst_ptr -> inst_struc_basic.fill1_op = "0"b;
378 
379 
380 end test_for_overflow;
381 ^L
382 /**************************************************/
383 /*        INTERNAL PROCEDURE                      */
384 /*        test_size_error                         */
385 /**************************************************/
386 
387 
388 test_size_error:proc(size_error_token_ptr,size_error_inst_ptr,next_stmt_tag,overflow_code_generated,not_bit);
389 
390 /*
391 
392 FUNCTION
393 
394 This internal procedure performs the following functions:
395 
396           If the overflow_code generated flag is "1"b then
397           the following functions are performed:
398                     1. Gets the A of Q register
399                     2. Generates two instructions.
400                               a.  LDA or LDQ with the contents of the size error flag
401                               b. TZE to the next_stmt_tag
402           If the overflow_code_generated flag is "0"b, then
403           the following instruction is generated:
404                     TRA to the next_stmt_tag
405 
406 
407 */
408 
409 /*  DECLARATION OF THE PARAMETERS  */
410 
411 dcl size_error_token_ptr ptr;
412 dcl size_error_inst_ptr ptr;
413 dcl next_stmt_tag fixed bin;
414 dcl (overflow_code_generated,not_bit) bit (1);
415 
416 /*  DESCRIPTION OF THE PARAMETERS  */
417 
418 /*
419 PARAMETER                     DESCRIPTION
420 
421 size_error_token_ptr          Points to a data name token
422                               for the size error flag.  (input)
423 
424 size_error_inst_ptr           Points to a 36 bit field that contains
425                               the non-eis address of the size
426                               error flag in the run-time stack.
427                               (input)
428 next_stmt_tag                 Contains a compiler generated tag
429                               to be associated with the next
430                               Cobol statement.  (input)
431 overflow_code_generated       Contains a one bit indicator that
432                               is "1"b if overflow testing
433                               code was generated for this statement.
434                               (input)
435 not_bit                       "1"b if NOT option follows
436 */
437 
438 /*  DECLARATION OF INTERNAL STATIC VARIABLES.  */
439 
440 dcl lda_op bit (10) int static                              init ("0100111010"b /*235(0)*/);
441 dcl ldq_op bit (10) int static                              init ("0100111100"b /*236(0)*/);
442 dcl tze_op bit (10) int static                              init ("1100000000"b /*600(0)*/);
443 dcl tnz_op bit (10) int static                              init ("1100000010"b /*601(0)*/);        /*[4.0-1]*/
444 dcl tra_op bit (10) int static                              init ("1110010000"b /*710(0)*/);
445 
446 
447 /*  DECLARATIONS OF INTERNAL AUTOMATIC VARIABLES  */
448 
449 /*  Structure used to communicate with the register$load procedure.  */
450 
451 dcl       1 register_struc,
452                     2 what_reg fixed bin,
453                     2 reg_no bit (4),
454                     2 lock fixed bin,
455                     2 already_there fixed bin,
456                     2 contains fixed bin,
457                     2 dname_ptr ptr,
458                     2 literal bit (36);
459 
460 dcl temp_inst_word bit (36);
461 dcl temp_inst_ptr ptr;
462 
463 dcl save_locno fixed bin;
464 dcl reloc_buffer (1:10) bit (5) aligned;
465 dcl reloc_ptr ptr;
466 dcl size_error_inst bit (36) based (size_error_inst_ptr);
467 
468 
469 /**************************************************/
470 /*        START OF EXECUTION                      */
471 /*        test_size_error                         */
472 /**************************************************/
473 reloc_ptr = addr(reloc_buffer(1));
474 reloc_buffer(1) = "0"b;
475 reloc_buffer(2) = "0"b;
476 
477 
478 if overflow_code_generated
479 then do;  /*  overflow code was generated, must load the size error flag and test it  */
480 
481           size_error_inst_ptr = addr(size_error_inst);
482 
483           /*  Get the A or Q register  */
484           register_struc.what_reg = 0;  /*  A or Q  */
485           register_struc.lock = 0;  /*  No change to locks  */
486           register_struc.contains = 1;  /*  Register will contain a data item  */
487           register_struc.dname_ptr = size_error_token_ptr;
488 
489           call   cobol_register$load(addr(register_struc));
490 
491           /*  Build the LDA or LDQ instruction  */
492 
493           if register_struc.reg_no = "0001"b
494                     then size_error_inst_ptr -> inst_struc_basic.fill1_op = lda_op;  /* A reg */
495                     else size_error_inst_ptr -> inst_struc_basic.fill1_op = ldq_op;  /*  Q reg  */
496 
497 
498           /*  Emit the LDA or LDQ instruction  */
499 
500           call   cobol_emit(size_error_inst_ptr,reloc_ptr,1);
501           end;  /*  overflow code was generated, must load the size error flag and test it  */
502 
503 
504           /*  Generate a TZE or TRA instruction  */
505           temp_inst_word = "0"b;
506           temp_inst_ptr = addr(temp_inst_word);
507           if overflow_code_generated
508 /*[4.2-1]*/         then      if not_bit
509 /*[4.2-1]*/                   then temp_inst_ptr -> inst_struc_basic.fill1_op = tnz_op;
510 /*[4.2-1]*/                   else temp_inst_ptr -> inst_struc_basic.fill1_op = tze_op;
511           else temp_inst_ptr -> inst_struc_basic.fill1_op = tra_op;
512 
513           /*  Save the text word offset at which the tze is to be emitted  */
514           save_locno =   cobol_$text_wd_off;
515 
516           /*  Emit the instruction  */
517           call   cobol_emit(temp_inst_ptr,reloc_ptr,1);
518 
519           /*  Generate a tagref to the next cobol statement at the TZE or TRA just emitted  */
520           call   cobol_make_tagref(next_stmt_tag,save_locno,null());
521 
522 
523 end test_size_error;
524 
525 
526 
527 ^L
528 not_dec_operand:proc(token_ptr) returns (bit (1));
529 
530 /*  This function procedure determines whether an input data
531 name token represents a data item that is not decimal,
532 namely short fixed binary, long fixed binary, or overpunch
533 sign.  If the token represents a fixed binary or overpunch
534 sign data item, then "1"b is returned.  Otherwise "0"b is
535 returned.  */
536 
537 dcl token_ptr ptr;
538 
539           if token_ptr -> data_name.bin_18
540           | token_ptr -> data_name.bin_36
541           | token_ptr -> data_name.sign_type = "010"b  /*  leading not separate  */
542           | token_ptr -> data_name.sign_type = "001"b  /*  trailing, not separate  */
543           | (token_ptr -> data_name.display & token_ptr -> data_name.item_signed
544           & token_ptr -> data_name.sign_separate = "0"b)  /*  Default overpunch.  */
545                     then return ("1"b);
546                     else return ("0"b);
547 
548 end not_dec_operand;
549 ^L
550 /* END INCLUDE FILE ...   cobol_arith_util.incl.pl1 */
551