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 /****^  HISTORY COMMENTS:
15   1) change(86-10-01,JRGray), approve(86-10-01,MCR7507),
16      audit(86-10-27,RWaters), install(86-11-12,MR12.0-1202):
17      Rewritten to ignore alignment and not put out padding characters.
18                                                    END HISTORY COMMENTS */
19 
20 
21 /* prlst_ procedure to put a remark into the ALM listing. A newline
22    is added to each line. This is used by all of ALM except prwrd_
23    which does it himself for efficiency.
24 
25    Totally recoded by Richard Gray, 2/14/85, (alm 6) to remove word
26    alignments and padding characters.  Note: lstlen used to be
27    current length of listing component in words, now the length is
28    in characters. */
29 
30 prlst_:   procedure(remark);
31 dcl       remark char(*);
32 dcl       (length, substr) builtin;
33 dcl       (strstart, strlen, strmaxlen) fixed bin(21);
34 dcl       listing_segment char(strlen) based(list);
35 dcl       ec fixed bin(35);
36 
37 dcl       eb_data_$list_component fixed bin external;
38 dcl       eb_data_$listing_max_length fixed bin(19) external;
39 dcl       eb_data_$who_am_I char(12) external;
40 dcl       error_table_$segknown fixed bin(35) external;
41 dcl       utils_$abort external entry;
42 dcl       com_err_ entry options(variable);
43 dcl       msf_manager_$get_ptr entry(ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));
44 dcl       NL char(1) int static options(constant) init("
45 ");
46 
47 %include segnfo;
48 
49 %include lstcom;
50 
51 %include alm_options;
52 
53           if tnolst ^= 0 then return; /* no listing wanted */
54           strstart = lstlen + 1;
55           strlen = length(remark) + 1;
56           strmaxlen = 4*eb_data_$listing_max_length - lstlen;
57           if strlen > strmaxlen then do;
58                     lstlen = lstlen + strmaxlen;
59                     substr(listing_segment, strstart, strmaxlen) = substr(remark, 1, strmaxlen);
60                     call new_list_seg;
61                     lstlen = strlen - strmaxlen;
62                     substr(listing_segment, 1, lstlen) = substr(remark || NL, strmaxlen+1, lstlen);
63                     return;
64             end;
65           lstlen = lstlen + strlen;
66           substr(listing_segment, strstart, strlen) = remark || NL;
67           return;
68 
69 new_list_seg:       entry;
70           eb_data_$list_component = eb_data_$list_component + 1;
71           call msf_manager_$get_ptr(eb_data_$segnfo.list_fcb, eb_data_$list_component, "1"b, eb_data_$segnfo.list, 0, ec);
72           eb_data_$segnfo.lstlen = 0;
73           if ec ^= 0 then  if ec ^= error_table_$segknown then do;
74                     if tquietsw ^= 1 then call com_err_(ec, eb_data_$who_am_I, "Listing segment.");
75                     call utils_$abort;
76             end;
77 end prlst_;