1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(1989-09-27,RWaters), approve(1989-09-27,MCR8068),
 17      audit(1989-09-27,Vu), install(1989-10-02,MR12.3-1080):
 18      Fixed to remove duplicate declaration attributes.
 19   2) change(1990-05-03,Huen), approve(1990-05-03,MCR8169),
 20      audit(1990-05-18,Gray), install(1990-05-30,MR12.4-1012):
 21      pl1_1885: Fix pl1 optimizer to handle the concatenation of a common string
 22      expression correctly.
 23   3) change(2017-02-09,Swenson), approve(2017-02-09,MCR10029),
 24      audit(2017-02-11,Davidoff), install(2017-02-11,MR12.6f-0016):
 25      Fix the previous fix (MCR8169) to string concatenation.  See
 26      http://multics-trac.swenson.org/ticket/9 for details.
 27                                                    END HISTORY COMMENTS */
 28 
 29 
 30 /* program to compile concatenation operator
 31 
 32    Initial Version: 28 December, 1968 by BLW
 33           Modified:  9 September 1971 by BLW for Version II
 34           Modified: 27 July 1972 by BLW
 35           Modified: 8 June 1973 by RAB for EIS
 36           Modified: 14 Sept 1979 by PCK to fix bug 1855
 37 */
 38 
 39 cat_op:   proc(node_pts,refs,code);
 40 
 41 dcl       node_pts ptr,                 /* points at operator node */
 42           refs(3) ptr,                  /* reference nodes for operands */
 43           code fixed bin;               /* local context */
 44 
 45 dcl       node_pt ptr defined (node_pts),
 46           ref(3) ptr defined (refs);
 47 
 48 dcl       (p1,p2,p3,p,q2,q3) ptr,
 49           (dt,type,n,s2,size1,size2,size3) fixed bin,
 50           macro fixed bin(15),
 51           tag bit(4) aligned,
 52           base bit(3) aligned,
 53           (lunits,word_offset) fixed bin(15),
 54           string_temp entry(ptr,ptr,ptr) returns(ptr),
 55           adjust_ref_count entry(ptr,fixed bin),
 56           compile_exp entry(ptr),
 57           (compile_exp$save,compile_exp$save_exp) entry(ptr) returns(ptr),
 58           m_a entry(ptr,bit(2) aligned),
 59           base_man$load_any_var entry(fixed bin,ptr,bit(3) aligned),
 60           load_size$xr_or_aq entry(ptr,bit(4) aligned),
 61           state_man$erase_reg entry(bit(19) aligned),
 62           expmac$eis entry(fixed bin(15),ptr),
 63           aq_man$clear_q entry,
 64           c_a entry(fixed bin,fixed bin) returns(ptr),
 65           expmac$one entry(fixed bin(15),ptr,fixed bin),
 66           expmac entry(fixed bin(15),ptr);
 67 
 68 dcl       (addr,divide,fixed,mod,null) builtin;
 69 
 70 dcl       1 p1_address aligned based(addr(p1 -> reference.address)),
 71           2 base bit(3) unal,
 72           2 offset fixed bin(14) unal,
 73           2 op bit(9) unal,
 74           2 no_address bit(1) unal,
 75           2 inhibit bit(1) unal,
 76           2 ext_base bit(1) unal,
 77           2 tag bit(6) unal;
 78 
 79 
 80 dcl (     cat_move_chars      init(218),
 81           lda                 init(1),
 82           ldq                 init(7),
 83           sta                 init(4),
 84           ora                 init(46),
 85           arl                 init(245),
 86           lrl                 init(62)) fixed bin(15) int static;
 87 
 88 %include boundary;
 89 %include cgsystem;
 90 %include cg_reference;
 91 %include operator;
 92 %include data_types;
 93 %include machine_state;
 94 
 95 begin:    p = node_pt;
 96 
 97           p1 = ref(1);
 98           p2 = ref(2);
 99           p3 = ref(3);
100 
101           q2 = p -> operand(2);
102           q3 = p -> operand(3);
103 
104           type = p1 -> reference.data_type;
105           n = convert_size(type);
106           size1 = p1 -> reference.c_length * n;
107           size2 = p2 -> reference.c_length * n;
108           size3 = p3 -> reference.c_length * n;
109           s2 = fixed(size2 > bits_per_word,1);
110           dt = type - char_string;
111 
112           goto switch(code);
113 
114           /* have atm || exp */
115 
116 switch(2):
117 ae:       if p1 -> reference.long_ref then p3 = compile_exp$save_exp(q3);
118 
119           /* have atm || atm */
120 
121 switch(3):
122 aa:       if p1 -> reference.long_ref
123           then do;
124 
125                /* resultant string is long */
126 
127 /* Want to protect possible length expr of p2 */
128 
129 aa_l1:         if ^ p2 -> reference.shared
130                     then p2 -> reference.ref_count = p2 -> reference.ref_count + 1;
131 
132 /* Call string_temp to allocate a temporary and move in p2 */
133 
134                p1 = string_temp(p,p2,p3);
135 
136 /* THE FOLLOWING SECTION SETS UP A MOVE TO EFFECT THE CONCATENATION */
137 
138 aa_l3:
139 
140 /* If p2's length was able to be inserted directly into a descriptor, try to optimize
141   by changing the constant offset of the target */
142 
143                if p2 -> reference.length = null
144                then if p2 -> reference.c_length < 4096
145                     then if ^ p2 -> reference.varying_ref
146                          then do;
147                               call m_a(p1,"11"b);
148 
149                               if dt = 0
150                               then lunits = character_;
151                               else lunits = bit_;
152 
153                               word_offset = divide(p2 -> reference.c_length,units_per_word(lunits),15,0)
154                                           + p1_address.offset;
155                               if word_offset < 16383
156                               then do;
157                                    p1 -> reference.c_f_offset = mod(p2 -> reference.c_length,units_per_word(lunits))
158                                                               + p1 -> reference.c_f_offset;
159                                    if p1 -> reference.c_f_offset >= units_per_word(lunits)
160                                    then do;
161                                         p1 -> reference.c_f_offset = p1 -> reference.c_f_offset - units_per_word(lunits);
162                                         word_offset = word_offset + 1;
163                                         end;
164                                    p1_address.offset = word_offset;
165                                    go to set_perm;
166                                    end;
167                               end;
168 
169 /* This sequence is used when p2's length was in a register .  We use p2's length as the
170    offset in p1 in which to move p3 for the concatenation */
171 
172                call load_size$xr_or_aq(p2,tag);
173 
174                call m_a(p1,"11"b);
175 
176                if p1 -> address.tag
177                then do;
178                     p1 -> reference.ref_count = p1 -> reference.ref_count + 1;
179                     p1 -> reference.perm_address = "1"b;
180                     call base_man$load_any_var(2,p1,base);
181                     end;
182 
183                p1 -> address.tag = "00"b || tag;
184 
185 /* Issue the move macro for the concatenation */
186 
187 set_perm:      p1 -> reference.perm_address = "1"b;
188 
189                call expmac$eis(cat_move_chars+dt,p3);
190 
191                if dt > 0
192                     then machine_state.indicators = -1;
193 
194                p1 -> reference.perm_address = "0"b;
195 
196                if ^ p2 -> reference.shared
197                     then call adjust_ref_count(p2,-1);
198 
199                return;
200                end;
201 
202           /* resultant string is short */
203 
204           if p2 -> reference.c_length = 0
205           then do;
206                call compile_exp(q3);
207                return;
208                end;
209 
210 aa_2:     if size2 = bits_per_word & mod(code,2) ^= 0
211           then do;
212 aa_2a:         call expmac((lda),p2);
213 aa_2b:         call expmac((ldq),p3);
214                end;
215           else do;
216 aa_3:          call compile_exp(q3);
217 
218 
219                call state_man$erase_reg("1"b);    /* shift won't flush the register first */
220 
221                if size1 > bits_per_word
222                then do;
223                     macro = lrl;
224 
225                     /* clear q if necessary, so we
226                        won't have garbage left over */
227 
228                     if size3 <= bits_per_word
229                     then if size2 ^= bits_per_word
230                          then if a_reg.length < bits_per_two_words
231                               then call aq_man$clear_q;
232                     end;
233 
234                else macro = arl;
235 
236                call expmac(macro,c_a(size2,1));
237 
238                call expmac$one((ora),p2,s2);
239                end;
240 
241           a_reg.size = size1;
242           return;
243 
244           /* have exp || exp */
245 
246 switch(0):
247 ee:       if ^ p1 -> reference.long_ref
248           then do;
249 ee1:           p2 = compile_exp$save(q2);
250                goto aa_3;
251                end;
252 
253           p3 = compile_exp$save_exp(q3);
254 
255           /* have exp || atm */
256 
257 switch(1):
258 ea:       if ^ p1 -> reference.long_ref
259           then do;
260                if size2 ^= bits_per_word then goto ee1;
261                if p2 -> reference.ref_count < 1 then do;
262                     call compile_exp(q2);
263                     goto aa_2b;
264                     end;
265                else do;
266                     p2 = compile_exp$save(q2);    /* needed later */
267                     goto aa_2a;
268                     end;
269                end;
270 
271 ea1:      if p2 -> reference.long_ref | p2 -> reference.varying_ref
272                then call compile_exp(q2);
273                else p2 = compile_exp$save_exp(q2);
274 
275           goto aa_l1;
276 
277           end;