1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23 prwrd_$prwrd_: procedure (pc, word, how);
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38 relwrd = ""b;
39 go to pr_common;
40
41 prwrd_$source_only:
42 entry;
43 source_only_flag = "1"b;
44 go to common;
45
46 prwrd_$prwrd2:
47 entry (pc, word, how, relarg);
48 relwrd = relarg;
49 pr_common:
50 source_only_flag = ""b;
51 go to common;
52
53 dcl prlst_$new_list_seg entry;
54 dcl eb_data_$ib6 external fixed bin;
55 dcl eb_data_$macro_linect external fixed bin;
56 dcl eb_data_$listing_max_length external fixed bin (35);
57 dcl eb_data_$nlpads external character (4);
58 dcl eb_data_$macro_depth fixed bin external,
59 eb_data_$include_control bit (110) aligned external;
60 dcl eb_data_$include_number fixed bin external;
61 dcl eb_data_$macro_listing_control bit (36) aligned external;
62 dcl err_count fixed bin;
63 dcl source_had_been_printed bit (1) aligned;
64 dcl flag_character char (18) static options (constant) init
65 ("EFMNOPRSTUXBCDA567");
66 dcl error_sv(18) fixed bin int static options(constant) init
67 (3, 1, 3, 2, 3, 3, 1, 2, 2, 3, 0, 1, 0, 3, 3, 0, 0, 1);
68 dcl how fixed bin (35);
69 dcl i fixed bin;
70 dcl hdrlen fixed bin;
71 dcl source_charray char (1) unal based (source) dim (srclen);
72 dcl source_line char (linelen) based (addr (source_charray (begin_line + 1)));
73 dcl linelen fixed bin;
74 dcl padlen fixed bin;
75 dcl iox_$user_output ptr ext;
76 dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
77 dcl prwrd_util_$pc entry (char (40), bit (36) aligned);
78 dcl prwrd_util_$inst entry (char (40), bit (36) aligned, fixed bin (35));
79 dcl j fixed bin;
80 dcl listing_buf char (40);
81 dcl (strstart, strlen, strmaxlen) fixed bin(21);
82 dcl listing_segment char(strlen) based(list);
83 dcl based_listing_buf char (hdrlen) based (addr (listing_buf));
84 dcl 1 listline aligned based (addrel (list, lstlen)),
85 2 chars char (linelen) unal,
86 2 pads char (padlen) unal;
87
88 dcl listing_buf_pointer pointer;
89 dcl NL static character (1) initial ("
90 ");
91 dcl num pic "zzzzzzz9";
92 dcl zzzz9 pic "zzzz9";
93 dcl pc bit (36) aligned;
94 dcl relarg bit (36) aligned;
95 dcl reloc_character char (32) static options (constant) init
96 ("a???????????????0123456789Ld???*");
97 dcl relwrd bit (36) aligned;
98 dcl source_only_flag bit (1) aligned;
99 dcl source_segment character (srclen) based (source) aligned;
100 dcl word bit (36) aligned;
101 dcl (addr, addrel, bin, divide, index, length, ltrim, min, substr) builtin;
102 % include concom;
103 % include erflgs;
104 % include lstcom;
105 % include segnfo;
106 % include varcom;
107 % include alm_options;
108
109
110 common: listing_buf = " ";
111
112 err_count = 0;
113 do i = 1 to 18;
114 if flgvec (i) ^= 0 then do;
115 tfatal = max(tfatal, error_sv(i));
116 flgvec (i) = 0;
117 if err_count < 3 then do;
118 substr (listing_buf, err_count + 1, 1) = substr (flag_character, i, 1);
119 err_count = err_count + 1;
120 end;
121 end;
122 end;
123
124 if err_count = 0 & tnolst ^= 0 then do;
125 source_printed = "1"b;
126 return;
127 end;
128
129 if (eb_data_$macro_depth > 0) & (err_count = 0) then do;
130 if substr (eb_data_$macro_listing_control, 1, 1) then
131 source_printed = "1"b;
132 if substr (eb_data_$macro_listing_control, 2, 1) then
133 return;
134 end;
135
136 if ^source_only_flag then do;
137
138
139 if how ^= eb_data_$ib6 then
140 call prwrd_util_$pc (listing_buf, pc);
141
142
143 if how = ibb then;
144 else if (how = eb_data_$ib6) then
145 if (substr (word, 1, 18) ^= "0"b) then
146 call prwrd_util_$inst (listing_buf, word, (i66));
147 else call prwrd_util_$inst (listing_buf, word, how);
148 else do;
149 substr (listing_buf, 13, 1) = substr (reloc_character, bin (substr (relwrd, 1, 18), 18) + 1, 1);
150 substr (listing_buf, 14, 1) = substr (reloc_character, bin (substr (relwrd, 19, 18), 18) + 1, 1);
151 call prwrd_util_$inst (listing_buf, word, how);
152 end;
153 end;
154 else if eb_data_$macro_linect > 0 then do;
155 zzzz9 = eb_data_$macro_linect;
156 substr (listing_buf, 27, 5) = zzzz9;
157 end;
158
159
160 source_had_been_printed = source_printed;
161 if tquietsw ^= 0 then err_count = 0;
162 if source_printed & err_count = 0 then do;
163 substr (listing_buf, 32, 1) = NL;
164 hdrlen = 32;
165 end;
166 else do;
167 hdrlen = 40;
168 if tpostp = 0 then do;
169
170 num = binlin;
171 j = length (ltrim (num));
172 i = 39 - j;
173 substr (listing_buf, i, j) = ltrim (num);
174
175 if include_index > 0 then do;
176 num = eb_data_$include_number;
177 j = length (ltrim (num));
178 i = i - 1;
179 substr (listing_buf, i, 1) = "-";
180 i = i - j;
181 substr (listing_buf, i, j) = ltrim (num);
182 end;
183
184 end;
185 linelen = index (substr (source_segment, begin_line + 1), NL) - 1;
186 if linelen < 0 then linelen = srclen - begin_line;
187 if err_count ^= 0 & tquietsw = 0 then do;
188 call iox_$put_chars (iox_$user_output, addr (listing_buf), hdrlen, (0));
189 call iox_$put_chars (iox_$user_output, addr (source_line), length (source_line)+1, (0));
190 end;
191
192 if source_had_been_printed then
193 substr (listing_buf, 40, 1) = NL;
194 source_only_flag = "0"b;
195 source_printed = "1"b;
196 if substr (eb_data_$include_control, 1, 1) | source_had_been_printed then
197 substr (listing_buf, 33, 6) = "";
198 end;
199 if source_only_flag then return;
200 if tnolst ^= 0 then return;
201
202 strstart = lstlen + 1;
203 strmaxlen = 4*eb_data_$listing_max_length - lstlen;
204 if hdrlen > strmaxlen then do;
205 lstlen = lstlen + strmaxlen;
206 substr(listing_segment, strstart, strmaxlen) = substr(listing_buf, 1, strmaxlen);
207 call prlst_$new_list_seg;
208 lstlen = hdrlen - strmaxlen;
209 substr(listing_segment, 1, lstlen) = substr(listing_buf, strmaxlen+1, lstlen);
210 end;
211 else do;
212 lstlen = lstlen + hdrlen;
213 substr(listing_segment, strstart, hdrlen) = based_listing_buf;
214 end;
215
216 if source_had_been_printed then return;
217
218 strstart = lstlen + 1;
219 strlen = length(source_line) + 1;
220 strmaxlen = 4*eb_data_$listing_max_length - lstlen;
221 if strlen > strmaxlen then do;
222 lstlen = lstlen + strmaxlen;
223 substr(listing_segment, strstart, strmaxlen) = substr(source_line, 1, strmaxlen);
224 call prlst_$new_list_seg;
225 lstlen = strlen - strmaxlen;
226 substr(listing_segment, 1, lstlen) = substr(source_line || NL, strmaxlen+1, lstlen);
227 return;
228 end;
229 lstlen = lstlen + strlen;
230 substr(listing_segment, strstart, strlen) = source_line || NL;
231 return;
232
233 end prwrd_$prwrd_;