Trailing-Edge
-
PDP-10 Archives
-
decuslib10-11
-
43,50544/parse2.bli
There is 1 other file named parse2.bli in the archive. Click here to see a list.
!<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