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

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

		IDENT = '7.0'
		) =
BEGIN

!++
! Facility: BLISS Formatter
!
! Abstract:
!
!	This module formats BLISS declarations. The main
!	entry to this module is the routine 'prs$decl',
!	which is called to parse an entire declaration.
!	Since all declarations in BLISS end in a semicolon,
!	prs$decl gobbles up the semicolon.
!
! Environment: transportable, using Xport
!
!
! REVISION HISTORY
!
!	15-Sep-81	TT	In the beginning, there was PRETTY.
!				And then a programmer. And the Supervisor
!				said "Giveth this man something to maintain."
!				And so the union began. Forthwith is the
!				history of that union, given in words as yours
!				truely sees fit.
!
!				Many changes to allow for formal attributes
!				in routine declarations. Psect allocation
!				attributes weren't handled at all. And when a
!				routine was declared as forward & novalue, its
!				name was displayed to the terminal once at the
!				forward declaration and again when the routine
!				was actually found. Fix to DO_ROUTINE to assure
!				that each routine is displayed only once.
!
!	28-Sep-81	TT	A second kludge to PRS$DECL. A syntax change
!				permits Psects within Plit declarations, so
!				semicolon is no longer a valid terminator.
!				Special case Psects in Plits a la Psect
!				allocation attributes not to error out if a
!				semicolon is not found.
!
!	 4-Nov-81	TT	Remove hack I'd inserted in DO_ROUTINE that
!				permitted PRS$PAREN_ELIST to handle the new
!				Bliss V2.1 & V3 syntax in routine formals.
!				The hack was called IN_ROUTINE_DECL. Impetus
!				for removing hack was that DO_ROUTINE was not
!				finding the desired semi-colon in its main
!				loop, thought it was working with nested
!				routines, and therefore stopppd putting out
!				page marks. This occurred on all routines AFTER
!				a routine of the form ROUT (A : B) was parsed.
!				The fix is a new routine, called
!				DO_ROUTINE_FORMALS to handle the left through
!				the first right parenthesis.
!				
! END OF REVISION HISTORY
!--

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

FORWARD ROUTINE
    do_attr_list : NOVALUE,
    do_bind : NOVALUE,
    do_decl_def : NOVALUE,
    do_enable : NOVALUE,
    do_external : NOVALUE,
    do_field : NOVALUE,
    do_global : NOVALUE,
    do_kwmacro : NOVALUE,
    do_linkage : NOVALUE,
    do__macro : NOVALUE,
    do_macro_body : NOVALUE,
    do_name_list : NOVALUE,
    do_psect : NOVALUE,
    do_require : NOVALUE,
    do_routine : NOVALUE,
    do_routine_formals : NOVALUE,
    do_structure : NOVALUE,
    in_set,
    prs$decl : NOVALUE,
    prs$_mac_level,
    prs$set_level : NOVALUE;

!
! Include files:
!--

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

REQUIRE 'BLFMAC';				! Defines WRITE, LEX, etc.

REQUIRE 'SYMCOD';				! Defines symbol property table, 'sym...'

REQUIRE 'TOKTYP';				! Defines 'token' and the token type values 's_...'

REQUIRE 'UTLCOD';				! Defines error codes, i.e. 'er_...'

!
! Macros:
!--

MACRO
    plit_count (aplit) =
	( ( aplit ) - %UPVAL ) %;

!
! Equated symbols:
!--

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

!
! Own storage:
!--

OWN
    macro_level : INITIAL (0);			! For imbedded macro-defs

!
! External references:
!--

EXTERNAL
    symprop : sym_table;

EXTERNAL ROUTINE
    ctl$switch,
    lex$getsym : NOVALUE,			!
    lst$module : NOVALUE,
    lst$routine : NOVALUE,
    out$break : NOVALUE,			!
    out$default : NOVALUE,
    out$erase : NOVALUE,
    out$eject : NOVALUE,			!
    out$force : NOVALUE,			!
    out$indent : NOVALUE,			!
    out$ntbreak : NOVALUE,			!
    out$pend_skip : NOVALUE,			!
    out$set_tab : NOVALUE,
    out$skip : NOVALUE,				!
    out$space : NOVALUE,			!
    out$stoks : NOVALUE,			!
    out$terminal : NOVALUE,
    out$tok : NOVALUE,				!
    prs$body : NOVALUE,
    prs$expression : NOVALUE,			! Parse3
    prs$module : NOVALUE,			! Parse1
    prs$paren_elist : NOVALUE,			! Parse3
    prs$plit_body : NOVALUE,			! Parse1
    prs$switches : NOVALUE,			! Parse1
    scn$mbstrt : NOVALUE,			! Manually format macros
    scn$mfin : NOVALUE,				!
    scn$plit : NOVALUE,
    utl$error : NOVALUE;			!

EXTERNAL
    tok;

EXTERNAL
    token : tok_block;				! One symbol at a time

GLOBAL

    !+
    ! Labelled block causes an ambiguity in BIND declarations
    ! Because colon is used in a declaration
    ! And a labelled block is an expression.
    !   e.g.
    !	BIND foo = name : ???????
    ! Are we at a labelled block or is "name" the bound
    ! expression?
    ! So we disallow labelled blocks in declaration expressions
    ! following equal signs.
    !-
    nolabl : INITIAL (false);

global ROUTINE do_attr_list (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine parses attribute lists for declarations. It is
!	more general than the BLISS language in its permitted
!	sequences of attributes, and thus will overlook many errors
!	in BLISS syntax.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    if .tok eql s_initial
    then
	out$skip (1)
    else
	begin
	! A colon or "(" has been recognized by the parser...
	out$stoks ();				! " : " or "("
	lex;
	out$indent (1);
	end;

    !+
    ! Pick up attributes
    !-

    WHILE .tok NEQ s_end_of_file DO

	SELECT .tok OF
	    SET

	    [s_byte, s_word, s_long, s_global, s_local] :
		(out$tok (); lex; );

	    [s_name, s_field, s_psect] :
		BEGIN
		out$stoks ();			! Name, " FIELD ", or " PSECT "
		lex;

		IF .symprop [.tok, sym_type] EQL open_bracket THEN prs$paren_elist (.block_context);

		END;

	    [s_initial] :
		BEGIN
		out$stoks ();			! " INITIAL "

		IF NOT ctl$switch (sw_plit) THEN scn$plit (+1);	! Suppress formatting of PLIT-bodies

		lex;
		prs$plit_body (.block_context);

		IF NOT ctl$switch (sw_plit) THEN scn$plit (-1);

		END;

	    [s_comma] :
		EXITLOOP;

	    [s_colon] :
		(out$stoks (); lex; );		! " : "

	    [s_semicolon, s_rparen] :
		EXITLOOP;

	    [OTHERWISE] :
		(utl$error (er_semi_decl); out$default (); lex; );
	    TES;

    out$indent (-1);
    END;					! End of routine 'do_attr_list'
ROUTINE do_bind (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine is called to handle BIND declarations.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    IF .tok EQL s_routine THEN (out$stoks (); lex);	! " ROUTINE "

    do_decl_def (.block_context);
    RETURN;
    END;					! End of routine 'do_bind'
ROUTINE do_decl_def (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine is the default declarations handler.
!	It is used for declarations like: MAP, LOCAL, LITERAL, etc.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    out$force ();

    WHILE .tok NEQ s_semicolon DO
	BEGIN

	!+
	! Once through for each item in the declaration
	!-

	IF .tok EQL s_name
	THEN
	    BEGIN
	    out$tok ();				! The name of the declared item
	    lex;

	    IF .symprop [.tok, sym_type] EQL open_bracket THEN prs$paren_elist (.block_context);

	    END
	ELSE
	    utl$error (er_name);

	IF .tok EQL s_equal
	THEN
	    BEGIN
	    out$stoks ();			! " = "
	    lex;
	    nolabl = true;			! See comment on 'nolabl' decl
	    prs$expression (.block_context);	! The bound value
	    nolabl = false;
	    END;

	IF .tok EQL s_colon
	THEN
	    BEGIN
	    do_attr_list (.block_context);
	    END;

	IF .tok EQL s_comma
	THEN
	    (out$erase (); out$tok (); out$force (); lex; )	! ","
	ELSE

	    IF .tok NEQ s_semicolon THEN (utl$error (er_semi_decl); out$default (); lex; );

	END;

    END;					! End of routine 'do_decl_def'
ROUTINE do_enable (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine formats ENABLE declarations.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    out$force ();
    out$stoks ();				! " ENABLE "
    lex;

    IF .tok EQL s_lparen
    THEN
	BEGIN
	prs$paren_elist (.block_context);
	END;

    RETURN;
    END;					! End of routine 'do_enable'
ROUTINE do_external (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine is invoked for the "EXTERNAL" declarator
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    IF .tok EQL s_routine OR 			!
	.tok EQL s_literal OR 			!
	.tok EQL s_register
    THEN
	(out$stoks (); lex; );			! " ROUTINE " or " LITERAL " or " REGISTER "

    do_decl_def (.block_context);
    RETURN
    END;					! End of routine 'do_external'
ROUTINE do_field (block_context) : NOVALUE = 	!

!++
! Functional description:
!	Format a "FIELD" declaration.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    out$force ();				! Put keyword on one line,

    WHILE .tok NEQ s_end_of_file DO 		! then the rest.
	BEGIN

	IF .tok NEQ s_name THEN utl$error (er_name);

	out$default ();				! Name being declared
	lex;

	IF .tok NEQ s_equal THEN utl$error (er_equal);

	out$default ();				! " = "
	out$force ();
	lex;

	IF .tok EQL s_set
	THEN 					! "Set" form
	    BEGIN
	    out$indent (1);
	    out$tok ();				! Print "set"
	    out$force ();			! On a new line
	    lex;

	    WHILE .tok NEQ s_end_of_file DO
		BEGIN

		IF .tok NEQ s_name THEN utl$error (er_name);

		out$default ();			! Field name
		lex;

		IF .tok NEQ s_equal THEN utl$error (er_equal);

		out$default ();			! " = "
		lex;
		prs$paren_elist (.block_context);	! Field components

		!+
		! The next token is a comma or "tes"
		!-

		IF .tok EQL s_tes
		THEN
		    BEGIN
		    out$force ();
		    out$tok ();			! "TES"
		    out$indent (-1);
		    lex;
		    EXITLOOP;
		    END
		ELSE

		    IF .tok EQL s_comma
		    THEN
			(out$erase (); out$tok (); out$force (); lex; )	! ","
		    ELSE
			utl$error (er_tes);

		END;

	    END
	ELSE
	    prs$paren_elist (.block_context);

	IF .tok EQL s_semicolon
	THEN
	    EXITLOOP 				! prs$decl will clean up
	ELSE

	    IF .tok EQL s_comma
	    THEN
		(out$erase (); out$tok (); out$force (); lex; )	! ","
	    ELSE
		utl$error (er_semi_decl);

	END;

    END;					! End of routine 'do_field'
ROUTINE do_global (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine is invoked for the "GLOBAL" declarator.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    SELECT .tok OF
	SET

	[s_bind] :
	    BEGIN
	    out$stoks ();
	    out$force ();
	    lex;
	    do_bind (.block_context);
	    END;

	[s_literal] :
	    BEGIN
	    out$stoks ();
	    out$force ();
	    lex;
	    do_decl_def (.block_context);
	    END;

	[s_routine] :
	    BEGIN
	    out$stoks ();
	    lex;
	    do_routine (.block_context);
	    END;

	[s_register] :
	    BEGIN
	    out$stoks ();			! " REGISTER "
	    out$force ();
	    lex;

	    WHILE .tok NEQ s_semicolon DO
		BEGIN
		nolabl = true;			! Assure colon seen as attr list head
		out$indent (-1);
		prs$expression (.block_context);	! "name=value"
		out$indent (+1);
		nolabl = false;

		IF .tok EQL s_colon THEN do_attr_list (.block_context);

		IF .tok EQL s_comma THEN (out$tok (); out$force (); lex)

		END;

	    END;

	[OTHERWISE] :
	    do_decl_def (.block_context);
	TES;

    END;					! End of routine 'do_global'
ROUTINE do_kwmacro (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine formats KEYWORDMACRO declarations
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    LOCAL
	level;

    macro_level = .macro_level + 1;

    WHILE .tok NEQ s_end_of_file DO
	BEGIN

	!+
	! Once per macro declaration
	!-

	out$break ();
	out$stoks ();				! Macro name
	lex;

	IF .tok EQL s_lparen
	THEN
	    BEGIN				! Pick up formals list
	    out$tok ();				! "("
	    out$force ();
	    out$indent (2);
	    lex;

	    WHILE .tok NEQ s_end_of_file DO
		BEGIN

		!+
		! Once for each keyword formal
		!-

		IF .tok EQL s_name
		THEN
		    BEGIN
		    out$tok ();			! Formal parameter name
		    lex;
		    level = 0;

		    IF .tok EQL s_equal
		    THEN
			BEGIN

			!+
			!  Keyword default value expression
			!-

			out$stoks ();		! " = "
			lex;

			DO
			    BEGIN

			    SELECTONE .tok OF
				SET

				[s_lparen, s_lbracket, s_langle] :
				    (level = .level + 1; out$tok (); );

				[s_rparen, s_rbracket, s_rangle] :
				    (level = .level - 1; out$tok (); );

				[OTHERWISE] :
				    out$stoks ();
				TES;

			    lex;
			    END
			UNTIL (.level EQL 0 AND .tok EQL s_comma)	!
			    OR .level LSS 0	!
			    OR .tok EQL s_semicolon;

			END

		    END
		ELSE
		    utl$error (er_name);

		IF .tok EQL s_comma
		THEN
		    (out$erase (); out$tok (); out$force (); lex; )	! ","
		ELSE

		    IF .level LSS 0 THEN EXITLOOP;

		IF .tok EQL s_rparen
		THEN
		    BEGIN
		    out$tok ();			! ")"
		    lex;
		    EXITLOOP;
		    END;

		END;

	    out$indent (-2);
	    END					! of argument list.
	ELSE
	    utl$error (er_formal_list);

	IF .tok EQL s_equal
	THEN
	    BEGIN
	    do_macro_body (PLIT (s_percent));
	    out$space (1);
	    out$tok ();				! " %"

	    IF NOT ctl$switch (sw_macro) THEN scn$mfin (s_macro);	! Resume automatic formatting

	    lex;
	    END
	ELSE
	    utl$error (er_macro_body);

	IF .tok EQL s_comma
	THEN
	    BEGIN
	    out$erase ();
	    out$tok ();				! ","
	    lex;
	    END
	ELSE
	    BEGIN
	    macro_level = .macro_level - 1;
	    EXITLOOP;				! ";" Is handled by prs$decl
	    END;

	END

    END;					! End of routine 'do_kwmacro'
ROUTINE do_linkage (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine parses a LINKAGE declaration.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    WHILE .tok NEQ s_end_of_file DO
	BEGIN
	out$force ();
	out$stoks ();				! Name being declared
	lex;

	IF .tok EQL s_equal
	THEN
	    BEGIN
	    out$stoks ();			! " = "
	    lex;

	    IF .tok EQL s_name			! Name = linkage-type
	    THEN
		BEGIN

		!+
		! linkage-options
		!-

		out$stoks ();			! Linkage type
		lex;

		IF .tok EQL s_lparen
		THEN

		!+
		! parameter-locations list
		!-

		    BEGIN
		    out$tok ();			! "("
		    lex;

		    WHILE .tok NEQ s_end_of_file DO

			SELECTONE .tok OF
			    SET

			    [s_register] :
				BEGIN
				out$tok ();
				lex;

				IF .tok EQL s_equal
				THEN
				    (out$stoks (); lex;
				    prs$expression (.block_context); )
				ELSE
				    (utl$error (er_equal); out$default (); lex; );

				END;

			    [s_name] :
				(out$tok (); lex; );

			    [s_comma] :
				(out$erase (); out$tok (); out$space (1); lex; );

			    [s_rparen] :
				(out$tok (); lex; EXITLOOP );

			    [s_semicolon] :
				(out$tok (); out$space (1); lex; );

			    [OTHERWISE] :
				(utl$error (er_rparen); out$default (); lex; );
			    TES;

		    END;

		SELECTONE .tok OF
		    SET

		    [s_colon] :
			BEGIN

			!+
			! linkage modifiers
			!-

			out$stoks ();		! " : "
			lex;

			WHILE .tok NEQ s_end_of_file DO

			    SELECTONE .tok OF
				SET

				[s_global, s_name] :
				    BEGIN
				    out$stoks ();	! " GLOBAL " etc.
				    lex;

				    !+
				    ! GLOBAL-REGISTER-segment
				    ! or PRESERVE/NOPRESERVE-segment
				    !-

				    IF .tok EQL s_lparen
				    THEN
					BEGIN
					prs$paren_elist (.block_context);

					IF .tok NEQ s_comma AND .tok NEQ s_semicolon THEN out$force ();

					END;

				    END;

				[s_comma] :
				    BEGIN
				    out$erase ();
				    out$tok ();	! ", "
				    out$space (1);
				    lex;
				    EXITLOOP;
				    END;

				[s_semicolon] :
				    RETURN;

				[OTHERWISE] :
				    (out$default (); lex; );
				TES;

			END;

		    [s_comma] :
			(out$erase (); out$tok (); out$space (1); lex; );

		    [s_semicolon] :
			RETURN;

		    [OTHERWISE] :
			(utl$error (er_semi_decl); out$default (); lex; );
		    TES;

		END;

	    END
	ELSE

	    IF .tok EQL s_semicolon THEN RETURN ELSE (utl$error (er_equal); out$default (); lex; );

	END;

    END;					! End of routine 'do_linkage'
ROUTINE do__macro (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine formats positional MACROs
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    macro_level = .macro_level + 1;

    WHILE .tok NEQ s_end_of_file DO
	BEGIN

	!+
	! Once for each positional macro
	!-

	out$break ();
	out$stoks ();				! Macro name.
	lex;

	IF .tok EQL s_lparen
	THEN
	    BEGIN
	    prs$paren_elist (.block_context);
	    END;

	IF .tok EQL s_lbracket
	THEN
	    BEGIN
	    out$space (1);
	    prs$paren_elist (.block_context);
	    END;

	IF .tok EQL s_equal
	THEN
	    BEGIN
	    do_macro_body (PLIT (s_percent));

	    IF .tok EQL s_percent
	    THEN
		BEGIN
		out$space (1);
		out$tok ();			! "%"

		IF NOT ctl$switch (sw_macro) THEN scn$mfin (s_macro);	! Resume auto. formatting

		lex;
		END
	    ELSE
		utl$error (er_end_macro)

	    END
	ELSE
	    utl$error (er_equal);

	IF .tok EQL s_comma
	THEN
	    BEGIN
	    out$erase ();
	    out$tok ();				! ","
	    lex;
	    END
	ELSE
	    BEGIN
	    macro_level = .macro_level - 1;
	    EXITLOOP;
	    END;

	END

    END;					! End of routine 'do__macro'
ROUTINE do_macro_body (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine formats a macro body
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    out$indent (1);

    IF .tok EQL s_equal
    THEN
	BEGIN
	out$stoks ();				! " = "

	IF NOT ctl$switch (sw_macro) THEN scn$mbstrt (s_macro);	! Begin non-formatting

	out$force ();
	lex;
	END
    ELSE
	utl$error (er_equal);

    WHILE .tok NEQ s_end_of_file DO
	BEGIN

	IF .tok EQL s_percent
	THEN
	    EXITLOOP
	ELSE

	    IF ctl$switch (sw_macro)
	    THEN
		prs$body (s_percent)
	    ELSE
		(out$stoks (); lex; )		! Terminating symbol
	END;

    out$indent (-1);
    END;					! End of routine 'do_macro_body'
ROUTINE do_name_list (right_close) : NOVALUE = 	!

!++
! Functional description:
!
!	This is a utility routine that formats a name list
!
! Formal parameters:
!
!	Right_close - PLIT of integers representing the set of allowable
!			closing brackets
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    out$tok ();					! Initial delimiter, e.g. "("
    lex;

    WHILE .tok EQL s_name DO
	BEGIN
	out$tok ();				! Name
	lex;

	IF .tok NEQ s_comma
	THEN
	    EXITLOOP
	ELSE
	    BEGIN
	    out$erase ();
	    out$tok ();				! ", "
	    out$space (1);
	    lex;
	    END;

	END;

    IF in_set (.tok, .right_close) THEN RETURN ELSE utl$error (er_name_list);

    END;					! End of routine 'do_name_list'
ROUTINE do_psect (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine parses PSECT declarations.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    if .tok eql s_lparen		! PSECT allocation attribute
    then				! TT   15-Sep-81  thru
	begin
	out$default ();
	lex;

	if .tok eql s_name
	then
	    begin
	    out$tok ();
	    lex
	    end
	else
	    begin
	    utl$error(er_name);
	    out$default ();
	    lex
	    end;

	if .tok eql s_rparen
	then
	    begin
	    out$default ();
	    lex
	    end
	else
	    begin
 	    utl$error(er_rparen);
	    out$default ();
	    lex
	    end;

	if .tok eql s_initial
	then
	    do_attr_list (.block_context);
	end
	
    else					! TT   15-Sep81 ^
	WHILE .tok NEQ s_semicolon DO
	BEGIN

	!+
	! Once for each storage class (OWN, GLOBAL, etc.)
	!-

	out$force ();

	IF .tok EQL s_own OR 			!
	    .tok EQL s_global OR 		!
	    .tok EQL s_plit OR 			!
	    .tok EQL s_name
	    ! "name" is permitted, to handle "CODE" cleanly.
	THEN
	    BEGIN
	    out$stoks ();
	    lex;

	    IF .tok EQL s_equal
	    THEN
		(out$stoks (); lex; )		! " = "
	    ELSE
		(utl$error (er_equal); out$default (); lex; );


	    IF .tok EQL s_name
	    THEN
		BEGIN
                if .tok eql s_name
                then
	            (out$tok (); lex;);		! name

		IF .tok EQL s_lparen
		THEN
		    BEGIN

		    LOCAL
			plevel;

		    out$tok ();			! "("
		    lex;
		    plevel = 1;

		    UNTIL .plevel EQL 0 DO
			BEGIN

			SELECT .tok OF
			    SET

			    [s_lparen] :
				(plevel = .plevel + 1; out$default ());	! "("

			    [s_rparen] :
				(plevel = .plevel - 1; out$default ());	! ")"

			    [first_decl TO last_decl] :
				out$stoks ();	! "LOCAL", etc.

			    [OTHERWISE] : 	! Anything else...
				out$default ();
			    TES;

			lex;
			END;

		    END

		END
	    ELSE
    
		(utl$error (er_name); out$default (); lex);

	    END
	ELSE
	    BEGIN
	    utl$error (er_stge_class);
	    out$default ();
	    lex;
	    EXITLOOP;
	    END;

	IF .tok EQL s_comma
	THEN
	    (out$erase (); out$tok (); out$force (); lex; )
	ELSE
	    IF .tok NEQ s_semicolon THEN (utl$error (er_semi_decl); out$default (); lex; EXITLOOP );

	END;

    END;					! End of routine 'do_psect'
ROUTINE do_require : NOVALUE = 			!

!++
! Functional description:
!
!	This routine handles LIBRARY and REQUIRE declarations.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    IF .tok EQL s_string
    THEN
	(out$stoks (); lex; )			! Required file name
    ELSE
	utl$error (er_string);

    RETURN;
    END;					! End of routine 'do_require'
ROUTINE do_routine (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine processes all "ROUTINE" declarations.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    OWN
	nest : INITIAL (0);			! ROUTINE nesting level
    local
	once;					!  TT   15-Sep-81

    once = false;

    DO
	BEGIN

	!+
	! An indent is done before dispatching to a declaration
	! handler. This is valid for most declarations, but
	! not for ROUTINEs, so it must be un-done.
	!-

	! Save the routine name for the listing file heading line.
	lst$routine (.token [tok_len], .token [tok_cp]);
	out$tok ();				! Routine name

	IF .tok EQL s_name and not .once
	THEN
	    begin
	    out$terminal ();		! Display routine name on the terminal
	    once = true;
	    end;

	IF .nest EQL 0 THEN out$eject (s_routine);	! First level routines start a new page

	nest = .nest + 1;
	out$space (1);
	lex;

	IF .tok EQL s_lparen			! TT  4-Nov-81
	THEN
	    BEGIN				! Pick up the formal list
	    do_routine_formals ();
	    lex;
	    END;

	IF .tok EQL s_colon
	THEN
	    BEGIN				! Pick up attributes
	    out$stoks ();			! " : "
	    lex;

	    WHILE .tok EQL s_name OR .tok EQL s_psect DO

		IF .tok EQL s_psect
		THEN
		    BEGIN
		    out$stoks ();		! " PSECT "
		    lex;

		    IF .tok EQL s_lparen THEN prs$paren_elist (.block_context);

		    END
		ELSE
		    (out$stoks (); lex; );	! Attribute name

	    END;				! Pick up attributes

	IF .tok EQL s_equal
	THEN
	    BEGIN
	    out$stoks ();			! " = "
	    out$force ();
	    lex;
	    END;

	out$indent (-1);			! See note on indentation above
	prs$expression (.block_context);
	out$indent (+1);

	IF .tok EQL s_semicolon THEN EXITLOOP;

	IF .tok EQL s_comma or .tok eql s_rparen
	THEN
	    (out$erase (); out$tok (); out$space (1); lex; )	! ","
	ELSE
	    (utl$error (er_semi_decl); out$default (); lex; );

	END
    UNTIL .tok EQL s_semicolon;

    nest = .nest - 1;
    RETURN;
    END;					! End of routine 'do_routine'
ROUTINE do_routine_formals : NOVALUE =

!++
! Functional description:
!
!	This routine processes all argument lists on routine declarations.
!	PRS$PAREN_ELIST used to do this but the new V2.1/V3 syntax got things
!	upset. Now we have a separate routine. Much cleaner.
!
! Formal Parameters:
!
!	None
!
! Implicit inputs:
!
!	Expects "(" to be the current TOKen.
!
! Routine value:
!
!	None
!
! Side effects
!
!	None
!
!--

    BEGIN
    out$tok ();				! "("
    lex;

    UNTIL .tok EQL s_rparen DO
    BEGIN
	SELECTONE .tok OF
 	SET						! Allowed in formals.
	[s_name]:			(out$tok ());
	[s_comma]:			(out$tok (); out$space(1));
	[s_semicolon]:			(out$stoks ());
	[s_colon]:			(out$stoks ());
	[OTHERWISE]:			(out$default ());  ! Lost.
	TES;

	lex				! Next TOKen in the formals list.
    END;

    out$tok ();				! ")"
    END;				! End of routine 'do_routine_formals'
ROUTINE do_structure (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine formats STRUCTURE declarations.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    DO
	BEGIN

	!+
	! For each STRUCTURE declaration
	!-

	out$break ();
	out$tok ();				! Structure name
	lex;

	IF .tok EQL s_lbracket
	THEN
	    BEGIN
	    out$space (1);
	    do_name_list (PLIT (s_semicolon, s_rbracket));

	    IF .tok EQL s_semicolon
	    THEN
		BEGIN
		out$erase ();
		out$tok ();			! "; "
		out$space (1);
		lex;

		DO
		    BEGIN

		    !+
		    ! Each access formal and default
		    !-

		    IF .tok NEQ s_name THEN EXITLOOP;

		    out$tok ();			! Allocation formal
		    lex;

		    IF .tok EQL s_equal
		    THEN
			BEGIN
			out$stoks ();		! " = "
			lex;
			prs$expression (.block_context);
			END;

		    IF .tok EQL s_comma
		    THEN
			BEGIN
			out$erase ();
			out$tok ();		! ","
			out$space (1);
			lex;
			END;

		    END
		UNTIL .tok EQL s_rbracket;

		END;

	    IF .tok EQL s_rbracket
	    THEN
		BEGIN
		out$tok ();			! "]"
		lex;
		END
	    ELSE
		utl$error (er_rbracket);

	    END;

	IF .tok EQL s_equal
	THEN
	    BEGIN
	    out$stoks ();			!" = "
	    out$indent (1);
	    out$force ();
	    lex;

	    IF .tok EQL s_lbracket
	    THEN
		BEGIN
		out$tok ();			! "["
		lex;
		prs$expression (.block_context);	! Structure size expression

		IF .tok NEQ s_rbracket THEN utl$error (er_rbracket) ELSE (out$tok (); out$force (); lex; );

						! "]"
		END;

	    out$indent (-1);
	    prs$expression (.block_context);	! Structure body
	    END;

	IF .tok EQL s_comma
	THEN
	    (out$erase (); out$tok (); out$space (1); lex; )	! ","
	ELSE

	    IF .tok NEQ s_semicolon THEN utl$error (er_semi_decl);

	END
    UNTIL .tok EQL s_semicolon;

    END;					! End of routine 'do_structure'
ROUTINE in_set (elem, sett) = 			!

!++
! Functional description:
!
!	This routine returns 'true' if the elem is in the set
!	and 'false' otherwise. A set is represented by a PLIT.
!
! Formal parameters:
!
!	Elem - an integer
!	Sett - a PLIT of integers
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	True or false
!
! Side effects:
!
!	None
!
!--

    BEGIN

    MAP
	sett : REF VECTOR;

    INCR i FROM 0 TO .plit_count (.sett) - 1 DO

	IF .elem EQL .sett [.i] THEN RETURN true;

    RETURN false;
    END;					! End of routine 'in_set'

GLOBAL ROUTINE prs$decl (block_context) : NOVALUE = 	!

!++
! Functional description:
!
!	This routine is called to format a declaration through
!	its semicolon.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN

    LOCAL
	i,					! Loop index
	ltok;					! The declarator

    LITERAL
	num_types = 16;

    BIND
	decl = UPLIT (
	    s_bind, 							!
	    s_enable, 							!
	    s_external, 						!
	    s_field, 							!
	    s_forward, 							!
	    s_global, 							!
	    s_keywordmacro, 						!
	    s_library, 							!
	    s_linkage, 							!
	    s_macro, 							!
	    s_module, 							!
	    s_psect, 							!
	    s_require, 							!
	    s_routine, 							!
	    s_structure, 						!
	    s_switches							!
	    ) : VECTOR [num_types],
	dispatch = UPLIT (do_bind,
	    do_enable, 							!
	    do_external, 						!
	    do_field, 							!
	    do_external, 						! FORWARD
	    do_global, 							!
	    do_kwmacro, 						!
	    do_require, 						! LIBRARY
	    do_linkage, 						!
	    do__macro, 							!
	    prs$module, 						!
	    do_psect, 							!
	    do_require, 						!
	    do_routine, 						!
	    do_structure, 						!
	    prs$switches						!
	    ) : VECTOR [num_types];

    ltok = .tok;

    IF .ltok NEQ s_routine AND
	.ltok NEQ s_module AND
	 .ltok NEQ s_psect			! TT   15-Sep-81
	THEN out$skip (1);			! Skip a line before most decls

    out$tok ();					! Declarative keyword
    out$space (1);

    IF .ltok NEQ s_module THEN out$indent (1);

    lex;
    i = 0;

    WHILE .tok NEQ s_end_of_file DO
	BEGIN

	IF .i EQL num_types
	THEN
	    (do_decl_def (.block_context); EXITLOOP; )
	ELSE

	    IF .ltok EQL .decl [.i] THEN ((.dispatch [.i]) (.block_context); EXITLOOP; ) ELSE i = .i + 1;

	END;

    IF .ltok NEQ s_module THEN out$indent (-1);

    IF .tok EQL s_eludom
    THEN
	BEGIN
	out$ntbreak ();
	out$tok ();				! "ELUDOM"
	out$break ();
	lex;
	! These calls occur only if "ELUDOM" is not
	! the last token in the file, e.g. if another MODULE follows.
	lst$module (0, 0);			! Erase module name
	out$eject (s_eludom);
	RETURN;
	END;

    IF .tok EQL s_rparen AND .ltok EQL s_psect		! TT 15-Sep-81
    THEN					! Did a PSECT allocation attr.
	return;

    IF .tok EQL s_Lparen AND .ltok EQL s_psect		! TT 28-Sep-81
    THEN					! Did a PSECT in a Plit/Uplit.
	return;

    IF .tok NEQ s_semicolon
    THEN					! In the routine decl, comma is
	utl$error (er_semi_decl)		!  the delimiter, not semicolon
    ELSE
	BEGIN
	out$erase ();
	out$tok ();				! ";" or ","
	out$force ();
	out$set_tab (true);			! Assure following lines tabbed ok

	IF .ltok NEQ s_routine THEN out$pend_skip (1);	! Skip before comments

	lex;
	END;

    END;					! End of routine 'prs$decl'

GLOBAL ROUTINE prs$_mac_level = 		!

!++
! Functional description:
!
!	This function returns the value of the own variable "macro_level"
!	for use in formatting %IF, etc. within macro definitions.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    RETURN .macro_level;
    END;					! End of routine 'prs$_mac_level'

GLOBAL ROUTINE prs$set_level : NOVALUE = 	!

!++
! Functional description:
!
!	This routine sets the value of the own variable "macro_level"
!	to zero. This must be done between files in case there is an
!	incomplete macro definition in some file.
!
! Formal parameters:
!
!	None
!
! Implicit inputs:
!
!	None
!
! Implicit outputs:
!
!	None
!
! Routine value:
!
!	None
!
! Side effects:
!
!	None
!
!--

    BEGIN
    macro_level = 0;
    END;					! End of routine 'prs$set_level'

%TITLE 'Last page of Module "PARSE2.BLI"'
END						! End of module 'PARSE2'

ELUDOM