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 3 October 1980 by M. N. Davidoff to eliminate internal static for previous.  Fixes 2023.
 12 */
 13 /* format: style3 */
 14 copy_expression:
 15      procedure (a) returns (pointer);
 16 
 17 dcl       a                   ptr unaligned;
 18 dcl       father              ptr;
 19 dcl       stepfather          ptr;
 20 
 21 /* automatic */
 22 
 23 dcl       i                   fixed bin;
 24 dcl       inptr               ptr;
 25 dcl       nodetype            bit (9) aligned;
 26 dcl       outptr              ptr;
 27 dcl       p                   ptr;
 28 
 29 /* builtin */
 30 
 31 dcl       null                builtin;
 32 
 33 /* external static */
 34 
 35 dcl       pl1_stat_$util_abort
 36                               external static entry (fixed bin (15), ptr) variable;
 37 ^L
 38 %include language_utility;
 39 %include array;
 40 %include symbol;
 41 %include declare_type;
 42 %include list;
 43 %include nodes;
 44 %include operator;
 45 %include op_codes;
 46 %include reference;
 47 ^L
 48 /* program */
 49 
 50           inptr = a;
 51 
 52           if inptr = null
 53           then return (inptr);
 54 
 55           nodetype = inptr -> node.type;
 56 
 57           if nodetype = operator_node
 58           then do;
 59                     if inptr -> operator.number = 0
 60                     then return (inptr);
 61 
 62                     if inptr -> operator.operand (1) ^= null
 63                     then if inptr -> operator.operand (1) -> node.type = reference_node
 64                          then if ^inptr -> operator.operand (1) -> reference.shared
 65                               then do;
 66                                         inptr -> operator.operand (1) -> reference.ref_count =
 67                                              inptr -> operator.operand (1) -> reference.ref_count + 1;
 68                                         return (inptr);
 69                                    end;
 70 
 71                     outptr = create_operator ((inptr -> operator.op_code), (inptr -> operator.number));
 72 
 73                     do i = 1 to inptr -> operator.number;
 74                          if inptr -> operator.operand (i) ^= null
 75                          then outptr -> operator.operand (i) = copy_expression (inptr -> operator.operand (i));
 76                     end;
 77 
 78                     outptr -> operator.processed = inptr -> operator.processed;
 79 
 80                     if outptr -> operator.op_code = std_call
 81                     then if outptr -> operator.operand (1) ^= null
 82                          then do;
 83                                    p = outptr -> operator.operand (3) -> operator.operand (2);
 84                                    outptr -> operator.operand (1) = p -> list.element (p -> list.number);
 85                               end;
 86 
 87                     return (outptr);
 88                end;
 89 
 90           else if nodetype = list_node
 91           then do;
 92                     outptr = create_list ((inptr -> list.number));
 93 
 94                     do i = 1 to inptr -> list.number;
 95                          outptr -> list.element (i) = copy_expression (inptr -> list.element (i));
 96                     end;
 97 
 98                     return (outptr);
 99                end;
100 
101           else if nodetype = reference_node
102           then do;
103                     if inptr -> reference.symbol ^= null
104                     then do;
105                               p = inptr -> reference.symbol;
106                               if p -> node.type = symbol_node
107                               then if p -> symbol.constant & ^p -> symbol.file & ^p -> symbol.entry & ^p -> symbol.format
108                                    then return (inptr);
109                          end;
110 
111                     if ^inptr -> reference.shared
112                     then do;
113                               inptr -> reference.ref_count = inptr -> reference.ref_count + 1;
114                               return (inptr);
115                          end;
116 
117                     outptr = create_reference ((inptr -> reference.symbol));
118 
119                     outptr -> reference = inptr -> reference;
120 
121                     if outptr -> reference.offset ^= null
122                     then outptr -> reference.offset = copy_expression (inptr -> reference.offset);
123 
124                     if outptr -> reference.length ^= null
125                     then outptr -> reference.length = copy_expression (inptr -> reference.length);
126 
127                     if outptr -> reference.qualifier ^= null
128                     then outptr -> reference.qualifier = copy_expression (inptr -> reference.qualifier);
129 
130                     return (outptr);
131                end;
132 
133           else if nodetype = token_node | nodetype = label_node | nodetype = sf_par_node | nodetype = block_node
134           then return (inptr);
135 
136           else if nodetype = array_node
137           then do;
138                     outptr = create_array ();
139                     outptr -> array = inptr -> array;
140                     outptr -> array.element_size = copy_expression (inptr -> array.element_size);
141                     outptr -> array.element_size_bits = copy_expression (inptr -> array.element_size_bits);
142                     outptr -> array.virtual_origin = copy_expression (inptr -> array.virtual_origin);
143                     outptr -> array.bounds = copy_expression (inptr -> array.bounds);
144                     outptr -> array.element_descriptor = copy_expression (inptr -> array.element_descriptor);
145 
146                     return (outptr);
147                end;
148 
149           else if nodetype = bound_node
150           then do;
151                     outptr = create_bound ();
152                     outptr -> bound = inptr -> bound;
153                     outptr -> bound.next = copy_expression (inptr -> bound.next);
154                     outptr -> bound.lower = copy_expression (inptr -> bound.lower);
155                     outptr -> bound.upper = copy_expression (inptr -> bound.upper);
156                     outptr -> bound.desc_multiplier = copy_expression (inptr -> bound.desc_multiplier);
157                     outptr -> bound.multiplier = copy_expression (inptr -> bound.multiplier);
158 
159                     return (outptr);
160                end;
161 
162           else if nodetype = symbol_node
163           then return (copy_symbol (inptr, null));
164 
165           call pl1_stat_$util_abort (32, inptr);
166 
167           return (inptr);
168 
169 /* Copy the sons of a symbol node.
170 
171    The caller is responsible for threading the new symbol.next chain onto an
172    existing symbol.next chain for a block. */
173 
174 copy_sons:
175      entry (father, stepfather);
176 
177           stepfather -> symbol.son = null;
178 
179           if father -> symbol.son = null
180           then return;
181 
182           stepfather -> symbol.son = copy_symbol ((father -> symbol.son), stepfather);
183 
184           return;
185 ^L
186 /* This procedure copies a symbol node.  If the symbol node is a structure
187    declaration, this procedure makes a prefix walk of the member symbol nodes
188    and copies them also.  The brothers of the root are copied if stepfather is
189    not null. */
190 
191 copy_symbol:
192      procedure (root, stepfather) returns (ptr);
193 
194 dcl       root                ptr;
195 dcl       stepfather          ptr;
196 
197 dcl       more_nodes          bit (1) aligned;
198 dcl       new_s               ptr;
199 dcl       new_tree            ptr;
200 dcl       previous            ptr;
201 dcl       s                   ptr;
202 
203           s = root;
204           new_tree, previous, new_s = copy_symbol_node (root);
205           new_s -> symbol.father = stepfather;
206 
207           more_nodes = "1"b;
208           do while (more_nodes);
209                if s -> symbol.son ^= null
210                then do;
211                          new_s -> symbol.son, previous -> symbol.next = copy_symbol_node ((s -> symbol.son));
212                          new_s -> symbol.son -> symbol.father = new_s;
213                          s = s -> symbol.son;
214                          previous, new_s = new_s -> symbol.son;
215                     end;
216                else do;
217                          more_nodes = "0"b;
218                          do while (s ^= root -> symbol.father & ^more_nodes);
219                               if s -> symbol.brother ^= null & (s ^= root | stepfather ^= null)
220                               then more_nodes = "1"b;
221                               else do;
222                                         s = s -> symbol.father;
223                                         new_s = new_s -> symbol.father;
224                                    end;
225                          end;
226 
227                          if more_nodes
228                          then do;
229                                    new_s -> symbol.brother,
230                                         previous -> symbol.next = copy_symbol_node ((s -> symbol.brother));
231                                    new_s -> symbol.brother -> symbol.father = new_s -> symbol.father;
232                                    s = s -> symbol.brother;
233                                    previous, new_s = new_s -> symbol.brother;
234                               end;
235                     end;
236           end;
237 
238           return (new_tree);
239 ^L
240 copy_symbol_node:
241      procedure (s) returns (ptr);
242 
243 dcl       s                   ptr;
244 
245 dcl       p                   ptr;
246 
247           p = create_symbol (null, null, by_compiler);
248 
249           p -> symbol = s -> symbol;
250           p -> symbol.dcl_type = by_compiler;
251           p -> symbol.next, p -> symbol.multi_use = null;
252           p -> symbol.reference = copy_expression (s -> symbol.reference);
253           p -> symbol.reference -> reference.symbol = p;
254           p -> symbol.array = copy_expression (s -> symbol.array);
255           p -> symbol.general = copy_expression (s -> symbol.general);
256           p -> symbol.initial = copy_expression (s -> symbol.initial);
257 
258           return (p);
259      end copy_symbol_node;
260 
261      end copy_symbol;
262 
263      end copy_expression;