1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  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(86-10-01,JRGray), approve(86-10-01,MCR7507),
 17      audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
 18      Modified to support error severity, block joined to the definition
 19      section, and to remove pads from the listing.
 20                                                    END HISTORY COMMENTS */
 21 
 22 
 23 prwrd_$prwrd_: procedure (pc, word, how);
 24 
 25 /*
 26    Modified 4/29/81 by EBush to make A error fatal and B non-fatal.
 27    Modified 2/5/81 by EBush to add A error.
 28    Modified 3/25/77 by Greenberg for iox_ and no line buffer.
 29    Modified 3/23/77 by Noel I. Morris for macro processing.
 30    modified in 01/74 by E Stone to convert to v2 and to change check for end of listing seg
 31    modified on 11/28/72 at 20:49:00 by R F Mabee.
 32    Another line numbering change and 36-bit values for equ, 28 November 1972, R F Mabee.
 33    Minor change to line numbering, 23 July 1972, R F Mabee.
 34    Added B and C error codes, 16 April 1972, R F Mabee.
 35    by RHG on 3 June 1971 to get binlin right even if no list
 36    by R H Campbell 15 Nov 1970
 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;                                     /* Go to it. */
 52                                                             /* ^L */
 53 dcl  prlst_$new_list_seg entry;
 54 dcl  eb_data_$ib6 external fixed bin;                       /* character (4) */
 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);                                    /* character (4) aligned */
 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)),       /* to listing */
 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 ");                                                         /* New line. */
 91 dcl  num pic "zzzzzzz9";
 92 dcl  zzzz9 pic "zzzz9";
 93 dcl  pc bit (36) aligned;                                   /* fixed bin (35) */
 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 /* ^L */
109 /* FIRST CLEAR THE LISTING BUFFER */
110 common:   listing_buf = " ";                                /* Blank out listing buffer header */
111                                                             /* FIRST PRINT THE FLAGS IF ANY */
112           err_count = 0;
113           do i = 1 to 18;                                   /* Print out the error flags, if any. */
114                if flgvec (i) ^= 0 then do;                  /* Is this flag set? */
115                     tfatal = max(tfatal, error_sv(i));      /* Severity of worst error. */
116                     flgvec (i) = 0;                         /* Clear the flag now that we are printing it. */
117                     if err_count < 3 then do;               /* Do we have room for this flag? */
118                          substr (listing_buf, err_count + 1, 1) = substr (flag_character, i, 1); /* Yes, print it. */
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;                       /* Don't print if no list, no errors. */
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 /* NOW PRINT OUT THE PROGRAM COUNTER */
139                if how ^= eb_data_$ib6 then
140                     call prwrd_util_$pc (listing_buf, pc);
141 
142 /* CHECK IF LEFT HALF OF WORD IS BLANK */
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;        /* List macro def line */
155                zzzz9 = eb_data_$macro_linect;
156                substr (listing_buf, 27, 5) = zzzz9;
157           end;
158 
159 /* NOW ADD THE SOURCE IF IT HAS NOT ALREADY BEEN PRINTED */
160           source_had_been_printed = source_printed;
161           if tquietsw ^= 0 then err_count = 0;              /* Force error count zero in quiet mode. */
162           if source_printed & err_count = 0 then do;        /* Only octal word to print. */
163                substr (listing_buf, 32, 1) = NL;            /* Append a new-line character. */
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;           /* Insert include file number into listing. */
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; /* Find last character on this line. */
186                if linelen < 0 then linelen = srclen - begin_line;
187                if err_count ^= 0 & tquietsw = 0 then do;    /* Output problems to iox_ */
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;                     /* make sure we print. */
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) = "";       /* Greenberg doesn't like this. */
198           end;
199           if source_only_flag then return;
200           if tnolst ^= 0 then return;                       /* As you like it, mister. */
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;           /* detail line */
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_;