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 /* Modified 780427 by PG to get ready for unsigned */
 12 /* Modified 790419 by PCK to implement 4-bit decimal */
 13 /* Modified 790840 by PCK to fix 1791 */
 14 /* Modified 800103 by RAB to fix 1680 in which passing a label constant as arg
 15    sometimes fails. */
 16 /* Modified 830509 BIM to check explicit_packed as part of alignment. ycch. */
 17 
 18 convert:  proc (tree, bv_target_type) returns (ptr);
 19 
 20 /* parameters */
 21 
 22 dcl       (tree ptr,
 23           bv_target_type bit (36) aligned) parameter;
 24 
 25 /* automatic */
 26 
 27 dcl       (p,r,target_ref,target,input,output,inlength,tlength,return_tree) ptr,
 28           (pointer1,pointer2) (32) ptr aligned,
 29           (m, n, svprec) fixed bin;
 30 
 31 dcl       (alignment_ok, known, sign_type_ok, validate_bit) bit(1) aligned,
 32           long_bit bit(1) aligned init("0"b),
 33           target_must_be_integer bit(1) aligned init("0"b),
 34           keep_full_precision bit(1) aligned init("0"b),
 35           suppress_bit bit(1) aligned init("1"b),
 36           varying_input bit(1) aligned init("0"b),
 37           varying_result bit(1) aligned init("0"b);
 38 
 39 dcl       1 itype like type;
 40 dcl       1 otype like type;
 41 dcl       1 inpicture like type;
 42 dcl       1 tpicture like type;
 43 
 44 /* based */
 45 
 46 dcl       value1 bit(2304) aligned based(addr(pointer1(1)));
 47 dcl       value2 bit(2304) aligned based(addr(pointer2(1)));
 48 dcl       char_target char(outclength) based aligned;
 49 dcl       bit_target bit(outclength) based aligned;
 50 
 51 /* builtin */
 52 
 53 dcl       (null,binary,addr,bit,divide,fixed,sign,min,max,abs,log10,string,substr,ceil) builtin;
 54 
 55 /* conditions */
 56 
 57 dcl       (conversion,fixedoverflow,overflow,underflow,size,stringsize) condition;
 58 
 59 /* defined */
 60 
 61 dcl       defined_itype bit (36) defined (itype);
 62 dcl       defined_otype bit (36) defined (otype);
 63 
 64 /* entries */
 65 
 66 dcl       (pl1_stat_$util_abort, pl1_stat_$util_error) variable external static entry(fixed bin, ptr);
 67 
 68 /* external static */
 69 
 70 dcl       pl1_stat_$cur_statement ptr ext static;
 71 
 72 /* internal static */
 73 
 74 dcl       plain_desc_type (46) fixed bin int static /* map descriptor types ignoring precision, varying, unsigned attributes */
 75                     init (    1, 1, 3, 3, 5, 5, 7, 7, 9, 10, 11, 12,
 76                               13, 14, 15, 16, 17, 18, 19, 19, 21, 21, 23, (9)0, 1, 1, (8)0, 9, 10, 11, 12);
 77 
 78 dcl       simplify_for_message (0:46) fixed bin int static initial (10, (12)1, 4, 5, 7, 8, 10, 6, 2, 2, 3, 3, 9,
 79           (9)0, 1, 1, (8)0, (4)1);      /* maps descriptor types into subscripts for message array, below. */
 80 
 81 /* The values of the simplify array, and the subscripts into the message array, are assigned as follows:
 82           1 = arithmetic      6 = area
 83           2 = bit             7 = label
 84           3 = char            8 = entry
 85           4 = ptr             9 = file
 86           5 = offset          10 = structure or undefined
 87 */
 88 
 89 dcl       message (9, 9) fixed bin int static init (
 90                                                      0,-234,-234, 231, 231, 249, 229, 223, 251,
 91                                                   -236,   0,-487, 231, 231, 249, 229, 223, 251,
 92                                                   -236,-489,   0, 231, 231, 249, 229, 223, 251,
 93                                                    227, 225, 225,   0,   0, 249, 229, 223, 251,
 94                                                    227, 225, 225,   0,   0, 249, 229, 223, 251,
 95                                                    227, 225, 225, 231, 231,   0, 229, 223, 251,
 96                                                    227, 225, 225, 231, 231, 249,   0, 223, 251,
 97                                                    227, 225, 225, 231, 231, 249, 229,   0, 251,
 98                                                    227, 225, 225, 231, 231, 249, 229, 223,   0);
 99 ^L
100 /* program */
101 
102           suppress_bit = "0"b;
103           go to start;
104 
105 to_integer:
106           entry (tree, bv_target_type) returns (ptr);
107 
108           target_must_be_integer = "1"b;
109           suppress_bit = "0"b;
110 
111 from_builtin:
112           entry (tree, bv_target_type) returns (ptr);
113 
114 start:
115           validate_bit = "0"b;
116           known = "0"b;
117           outscale_prec = 0;
118           tlength = null;
119           string (otype) = bv_target_type & convert_mask;
120           string (inpicture) = "0"b;
121           string (tpicture) = "0"b;
122           go to common;
123 
124 validate: entry(tree,target_ref);
125 
126           suppress_bit = "0"b;
127           validate_bit="1"b;
128           goto meet;
129 
130 to_target_fb:       entry(tree,target_ref) returns(ptr);
131 
132           validate_bit = "0"b;
133           keep_full_precision = "1"b;
134           goto meet;
135 
136 to_target:          entry(tree,target_ref) returns(ptr);
137 
138           suppress_bit  ,
139           validate_bit="0"b;
140 ^L
141                     /*   the second argument is a reference_node,
142                          get output type and other output attributes,
143                          therefore   the known bit is on     */
144 meet:
145           known = "1"b;
146 
147           /* initialize important vars, just in case */
148 
149           outscale_prec = 0;
150           tlength = null;
151 
152           string (inpicture) = "0"b;
153           string (tpicture) = "0"b;
154           if target_ref = null then call print(248);
155           if target_ref->node.type ^= reference_node then call print(248);
156 
157           target = target_ref->reference.symbol;
158 
159           if target->node.type=label_node
160           then do;
161                     defined_otype = label_mask;
162                     goto common;
163           end;
164 
165           if target->symbol.bit | target->symbol.char | target->symbol.picture
166           then do;
167                     tlength = target_ref->reference.length;
168                     outclength = target_ref->reference.c_length;
169 
170                     if target_ref->reference.varying_ref
171                     then do;
172                               known = "0"b;
173                               varying_result = "1"b;
174                     end;
175           end;
176 
177           else
178           if target->symbol.fixed | target->symbol.float
179           then do;
180                     tlength = null;
181                     outprec = target->symbol.c_dcl_size;
182                     outscale = target->symbol.scale;
183           end;
184 
185           else
186           if target->symbol.arg_descriptor
187           then do;
188                     tlength = null;
189                     outprec = default_fix_bin_p;
190                     outscale = 0;
191                     defined_otype = integer_type;
192                     goto common;
193           end;
194 
195           string (otype) = substr (string (target -> symbol.attributes), 1, 36) & convert_mask;
196 
197           if target->symbol.picture
198           then do;
199                     string(tpicture) = string(otype);
200 
201                     if target->symbol.pix.pic_char
202                     then      defined_otype = defined_otype & ^picture_mask | char_mask;
203                     else do;
204                               defined_otype = defined_otype & ^picture_mask  & ^unaligned_mask | aligned_mask | decimal_mask;
205 
206                               outprec = target->symbol.pix.pic_size;
207 
208                               if ^target->symbol.complex
209                               then      defined_otype = defined_otype | real_mask;
210 
211                               if target->symbol.pix.pic_fixed
212                               then do;
213                                         defined_otype = defined_otype | fixed_mask;
214                                         outscale = target->symbol.pix.pic_scale;
215                               end;
216                               else      defined_otype = defined_otype | float_mask;
217                     end;
218           end;
219 ^L
220                     /*   get input type and other input attributes   */
221 
222 common:
223           outtype = pl1_descriptor_type(defined_otype,(outprec));
224           inlength = null;
225           inscale_prec = 0;
226           if tree = null then call print(248);
227 
228           if tree->node.type = token_node then go to token_input;
229 
230           if tree->node.type = operator_node
231           then      r = tree->operator.operand(1);
232           else      r = tree;
233 
234           if r = null then call print(248);
235 
236           if r->node.type = label_node
237           then      if outtype = label_dtype
238                     then      if validate_bit
239                               then      return;
240                               else      goto assign_it;
241                     else      call print(message(7,simplify_for_message(outtype)));
242 
243           if r->node.type ^= reference_node then call print(248);
244 
245 /* The input is a reference or an operator. */
246 
247           input = r->reference.symbol;
248           if input->node.type=label_node
249           then do;
250                     intype = label_dtype;
251                     goto meet2;
252           end;
253 
254           if input->symbol.fixed | input->symbol.float
255           then do;
256                     inprec = input->symbol.c_dcl_size;
257                     inscale = input->symbol.scale;
258           end;
259 
260           if input->symbol.bit | input->symbol.char | input->symbol.picture
261           then      if r->reference.varying_ref
262                     then do;
263                               varying_input = "1"b;
264                               inclength = 0;
265                               inlength = create_operator(length_fun,2);
266                               inlength->operator.processed = "1"b;
267                               inlength->operand(1) = declare_temporary(integer_type,max_length_precision,0,null);
268                               inlength->operand(2) = tree;
269                     end;
270                     else do;
271                               inclength = r->reference.c_length;
272                               inlength = r->reference.length;
273                     end;
274 
275           if input->symbol.arg_descriptor
276           then do;
277                     inlength = null;
278                     inprec = default_fix_bin_p;
279                     inscale = 0;
280                     defined_itype = integer_type;
281           end;
282           else      defined_itype = substr (string (input -> symbol.attributes), 1, 36);
283 
284           if input->symbol.picture
285           then do;
286                     string(inpicture) = string(itype);
287 
288                     if input->symbol.pix.pic_char
289                     then      defined_itype = defined_itype & ^picture_mask | char_mask;
290                     else do;
291                               defined_itype = defined_itype & ^picture_mask & ^unaligned_mask | aligned_mask | decimal_mask;
292 
293                               inprec = input->symbol.pix.pic_size;
294 
295                               if ^input->symbol.complex
296                               then      defined_itype = defined_itype | real_mask;
297 
298                               if input->symbol.pix.pic_fixed
299                               then do;
300                                         defined_itype = defined_itype | fixed_mask;
301                                         inscale = input->symbol.pix.pic_scale;
302                               end;
303                               else      defined_itype = defined_itype | float_mask;
304                     end;
305           end;
306 
307           intype = pl1_descriptor_type(defined_itype,(inprec));
308 ^L
309 /* check the legality of this attempted conversion. */
310 
311 meet2:
312           if validate_bit & plain_desc_type(intype)=plain_desc_type(outtype)
313           then return;
314 
315           if simplify_for_message(intype)>9 then call pl1_stat_$util_abort(130,input);
316           if simplify_for_message(outtype)>9 then call pl1_stat_$util_abort(136,null);
317 
318           if intype ^= outtype
319           then do;
320                     m = message(simplify_for_message(intype),simplify_for_message(outtype));
321 
322                     if m ^= 0
323                     then if ^otype.char | string (inpicture) = "0"b
324                          then call print (m);
325                end;
326 
327           if validate_bit
328           then return;
329 
330 /* If input and output are identical no conversion is done. */
331 
332           if otype.bit | otype.char
333           then do;
334                     alignment_ok = "1"b;
335                     sign_type_ok = "1"b;
336                end;
337           else do;
338                     alignment_ok = ((itype.aligned = otype.aligned) | (itype.unaligned = otype.unaligned)) & (itype.explicit_packed = otype.explicit_packed);
339                     sign_type_ok = itype.unsigned = otype.unsigned;
340 
341                     if alignment_ok
342                     then do;
343                               otype.aligned = itype.aligned;
344                               otype.unaligned = itype.unaligned;
345                          end;
346 
347                     if sign_type_ok
348                     then otype.unsigned = itype.unsigned;
349                end;
350 
351           if known
352           then      if intype=outtype & inprec=outprec & inscale=outscale & inlength=tlength & alignment_ok & sign_type_ok
353                     | otype.char & inprec=outprec & string(inpicture)^="0"b
354                     then do;
355                               return_tree = tree;
356                               goto ret;
357                     end;
358                     else go to assign_it;
359           else do;
360                     if plain_desc_type(intype) = plain_desc_type(outtype) & alignment_ok & sign_type_ok
361                     then do;
362                               return_tree = tree;
363 
364                               if target_must_be_integer
365                               &  inscale^=0
366                               then do;
367                                         outprec = max(inprec-inscale,1);
368                                         outscale = 0;
369 
370                                         goto assign_it;
371                               end;
372 
373                               goto ret;
374                     end;
375 
376                     if otype.char
377                     &  string(inpicture)^="0"b
378                     then do;
379                               return_tree = tree;
380                               goto ret;
381                     end;
382 
383                     call get_target_size;
384 
385                     if target_must_be_integer
386                     &  outscale^=0
387                     then do;
388                               outprec = min(max(outprec-outscale,1),max_p_fix_bin_1);
389                               outscale = 0;
390                     end;
391 
392                     go to assign_it;
393           end;
394 ^L
395 /* The input is a token.  It will be converted to conform to the target. If the target
396    size is known it is used, otherwise the language rules are used to determine the size.
397    If the target is a variable length string an assignment is generated.  All constants
398    are declared by calls to declare_constant.     */
399 
400 token_input:
401           if (string (otype) & computational_mask) = ""b
402           then      call pl1_stat_$util_abort(246,tree);    /* target isn't computational */
403 
404           if (tree->token.type & is_constant)="0"b
405           then      call print(247);
406 
407           on conversion, overflow, underflow, fixedoverflow call print(252);
408           on size call print(442);
409           on stringsize call print(-192);
410 
411           inclength = tree->token.size;
412 
413           /* The input token is either bit, char, or arithmetic. */
414 
415           if tree->token.type=bit_string
416           then do;                                          /* BIT */
417                     intype=bit_dtype;
418                     if inclength ^= 0 then inclength = inclength - 1;
419                     if tree->token.string="b"               /* null bit-string */
420                     then      tree = create_token("",bit_string);
421           end;
422 
423           else
424           if tree->token.type=char_string
425           then      intype = char_dtype;                    /* CHAR */
426 
427           else do;                                          /* ARITHMETIC */
428                     call char_to_numeric_(addr(value1),intype,inscale_prec,addr(tree->token.string),(inclength));
429                     intype = divide(intype,2,15,0);
430           end;
431 
432           if ^known
433           then call get_target_size;
434           else if ^target -> symbol.picture & otype.decimal & ^keep_full_precision
435                then call get_target_size;
436 
437           if target_must_be_integer
438           &  inscale^=0
439           &  intype ^= char_dtype       /* inscale overlays inclength */
440           &  intype ^= bit_dtype        /* .. */
441           then do;
442                     outprec = min(max(outprec-outscale,1),max_p_fix_bin_1);
443                     outscale = 0;
444           end;
445 
446           outtype = pl1_descriptor_type (defined_otype, (outprec));   /* in case outprec changed */
447 
448           /* Now do the assignment. There are three cases...char, bit, or arithmetic */
449 
450           if otype.char                                     /* CHAR TARGET */
451           then do;
452                     if tree->token.type & is_arith_constant
453                     then do;
454                               call print(-234);
455 
456                               if outclength > characters_per_double & known
457                               then do;
458                                         svprec = outclength;
459                                         call get_target_size;
460                                         long_bit = "1"b;
461                               end;
462 
463                               call assign_(addr(value2),outtype*2,(outclength),addr(value1),intype*2,inscale_prec);
464 
465                               addr(value1)->char_target  = addr(value2)->char_target;
466                     end;
467                     else
468 
469                     if tree->token.type = bit_string
470                     then do;
471                               n = tree -> token.size;
472                               if n ^= 0 then n = n - 1;
473                               if outclength > characters_per_double & known
474                               then do;
475                                         svprec = outclength;
476                                         outclength = n;
477                                         long_bit = "1"b;
478                               end;
479 (stringsize):                 addr(value1)->char_target = substr(tree->token.string,1,n);
480 
481                               call print(-487);
482                     end;
483 
484                     else
485                     if tree->token.type = char_string
486                     then do;
487                               if outclength > characters_per_double & known
488                               then do;
489                                         svprec = outclength;
490                                         outclength = tree->token.size;
491                                         long_bit = "1"b;
492                               end;
493 (stringsize):                 addr(value1)->char_target = tree->token.string;
494                     end;
495           end;
496           else
497 
498           if otype.bit                                      /* BIT TARGET */
499           then do;
500                     if tree->token.type & is_arith_constant
501                     then do;
502                               call print(-234);
503 
504                               if outclength > bits_per_double & known
505                               then do;
506                                         svprec = outclength;
507                                         call get_target_size;
508                                         long_bit = "1"b;
509                               end;
510 
511                               call assign_(addr(value2),outtype*2,(outclength),addr(value1),intype*2,inscale_prec);
512 
513                               addr(value1)->bit_target = addr(value2)->bit_target;
514                     end;
515 
516                     else
517                     if tree->token.type=bit_string
518                     then do;
519                               n = tree -> token.size ;
520                               if n ^= 0 then n = n - 1;
521                               if outclength > bits_per_double & known
522                               then do;
523                                         svprec = outclength;
524                                         outclength = n;
525                                         long_bit = "1"b;
526                               end;
527 (stringsize):                 addr(value1)->bit_target = bit(substr(tree -> token.string,1,n));
528                     end;
529 
530                     else
531                     if tree->token.type=char_string
532                     then do;
533                               if outclength > bits_per_double & known
534                               then do;
535                                         svprec = outclength;
536                                         outclength = tree->token.size;
537                                         long_bit = "1"b;
538                               end;
539 (stringsize):                 addr(value1)->bit_target = bit(tree->token.string);
540 
541                               call print(-489);
542                     end;
543           end;
544           else do;                                          /* ARITHMETIC TARGET */
545                     if (tree -> token.type & is_arithmetic_constant) ^= is_arithmetic_constant
546                     then call print(-236);
547 
548                     call assign_(addr(value1),outtype*2+binary(otype.unaligned,1),outscale_prec,
549                               addr(tree->token.string),char_dtype*2,(tree->token.size));
550           end;
551 
552           if tlength^=null | long_bit
553           then do;
554 
555                     /* declare the string constant and then assign it */
556 
557                     tree = declare_constant(value1,(defined_otype),(outclength),0);
558                     if long_bit then outprec = svprec;
559                     go to assign_it;
560           end;
561 
562           if varying_result
563           then      if target->symbol.dcl_size=null
564                     then      outclength = min(outclength,target->symbol.c_dcl_size);
565 
566           tree  ,
567           return_tree = declare_constant(value1,(defined_otype),(outprec),(outscale));
568 
569           if varying_result
570           then      if target->symbol.dcl_size^=null
571                     then      goto assign_it;
572 
573           goto ret;
574 
575 /* This conversion must be done at runtime */
576 
577 assign_it:
578           if target_must_be_integer
579           then      outprec = max(min(outprec,max_p_fix_bin_1),1);
580 
581           output = create_operator(assign,2);
582           if otype.bit | otype.char
583           then      output->operand(1) = declare_temporary((defined_otype),outclength,0,tlength);
584           else      output->operand(1) = declare_temporary((defined_otype),(outprec),(outscale),tlength);
585 
586           output->operand(2) = tree;
587           output->operator.processed = "1"b;
588 
589           if varying_result
590           then do;
591                     output->operand(1) = copy_expression(output->operand(1));
592 
593                     output->operand(1)->reference.c_length = min(outclength,target->symbol.c_dcl_size);
594 
595                     if target->symbol.dcl_size^=null
596                     then do;
597                               r = create_operator(min_fun,3);
598                               r->operand(1) = declare_temporary(integer_type,max_length_precision,0,null);
599                               r->operand(2) = copy_expression(target->symbol.dcl_size);
600                               r->operand(2) = expression_semantics((target->symbol.block_node),pl1_stat_$cur_statement,(r->operand(2)),"0"b);
601                               r->operand(2) = convert$to_integer((r->operand(2)),integer_type);
602                               if target->symbol.refer_extents
603                               then      r->operand(2) = fill_refer((r->operand(2)),(target_ref->reference.qualifier),"1"b);
604                               r->operand(3) = declare_constant$integer((outclength));
605 
606                               output->operand(1)->reference.length = r;
607                               output->operand(1)->reference.c_length = 0;
608                     end;
609           end;
610 
611           return_tree = output;
612 ^L
613 ret:
614           if string(inpicture) ="0"b & string(tpicture) ="0"b
615           then      return(return_tree);
616 
617           if string(inpicture)^="0"b
618           &  string(tpicture)^="0"b
619           then do;
620                     if return_tree->node.type=operator_node
621                     then      if return_tree->operator.op_code=pack
622                               then      return(return_tree);
623 
624                     if ^ itype.char     /* input is not a character picture */
625                      & target->symbol.general->reference.symbol->symbol.initial
626                        = input->symbol.general->reference.symbol->symbol.initial
627                     then      return(return_tree);
628           end;
629 
630           if string(inpicture)^="0"b    /*   input is a picture   */
631           & ^itype.char       /*   input is not a pic char   */
632           & ^otype.char       /*   output is not a character string or pic char   */
633           then do;
634                     output = create_operator(unpack,2);
635                     output->operand(1) = declare_temporary((defined_itype & undesirable_mask),(inprec),(inscale),null);
636                     output->operator.processed = "1"b;
637 
638                     if return_tree->node.type=operator_node
639                     then      if return_tree->operator.op_code^=std_call
640                               then do;                                /* must be convert-created assign */
641                                         output->operand(2) = return_tree->operand(2);
642                                         return_tree->operand(2) = output;
643                               end;
644                               else do;
645                                         output->operand(2) = return_tree;
646                                         return_tree = output;
647                               end;
648                     else do;
649                               output->operand(2) = return_tree;
650                               return_tree = output;
651                     end;
652           end;
653 
654           if string(tpicture) ^= "0"b
655           then do;
656                     output = create_operator(pack,2);
657                     p = target->symbol.general->reference.symbol->symbol.initial;
658                     output->operand(1) = declare_picture_temp(p->picture_image.chars,
659                               (p->picture_image.scalefactor),
660                               (tpicture.complex),
661                               (tpicture.unaligned));
662 
663                     output->operand(2) = return_tree;
664                     output->operator.processed = "1"b;
665 
666                     return_tree = output;
667           end;
668 
669           return(return_tree);
670 ^L
671 /* subroutine to issue diagnostics.     */
672 
673 print: proc(m);
674 
675 dcl       symbol ptr;
676 dcl       m fixed bin;
677 
678           symbol = null;
679 
680           if tree=null then goto print_;
681 
682           if tree->node.type^=reference_node
683           &  tree->node.type^=token_node
684           then      goto print_;
685 
686           if tree->node.type=reference_node
687           then      if tree->reference.symbol->symbol.dcl_type=by_compiler then goto print_;
688 
689           m = m+1;
690           symbol = tree;
691 
692 print_:
693           if m > 0
694           then      call pl1_stat_$util_abort(m,symbol);
695           else      if ^suppress_bit
696                     then      call pl1_stat_$util_error(-m,symbol);
697 
698           end print;
699 ^L
700 /* subroutine to determine the target size, prec, and scale. */
701 
702 get_target_size: proc;
703 
704 /* automatic */
705 
706 dcl       (oprec, oscale) fixed bin(15);
707 
708 /* internal static */
709 
710 /* The following array maps descriptor type codes into indexes into the action_index matrix. */
711 
712 dcl       simplify (46) fixed bin int static initial (1, 1, 2, 2, 1, 1, 2, 2, 3, 4, 3, 4, 5, 6, 7, 8, 9, 10,
713           11, 11, 12, 12, 13, (9)0, 1, 1, (8)0, 3, 4, 3, 4);
714 
715 /* The following matrix maps combinations of source type and target type into an action index.
716    The values of the simplify matrix correspond to the subscripts of action_index, and are assigned
717    as follows:
718           1 = fixed bin       8 = entry
719           2 = float bin       9 = structure
720           3 = fixed dec       10 = area
721           4 = float dec       11 = bit
722           5 = ptr             12 = char
723           6 = offset          13 = file
724           7 = label
725 */
726 
727 dcl       action_index(13,13) fixed bin(15) int static initial(
728                     20, 1, 3, 2, 0, 0, 0, 0, 0, 0, 4, 5, 0,
729                     22,20, 0,11, 0, 0, 0, 0, 0, 0,12,13, 0,
730                      8, 6,20, 7, 0, 0, 0, 0, 0, 0, 9,10, 0,
731                     21,14,22,20, 0, 0, 0, 0, 0, 0,15,16, 0,
732                      0, 0, 0, 0,20,20, 0, 0, 0, 0, 0, 0, 0,
733                      0, 0, 0, 0,20,20, 0, 0, 0, 0, 0, 0, 0,
734                      0, 0, 0, 0, 0, 0,20, 0, 0, 0, 0, 0, 0,
735                      0, 0, 0, 0, 0, 0, 0,20, 0, 0, 0, 0, 0,
736                      0, 0, 0, 0, 0, 0, 0, 0,20, 0, 0, 0, 0,
737                      0, 0, 0, 0, 0, 0, 0, 0, 0,20, 0, 0, 0,
738                     17,19,18,18, 0, 0, 0, 0, 0, 0,20,20, 0,
739                     17,19,18,18, 0, 0, 0, 0, 0, 0,20,20, 0,
740                      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,20);
741 
742 /* program */
743 
744           go to action (action_index (simplify (intype), simplify (outtype)));
745 
746 action(0):                                                  /* conversion error */
747           if known then goto exit;                          /* It is not an error if the known bit is on */
748 
749                                                             /* bin float -> dec fixed */
750           call print(261);
751 
752 action(1):                                                  /* bin fixed -> bin float */
753           outprec = min(inprec,max_p_flt_bin_2);
754           go to exit;
755 
756 action(2):                                                  /* bin fixed -> dec float */
757           outprec = min(fixed(ceil(inprec/3.32e0)),max_p_dec);
758           go to exit;
759 
760 action(3):                                                  /* bin fixed -> dec fixed */
761           outprec = min(fixed(ceil(inprec/3.32e0))+1,max_p_dec);
762           outscale = fixed(ceil(inscale/3.32e0));
763           go to exit;
764 
765 action(4):                                                  /* bin fixed -> bit */
766           outprec = min(max_p_fix_bin_2,max(inprec-inscale,0));
767           go to exit;
768 
769 action(5):                                                  /* bin fixed -> char */
770           outprec = min(fixed(ceil(inprec/3.32e0))+1,max_p_dec)+3;
771           outscale = fixed(ceil(abs(inscale)/3.32e0))*sign(inscale);
772           if outscale<0 | outscale>outprec
773                     then outprec = outprec+fixed(log10(abs(outscale)))+1;
774           outscale = 0;
775           if itype.complex then outprec = outprec*2+1;
776           go to exit;
777 
778 action(6):                                                  /* dec fixed -> bin float */
779           outprec = min(fixed(ceil(inprec*3.32e0)),max_p_flt_bin_2);
780           go to exit;
781 
782 action(7):                                                  /* dec fixed -> dec float */
783           outprec = inprec;
784           go to exit;
785 
786 action(8):                                                  /* dec fixed -> bin fixed */
787           oprec = min(fixed(ceil(inprec*3.32e0))+1,max_p_fix_bin_2);
788           oscale = fixed(ceil(inscale*3.32e0));
789           if oscale < min_scale | oscale > max_scale
790           then      if target_must_be_integer & oscale > 0
791                     then oscale = oprec - ((fixed(ceil(inprec*3.32e0))+1) - fixed(ceil(abs(inscale)*3.32e0)));
792                     else call print(479);
793           outprec = oprec;
794           outscale = oscale;
795           go to exit;
796 
797 action(9):                                                  /* dec fixed -> bit */
798           outprec = min(max_p_fix_bin_2,max(fixed(ceil((inprec-inscale)*3.32e0)),0));
799           go to exit;
800 
801 action(10):                                                 /* dec fixed -> char */
802           outprec = inprec+3;
803           if inscale<0 | inscale>inprec
804                     then outprec = outprec+fixed(log10(abs(inscale)))+1;
805           if itype.complex then outprec = outprec *2 +1;
806           go to exit;
807 
808 action(11):                                                 /* bin float -> dec float */
809           outprec = min(fixed(ceil(inprec/3.32e0)),max_p_dec);
810           go to exit;
811 
812 action(12):                                                 /* bin float -> bit */
813           outprec = min(inprec,max_p_fix_bin_2);
814           go to exit;
815 
816 action(13):                                                 /* bin float -> char */
817           outprec = min(fixed(ceil(inprec/3.32e0)),max_p_dec) + 7;
818           if itype.complex then outprec = outprec*2+1;
819           go to exit;
820 
821 action(14):                                                 /* dec float -> bin float */
822           outprec = min(fixed(ceil(inprec*3.32e0)),max_p_flt_bin_2);
823           go to exit;
824 
825 action(15):                                                 /* dec float -> bit */
826           outprec = min(fixed(ceil(inprec*3.32e0)),max_p_fix_bin_2);
827           go to exit;
828 
829 action(16):                                                 /* dec float -> char */
830           outprec = inprec+7;
831           if itype.complex then outprec = outprec*2+1;
832           go to exit;
833 
834 action(17):                                                 /* bit or char -> fixed bin */
835           outprec = max_p_fix_bin_2;
836           go to exit;
837 
838 action(18):                                                 /* bit or char -> fixed or float dec */
839           outprec = max_p_dec;
840           go to exit;
841 
842 action(19):                                                 /* bit or char -> float bin */
843           outprec = max_p_flt_bin_2;
844           go to exit;
845 
846 action(20):                                                 /* bit or char -> bit or char  any copy */
847           outprec = inprec;
848           outscale = inscale;
849 
850           if varying_input
851           then do;
852                tlength = inlength;
853                tlength -> operand(2) = share_expression(tree);
854                end;
855           else tlength = share_expression(inlength);
856           go to exit;
857 
858 action(21):                                                 /* dec float -> bin fixed */
859           outprec = min(fixed(ceil(inprec*3.32e0)) + 1,max_p_fix_bin_2);
860           outscale = 0;
861           go to exit;
862 
863 action(22):                                                 /* bin float -> bin fixed */
864                                                             /* dec float -> dec fixed */
865           outprec = inprec;
866           outscale = 0;
867 
868 exit:
869 
870           end get_target_size;
871 ^L
872 %include pl1_descriptor_type_fcn;
873 ^L
874 %include semant;
875 %include picture_image;
876 %include declare_type;
877 %include desc_dcls;
878 %include std_descriptor_types;
879 %include mask;
880 %include nodes;
881 %include op_codes;
882 %include operator;
883 %include pl1_symbol_type;
884 %include reference;
885 %include symbol;
886 %include system;
887 %include token;
888 %include token_types;
889           end convert;