1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1992   *
  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(92-09-10,Zimmerman), approve(92-09-10,MCR8257), audit(92-09-18,Vu),
 17      install(92-10-06,MR12.5-1023):
 18      Fix segment overflow in source section of listing.
 19                                                    END HISTORY COMMENTS */
 20 
 21 
 22 /*        print routines for use by the PL/1 compiler in writing into the listing */
 23 /*        segment.  There are four entries for the combinations of varying and non-*/
 24 /*        varying character string parameters and for with and without new-line */
 25 /*        characters appended to the string before transmission.                */
 26 
 27 /*        Written by:         J.D. Mills          */
 28 /*        On                  22 January 1969                                   */
 29 /*        Modified by:        B. L. Wolman on 16 May 1969 to use cv_string */
 30 /*        Modified by:        B. L. Wolman on 21 May 1969 to accept ptr to string */
 31 /*        Rewritten in pl1 replacing cv_string with substr on 28 JULY 1969 by the author. */
 32 /*        Modified on:        20 August 1970 by P. Green for Version II */
 33 /*        Modified on:        17 January 1974 by R. A. Barnes for 256K segments */
 34 /*        Modified 770502 by PG to rewrite $for_lex entry to work with EIS lex */
 35 
 36 pl1_print$varying:  proc(var_string);
 37 
 38 /* parameters */
 39 
 40 dcl       var_string          char(*) varying aligned;
 41 
 42 /* automatic */
 43 
 44 dcl       l_suff    fixed bin,
 45           arg_length          fixed bin(21);
 46 
 47 /* based */
 48 
 49 declare   string char (261120) aligned based (pl1_stat_$list_ptr);
 50 
 51 /* builtins */
 52 
 53 declare ( length, substr) builtin;
 54 
 55 /* conditions */
 56 
 57 declare   listing_overflow condition;
 58 
 59 /* external static */
 60 
 61 dcl (     pl1_stat_$list_ptr            ptr,
 62           pl1_stat_$max_list_size       fixed bin(21),
 63           pl1_stat_$char_pos            fixed bin(21)) static external;
 64 
 65 /* internal static */
 66 
 67 declare   NL        character(1) aligned static internal initial("
 68 ");
 69 ^L
 70 /* program */
 71 
 72 /*        Entry to write a varying character string sans new-line character into the listing segment.         */
 73 
 74           l_suff=0;
 75           go to l1;
 76 
 77 /*        Entry to write a varying character string avec new-line character into the listing segment.         */
 78 
 79 pl1_print$varying_nl:         entry(var_string);
 80 
 81           l_suff=1;
 82 
 83 l1:       arg_length=length(var_string);
 84 
 85           if arg_length + pl1_stat_$char_pos + l_suff > pl1_stat_$max_list_size
 86           then signal condition(listing_overflow);
 87 
 88           substr(string,pl1_stat_$char_pos,arg_length)=var_string;
 89           goto done;
 90 
 91 /*        Entry to write a non-varying character string sans new-line character into the listing segment.     */
 92 
 93 pl1_print$non_varying:        entry(nv_string,size);
 94 
 95 dcl       nv_string char(*) aligned,
 96           size fixed bin(35);
 97 
 98           l_suff=0;
 99           go to l2;
100 
101 /*        Entry to write non-varying character string avec new-line character into the listing segment.       */
102 
103 pl1_print$non_varying_nl:     entry(nv_string,size);
104 
105           l_suff=1;
106 
107 l2:       if size > 0
108           then arg_length=size;
109           else arg_length=length(nv_string);
110 
111           if arg_length + pl1_stat_$char_pos + l_suff > pl1_stat_$max_list_size
112           then signal condition(listing_overflow);
113           substr(string,pl1_stat_$char_pos,arg_length)=nv_string;
114 
115 done:     pl1_stat_$char_pos=pl1_stat_$char_pos + arg_length;
116 
117           if l_suff ^= 0
118           then do;
119                substr(string,pl1_stat_$char_pos,1) = NL;
120                pl1_stat_$char_pos = pl1_stat_$char_pos+1;
121                end;
122 
123           return;
124 ^L
125 /*        Entry to write string given by ptr into listing without nl */
126 
127 pl1_print$string_ptr: entry(pt,size);
128 
129 dcl       pt ptr;   /* points at string */
130 dcl       based_string char(size) aligned based(pt);
131 
132           l_suff = 0;
133           goto l3;
134 
135 /*        Entry to write string given by ptr into listing with nl */
136 
137 pl1_print$string_ptr_nl: entry(pt,size);
138 
139           l_suff = 1;
140 
141 l3:       arg_length = size;
142 
143           if arg_length + pl1_stat_$char_pos + l_suff > pl1_stat_$max_list_size
144           then signal condition(listing_overflow);
145 
146           substr(string,pl1_stat_$char_pos,arg_length)=based_string;
147 
148           goto done;
149 ^L
150 pl1_print$for_lex:
151           entry (bv_source_ptr, bv_line_number, bv_line_start, bv_line_length, bv_suppress_line_numbers,
152                bv_line_begins_in_comment);
153 
154 /* parameters */
155 
156 declare ( bv_source_ptr ptr,
157           bv_line_number fixed bin (14),
158           bv_line_start fixed bin (21),
159           bv_line_length fixed bin (21),
160           bv_suppress_line_numbers bit (1) aligned,
161           bv_line_begins_in_comment bit (1) aligned
162           ) parameter;
163 
164 /* automatic */
165 
166 declare   line_number_string picture "zzzzzzzz9";
167 
168 /* external static */
169 
170 declare   pl1_stat_$source_seg fixed bin (8) external static;
171 
172 /* internal static */
173 
174 declare SPACE_FOR_LINE_NUMBERS_PLUS_ONE_BLANK fixed bin internal static options (constant) init (10);
175 
176 /* program */
177 
178 /* A source program cannot be more than a single segment in length, but the
179    LISTING (including headers, incl. files, etc.) of the source can exceed
180    a single segment. Thus this check. We could do it in two parts (one for
181    the line number field, if we're not supressing them) and the other for
182    the actual line... but it's more efficient to only do the check once.
183    If we're going msf on the listing (which is guaranteed if we approach
184    msf in this phase) doing it a few characters early won't hurt.  phx21284 */
185 
186           if pl1_stat_$char_pos + SPACE_FOR_LINE_NUMBERS_PLUS_ONE_BLANK
187                + bv_line_length >= pl1_stat_$max_list_size
188                then signal condition(listing_overflow);
189 
190 
191           if ^bv_suppress_line_numbers
192           then do;
193                     line_number_string = bv_line_number;
194                     substr (string, pl1_stat_$char_pos,
195                          SPACE_FOR_LINE_NUMBERS_PLUS_ONE_BLANK) = line_number_string;  /* move in digits + 1 blank */
196 
197                     if pl1_stat_$source_seg > 0
198                     then do;
199                               line_number_string = pl1_stat_$source_seg;
200                               substr (string, pl1_stat_$char_pos, 3) = substr (line_number_string, 7, 3);
201                          end;
202 
203                     pl1_stat_$char_pos = pl1_stat_$char_pos + SPACE_FOR_LINE_NUMBERS_PLUS_ONE_BLANK;
204 
205                     if bv_line_begins_in_comment
206                     then substr (string, pl1_stat_$char_pos - 1, 1) = "*";
207                end;
208 
209           substr (string, pl1_stat_$char_pos, bv_line_length) = substr (bv_source_ptr -> based_string,
210                bv_line_start, bv_line_length);
211           pl1_stat_$char_pos = pl1_stat_$char_pos + bv_line_length;
212           return;
213 ^L
214 /*        Entry to write unaligned string avec new-line character into the listing segment */
215 
216 pl1_print$unaligned_nl:       entry(unal_string,size);
217 
218 dcl       unal_string char(*) unaligned;
219 
220           if size > 0
221           then arg_length = size;
222           else arg_length = length(unal_string);
223 
224           if arg_length + pl1_stat_$char_pos >= pl1_stat_$max_list_size
225           then signal condition(listing_overflow);
226 
227           substr(string,pl1_stat_$char_pos,arg_length) = unal_string;
228 
229           l_suff = 1;
230           goto done;
231           end;