1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 %;
  7 /* ******************************************************
  8    *                                                    *
  9    *                                                    *
 10    * Copyright (c) 1972 by Massachusetts Institute of   *
 11    * Technology and Honeywell Information Systems, Inc. *
 12    *                                                    *
 13    *                                                    *
 14    ****************************************************** */
 15 
 16 reference_parse:
 17           procedure(index,cblock) returns(pointer);
 18 
 19 /*        Re-written by:      Gabriel Chang for Version II
 20           Modified:           Richard A. Barnes to fix 1544
 21           Modified:           EBush for temporary extension of max
 22                               args per call to 512 */
 23 
 24 dcl       (i,j,k,m,n,index) fixed bin(15);
 25 dcl       (arg,cblock,p,q,qual,arglist,op,sym) ptr;
 26 dcl       s(512) ptr unaligned;
 27 dcl       t(128) ptr unaligned;
 28 
 29 dcl       (addr,null) builtin;
 30 
 31 %include parse;
 32 %include context_codes;
 33 %include declare_type;
 34 %include list;
 35 %include nodes;
 36 %include op_codes;
 37 %include operator;
 38 %include reference;
 39 %include symbol;
 40 %include token;
 41 %include token_list;
 42 %include token_types;
 43                               /*   ^L   */
 44 
 45 begin:
 46           qual=null;
 47           k=index;
 48           if t_table.type = isub
 49                     then do;
 50                               index=index+1;
 51                               return(token_list(k));
 52                          end;
 53 
 54 reset:
 55           i,j=0;
 56 
 57 next:
 58           if t_table.type ^= identifier then go to fail;
 59           q=token_list(k);
 60           k=k+1;
 61 
 62           if t_table.type = left_parn
 63                     then do;
 64                               if token_list(k+1)->t_table.type=right_parn
 65                               then do;
 66                                         call make_reference;
 67 
 68                                         if i = 0
 69                                         then do;
 70                                                   q -> reference.offset = create_list(0);
 71                                                   k = k + 2;
 72 
 73                                                   if t_table.type = arrow then goto test_ptr;
 74                                         end;
 75 
 76                                         goto entry_reference;
 77                               end;
 78 
 79 next_sub:
 80                               k=k+1;
 81                               i=i+1;
 82 
 83                               if t_table.type=asterisk
 84                               then do;
 85                                         if i > hbound(s,1)
 86                                              then goto fail;
 87                                         s(i)=token_list(k);
 88                                         k=k+1;
 89                               end;
 90                               else      if ^atom() then goto fail;
 91 
 92                               if t_table.type = comma then go to next_sub;
 93                               if t_table.type = colon then go to next_sub;
 94                               if t_table.type ^= right_parn then go to fail;
 95                               k=k+1;
 96                          end;
 97 
 98           if t_table.type = period
 99                     then do;
100                               k=k+1;
101                               j=j+1;
102                               if j > hbound(t,1)
103                                   then goto fail;
104                               t(j)=q;
105                               go to next;
106                          end;
107 
108           if qual^=null | j+i ^= 0
109                     then call make_reference;
110 
111           if t_table.type = arrow
112                     then do;
113 test_ptr:
114                               k=k+1;
115                               qual=q;
116                               if q->node.type = token_node
117                                         then if cblock^=null then call context(q,cblock,pointer_context);
118                               go to reset;
119                          end;
120 
121 entry_reference:
122           do while(t_table.type=left_parn);
123                     i=0;
124 
125                     if token_list(k+1)->t_table.type^=right_parn
126                     then do;
127 next_arg:
128                               k=k+1;
129                               i=i+1;
130 
131                               if ^atom() then goto fail;
132 
133                               if t_table.type=comma then goto next_arg;
134                               if t_table.type^=right_parn then goto fail;
135                     end;
136                     else      k=k+1;
137 
138                     k=k+1;
139 
140                     arglist=create_operator(std_arg_list,3);
141                     arglist->operand(2)=create_list(i);
142 
143                     do j=1 to i;
144                               arglist->operand(2)->list.element(j)=s(i-j+1);
145                     end;
146 
147                     op=create_operator(std_call,3);
148                     op->operand(2)=q;
149                     op->operand(3)=arglist;
150 
151                     q=op;
152           end;
153 
154           if t_table.type=arrow
155           then      goto test_ptr;
156 
157 ret1:
158           index=k;
159           return(q);
160 
161 fail:
162           return(null);
163 
164 
165 make_reference:     proc;
166 
167                     q=create_reference(q);
168                     q->reference.qualifier=qual;
169                     if i^=0 then do;
170                                         p=create_list(i);
171                                         do m=1 to i;
172                                                   p->list.element(m) = s(i+1-m);
173                                         end;
174                                         q->reference.offset=p;
175                                  end;
176                     if j^=0 then do;
177                                         p=create_list(j);
178                                         do m=1 to j;
179                                                   p->list.element(m) = t(j+1-m);
180                                         end;
181                                         q->reference.length=p;
182                                    end;
183 
184                     end make_reference;
185 
186 
187 atom:     proc() returns(bit(1)aligned);
188 
189 dcl       save_index fixed bin(15);
190 
191           save_index=k;
192 
193           if i > hbound(s,1)
194                then goto fail;
195           s(i) = expression_parse(k,cblock);
196           if s(i)=null then return("0"b);
197 
198           if token_list(save_index)->token.type^=left_parn
199           then;                         else
200 
201           if s(i)->node.type=operator_node
202           then;                         else
203 
204           if s(i)->node.type=token_node
205           &  s(i)->token.type^=identifier
206           then;
207 
208           else do;
209                     sym=create_symbol(null,null,by_compiler);
210                     sym->symbol.temporary="1"b;
211 
212                     op=create_operator(assign,2);
213                     op->operand(1)=sym->symbol.reference;
214                     op->operand(2)=s(i);
215 
216                     if i > hbound(s,1)
217                          then goto fail;
218                     s(i)=op;
219           end;
220 
221           return("1"b);
222 
223           end atom;
224 
225           end reference_parse;