Trailing-Edge
-
PDP-10 Archives
-
decuslib10-11
-
43,50544/parse3.bli
There is 1 other file named parse3.bli in the archive. Click here to see a list.
!<BLF/lowercase_user>
!<BLF/uppercase_key>
MODULE prs3 ( !
%IF %BLISS (BLISS32)
%THEN
ADDRESSING_MODE (EXTERNAL = LONG_RELATIVE, !
NONEXTERNAL = LONG_RELATIVE) ,
%FI
IDENT = '6.3-6'
) =
BEGIN
!++
! Facility: BLISS Formatter
!
! Abstract:
!
! This module formats BLISS expressions, of which there
! are two varieties: control expressions and operator
! expressions. 'prs$expression' is the main entry point
! to this module. 'prs$oper' formats operator expressions.
!
! Environment: transportable, with Xport
!
!
! REVISION HISTORY
!
! 15-Sep-81 TT Permit attribute on routine formal parameters
!
! 4-Nov-81 TT Remove special case code in PRS$PAREN_ELIST
! that involved routine formals list. This is now
! handled by DO_ROUTINE_FORMALS in PARSE2.
!
! END OF REVISION HISTORY
!--
!<BLF/page>
!
! Table of contents:
!--
FORWARD ROUTINE
do_case : NOVALUE,
do_codecom : NOVALUE,
do_count_loop : NOVALUE,
do_exit : NOVALUE,
do_if : NOVALUE,
do_post_loop : NOVALUE,
do_pre_loop : NOVALUE,
do_primary : NOVALUE,
do_select : NOVALUE,
do_set : NOVALUE,
prs$expression : NOVALUE,
prs$oper : NOVALUE,
prs$paren_elist : NOVALUE;
!
! Include files:
!--
REQUIRE 'BLFCSW'; ! Defines control switches 'sw_...'
REQUIRE 'BLFMAC'; ! Defines macros 'lex', 'msg', 'write'
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:
!--
!
! Equated symbols:
!--
LITERAL
true = 1 EQL 1,
false = 1 NEQ 1;
!
! Own storage:
!--
!
! External references:
!--
EXTERNAL ROUTINE
ctl$switch,
lex$getsym : NOVALUE,
out$break : NOVALUE,
out$cut,
out$default : NOVALUE,
out$erase : NOVALUE,
out$force : NOVALUE,
out$indent : NOVALUE,
out$mark : NOVALUE,
out$ntbreak : NOVALUE,
out$pend_skip : NOVALUE,
out$pop_marks : NOVALUE,
out$push_marks : NOVALUE,
out$skip : NOVALUE,
out$space : NOVALUE,
out$stoks : NOVALUE,
out$tok : NOVALUE,
do_attr_list: novalue,
prs$block : NOVALUE, ! Parse1
prs$plit_body : NOVALUE, ! Parse1
scn$plit : NOVALUE,
utl$error : NOVALUE;
EXTERNAL
tok,
token : tok_block,
nolabl, ! True if labelled blocks not allowed
symprop : sym_table;
ROUTINE do_case (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats a CASE expression
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
out$tok (); ! " CASE "
out$space (1);
lex;
prs$expression (.block_context);
IF .tok EQL s_from
THEN
BEGIN
out$stoks (); ! " FROM "
lex;
prs$expression (.block_context);
IF .tok EQL s_to
THEN
BEGIN
out$stoks (); ! " TO "
lex;
prs$expression (.block_context); ! Limit expression
IF .tok EQL s_of
THEN
(out$stoks (); out$force (); lex; ) ! "OF"
ELSE
utl$error (er_of);
IF .tok EQL s_set
THEN
BEGIN
out$indent (1);
do_set (.block_context);
END
ELSE
utl$error (er_set); !"SET..TES" missing.
IF .tok EQL s_tes
THEN
BEGIN
out$break ();
out$tok (); ! Output the "TES"
out$indent (-1);
lex;
END
ELSE
utl$error (er_tes);
END;
END
ELSE
utl$error (er_from);
END; ! End of routine 'do_case'
ROUTINE do_codecom (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats a CODECOMMENT
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
out$break ();
out$tok (); ! "CODECOMMENT"
lex;
WHILE .tok NEQ s_end_of_file DO
BEGIN
IF .tok EQL s_string
THEN
BEGIN
out$break ();
out$tok (); ! String specified
lex;
END
ELSE
utl$error (er_string);
IF .tok EQL s_comma
THEN
BEGIN
out$erase ();
out$tok (); ! ","
lex;
END
ELSE
BEGIN
IF .tok EQL s_colon
THEN
BEGIN
out$stoks (); ! " : "
lex;
END
ELSE
utl$error (er_colon);
EXITLOOP;
END;
END;
IF .tok EQL s_begin OR .tok EQL s_lparen THEN prs$block () ELSE utl$error (er_block_start);
END; ! End of routine 'do_codecomment'
ROUTINE do_count_loop (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats INCR and DECR loops
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
out$tok (); ! " INCR " or " DECR "
out$space (1);
lex;
out$indent (1); ! Prepare for following lines
IF .tok EQL s_name
THEN
BEGIN
out$tok (); ! Name of index variable
lex;
END
ELSE
utl$error (er_name);
WHILE .tok EQL s_from !
OR .tok EQL s_to !
OR .tok EQL s_by DO
BEGIN
out$stoks (); ! " FROM ", " TO ", or " BY "
lex;
prs$expression (.block_context);
END;
IF .tok EQL s_do
THEN
BEGIN
out$stoks (); ! " DO " appears on the same line
(IF .block_context NEQ s_lparen THEN out$force ());
lex;
END
ELSE
utl$error (er_do);
out$indent (-1);
prs$expression (.block_context); ! Parse the action expression.
END; ! End of routine 'do_count_loop'
ROUTINE do_exit (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats LEAVE, RETURN, and EXITLOOP expressions
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
IF .tok EQL s_leave
THEN
BEGIN
out$tok (); ! " LEAVE "
out$space (1);
lex;
out$tok (); ! <label>
lex;
IF .tok NEQ s_with THEN RETURN;
END;
out$tok (); ! " RETURN " or " EXITLOOP "
out$space (1);
lex;
prs$expression (.block_context);
END; ! End of routine 'do_exit'
ROUTINE do_if (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats an IF expression
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
out$push_marks ();
out$tok (); ! " IF "
out$space (1);
lex;
prs$expression (.block_context); ! Parse the control conditional expr.
IF .tok EQL s_then
THEN
BEGIN
IF .block_context NEQ s_lparen
THEN
IF out$cut ()
THEN
out$break () ! On a new line put
ELSE
BEGIN
out$space ();
out$mark (0);
out$mark (0);
END;
out$stoks (); ! "THEN "
IF .block_context NEQ s_lparen
THEN
IF out$cut ()
THEN
out$force ()
ELSE
BEGIN
out$space ();
out$mark (1);
END;
lex;
prs$expression (.block_context); ! Parse the 'true' action expression.
IF .tok EQL s_else
THEN
BEGIN
IF .block_context NEQ s_lparen
THEN
IF out$cut ()
THEN
out$break () ! On another new line put
ELSE
BEGIN
out$space ();
out$mark (0);
out$mark (0);
END;
out$stoks (); ! "ELSE "
IF .block_context NEQ s_lparen
THEN
IF out$cut ()
THEN
out$force ()
ELSE
BEGIN
out$space ();
out$mark (1);
END;
lex;
prs$expression (.block_context); ! Parse the 'false' action expr.
END;
END
ELSE
utl$error (er_then);
out$pop_marks ();
END; ! End of routine 'do_if'
ROUTINE do_post_loop (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats DO-WHILE and DO-UNTIL expressions
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
out$tok (); ! " DO "
out$force ();
lex;
prs$expression (.block_context); ! Parse the action expression
IF .tok EQL s_while OR .tok EQL s_until
THEN
BEGIN
out$break (); ! Put the terminating
out$tok (); ! "UNTIL " or "WHILE " on new line
out$space (1);
lex;
prs$expression (.block_context); ! Conditional for loop
END
ELSE
utl$error (er_post_test); ! "UNTIL" or "WHILE" missing.
END; ! End of routine 'do_post_loop'
ROUTINE do_pre_loop (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats WHILE and UNTIL expressions
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
out$tok (); ! " UNTIL " or " WHILE "
out$space (1);
lex;
prs$expression (.block_context); ! Conditional value for loop
IF .tok EQL s_do
THEN
BEGIN
out$stoks (); ! ' DO ' appears on same line
IF .block_context NEQ s_lparen THEN out$force ();
lex
END
ELSE
utl$error (er_do);
prs$expression (.block_context); ! Parse the action expression
END; ! End of routine 'do_pre_loop'
ROUTINE do_primary (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats primaries.
! Since a routine call is a primary, and since a routine
! address in a routine call is a primary, we continue
! searching for a "(" after we have found a primary,
! and continue until there are no more routine calls.
!
! For the purposes of the formatter, "REP expr OF (list)"
! is regarded as a primary. This provides for a simple means
! of handling PLIT bodies and also the argument lists for calls
! to CH$TRANSTABLE.
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
!+
! Primaries are parsed at the highest precedence level
!-
IF .symprop [.tok, sym_close_br] THEN RETURN;
SELECTONE .tok OF
SET
[s_numeric, s_string] :
BEGIN
out$tok (); ! "Numeric" or "string"
lex;
END;
[s_begin, s_lparen] :
prs$block ();
[s_langle, s_lbracket] :
!+
! To handle keyword macro refs...
!-
prs$paren_elist (.block_context);
[s_plit, s_uplit] :
BEGIN
out$tok (); ! "PLIT " or "UPLIT "
out$space ();
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_rep] :
BEGIN
out$stoks ();
lex;
prs$expression (.block_context);
IF .tok NEQ s_of THEN utl$error (er_of);
out$default ();
lex;
IF .symprop [.tok, sym_type] EQL alloc_unit THEN (out$tok (); lex; );
prs$paren_elist (.block_context);
END;
[s_codecomment] :
do_codecom (.block_context);
[s_name] :
BEGIN
!+
! The following test is heuristic: if the expected colon is one
! space beyond the current name, we can pre-recognize it as a
! label and left-adjust the label on a new line.
!-
IF CH$RCHAR (CH$PLUS (.token [tok_cp], .token [tok_len])) EQL %C' ' AND !
CH$RCHAR (CH$PLUS (.token [tok_cp], .token [tok_len] + 1)) EQL %C':' AND !
NOT .nolabl
THEN
out$ntbreak (); ! Left- adjust label on new line
out$tok (); ! name
lex;
IF .tok EQL s_string
THEN
(out$tok (); lex; ) ! "String"
ELSE
IF .tok EQL s_colon AND NOT .nolabl
THEN
BEGIN
out$stoks (); ! " : "
out$force ();
lex;
prs$block ();
END;
END;
[OTHERWISE] : ! Check for allocation-unit
BEGIN
! IF .symprop [.tok, sym_type] NEQ alloc_unit
! THEN
! utl$error (er_primary);
out$default (); ! "BYTE", e.g.
lex;
END;
TES;
WHILE .symprop [.tok, sym_type] EQL open_bracket DO
prs$paren_elist (.block_context);
END; ! End of routine 'do_primary'
ROUTINE do_select (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats SELECT, SELECTONE, etc. expressions
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
out$tok (); ! " SELECT... "
out$space (1);
lex;
prs$expression (.block_context);
IF .tok EQL s_of
THEN
BEGIN
out$stoks (); ! " OF "
out$force ();
lex;
END
ELSE
utl$error (er_of);
IF .tok EQL s_set THEN (out$indent (1); do_set (.block_context); ) ELSE utl$error (er_set);
IF .tok EQL s_tes
THEN
BEGIN
out$break ();
out$tok (); ! "TES"
out$indent (-1);
lex;
END
ELSE
utl$error (er_tes);
END; ! End of routine 'do_select'
ROUTINE do_set (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine is called to format the SET..TES in
! CASE and SELECT expressions.
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
IF .block_context NEQ s_lparen THEN out$break (); ! On a new line put the
out$stoks (); ! "SET"
out$force ();
lex;
WHILE .tok EQL s_lbracket DO
BEGIN
IF .block_context NEQ s_lparen THEN out$skip (1);
out$tok (); ! "["
lex;
WHILE .tok NEQ s_end_of_file DO
BEGIN
!+
! [ Label ,... ]
!-
prs$expression (.block_context);
IF .tok EQL s_to ! " TO " <expr>
THEN
(out$stoks (); lex; prs$expression (.block_context); );
IF .tok EQL s_rbracket
THEN
BEGIN
out$tok (); ! Closing bracket
lex;
EXITLOOP;
END;
IF .tok EQL s_comma
THEN
BEGIN
out$erase ();
out$tok (); ! ", "
out$space (1);
lex;
END
ELSE
IF .tok EQL s_tes THEN RETURN ELSE (utl$error (er_set_tes); out$default (); lex; );
END; ! [ Label ,... ]
IF .tok EQL s_colon
THEN
BEGIN
out$stoks (); ! " : "
IF .block_context NEQ s_lparen THEN out$force ();
out$indent (+1); ! Indent block comments at head of block
lex;
out$indent (-1);
END
ELSE
utl$error (er_colon);
prs$expression (.block_context); ! Action for this value of the set
IF .tok EQL s_semicolon
THEN
BEGIN
out$erase ();
out$tok (); ! ";"
out$force ();
lex;
END;
END;
END; ! End of routine 'do_set'
GLOBAL ROUTINE prs$expression (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine formats expressions.
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
LOCAL
save_tok;
out$indent (1); ! Always for every expr.
IF .tok LSS first_control !
OR .tok GTR last_control
THEN
prs$oper (1, .block_context) ! Operator expression
ELSE ! It's a control expression.
BEGIN
!+
! Dispatch through a transfer vector to format a
! Control expression . The format of this vector depends
! On the ordering of the control symbols in 'TOKTYP.BLI'.
!-
BIND
ctl_routines = !
UPLIT (
do_if, !
do_case, !
REP 6 OF (do_select), !
REP 6 OF (do_count_loop), !
REP 2 OF (do_pre_loop), !
do_post_loop, !
REP 3 OF (do_exit)) !
: VECTOR [last_control - first_control + 1];
save_tok = .tok;
IF .tok LSS s_leave AND !
.block_context NEQ s_lparen
THEN
out$skip (1);
! Skip a line for non-trivial control
! Expressions
(.ctl_routines [.tok - first_control]) (.block_context);
!+
! Skip a line after each non-trivial control expression
!-
IF .save_tok LSS s_leave AND !
.block_context NEQ s_lparen
THEN
out$pend_skip (1);
END;
out$indent (-1);
RETURN;
END; ! End of routine 'prs$expression'
GLOBAL ROUTINE prs$oper (level, block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine is called to format all operator expressions.
!
! These are:
!
! E1 ::= E2 = E1 \ E2
! E2 ::= E3 EQV E2 \ E3
! XOR
! E3 ::= E4 OR E3 \ E4
! E4 ::= E5 AND E4 \ E5
! E5 ::= NOT E5 \ E6
! E6 ::= E7 <Relational-operators> E7 \ E7
! E7 ::= E8 + E7 \ E8
! -
! E8 ::= E9 * E8 \ E9
! /
! MOD
! E9 ::= E10 ^ E9 \ E10
! E10 ::= + E11
! -
! E11 ::= . E11 \ PRIMARY
!
! Note that the precedence level of a PRIMARY is 12.
!
! Formal parameters:
!
! Level - the precedence level this call is to parse at.
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
!<BLF/page>
BEGIN
LOCAL
num_choice;
MACRO
plit_count (aplit) =
((aplit)-%UPVAL)%;
BIND
BINARY = UPLIT (0, REP 4 OF (true), false, REP 4 OF (true),
false, false) : VECTOR,
right_prece = !
UPLIT (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11) : VECTOR,
left_prece = !
UPLIT (0, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) : VECTOR, ! No left precedence for unary ops
prece_tokens = !
UPLIT (
0, ! Levels
PLIT(s_equal), ! 1
PLIT(s_eqv, s_xor), ! 2
PLIT(s_or), ! 3
PLIT(s_and), ! 4
PLIT(s_not), ! 5
PLIT( !
s_eql, ! 6
s_neq, ! 6
s_lss, ! 6
s_leq, ! 6
s_gtr, ! 6
s_geq, ! 6
s_eqlu, ! 6
s_nequ, ! 6
s_lssu, ! 6
s_lequ, ! 6
s_gtru, ! 6
s_gequ, ! 6
s_eqla, ! 6
s_neqa, ! 6
s_lssa, ! 6
s_leqa, ! 6
s_gtra, ! 6
s_geqa), ! 6
PLIT(s_plus, s_minus), ! 7
PLIT(s_multiply, s_divide, s_mod), ! 8
PLIT(s_circumflex), ! 9
PLIT(s_plus, s_minus), ! 10
PLIT(s_dot)) ! 11
: VECTOR;
BIND
choice = .prece_tokens [.level] : VECTOR;
LITERAL
primary_level = 12;
!<BLF/page>
IF .symprop [.tok, sym_close_br] THEN RETURN;
IF .level EQL primary_level THEN (do_primary (.block_context); RETURN; );
!+
! If binary level, try for left operand. Check operator.
! If it matches, try for right operand, and return.
! If unary, try to match operator.
! If it matches, try for right operand and return.
! Otherwise, try for a left operand and return.
!-
IF .BINARY [.level] THEN prs$oper (.left_prece [.level], .block_context);
num_choice = .plit_count (choice);
INCR i FROM 0 TO .num_choice - 1 DO
BEGIN
IF .tok EQL .choice [.i]
THEN
BEGIN
IF .tok EQL s_dot OR !
.tok EQL s_multiply OR !
.tok EQL s_divide OR !
.tok EQL s_circumflex OR !
.level EQL 10 AND !
(.tok EQL s_plus OR .tok EQL s_minus) ! Unary +,-
THEN
out$tok () ! ".", "*", or "/"
ELSE
out$stoks (); ! Binary "+", "-", etc.
lex;
prs$oper (.right_prece [.level], .block_context);
RETURN;
END;
END;
IF NOT .BINARY [.level] THEN prs$oper (.left_prece [.level], .block_context);
RETURN;
END; ! End of routine 'prs$oper'
GLOBAL ROUTINE prs$paren_elist (block_context) : NOVALUE = !
!++
! Functional description:
!
! This routine is invoked to parse a list of expressions,
! ending with the close bracket corresponding to
! the symbol contained in 'token', which is
! assumed to contain the left bracket of the list to
! be parsed.
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
LOCAL
bracket; ! Which kind of bracket opened it
BIND
kinds = UPLIT (s_lparen, s_langle, s_lbracket) : VECTOR,
match = UPLIT (s_rparen, s_rangle, s_rbracket) : VECTOR;
bracket = .tok;
out$push_marks ();
IF .tok NEQ s_langle THEN out$space (1);
out$tok (); ! Output the left symbol
lex;
WHILE .tok NEQ s_end_of_file DO
BEGIN
prs$expression (.block_context);
IF .tok EQL s_comma OR !
.tok EQL s_semicolon ! In general structure references
THEN
BEGIN
out$erase ();
out$tok (); ! ", " or "; "
out$space (1);
out$pop_marks ();
out$push_marks ();
out$mark (1); ! Prepare to break line here
lex;
END
ELSE
EXITLOOP;
END;
! TT 4-Nov-81
INCR i FROM 0 TO 2 DO
IF .kinds [.i] EQL .bracket
THEN
BEGIN
IF .tok NEQ .match [.i]
THEN
utl$error (er_inv_bracket)
ELSE
BEGIN
out$tok (); ! Closing bracket
out$pop_marks ();
out$push_marks ();
lex;
END;
EXITLOOP;
END;
out$pop_marks ();
END; ! End of routine 'prs$paren_elist'
%TITLE 'Last page of PARSE3.BLI'
END ! End of module 'PARSE3'
ELUDOM