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: 79/04/23 by PCK to implement 4-bit decimal */
 12 
 13 subscripter: proc(blk,stmnt,tree,subs,s) returns(ptr);
 14 
 15 dcl       (blk,stmnt,tree,s,subs,subscript,e,sum,a,b,q,off,pdssl) ptr;
 16 dcl       (n,i,k,n_minus_k) fixed bin(15);
 17 dcl       (units,cunits) fixed binary(3);
 18 dcl       (c_sum,c_subscript,coff) fixed bin(31);
 19 
 20 dcl       op_table(4) bit(9) aligned initial(mod_bit,""b,mod_byte,mod_half);
 21 
 22 dcl       pl1_stat_$eis_mode bit(1) aligned ext static;
 23 
 24 dcl       (addr,null,substr,string,fixed,char,max) builtin;
 25 ^L
 26           c_sum = 0;
 27           sum = null;
 28           n = subs->list.number;
 29           if s->node.type = label_node
 30           then do;
 31                     b = create_bound();
 32                     b->bound.c_lower = s->label.low_bound;
 33                     b->bound.c_upper = s->label.high_bound;
 34                     b->bound.c_multiplier = 1;
 35                     k = 1;
 36                end;
 37           else do;
 38                     a = s->symbol.array;
 39                     b = a->array.bounds;
 40                     k = a->array.number_of_dimensions;
 41                     if n < k then call print(81);
 42                     if n > k & ^s->symbol.entry then call print(82);
 43                end;
 44 
 45           if tree->reference.put_data_sw
 46           then pdssl = create_list(k);
 47           else pdssl = null;
 48 
 49 /* The parse produces separate subscript and argument lists when possible
 50           ex 1:     a(i)(arg1,arg2);
 51    but when the syntax is ambiguous, it produces a single list:
 52           ex 2:     a(i).b(first_arg_or_subs,...last_arg_or_subs);
 53 
 54    Note that the elements are pushed, i.e., the list for example 2 is:
 55           (last_arg_or_subs,...first_arg_or_subs,i)
 56 */
 57           do i = n-k+1 to n;                      /* take last _^Hk of _^Hn elements */
 58 
 59                subscript = subs->list.element(i);
 60                if subscript->node.type = token_node
 61                     then if subscript->token.type = dec_integer
 62                               then do;
 63                                         c_subscript = token_to_binary(subscript);
 64 
 65 /* Check the subscript against the constant array bounds.
 66    The following code works for all cases except where someone has already put a reference
 67    to the constant in the bound.upper or bound.lower fields, _^Ha_^Hn_^Hd that constant is zero.
 68 */
 69 
 70 
 71                                         if b->bound.lower = null | b->bound.c_lower ^= 0
 72                                         then if c_subscript < b->bound.c_lower
 73                                              then call print(184);
 74                                         if b->bound.upper = null | b->bound.c_upper ^= 0
 75                                         then if c_subscript > b->bound.c_upper
 76                                              then call print(184);
 77                                         subscript = null;
 78                                    end;
 79                               else;
 80                     else if subscript->node.type=operator_node
 81                          then subscript = copy_expression((subscript));
 82 
 83                if subscript ^= null
 84                     then do;
 85                               this_context = "0"b;
 86                               subscript = expression_semantics(blk,stmnt,subscript,this_context);
 87                               if def_this_context.aggregate then call print(84);
 88                               subscript = convert$to_integer(subscript,integer_type);
 89                          end;
 90 
 91 
 92                if substr(stmnt->statement.prefix,7,1) /* subscriptrange */
 93                     then if b->bound.lower^=null | b->bound.upper^=null | subscript^=null
 94                     then do;
 95                               if subscript = null then subscript = declare_constant$integer(c_subscript);
 96                               if b->bound.lower = null
 97                                         then b->bound.lower = declare_constant$integer((b->bound.c_lower));
 98                               if b->bound.upper = null
 99                                         then b->bound.upper = declare_constant$integer((b->bound.c_upper));
100                               q = create_operator(bound_ck,4);
101                               q->operand(2) = subscript;
102                               q->operand(3) = copy_expression(b->bound.lower);
103                               q->operand(4) = copy_expression(b->bound.upper);
104                               subscript = expression_semantics((s->symbol.block_node),stmnt,q,this_context);
105                          end;
106 
107                if b->bound.c_multiplier^=0
108                then if subscript=null
109                     then      c_sum = c_sum+b->bound.c_multiplier*c_subscript;
110                     else      if b->bound.c_multiplier=1
111                               then      sum = addf(sum,subscript);
112                               else      sum = addf(sum,multf
113                                                   (declare_constant$integer((b->bound.c_multiplier)),subscript));
114 
115                else if subscript=null
116                     then      if c_subscript=1
117                               then      sum = addf(sum,copy_expression(b->bound.multiplier));                 else
118                               if c_subscript^=0
119                               then      sum = addf(sum,multf
120                                         (copy_expression(b->bound.multiplier),declare_constant$integer(c_subscript)));
121                               else;
122                     else      sum = addf(sum,multf(copy_expression(b->bound.multiplier),subscript));
123 
124                if pdssl ^= null                   /* save the subscripts for data i/o in the opposite order */
125                     then if subscript ^= null
126                               then pdssl->list.element(n-i+1) = share_expression(subscript);
127                               else pdssl->list.element(n-i+1) = declare_constant$integer(c_subscript);
128 
129                b = b->bound.next;
130           end;
131 
132 /* strip off the subscripts we used, return the extra ones (possible arguments to a
133    subscripted entry variable, for example. */
134 
135           if k ^= n
136           then do;
137                     n_minus_k=n-k;
138                     b = create_list(n_minus_k);
139                     do i = 1 to n_minus_k;        /* take first n_minus_k elements of subs */
140                          b->element(i) = subs->element(i);
141                     end;
142                     subs = b;
143           end;
144           else      subs = null;
145 
146 /* Subtract the virtual origin from the sum of the multipliers times the subscripts. */
147 
148           e = tree;
149           if s->node.type = symbol_node
150           then if tree = s->symbol.reference
151                     then      e = copy_expression((tree));
152 
153           if pdssl ^= null
154           then do;
155                     e->reference.subscript_list=pdssl;
156                     blk->block.plio_ssl->symbol.c_word_size = max(blk->block.plio_ssl->symbol.c_word_size,k+1);
157           end;
158 
159           if s->node.type = label_node
160           then do;
161                     units = word_;
162                     c_sum = c_sum-s->label.low_bound;
163           end;
164           else do;
165                     units = a->array.offset_units;
166                     c_sum = c_sum-a->array.c_virtual_origin;
167                     if a->virtual_origin^=null
168                     then      if sum=null
169                               then do;
170                                         sum = create_operator(negate,2);
171                                         sum->operator.operand(2) = copy_expression(a->virtual_origin);
172                               end;
173                               else      sum = subf(sum,copy_expression(a->array.virtual_origin));
174 
175                     if        units=character_
176                     then if   pl1_stat_$eis_mode
177                     then if   s->symbol.bit
178                          |    s->symbol.binary
179                          |    s->symbol.ptr
180                     then do;
181                               units = bit_;
182                               c_sum = c_sum * bits_per_character;
183                               if sum^=null
184                               then      sum = multf(sum,declare_constant$integer(bits_per_character));
185                     end;
186           end;
187 
188 /* call the offset_adder to add the offset produced from the subscripts to the offset
189    produced by the declaration processor.  All conversions of units are done by the
190    offset adder.  */
191 
192           off = e->reference.offset;
193           coff = e->reference.c_offset;
194           cunits = e->reference.units;
195           call offset_adder(off,coff,cunits,(e->reference.modword_in_offset),sum,c_sum,units,"0"b,e->reference.fo_in_qual);
196           e->reference.offset = off;
197           e->reference.c_offset = coff;
198           e->reference.units = cunits;
199           e->reference.modword_in_offset = "0"b;
200 
201 /* If the units of the offset are less than words and the offset is variable the top operator
202    in the offset expression must be a mod operator.  */
203 
204           if        ^pl1_stat_$eis_mode
205           then if   e->reference.units < word_
206           then if   e->reference.offset ^= null
207           then do;
208                     q = create_operator(op_table(e->reference.units),3);
209                     q->operand(3) = e->reference.offset;
210                     e->reference.offset = q;
211           end;
212 
213           e->reference.shared = "0"b;
214           e->reference.ref_count = 1;
215           if s->symbol.packed then e->reference.padded_ref = "0"b;
216 
217           return(e);
218 ^L
219 /* subroutine to print an error message and abort. */
220 
221 print: proc(m);
222 
223 dcl       m fixed bin(15);
224 dcl       semantic_translator$abort entry(fixed bin(15),ptr);
225 
226           call semantic_translator$abort(m,s);
227 
228           end print;
229 
230 /* subroutine to build expressions.  */
231 
232 addf: proc(a,b) returns(ptr);
233 
234 dcl       (a,b,c) ptr;
235 dcl       opcode bit(9) aligned;
236 
237           opcode = add;
238 
239           if a=null
240           then return(b);
241 
242           go to common;
243 
244 subf: entry(a,b) returns(ptr);
245 
246           opcode = sub;
247           go to common;
248 
249 multf: entry(a,b) returns(ptr);
250 
251           opcode = mult;
252 common:
253           c = create_operator(opcode,3);
254           c->operand(2) = a;
255           c->operand(3) = b;
256 
257           return(c);
258 
259           end addf;
260 ^L
261 %include semant;
262 %include block;
263 %include label;
264 %include symbol;
265 %include array;
266 %include reference;
267 %include statement;
268 %include list;
269 %include token;
270 %include operator;
271 %include op_codes;
272 %include boundary;
273 %include nodes;
274 %include token_types;
275 %include declare_type;
276 %include semantic_bits;
277 %include system;
278 
279 ^L
280           end subscripter;