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 statement_parse: proc(k,label_ptr,conditions,cblock,type);
 12 
 13 /*        Rewritten:          28 September 1970 by P. Green for Version II
 14           Modified: 15 Feb 1978 to implement options(main) and the stop statement
 15           Modified: 26 Dec 1979 by PCK to implement by name assignment */
 16 
 17 dcl       (i,j,k,libe_no,n initial(0),type) fixed bin(15);
 18 dcl       (addr,bit,fixed,null,binary) builtin;
 19 dcl       conditions bit(12) aligned;
 20 dcl       (p,q,r,s,cblock,label_ptr,stmnt) ptr;
 21 dcl       stack(128) ptr;
 22 dcl       op_code bit(9) aligned;
 23 
 24 dcl       pl1_stat_$cur_statement ptr ext static;
 25 
 26 dcl       action_index(0:37) fixed bin(15) int static initial(
 27 
 28                     0,1,2,0,3,          10,0,10,10,10,      0,9,0,0,10,         10,4,10,5,0,
 29                     10,6,0,10,0,        10,10,7,8,10,       8,11,0,10,10,       10,0,0);
 30 
 31 %include parse;
 32 %include block;
 33 %include declare_type;
 34 %include context_codes;
 35 %include label;
 36 %include list;
 37 %include nodes;
 38 %include op_codes;
 39 %include operator;
 40 %include reference;
 41 %include statement;
 42 %include statement_types;
 43 %include symbol;
 44 %include token;
 45 %include token_list;
 46 %include token_types;
 47 %include block_types;
 48 
 49 /*^L      */
 50 begin:
 51 
 52 make_statement:
 53           pl1_stat_$cur_statement  ,
 54           stmnt=create_statement(bit(fixed(type,9),9),cblock,label_ptr,conditions);
 55           if label_ptr^=null
 56           then      call declare_label(cblock,stmnt,label_ptr,by_explicit_context);
 57           label_ptr=null;
 58           go to action(action_index(type));
 59 
 60 action(0):                                                  /* unknown statement          */
 61           return;   /* print(400) not needed - statement_type has already complained */
 62 
 63 action(1):                                                  /* allocate statement         */
 64           q,stmnt->statement.root=create_operator(allot_var,2);
 65           k=k+1;
 66           if t_table.type ^= identifier then call print(454);
 67           q->operand(1)=token_list(k);
 68 
 69 alloc_loop:
 70           k=k+1;
 71           if t_table.string = "set"
 72                     then do;
 73                               k=k+1;
 74                               if q->operand(1)->node.type^=token_node then call print(450);
 75                               if t_table.type ^= left_parn then call print(451);
 76                               k=k+1;
 77                               p = reference_parse(k,cblock);
 78                               if p = null then call print(454);
 79                               call context(p,cblock,pointer_context);
 80                               r = create_reference((q->operand(1)));
 81                               r->reference.qualifier = p;
 82                               q->operand(1) = r;
 83                               if t_table.type ^= right_parn then call print(454);
 84                               go to alloc_loop;
 85                          end;
 86           if t_table.string ="in"
 87                     then do;
 88                               k=k+1;
 89                               if q->operand(2) ^= null then call print(452);
 90                               if t_table.type ^= left_parn then call print(453);
 91                               k=k+1;
 92                               q -> operand(2) = reference_parse(k,cblock);
 93                               if q -> operand(2) = null then call print(454);
 94                               call context((q->operand(2)),cblock,area_context);
 95                               if t_table.type ^= right_parn then call print(454);
 96                               go to alloc_loop;
 97                          end;
 98           if t_table.type = comma then go to make_statement;
 99           go to check_semi_colon;
100 
101 action(2):                                                  /* assignment statement       */
102           p = reference_parse(k,cblock);
103           if p = null then call print(1);
104           n=n+1;
105           if n>128 then call print(5);
106           stack(n)=p;
107           if t_table.type = assignment then go to make_op;
108           if t_table.type ^= comma then call print(1);
109           k=k+1;
110           go to action(2);
111 
112 make_op:
113           k=k+1;
114           p = expression_parse(k,cblock);
115           if p = null then call print(49);
116           if t_table.type = comma then go to make_assign_by_name;
117           stmnt->statement.root,q=create_operator(assign,2);
118           if n=1 then do;
119                               q->operand(1)=stack(1);
120                               q->operand(2)=p;
121                               go to check_semi_colon;
122                          end;
123           if p->node.type = token_node
124           then if p->token.type & is_constant
125                then do;
126                     s = p;
127                     q->operand(1) = stack(1);
128                     q->operand(2) = s;
129                     j = 2;
130                     go to make_assignment;
131                     end;
132 
133           s = create_symbol(null,null,by_compiler);
134           s->symbol.temporary = "1"b;
135           s = s->symbol.reference;
136           s->reference.shared="0"b;
137           s->reference.ref_count = n+1;
138           q->operand(1) = s;
139           q->operand(2) = p;
140           j = 1;
141 
142 make_assignment:
143           do i = j to n;
144                stmnt = create_statement(assignment_statement,cblock,null,conditions);
145                stmnt->statement.root, q = create_operator(assign,2);
146                stmnt->statement.generated = "1"b; /* to suppress the free_temps bit */
147                q->operand(1) = stack(i);
148                q->operand(2) = s;
149           end;
150           go to check_semi_colon;
151 
152 make_assign_by_name:
153           k=k+1;
154           if t_table.string ^= "by"
155           then call print(371);
156           k=k+1;
157           if t_table.string ^= "name"
158           then call print(371);
159           stmnt->statement.root,q=create_operator(assign_by_name,2);
160           q->operand(2) = p;
161           r = create_list(n);
162           do i=1 to n;
163                r -> list.element(i) = stack(i);
164           end;
165           q->operand(1) = r;
166           k=k+1;
167           go to check_semi_colon;
168 
169 action(3):                                                  /* call statement   */
170           k=k+1;
171           stmnt -> statement.root = reference_parse(k,cblock);
172           if stmnt -> statement.root = null then call print(444);
173           q = stmnt->statement.root;
174           if q->node.type = token_node
175                then do;
176                     q = create_reference(q);
177                     q->reference.offset = create_list(0);
178                     stmnt->statement.root = q;
179                     end;
180                else if q->node.type = reference_node
181                     then if q->reference.offset = null
182                          then q->reference.offset = create_list(0);
183           go to check_semi_colon;
184 
185 action(4):                                                  /* free statement   */
186           k=k+1;
187           q,stmnt->statement.root=create_operator(free_var,2);
188           q -> operand(1) = reference_parse(k,cblock);
189           if q -> operand(1) = null then call print(456);
190           if t_table.string = "in"
191                     then do;
192                               k=k+1;
193                               if t_table.type ^= left_parn then call print(455);
194                               k=k+1;
195                               q -> operand(2) = reference_parse(k,cblock);
196                               if q -> operand(2) = null then call print(456);
197                               call context((q->operand(2)),cblock,area_context);
198                               if t_table.type ^= right_parn then call print(456);
199                               k=k+1;
200                          end;
201           if t_table.type = comma then go to make_statement;
202           go to check_semi_colon;
203 
204 action(5):                                                  /* go to statement  */
205           if t_table.string ="goto"
206           then k = k + 1;
207           else do;
208                     k = k + 1;
209                     if t_table.string ^= "to" then call print(446);             /* syntax error in goto statement */
210                     k = k + 1;
211                end;
212           q,stmnt->statement.root=create_operator(jump,1);
213           q -> operand(1) = reference_parse(k,cblock);
214           if q -> operand(1) = null then call print(446);
215           go to check_semi_colon;
216 
217 action(6):                                                  /* null statement   */
218           if stmnt->statement.labels^=null
219           then      stmnt->statement.root = create_operator(nop,0);
220           go to check_semi_colon;
221 
222 action(7):                                                  /* return statement */
223           k=k+1;
224           if t_table.type = semi_colon
225                then do;
226                     q,stmnt->statement.root=create_operator(std_return,0);
227                     return;
228                end;
229           if t_table.type ^= left_parn then call print(447);
230           k=k+1;
231           q,stmnt->statement.root=create_operator(return_value,1);
232           q -> operand(1) = expression_parse(k,cblock);
233           if q -> operand(1) = null then call print(447);
234           if t_table.type ^= right_parn then call print(447);
235           k=k+1;
236 
237 check_semi_colon:
238           if t_table.type^=semi_colon then call print(1);
239           return;
240 
241 action(8):                                                  /* revert and signal statements */
242           call on_parse$revert(k,stmnt,cblock);
243           if t_table.type = comma
244           then if type = fixed(revert_statement,15)         /* revert statements may mention more than one    */
245                then go to make_statement;                   /* signal statements must have only one.          */
246           go to check_semi_colon;
247 
248 action(9):                                                  /* singleton else clause */
249           call print(150);
250           return;
251 
252 action(10):                                                 /* unimplemented statements */
253           call print(460);
254           return;
255 
256 action(11):                                                 /* stop statement */
257           k=k+1;
258           stmnt->statement.root=create_operator(stop,0);
259           go to check_semi_colon;
260 
261 print: proc(m);
262 
263 dcl       m fixed bin(15);
264 
265           call parse_error(m,null);
266           stmnt->statement.root=null;
267           stmnt->statement.statement_type=null_statement;
268           go to ret;
269           end;
270 
271 ret:
272           end statement_parse;