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 default_parse: proc(k,b,labels);
 12 
 13 dcl       (b,labels,d,s,last) ptr;
 14 dcl       (k,n) fixed bin(15);
 15 dcl       pl1_stat_$cur_statement ptr ext static;
 16 dcl       pl1_stat_$unwind external label;
 17 dcl       pl1_stat_$check_ansi bit(1) aligned ext static;
 18 dcl       pl1_stat_$root ptr ext static;
 19 
 20 dcl       (string,null,addr) builtin;
 21 %include parse;
 22 %include default;
 23 %include symbol;
 24 %include block;
 25 %include token_list;
 26 %include token_types;
 27 %include statement_types;
 28 %include declare_type;
 29 
 30           if labels ^= null
 31                     then do;
 32                               pl1_stat_$cur_statement,d = create_statement(null_statement,b,labels,(b->block.prefix));
 33                               call declare_label(b,d,labels,by_explicit_context);
 34                          end;
 35 
 36           k = k+1;
 37           d = create_default();
 38           string(d->default.source_id) = string(pl1_stat_$statement_id);
 39           if t_table.type = left_parn
 40                     then do;
 41                               k=k+1;
 42                               d -> default.predicate = expression_parse(k,b);
 43                               if d -> default.predicate = null then go to fail;
 44                               if t_table.type ^= right_parn  then go to fail;
 45                          end;
 46                     else do;
 47                               if t_table.type = identifier
 48                                         then do;
 49                                                   if t_table.string = "system"
 50                                                             then d->default.system = "1"b;
 51                                                             else if t_table.string = "none"
 52                                                                       then d->default.no_defaults = "1"b;
 53                                                                       else go to fail;
 54                                                   k=k+1;
 55                                                   if t_table.type = semi_colon then go to done;
 56                                              end;
 57                               go to fail;
 58                          end;
 59           k=k+1;
 60           if t_table.string = "error"
 61                     then do;
 62                               d->default.error = "1"b;
 63                               k=k+1;
 64                               if t_table.type = semi_colon
 65                                         then go to done;
 66                                         else go to fail;
 67                          end;
 68 
 69 /* loop to parse attribute sets */
 70 
 71           pl1_stat_$unwind = check_end;
 72           last = null;
 73           k=k-1;
 74 
 75           do while("1"b);
 76 
 77           s = create_symbol(null,null,by_compiler);
 78           call attribute_parse(b,s,k,"0"b);
 79           if last = null
 80                     then d->default.symbol = s;
 81                     else last->symbol.next = s;
 82           last = s;
 83 
 84 check_end:
 85           if t_table.type = semi_colon then go to done;
 86           if t_table.type ^= comma then go to fail;
 87           end;
 88 
 89 done:     /* must now link valid default node into block default chain in order */
 90           if b->block.end_default ^= null
 91                     then b->block.end_default->default.next = d;
 92                     else b->block.default = d;
 93           b->block.end_default = d;
 94 
 95           if pl1_stat_$check_ansi
 96           then if b ^= pl1_stat_$root -> block.son
 97                then call parse_error(350,null);
 98 
 99           return;
100 
101 fail:
102           call free_node(d);
103           call parse_error(48,null);
104 end default_parse;