!<BLF/lowercase_user>
!<BLF/uppercase_key>
MODULE lsting (						!

%IF %BLISS (BLISS32)
%THEN
		ADDRESSING_MODE (EXTERNAL = LONG_RELATIVE, 	!
		NONEXTERNAL = LONG_RELATIVE) ,
%FI

		IDENT = '02'
		) =
BEGIN

!++
! Facility:
!
!	BLISS Language Formatter ("PRETTY")
!
! Abstract:
!
!	This module contains global routines to produce a listing file
!	for PRETTY. This file includes the following features:
!	1) Indentation is indicated by ".    " instead of the logical
!		tab produced in the source output file.
!	2) Header lines include %TITLE and %SBTTL information, visual
!		and SOS page numbers, and SOS line numbers related to
!		the source output file.
!
! Environment:
!
!	Transportable, with XPORT.
!
! REVISION HISTORY
!
!	12-Jan-82	TT	LST$LINE was dropping characters in bodies
!				of macro declarations when the body began
!				and ended on one line, and consisted of
!				patterns of three characters followed by a
!				space. Now, if we find a space, check that
!				there are three more before printing ":   ",
!				if not, just put out the space. Also fixed
!				bug in same routine where if line was equal
!				to Sw_page_width we were one tab short before
!				the line number was printed.
!--

!<BLF/page>
!
! Table of contents:
!--

FORWARD ROUTINE 					!
    list_heading : NOVALUE,
    lst$dot : NOVALUE,					! Set up dot switch for listing
    lst$file : NOVALUE,					! Set up file switch for listing
    lst$line : NOVALUE,					! copy source line to listing
    lst$module : NOVALUE,				! Save current module name
    lst$on,						! Switch = true if producing listing
    lst$routine : NOVALUE,				! Save current routine name
    lst$subtitle : NOVALUE,				! Save subtitle for listing
    lst$title : NOVALUE;				! Save title for listing

!
! Include files:
!--

REQUIRE 'BLFCSW';					! Defines control switches, i.e. 'sw_...'

REQUIRE 'BLFIOB';

REQUIRE 'BLFMAC';					! Defines macros 'lex', 'msg', 'write'

!
! Macros:
!--

MACRO
    next_tab (col) =

	(((col+7)/8)*8) + 1  %;

!
! Equated symbols:
!--

LITERAL
    true = 1 EQL 1,
    false = 1 NEQ 1;

LITERAL
    buf_len = 132,
    name_length = 31;

LITERAL
    form_feed = %O'14',
    space = %C' ',
    tab = %O'11';

LITERAL
    ! These numbers are scaled by 10 to fit in the PDP-11.
    sos_max = 9990,
    sos_start = 10,
    sos_step = 10;

!
! Own storage:
!--

OWN
    cp_lst,						! Character pointer to listing line
    cp_src,
    dot_3sp : INITIAL (CH$PTR (UPLIT (':   '))),
    len_lst,						! Length of listing line
    len_mod_name,					! Length of module name
    len_rout_name,					! Length of routine name
    len_subtitle,
    len_title,
    lines_per_page : INITIAL (54),
    listing_buf : VECTOR [CH$ALLOCATION (buf_len)],
    lst_dot : INITIAL (true),				! switch for vertical dots
    lst_req,						! Is listing requested?
    module_name : VECTOR [CH$ALLOCATION (name_length)],
    page_ascii : VECTOR [CH$ALLOCATION (3)],
    routine_name : VECTOR [CH$ALLOCATION (name_length)],
    sos_ascii : VECTOR [CH$ALLOCATION (5)],
    sos_line,						! Source file line number
    sos_page,						! Source file page number
    subtitle : VECTOR [CH$ALLOCATION (buf_len)],
    title : VECTOR [CH$ALLOCATION (buf_len)],
    vis_column,						! Apparent length of listing line
    vis_line,
    vis_page;

!
! External references:
!--

EXTERNAL ROUTINE 					!
    ctl$switch,						! CONTRL
    cvt$put_dec,					! CONVRT
    scn$verbatim;					! SCANNR

ROUTINE list_heading : NOVALUE = 			!

!++
! Functional description:
!
!	This routine puts the page heading at the top of each page
!	of the listing file. The lines are:
!	1) Module name; routine name; visual page; SOS page
!	2) Title line
!	3) Subtitle line
!	4) a blank line.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	Title and Subtitle lines, from LEX$GETSYM.
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    cvt$put_dec (.vis_page, 3, CH$PTR (page_ascii));
    CH$WCHAR (form_feed, CH$PTR (listing_buf));
    CH$COPY ((IF .len_mod_name NEQ 0 THEN 7 ELSE 0),	!
	CH$PTR (UPLIT ('Module ')), 			!
	.len_mod_name, CH$PTR (module_name), 		!
	(IF .len_rout_name NEQ 0 THEN 9 ELSE 0),	!
	CH$PTR (UPLIT (' Routine ')), 			!
	.len_rout_name, CH$PTR (routine_name), 		!
	5, CH$PTR (UPLIT (%STRING (%CHAR (9), %CHAR (9), %CHAR (9), %CHAR (9), %CHAR (9)))), 	! tabs
	9, CH$PTR (UPLIT ('Page no. ')),		!
	3, CH$PTR (page_ascii), 			!
	space, 						! Fill char.
	2*name_length + 7 + 9 + 5 + 9 + 3 - 1,		!
	CH$PTR (listing_buf, 1));
    $xpo_put (						!
	string = (2*name_length + 7 + 9 + 5 + 9 + 3,	!
	    CH$PTR (listing_buf)),			!
	iob = list_iob);
!+
! Title and Subtitle
!-
    CH$MOVE (.len_title, CH$PTR (title), CH$PTR (listing_buf));
    $xpo_put (						!
	string = (.len_title, CH$PTR (listing_buf)),	!
	iob = list_iob);
    CH$MOVE (.len_subtitle, CH$PTR (subtitle), CH$PTR (listing_buf));
    $xpo_put (						!
	string = (.len_subtitle, CH$PTR (listing_buf)),	!
	iob = list_iob);
    $xpo_put (						!
	string = (0, 0),				! Blank line
	iob = list_iob);
    END;						! End of routine 'list_heading'

GLOBAL ROUTINE lst$dot (arg) : NOVALUE = 		!

!++
! Functional description:
!
!	This routine sets the flag 'lst_dot' to the value of the
!	routine argument. This flags whether the following lines of the
!	listing are to be dotted or not. (Mainly to handle imbedded
!	comment lines.)
!
! Formal parameters:
!
!	arg = the value of the flag (true or false).
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    lst_dot = .arg;
    END;						! End of routine 'lst$dot'

GLOBAL ROUTINE lst$file (arg) : NOVALUE = 		!

!++
! Functional description:
!
!	This routine sets the flag 'lst_req' to the value of the
!	routine argument. This flags whether the file spec is a file
!	name (true) or empty (false).
!
! Formal parameters:
!
!	arg = the length of the filespec: 0 if none specified.
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    lst_req = .arg NEQ 0;
    END;						! End of routine 'lst$file'

GLOBAL ROUTINE lst$init : NOVALUE = 			!

!++
! Functional description:
!
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    CH$FILL (space, len_mod_name = name_length, CH$PTR (module_name));
    CH$FILL (space, len_rout_name = name_length, CH$PTR (routine_name));
    CH$FILL (space, buf_len, CH$PTR (title));
    CH$FILL (space, buf_len, CH$PTR (subtitle));
    sos_page = 1;
    sos_line = sos_start;
    vis_line = vis_page = 1;
    END;						! End of routine 'lst$init'

GLOBAL ROUTINE lst$line (len, cp) : NOVALUE = 		!

!++
! Functional description:
!
!	This routine accepts a character string descriptor (len, cp)
!	as the description of an input line. The line is copied into
!	the listing buffer; in the process, leading tabs and spaces
!	are converted into ":   " sequences. Trailing tabs and spaces
!	are added to fill out the line and the current SOS line
!	number is appended to the line. The line is then written to the
!	listing file.
!
! Formal parameters:
!
!	len	= length of the source text line
!	cp	= character pointer to the source text line
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    LOCAL
	chr,						! An input character
	leading,					! Flag for leading whitespace
	rem_src;					! Remaining source characters

    IF NOT .lst_req
    THEN
	RETURN 						! Listing suppressed.
    ELSE
	BEGIN
	leading = NOT scn$verbatim();	! Unformatted leading whitespace: ignore
	rem_src = .len;
	cp_src = .cp;
	len_lst = 0;
	cp_lst = CH$PTR (listing_buf);
	vis_column = 1;

	WHILE (.rem_src GTR 0) AND .leading DO
	    BEGIN
	    chr = CH$RCHAR_A (cp_src);
	    rem_src = .rem_src - 1;

	    SELECTONE .chr OF
		SET

		[form_feed] :
		    BEGIN
		    sos_page = .sos_page + 1;
		    vis_page = .vis_page + 1;
		    vis_line = 1;
		    sos_line = sos_start;
		    list_heading ();
		    END;				! Of form_feed handler

		[tab] :
		    BEGIN

		    IF .lst_dot
		    THEN

			INCR i FROM 0 TO 1 DO
			    BEGIN
			    cp_lst = CH$MOVE (4, .dot_3sp, .cp_lst);
			    len_lst = .len_lst + 4;
			    END

		    ELSE
			BEGIN
			CH$WCHAR_A (.chr, cp_lst);
			len_lst = .len_lst + 1;
			END;

		    vis_column = next_tab (.vis_column);
		    END;				! Of leading tab handler

		[space] :
		    IF NOT CH$EQL (3, .cp_src, 3, CH$PTR (UPLIT ('   ')))  ! TT  12-Jan-82
		    THEN
		    BEGIN
		    leading = false;
			cp_lst = CH$MOVE (4, .dot_3sp, .cp_lst);
			len_lst = .len_lst + 4;
			vis_column = .vis_column + 4;
		    CH$WCHAR_A (.chr, cp_lst);
		    vis_column = .vis_column + 1;
		    len_lst = .len_lst + 1;
		    END

		    ELSE
		    IF .lst_dot
		    THEN
			BEGIN
			cp_lst = CH$MOVE (4, .dot_3sp, .cp_lst);
			len_lst = .len_lst + 4;
			vis_column = .vis_column + 4;
			cp_src = CH$PLUS (.cp_src, 3);
			rem_src = .rem_src - 3;
			END
		    ELSE
			BEGIN
			CH$WCHAR_A (.chr, cp_lst);
			len_lst = .len_lst + 1;
			END;				! Of leading space handler

		[OTHERWISE] :
		    BEGIN
		    leading = false;
		    CH$WCHAR_A (.chr, cp_lst);
		    vis_column = .vis_column + 1;
		    len_lst = .len_lst + 1;
		    END;				! Of first nonblank handling
		TES;

	    END;					! Of leading whitespace

	WHILE .rem_src GTR 0 DO
	    BEGIN
	    chr = CH$RCHAR_A (cp_src);
	    rem_src = .rem_src - 1;

	    SELECTONE .chr OF
		SET

		[tab] :
		    BEGIN
		    vis_column = next_tab (.vis_column);
		    END;

		[OTHERWISE] :
		    vis_column = .vis_column + 1;
		TES;

	    CH$WCHAR_A (.chr, cp_lst);
	    len_lst = .len_lst + 1;
	    END;					! Of input text line

	! Fill out the line with tabs

	UNTIL .vis_column GTR ctl$switch (sw_page_width) DO
	    BEGIN
	    CH$WCHAR_A (tab, cp_lst);
	    len_lst = .len_lst + 1;
	    vis_column = next_tab (.vis_column);
	    END;

	IF .len_lst EQL ctl$switch (sw_page_width) AND	    ! TT  12-Jan-82
	    .vis_column NEQ .len_lst + 3
	THEN
	    BEGIN
	    CH$WCHAR_A (tab, cp_lst);
	    len_lst = .len_lst + 1;
	    vis_column = next_tab (.vis_column);
	    END;

	! Append the SOS line number
	BEGIN
	cvt$put_dec (.sos_page, 3, CH$PTR (sos_ascii));
	cp_lst = CH$COPY (1, CH$PTR (UPLIT ('/')), 	!
	    3, CH$PTR (sos_ascii), 			!
	    space, 					!
	    4, .cp_lst);
	cvt$put_dec (.sos_line*10, 5, CH$PTR (sos_ascii));
	cp_lst = CH$COPY (1, CH$PTR (UPLIT ('.')), 	!
	    5, CH$PTR (sos_ascii), 			!
	    space, 					!
	    6, .cp_lst);
	len_lst = .len_lst + 10;
	END;
	! Finally, write the line
	$xpo_put (					!
	    string = (.len_lst, CH$PTR (listing_buf)),	!
	    iob = list_iob);
	!++++++++++++++++++++++++++++++++++++++++++++
	! Update the line and page numbers
	!--------------------------------------------
	vis_line = .vis_line + 1;

	IF .vis_line GTR .lines_per_page
	THEN
	    BEGIN
	    vis_page = .vis_page + 1;
	    vis_line = 1;
	    list_heading ();
	    END;

	sos_line = .sos_line + sos_step;

	IF .sos_line GTR sos_max
	THEN
	    BEGIN
	    sos_page = .sos_page + 1;
	    sos_line = sos_start;
	    list_heading ();
	    END;

	END						! Of generation of new listing line.
    END;						! End of routine 'lst$line'

GLOBAL ROUTINE lst$module (len, cp) : NOVALUE = 	!

!++
! Functional description:
!
! This routine saves the module name for the listing heading lines.
!
! Formal parameters:
!
!	len = length of module name
!	cp = character pointer to name string
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    CH$COPY (len_mod_name = .len, .cp, 		!
	space,					!
	name_length, CH$PTR (module_name));
    lst$routine (0, 0);				! Erase routine name
    END;					! End of routine 'lst$module'

GLOBAL ROUTINE lst$on = 				!

!++
! Functional description:
!
!	This routine returns true if we are producing a listing file.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit listings:
!
!	None
!
! Routine value:
!
!	true if listing filespec was given,
!	false if listing filespec was empty.
!
! Side effects:
!
!	None
!
!--

    BEGIN
    RETURN .lst_req;
    END;						! End of routine 'lst$on'

GLOBAL ROUTINE lst$routine (len, cp) : NOVALUE = 	!

!++
! Functional description:
!
! This routine saves the routine name for the listing heading lines.
!
! Formal parameters:
!
!	len = length of routine name
!	cp = character pointer to name string
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    CH$COPY (len_rout_name = .len, .cp, 	!
	space,					!
	name_length, CH$PTR (routine_name));
    END;					! End of routine 'lst$routine'

GLOBAL ROUTINE lst$subtitle (len, cp) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine copies the text of a %SBTTL lexical function
!	into a buffer for use in the listing page heading.
!
! Formal parameters:
!
!	len	= the length of the text string
!	cp	= the character pointer to the text.
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    CH$COPY (len_subtitle = .len, .cp,			!
	space,						!
	buf_len, CH$PTR (subtitle));
    END;						! End of routine 'lst$subtitle'

GLOBAL ROUTINE lst$title (len, cp) : NOVALUE = 		!

!++
! Functional description:
!
!	This routine copies the text of a %SBTTL lexical function
!	into a buffer for use in the listing page heading.
!
! Formal parameters:
!
!	len	= the length of the text string
!	cp	= the character pointer to the text.
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    CH$COPY (len_title = .len, .cp,			!
	space,						!
	buf_len, CH$PTR (title));
    END;						! End of routine 'lst$title'

%TITLE 'Last page of LSTING.BLI'
END							! End of module 'LSTING'

ELUDOM