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 /*
 12 This procedure is called at entry point declare_parse to parse declare statements.
 13 This procedure is called at entry point abort when a parse error occurs.
 14 
 15 The entry point declare_parse is called to parse declare statements.
 16 It merely performs initialization and calls declare_parse_factored.
 17 Upon return, it makes sure that the last token processed was a semicolon.
 18 
 19 The entry point abort is called when an error is detected.
 20 It attempts to restart the parse at the first
 21 comma after the error token not contained in parentheses.
 22 
 23 The internal procedure declare_parse_factored does most of the work
 24 of parsing declare statements.  It is called by declare_parse to
 25 parse everything between the word "declare" and the semicolon.
 26 It calls attribute_parse to process attributes, and
 27 it calls itself recursively to process factored attribute lists
 28 when it encounters a left parenthesis.
 29 */
 30 
 31 declare_parse: proc(i,cur_block,labels);
 32 
 33 dcl       i fixed bin(15) parameter;
 34 dcl       (cur_block,labels) ptr parameter;
 35 
 36 declare   p ptr;
 37 declare   (cblock,previous_symbol) ptr internal static;
 38 
 39 declare   (n,j) fixed binary(15);
 40 declare   (k,l,factored_level) fixed binary(15) static internal;
 41 
 42 dcl       type bit(9);
 43 
 44 dcl       pl1_stat_$cur_statement ptr ext static;
 45 dcl       pl1_stat_$unwind label external static;
 46 
 47 
 48 dcl       (null,addr,string) builtin;
 49 
 50 %include parse;
 51 %include block;
 52 %include token_types;
 53 %include statement_types;
 54 %include symbol;
 55 %include token_list;
 56 %include token;
 57 %include declare_type;
 58 %include reference;
 59 
 60 ^L
 61 begin:
 62           k,l=i;              /* move the parameters into local static storage */
 63           cblock=cur_block;   /* to eliminate argument passing to declare_parse_factored */
 64                               /* and so that abort can access k and l */
 65 
 66           if labels ^= null
 67                     then do;
 68                               pl1_stat_$cur_statement  ,
 69                               p = create_statement(null_statement,cblock,labels,(cblock -> block.prefix));
 70                               call declare_label(cblock,p,labels,by_explicit_context);
 71                          end;
 72 
 73           pl1_stat_$unwind=error_restart;
 74           previous_symbol = null;
 75 
 76 error_restart:
 77           if t_table.type = semi_colon then return;
 78           factored_level = 0;           /* initial factored level is 0 */
 79           call declare_parse_factored;
 80           if t_table.type = semi_colon then return;
 81           call parse_error(1,null);
 82           return;
 83 
 84 declare_parse$abort: entry(m,bad_node);
 85 
 86 dcl       m fixed bin(15) parameter;
 87 dcl       bad_node pointer;
 88 
 89           call parse_error(m,bad_node);
 90           n=0;
 91           j=k;
 92           do k=l by 1;
 93           type = t_table.type;
 94           if type=left_parn then n=n+1;
 95           if type=right_parn then n=n-1;
 96           if type=semi_colon then go to pl1_stat_$unwind;
 97           if type=comma then if n=0 then if k>j then go to pl1_stat_$unwind;
 98           end;
 99 ^L
100 declare_parse_factored:       procedure;
101 
102 dcl       (last_dcl,s) ptr;
103 dcl       (current_level,level) fixed bin(15);
104 
105           current_level = factored_level;                   /* copy from static "parameter" */
106 
107 do while("1"b);
108           k=k+1;
109 
110           level = current_level;
111           if t_table.type = dec_integer
112              then do;
113                   if current_level = 0
114                      then level = token_to_binary(token_list(k));
115                      else call parse_error(1,null);         /* ignore level number inside factored level number */
116                   k=k+1;
117                   end;
118 
119           if t_table.type=left_parn
120                     then do;
121                               l=k-1;
122                               last_dcl = cblock->block.end_declaration;
123                               factored_level = level;       /* copy to static "parameter" */
124                               call declare_parse_factored;
125                               s = create_symbol(null,create_token("a factored attribute list",(identifier)),by_compiler);
126                               if t_table.type^=right_parn then call declare_parse$abort(3,null);
127                               call attribute_parse(cblock,s,k,"0"b);
128                               if last_dcl = null
129                                         then last_dcl = cblock->block.declaration;
130                                         else last_dcl = last_dcl->symbol.next;
131                               do last_dcl = last_dcl repeat last_dcl->symbol.next while(last_dcl^=null);
132                               if last_dcl->symbol.dcl_type = by_declare
133                                         then if merge_attributes(last_dcl,s) then call parse_error(27,null);
134                               end;
135                               call free_node(s);
136                          end;
137                     else do;
138                               if t_table.type ^= identifier then call declare_parse$abort(3,null);
139                               s = create_symbol(cblock,token_list(k),by_declare);
140                               string(s->symbol.source_id) = string(pl1_stat_$statement_id);
141                               s->symbol.level = level;
142                               call link_symbol(previous_symbol,s);    /* perform appropriate structure linking */
143                               call attribute_parse(cblock,s,k,"0"b);
144                          end;
145           if t_table.type ^= comma then return;
146 end;
147 end declare_parse_factored;
148 %include link_symbol;
149 
150 end declare_parse;