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 Dec 1978 by David Spector to process suppress_cross_ref context bit
 12    to suppress redundant int entry/label cross-references */
 13 /* Modified: 27 Dec 1980 by PCK to implement by name assignment */
 14 
 15 lookup: proc(blk,stmnt,tree,s,context) returns(bit(1) aligned);
 16 
 17 dcl       (blk,stmnt,tree,s,d,q,b,f,name) ptr;
 18 dcl       fully_qualified bit(1);
 19 dcl       (n,k) fixed bin(15);
 20 dcl       pl1_stat_$LHS ptr ext static;
 21 
 22 dcl       (addr,null,substr,string) builtin;
 23 
 24 %include semant;
 25 
 26 
 27 %include symbol;
 28 
 29 %include label;
 30 
 31 %include reference;
 32 %include semantic_bits;
 33 
 34 %include block;
 35 
 36 %include statement;
 37 
 38 
 39 %include token;
 40 
 41 %include list;
 42 
 43 %include cross_reference;
 44 
 45 %include nodes;
 46 
 47                               /*   ^L   */
 48 
 49           n = 0;
 50           d = null;
 51           if tree->node.type = reference_node
 52                     then do;
 53                               q = tree->reference.length;
 54                               name = tree->reference.symbol;
 55                          end;
 56                     else do;
 57                               q = null;
 58                               name = tree;
 59                          end;
 60 
 61 /* search for an applicable declaration for which this is a fully qualified reference.  Remember any
 62 applicable declaration for which this is a partialy qualified reference.  If two
 63 or more applicable declarations can be found and this is not a fully qualified reference
 64 to any of them, this is an ambiguous reference.  If only one applicable declaration
 65 can be found, this is a valid partialy qualified reference to that declaration.  The search
 66 for an applicable declaration begins in the current block and continues outward until
 67 the first applicable declaration is found.  After the first applicable
 68 declaration is found, all additional searching is confined to the block in which the
 69 first applicable declaration was found.  */
 70 
 71           b = blk;
 72           do while(b^=null);
 73                     s = name->token.declaration;
 74                     do while(s^=null);
 75                               fully_qualified = "1"b;
 76                               if s->symbol.block_node^=b
 77                               then      goto not_applicable;
 78                               if s->node.type = label_node
 79                                         then if q = null
 80                                                   then go to applicable;
 81                                                   else go to not_applicable;
 82                               if q = null then do;
 83                                                   if s->symbol.member then fully_qualified = "0"b;
 84                                                   go to applicable;
 85                                               end;
 86                               k = 1;
 87                               f = s;
 88                               do while(k <= q->list.number);
 89                                         do f=f->symbol.father repeat f->symbol.father while(f^=null);
 90                                                   if f->symbol.token = q->list.element(k) then go to next_name;
 91                                                   fully_qualified = "0"b;
 92                                         end;
 93                                         go to not_applicable;
 94 next_name:
 95                                         k = k+1;
 96                               end;
 97 
 98                               fully_qualified = fully_qualified & f->symbol.father=null;
 99 
100 applicable:
101 
102                               if fully_qualified then go to exit;
103                               n = n+1;
104                               d = s;
105 not_applicable:
106                               s = s->symbol.multi_use;
107                     end;
108 
109                     if n>0 then b = null;else b = b->block.father;
110           end;
111 
112           if n>1 then call semantic_translator$abort(221,name);
113           if d = null then return("0"b);
114           s = d;
115 
116 exit:
117           if tree->node.type = reference_node & ^def_context.by_name_lookup
118                     then do;
119                               tree->reference.length = null;
120                               tree->reference.symbol = s;
121                          end;
122           if s->node.type = symbol_node
123                     then      if ^def_context.ignore_based
124                               then do d=s repeat d->symbol.father while(d^=null);
125                                         d->symbol.allocate = "1"b;
126                               end;
127 
128           if stmnt ^= null
129           then if stmnt->node.type = statement_node & ^def_context.suppress_cross_ref
130           then do;
131                     d = create_cross_reference();
132                     q = s;
133                     if s -> node.type ^= label_node
134                     then if s -> symbol.condition
135                          then q = s -> symbol.equivalence;
136                     d->cross_reference.next = q->symbol.cross_references;
137                     q->symbol.cross_references = d;
138                     string(d->cross_reference.source_id) = string(stmnt->statement.source_id);
139           end;
140 
141           return("1"b);
142 
143           end lookup;