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 declare_picture:    proc(string,symbol_ptr,error_code);
12 
13 dcl       string char(*) aligned;
14 dcl       symbol_ptr ptr;
15 dcl       error_code fixed bin(15);
16 
17 dcl       n_storage_nodes fixed bin;
18 
19 dcl       pl1_stat_$node_uses(32) fixed bin ext static;
20 
21 dcl       bit_value bit(648) aligned based(addr(picture_constant));
22 
23 dcl       (addr,substr) builtin;
24 
25 dcl       picture_info_ ext entry(char(*)aligned,ptr,fixed bin(15));
26 
27 %include language_utility;
28 %include picture_constant;
29 %include picture_image;
30 %include picture_types;
31 %include reference;
32 %include symbol;
33 %include system;
34 ^L
35           call picture_info_(string,addr(picture_constant),error_code);
36 
37           if error_code^=0
38           then do;
39                     picture_constant.piclength = 64;
40 
41                     /* following code is inserted only to prevent future faults */
42 
43                     symbol_ptr->symbol.pix.pic_fixed = "1"b;
44                     symbol_ptr->symbol.pix.pic_size = default_fix_dec_p;
45                     goto skip;
46           end;
47 
48           symbol_ptr->symbol.pix.pic_size = picture_constant.prec;
49 
50           if picture_constant.type = real_fixed_picture
51           then      symbol_ptr->symbol.pix.pic_fixed = "1"b;
52           else      symbol_ptr->symbol.pix.pic_float = "1"b;
53 
54           if symbol_ptr->symbol.pix.pic_fixed
55           then      symbol_ptr->symbol.pix.pic_scale = picture_constant.scale-picture_constant.scalefactor;
56 
57           if picture_constant.type=char_picture
58           then      symbol_ptr->symbol.pix.pic_char = "1"b;
59 
60           if symbol_ptr->symbol.complex
61           then do;
62                     if picture_constant.type = real_fixed_picture
63                     then      picture_constant.type = cplx_fixed_picture;
64                     else      if picture_constant.type = real_float_picture
65                               then      picture_constant.type = cplx_float_picture;
66 
67                     symbol_ptr->symbol.reference->reference.c_length,
68                     symbol_ptr->symbol.c_dcl_size = 2 * picture_constant.varlength;
69           end;
70 
71           else do;
72                     symbol_ptr->symbol.reference->reference.c_length  ,
73                     symbol_ptr->symbol.c_dcl_size = picture_constant.varlength;
74           end;
75 
76 skip:
77 
78           /* Note that we really should use unspec(addr(picture_constant) -> picture_image) */
79 
80           /* We don't want the picture constant to be allocated unless absolutely necessary
81              (e.g., for I/O), but we don't want to turn off allocate bit if it was
82              turned on for a previous picture.  Since declare_constant normally turns
83              the bit on, we must go to some trouble to do this right. */
84 
85           n_storage_nodes = pl1_stat_$node_uses(14);
86           symbol_ptr->symbol.general = declare_constant$bit(substr(bit_value,1,72+picture_constant.piclength*9));
87           if n_storage_nodes ^= pl1_stat_$node_uses(14)
88                then symbol_ptr->symbol.general->reference.symbol->symbol.allocate = "0"b;
89 
90           end declare_picture;