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 on:        23 June 1975 by EEW  for new entry sequence
 12           Modified: 18 Feb 1977 by RAB for -check_ansi
 13           Modified: 30 Dec 1977 by RAB fo options(separate_static)
 14           Modified: 15 Feb 1978 by PCK to implement options(main)
 15           Modified: 6 Apr 1978 by RAB to fix 1725
 16           Modified: 24 August 1978 by RAB to make check_ansi more informative
 17           Modified: 24 May 1979 by PCK to implement options(packed_decimal)
 18           Modified: 3 September 1981 by EBush for temporary extension of
 19                     max parameters per proceedure/entry to 512 */
 20 
 21 process_entry: proc(k,stmnt_type,cblock,entries,conditions);
 22 
 23 dcl       (cblock,entries,p,q,e,return,s,t) ptr;
 24 dcl       (k,n,i) fixed bin(15);
 25 dcl       (stmnt_type,st_type) bit(9) aligned;
 26 dcl       (reducible,variable_arg) bit(1) aligned;
 27 dcl       pl1_stat_$cur_statement ptr ext static;
 28 dcl       pl1_stat_$unwind label external static;
 29 dcl       pl1_stat_$root ptr ext static;
 30 dcl       (pl1_stat_$check_ansi,pl1_stat_$options_packed_dec) bit(1) aligned ext static;
 31 dcl       pl1_stat_$validate_proc ptr ext static;
 32 dcl       cg_static_$support bit(1) aligned ext static;
 33 dcl       cg_static_$separate_static bit(1) aligned ext static;
 34 dcl       stack(513) ptr;
 35 dcl       conditions bit(12) aligned;
 36 
 37 dcl       (null,string) builtin;
 38 
 39 %include parse;
 40 %include token_list;
 41 %include context_codes;
 42 %include nodes;
 43 %include token;
 44 %include statement_types;
 45 %include statement;
 46 %include cross_reference;
 47 %include symbol;
 48 %include declare_type;
 49 %include operator;
 50 %include token_types;
 51 %include op_codes;
 52 %include list;
 53 %include block;
 54 %include block_types;
 55 
 56 
 57 
 58 
 59 
 60 
 61 begin:
 62           if entries = null
 63                then call parse_error(266,null);
 64           pl1_stat_$unwind=make_entry;                      /* in case descriptor_parse finds any errors */
 65           reducible, variable_arg = "0"b;
 66           n=0;
 67           return=null;
 68           st_type = stmnt_type;
 69           if t_table.type ^= left_parn then go to options;
 70           if token_list(k+1)->token.type = right_parn
 71                     then do;
 72                               k=k+2;                                  /* this is a null arg list    */
 73                               go to options;
 74                          end;
 75 circut:   k=k+1;
 76           if t_table.type ^= identifier then call print(35);
 77           n=n+1;
 78           if n>512 then call print(34);
 79           stack(n)=token_list(k);
 80           call context(stack(n),cblock,parameter_context);
 81           k=k+1;
 82           if t_table.type = comma then go to circut;
 83           if t_table.type ^= right_parn then call print(35);
 84           k=k+1;
 85 options:
 86           if t_table.type = semi_colon then go to make_entry;
 87           if t_table.type ^= identifier then call print(36);
 88           if t_table.string = "returns"
 89                     then do;
 90                               k=k+1;
 91                               if t_table.type ^= left_parn then call print(37);
 92                               return = descriptor_parse(cblock,
 93                                         create_token(entries->list.element(2)->token.string||"[return value]",
 94                                                             identifier),k);
 95                               if return ^= null
 96                               then do;
 97                                         if return->list.element(2) ^= null then call print(37);
 98                                         return = return->list.element(1);
 99                                         return->symbol.parameter = "1"b;
100                                         n=n+1;
101                                         stack(n) = return->symbol.token;
102                                    end;
103                               if t_table.type ^= right_parn then call print(37);
104                               k=k+1;
105                               go to options;
106                          end;
107           if t_table.string = "recursive" | t_table.string = "irreducible" | t_table.string = "irred"
108                     then do;
109                               if pl1_stat_$check_ansi
110                               then if t_table.string ^= "recursive"
111                                    then call print_warning(354,token_list(k));
112 
113                               k=k+1;
114                               go to options;
115                          end;
116           if t_table.string = "reducible" | t_table.string = "red"
117                     then do;
118                               if pl1_stat_$check_ansi
119                                    then call print_warning(354,token_list(k));
120 
121                               k=k+1;
122                               reducible="1"b;
123                               go to options;
124                          end;
125           if t_table.string = "options"
126                     then do;
127                               if pl1_stat_$check_ansi
128                                    then call print_warning(355,(token_list(k)));
129 
130                               k=k+1;
131                               if t_table.type ^= left_parn then call print(38);
132 opt_circuit:
133                               k=k+1;
134                               if t_table.string = "validate"
135                                         then do;
136                                                   if pl1_stat_$validate_proc ^= null then call print(39);
137                                                   k=k+1;
138                                                   if t_table.type ^= left_parn then go to bad;
139                                                   k=k+1;
140                                                   if t_table.type ^= identifier then call print(40);
141                                                   t = token_list(k);
142                                                   k=k+1;
143                                                   if t_table.type ^= right_parn then go to bad;
144                                                             s = create_symbol((pl1_stat_$root->block.son),t,by_explicit_context);
145                                                             s->symbol.cross_references = create_cross_reference();
146                                                             string(s->symbol.cross_references->cross_reference.source_id) = string(pl1_stat_$statement_id);
147                                                   s->symbol.entry,
148                                                   s->symbol.external,
149                                                   s->symbol.allocate = "1"b;
150                                                   pl1_stat_$validate_proc = s;
151                                                   k=k+1;
152                                              end;
153                               else if t_table.string = "rename"
154                                         then do;
155                                                   if ^reserve$rename_parse(k) then go to make_entry;
156                                              end;
157                                         else if t_table.string = "non_quick"
158                                               | t_table.string = "no_quick_blocks"
159                                              then do;
160                                                   cblock -> block.why_nonquick.options_non_quick = "1"b;
161                                                   cblock -> block.no_stack = "0"b;
162                                                   k = k + 1;
163                                                   end;
164                                              else if t_table.string = "support"
165                                                   then do;
166                                                        cg_static_$support = "1"b;
167                                                        k = k + 1;
168                                                        end;
169                                                   else if t_table.string = "variable"
170                                                        then do;
171                                                             variable_arg = "1"b;
172                                                             cblock -> block.why_nonquick.options_variable = "1"b;
173                                                             cblock -> block.no_stack = "0"b;
174                                                             k = k + 1;
175                                                             end;
176                                                        else if t_table.string = "separate_static"
177                                                             then do;
178                                                                  cg_static_$separate_static = "1"b;
179                                                                  k = k + 1;
180                                                                  end;
181                                                             else if t_table.string = "main" | t_table.string = "packed_decimal"
182                                                                  then do;
183                                                                       if stmnt_type^=procedure_statement
184                                                                            then do;
185                                                                                 call parse_error(368,token_list(k));
186                                                                                 go to make_entry;
187                                                                                 end;
188                                                                       if cblock->block.block_type^=external_procedure
189                                                                            then do;
190                                                                                 call parse_error(369,token_list(k));
191                                                                                 go to make_entry;
192                                                                                 end;
193 
194                                                                       if t_table.string = "main"
195                                                                       then cblock -> block.options_main = "1"b;
196                                                                       else pl1_stat_$options_packed_dec = "1"b;
197 
198                                                                       k = k+1;
199                                                                       end;
200                               if t_table.type = comma then go to opt_circuit;
201                               if t_table.type ^= right_parn then go to bad;
202                               k=k+1;
203                               go to options;
204                          end;
205 
206 bad:
207           call parse_error(41,token_list(k));                         /* invalid option   */
208 
209 /* create an entry statement for each entry label.  If returns(...) was given then
210    each entry is a function, otherwize they are subroutines.          */
211 
212 make_entry:
213           do e = entries repeat e->list.element(1) while(e^=null);
214                q=create_list(2);
215                q->list.element(2)=e->list.element(2);
216                if q->element(2)->node.type=reference_node
217                then do;
218                     call parse_error(270,null);
219                     return;
220                end;
221                pl1_stat_$cur_statement  ,
222                p=create_statement(st_type,cblock,q,conditions);
223                p->statement.root,q = create_operator(std_entry,n);
224                do i=1 to n;
225                     q->operand(i) = stack(i);
226                end;
227 
228 /* Declare each name as an entry constant.                                      */
229 
230                q=create_symbol((cblock->block.father),(e->list.element(2)),by_explicit_context);
231                if variable_arg
232                   then if return = null
233                        then q -> symbol.variable_arg_list = "1"b;
234                        else call parse_error(483,null);
235                if return ^= null
236                     then do;
237                               q->symbol.returns ="1"b;
238                               q->symbol.dcl_size = return;
239                               return->symbol.passed_as_arg = "1"b;
240                          end;
241                q->symbol.entry,
242                q->symbol.constant="1"b;
243                if cblock->block.block_type ^= external_procedure then q->symbol.internal="1"b;
244                q->symbol.reducible=reducible;
245                q->symbol.equivalence = cblock;
246                q->symbol.initial = p;             /* set initial field to point to entry statement */
247                string(q->symbol.source_id) = string(pl1_stat_$statement_id);
248                cblock->block.number_of_entries = cblock->block.number_of_entries + 1;
249                st_type = entry_statement;
250           end;
251 
252 /* error message subroutine   */
253 
254 print: proc(m);
255 
256 dcl       m fixed bin(15);
257 
258           call parse_error(m,null);
259           go to make_entry;
260           end;
261 
262 
263 print_warning: proc(m,p);
264 
265 dcl       m fixed bin(15);
266 dcl       p ptr;
267 
268           call parse_error(m,p);
269 
270           end;
271 
272 
273           end process_entry;