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 780425 by PG to prepare for reformatting of symbol node */
 12 /* Modified 780712 by PG for unsigned */
 13 /* Modified 790419 by PCK to implement 4-bit decimal */
 14 
 15 declare_constant:
 16      procedure (value, bv_input_type, size, scale) returns (ptr);
 17 
 18 /* parameters */
 19 
 20 dcl       value bit (*) aligned;
 21 dcl       bv_input_type bit (36) aligned;
 22 dcl       (size, scale) fixed bin (31);
 23 
 24 /* automatic */
 25 
 26 dcl       (p, q, p1, ref, pv, last, save) ptr;
 27 dcl       (boundary, i, j, word_size, bit_size, value_size) fixed bin(31);
 28 dcl       copy bit(18432);              /* max size of constant is 512 words */
 29 dcl       1 ctype like type;
 30 dcl       1 itype like type;
 31 
 32 /* based */
 33 
 34 dcl       const_value bit(value_size) aligned based;
 35 dcl       new_value bit(value_size) aligned based(pv);
 36 dcl       space bit(value_size)  aligned based;
 37 
 38 /* builtin */
 39 
 40 dcl       (addr, bit, divide, hbound, index, max, null, string, substr) builtin;
 41 
 42 /* external static */
 43 
 44 dcl       pl1_stat_$constant_list ptr external static;
 45 
 46 /* internal static */
 47 
 48 dcl       zero bit(36) int static init("0"b);
 49 
 50 /* include files */
 51 
 52 %include language_utility;
 53 %include symbol;
 54 %include pl1_symbol_type;
 55 %include reference;
 56 %include system;
 57 %include mask;
 58 %include boundary;
 59 %include declare_type;
 60 ^L
 61 /* program */
 62 
 63           string (itype) = bv_input_type;
 64           string (ctype) = string (itype) & declare_constant_mask;
 65           if ctype.ptr then do;
 66                                         boundary = mod2_;
 67                                         bit_size = bits_per_word*2;
 68                                         go to search;
 69                                 end;
 70           if ctype.offset then do;
 71                                         boundary = word_;
 72                                         bit_size = bits_per_word;
 73                                         go to search;
 74                                end;
 75           if ctype.decimal then do;
 76                                         boundary = character_;
 77                                         ctype.unaligned = itype.unaligned;
 78                                         if ctype.unaligned
 79                                         then do;
 80                                                   if ctype.float
 81                                                   then bit_size = size + 3;
 82                                                   else bit_size = size + 1;
 83 
 84                                                   bit_size = bit_size + mod(bit_size,2);
 85                                                   bit_size = divide(bit_size,packed_digits_per_character,24,0) * bits_per_character;
 86                                              end;
 87                                         else do;
 88                                                   if ctype.float
 89                                                   then bit_size = size + 2;
 90                                                   else bit_size = size + 1;
 91 
 92                                                   bit_size = bit_size * bits_per_character;
 93                                              end;
 94                                         if ctype.complex
 95                                         then bit_size = bit_size * 2;
 96                                         go to search;
 97                               end;
 98           if ctype.char then do;
 99                                         boundary = character_;
100                                         bit_size = size*bits_per_character;
101                                         go to search;
102                               end;
103           if ctype.bit | ctype.arg_descriptor
104                     then do;
105                                         boundary = bit_;
106                                         bit_size = size;
107                                         go to search;
108                               end;
109 
110 /* this is a binary constant */
111 
112           if ctype.fixed
113           then      if itype.unaligned
114                     then      if itype.unsigned
115                               then      bit_size = size;
116                               else      bit_size = size + 1;
117                     else      if size>max_p_fix_bin_1
118                               then      bit_size = bits_per_word*2;
119                               else      bit_size = bits_per_word;
120 
121           else      if itype.unaligned
122                     then      bit_size = size+bits_per_binary_exponent+1;
123                     else      if size>max_p_flt_bin_1
124                               then      bit_size = bits_per_word*2;
125                               else      bit_size = bits_per_word;
126 
127           if ctype.complex then bit_size = bit_size*2;
128           if bit_size > bits_per_word
129                     then boundary = mod2_;
130                     else boundary = word_;
131 
132           ctype.unaligned = itype.unaligned;
133           ctype.unsigned = itype.unsigned;
134 
135 /* search the chain of constants to find one who's value is equal to this value.
136    If no such constant can be found, make a new constant declaration. */
137 
138 search:
139           word_size = divide(bit_size+bits_per_word-1,bits_per_word,31,0);
140           value_size = word_size * bits_per_word;
141 
142           substr(copy,1,value_size) = substr(value,1,bit_size);
143 
144           pv = addr(copy);
145 
146           save  ,
147           last = null;
148           p = pl1_stat_$constant_list;
149 
150           do while(p^=null);
151                     if p->symbol.c_word_size >= word_size
152                     then      if p->symbol.initial->const_value = new_value
153                               then do;
154                                         if word_size = 0
155                                         then      if word_size ^= p -> symbol.c_word_size
156                                                   then      go to again;
157 
158                                         save = p;
159 
160                                         if p->symbol.c_bit_size^=bit_size then goto new_symbol;
161                                         if substr (string (p -> symbol.attributes), 1, 36) ^= string (ctype) then go to again;
162                                         if p->symbol.c_dcl_size ^= size then goto again;
163                                         if p->symbol.scale ^= scale then goto again;
164 
165                                         return(p->symbol.reference);
166                               end;
167                               else;
168                     else      last = p;
169 
170 again:
171                     p = p->symbol.multi_use;
172           end;
173 
174 /* create a new symbol node to represent this constant.     */
175 
176 new_symbol:
177           q = create_symbol(null,null,by_compiler);
178           q -> symbol.boundary = boundary;
179           substr (string (q -> symbol.attributes), 1, 36) = string (ctype);
180           q->symbol.c_dcl_size = size;
181           q->symbol.scale = scale;
182           q->symbol.c_word_size = word_size;
183           q->symbol.c_bit_size = bit_size;
184           q->symbol.internal,
185           q->symbol.constant = "1"b;
186 
187           q->symbol.packed = q->symbol.unaligned;
188 
189           q->symbol.allocate = save=null;
190           ref = q->symbol.reference;
191           if ctype.bit | ctype.char then ref->reference.c_length = size;
192           ref->reference.padded_ref = "1"b;
193 
194 /* If this value exists as the value of another constant then
195    this declaration will be equivalenced to the declaration of the other constant. */
196 
197           if save^=null
198           then do;
199                     if save->symbol.equivalence = null
200                               then q->symbol.equivalence = save;
201                               else q->symbol.equivalence = save->symbol.equivalence;
202 
203                     do p1 = q -> symbol.equivalence repeat p1 -> symbol.equivalence while(p1 -> symbol.equivalence ^= null);
204                     end;
205                     p1 -> symbol.boundary = max(boundary,p1 -> symbol.boundary);
206 
207                     q->symbol.initial = save->symbol.initial;
208                end;
209           else do;
210                     if word_size > 0
211                     then do;
212                               q->symbol.initial,p1 = create_storage((word_size));
213                               p1->space = substr(copy,1,bit_size);
214                          end;
215                     else      q -> symbol.initial = addr(zero);
216                end;
217 
218 /* hook this symbol node into the chain of constants keeping the chain ordered by size. */
219 
220           if last=null
221           then do;
222                     q->symbol.multi_use=pl1_stat_$constant_list;
223                     pl1_stat_$constant_list=q;
224           end;
225           else do;
226                     q->symbol.multi_use=last->symbol.multi_use;
227                     last->symbol.multi_use=q;
228           end;
229 
230           return(ref);
231 ^L
232 /* Entry points to allow easy declaration of constant values by the compiler. */
233 
234 dcl       integer fixed bin(31);
235 dcl       integer_image bit(bits_per_word) aligned based(addr(integer));
236 dcl       bits aligned bit(*);
237 dcl       char aligned char(*);
238 dcl       char_image aligned bit(length(char)*bits_per_character) based(addr(char));
239 
240 dcl       length builtin;
241 
242           /* following is table giving binary precision corresponding
243              to decimal precision, it is used by declare_constant$integer
244              to adjust computed binary precision so that it matches the
245              precision that would be used if a decimal integer were
246              converted to binary */
247 
248 dcl       prectab(0:10) fixed binary static init(0,5,8,11,15,18,21,25,28,31,35);
249 
250 integer: entry(integer) returns(ptr);
251 
252           i = index(bit(integer,31),"1"b);
253           if i = 0 then i = 1; else i = 31 - i + 1;
254 
255           do j = 0 to hbound(prectab,1)-1;
256                if i = prectab(j) then goto ok;
257                if i ^> prectab(j+1)
258                then do;
259                     i = prectab(j+1);
260                     goto ok;
261                     end;
262                end;
263 
264           i = max_p_fix_bin_1;
265 
266 ok:       return(declare_constant(integer_image,integer_type,i,0));
267 
268 desc: entry(bits) returns(ptr);
269 
270           return(declare_constant(bits,arg_desc_type,length(bits),0));
271 
272 bit: entry(bits) returns(ptr);
273 
274           return(declare_constant(bits,bit_type,length(bits),0));
275 
276 char: entry(char) returns(ptr);
277 
278           return(declare_constant(char_image,char_type,length(char),0));
279 
280      end;