Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/shwexa.bli
There are no other files named shwexa.bli in the archive.
MODULE SHWEXA (
IDENT = '1',
%IF
%BLISS(BLISS32)
%THEN
LANGUAGE(BLISS32),
ADDRESSING_MODE(EXTERNAL=LONG_RELATIVE,
NONEXTERNAL=LONG_RELATIVE)
%ELSE
LANGUAGE(BLISS36)
%FI
) =
BEGIN
!
! COPYRIGHT (C) 1982 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!
!++
! FACILITY: CMS library processor
!
! ABSTRACT:
! Some of the routines used in the analysis of show commands are
! located in this module
!
! ENVIRONMENT: VAX/VMS, DS-20
!
! AUTHOR: Robert Wheater, CREATION DATE: 3-Mar-80
!
! MODIFIED BY:
!
!--
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
DIRDES, ! Cks two gen exp for direct line of descent
EXABUF:NOVALUE, ! examines buffer for SHOW RESERVATION
EXPARM:NOVALUE, ! examine command parameter
EXQUAL ; ! examine command qualifiers
!
! INCLUDE FILES:
!
%if %bliss(bliss32) %then
library 'sys$library:starlet';
%else
require 'jsys:';
%fi
LIBRARY 'XPORT:';
REQUIRE 'SCONFG:';
REQUIRE 'BLISSX:';
REQUIRE 'COMUSR:';
REQUIRE 'HOSUSR:';
REQUIRE 'SHRUSR:';
REQUIRE 'SHWUSR:';
REQUIRE 'TERUSR:';
!
! MACROS:
!
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
GLOBAL ! PARAMETER AND QUAL DEF
D_CLS_FND: DESC_BLOCK, ! desc of class found
D_ELM_NAM: DESC_BLOCK, ! desc of element name
D_FORMAT: DESC_BLOCK, ! desc of format str
D_FROM: DESC_BLOCK, ! desc of from string
D_GEN_CLS: DESC_BLOCK, ! desc of gen ref or
! class ref
D_FIL_NAM: DESC_BLOCK, ! filename string desc
D_SHW_DFLT: DESC_BLOCK, ! default file name
D_SINCE: DESC_BLOCK, ! /since string
D_WILD_REF: DESC_BLOCK, ! desc wild card ref
F_BRIEF_QUA: initial(false), ! brief qual flag
f_cl_qua: initial(false), ! class qual flag
F_CLS_REF: initial(false), ! class ref flag
f_el_cls: initial(false), ! set when element and
! class specified
f_el_nam: initial(false), ! element name flag
F_ELM_REF: initial(false), ! single element ref flag
F_FMT_QUA: initial(false), ! format qual flag
F_FRM_QUA: initial(false), ! from qual flag
F_GEN_REF: initial(false), ! gen reference flag
F_INC_QUA: initial(false), ! include qual flag
F_NO_PARM: initial(false), ! no parameter flag
F_PLUS_OPR: initial(false), ! plus operator flag
F_SINCE_QUA: initial(false), ! set when since qual
! is present
F_SPEC_OUT: initial(false), ! special output flag
F_UNUSUAL_QUA : initial(false), ! set when unusual qual
! is present
F_WILD_REF: initial(false) ; ! set when wild card
! appears
!
! EXTERNAL REFERENCES:
!
EXTERNAL ! declared in module
BUF_TAB_LST, ! SHSTAT
F_OUTPUT, ! set when output issued(SHSTAT)
L_OLD_ELM, ! SHSTAT
P_OLD_ELM, ! SHSTAT
R_BUF_TAB: REF BLOCKVECTOR[,K_REC_FLD_FULL] FIELD(D_REC_FLD) ;
! SHSTAT
EXTERNAL ROUTINE
ASCDEC, ! convert ascii to decimal(ASCDEC)
BUG,
DEQUOT : NOVALUE, ! remove quotation marks(QUOTES)
OUTRES, ! output reservation line(SHSTAT)
SAY, ! put line on terminal(TERMIO)
SETOUT ; ! set output to file(TERMIO)
GLOBAL ROUTINE DIRDES(GEN1_LEN,GEN1_PTR,GEN2_LEN,GEN2_PTR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will take two generation expressions and determine
! if one in on the "Direct Line of Descent" from the other generation.
!
! FORMAL PARAMETERS:
!
! GEN1_LEN ! length of generation expression 1.
!
! GEN1_PTR ! pointer to generation expression 1.
!
! GEN2_LEN ! length of generation expression 2.
!
! GEN2_PTR ! pointer to generation expression 2.
!
! IMPLICIT INPUTS:
!
!
!
! IMPLICIT OUTPUTS:
!
!
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE = GEN2 expression is on a direct line of descent from
! GEN1 expression.
! FALSE = GEN2 expression is not on a direct line of descent from
! GEN1 expression.
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
LABEL
MAIN ;
LOCAL
CHAR1,
CHAR2,
LEN,
LPC,
L1,
L2,
NUM,
PTR,
P1,
P2,
VALUE1,
VALUE2 ;
! initialize local pointers
L1 = .GEN1_LEN ;
P1 = .GEN1_PTR ;
L2 = .GEN2_LEN ;
P2 = .GEN2_PTR ;
CHAR1 = 0;
CHAR2 = 0;
! compare strings for first non-match
UNTIL
(.CHAR1 NEQ .CHAR2) OR
(.L1 LEQ 0) OR
(.L2 LEQ 0)
DO
BEGIN ! loop
CHAR1 = CH$RCHAR_A(P1) ;
L1 = .L1-1 ;
CHAR2 = CH$RCHAR_A(P2) ;
L2 = .L2-1 ;
END ; ! loop
! first non-match must be numeric
IF
NOT ((.CHAR1 GEQ %C'0' AND .CHAR1 LEQ %C'9') OR
(.CHAR2 GEQ %C'0' AND .CHAR2 LEQ %C'9'))
THEN
RETURN FALSE;
! remaining characters in both string must be numeric
IF
.L1 NEQ 0
THEN
BEGIN ! ck remaining str1 for number
LEN = .L1 ;
PTR = .P1 ;
UNTIL
.LEN EQL 0
DO
BEGIN ! numeric check
LEN = .LEN-1 ;
NUM = CH$RCHAR_A(PTR) ;
IF
NOT (.NUM GEQ %C'0' AND
.NUM LEQ %C'9')
THEN
RETURN FALSE;
END; ! numeric check
END ; ! ck remaining str1 for number
IF
.L2 NEQ 0
THEN
BEGIN ! ck remaining str2 for number
LEN = .L2 ;
PTR = .P2 ;
UNTIL
.LEN EQL 0
DO
BEGIN ! numeric check
LEN = .LEN-1 ;
NUM = CH$RCHAR_A(PTR) ;
IF
NOT (.NUM GEQ %C'0' AND
.NUM LEQ %C'9')
THEN
RETURN FALSE;
END; ! numeric check
END ; ! ck remaining str2 for number
! back up pointer and length
L1 = .L1 +1;
P1 = CH$PLUS(.P1,-1);
L2 = .L2 + 1;
P2 = CH$PLUS(.P2,-1);
VALUE1 = ASCDEC(P1,.L1) ;
IF
.VALUE1 EQL -1
THEN
RETURN FALSE; ! *exit*
VALUE2 = ASCDEC(P2,.L2) ;
IF
.VALUE2 EQL -1
THEN
RETURN FALSE; ! *exit*
IF
.VALUE1 GTR .VALUE2 OR
.l1 GTR .l2 ! How about the case of comparing 105 TO 19
! At this point we would compare 05 to 9 and
! determine 9 > 5 however 105 >> 19.
THEN
RETURN FALSE; ! *exit*
TRUE
END; ! end of routine DIRDES
GLOBAL ROUTINE EXABUF:NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will examine the buffer after it is loaded by the
! SHWRES routine. First the buffer is scanned for reservations that
! are matched by a replacement line by the same user. These reservations
! are not printed and only the the unmatched reservations are printed.
! Then the buffer is scanned for replacement lines and all of these are
! printed.
!
! FORMAL PARAMETERS:
!
!
!
! IMPLICIT INPUTS:
!
! BUF_TAB_LST Index of highest valid entry in buffer table.
!
! L_OLD_ELM Length of previous element name.
!
! P_OLD_ELM Pointer to previous element name.
!
! R_BUF_TAB Address of buffer table.
!
! IMPLICIT OUTPUTS:
!
!
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! None
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
OWN
F_1ST_HDR ; ! set when first header is printed
LOCAL
F_MAT_RES, ! set when reserve-replace matching
! lines by user found
F_PRT_ELM, ! controls printing of element name
F_PRT_REP, ! controls printing of replacements header
I_REPL, ! index in buffer table to replace line
I_RESV ; ! index in buffer table to reserve line
! initialize flags
F_MAT_RES = FALSE ;
F_PRT_ELM = FALSE ;
F_PRT_REP = FALSE ;
! scan buffer for unmatched reservation
I_RESV = 0;
I_REPL = 0;
UNTIL
.I_RESV GTR .BUF_TAB_LST
DO
BEGIN ! outer loop on compare
! verify that reservation entry is blank on col 1
IF
CH$RCHAR(.R_BUF_TAB[.I_RESV,D_COM_LIN_PTR])
EQL %C' '
THEN
BEGIN ! valid reservation record
I_REPL = .I_RESV+1 ;
IF
.I_REPL LEQ .BUF_TAB_LST
THEN
BEGIN ! replacement may exist?
UNTIL
.I_REPL GTR .BUF_TAB_LST
DO
BEGIN ! inter loop on compare
IF
CH$RCHAR(.R_BUF_TAB[.I_REPL,D_COM_LIN_PTR])
EQL %C'*'
THEN
BEGIN ! validate record
IF
CH$EQL(.R_BUF_TAB[.I_RESV,D_USR_NAM_LEN],
.R_BUF_TAB[.I_RESV,D_USR_NAM_PTR],
.R_BUF_TAB[.I_REPL,D_USR_NAM_LEN],
.R_BUF_TAB[.I_REPL,D_USR_NAM_PTR],
%C' ')
AND
CH$EQL(.R_BUF_TAB[.I_RESV,D_RES_GEN_LEN],
.R_BUF_TAB[.I_RESV,D_RES_GEN_PTR],
.R_BUF_TAB[.I_REPL,D_RES_GEN_LEN],
.R_BUF_TAB[.I_REPL,D_RES_GEN_PTR],
%C' ')
THEN
BEGIN ! match found
F_MAT_RES = TRUE ;
EXITLOOP ;
END ; ! match found
END ; ! validate record
I_REPL = .I_REPL+1 ;
END ; ! inter loop on compare
END ; ! replacement image may exist?
IF
NOT .F_MAT_RES
THEN
BEGIN ! output
IF
NOT .F_1ST_HDR
THEN
BEGIN
SAY(CAT('The current reservations are:')) ;
F_1ST_HDR = TRUE ;
END ;
IF
NOT .F_PRT_ELM
THEN
BEGIN
SAY(CAT((.L_OLD_ELM,.P_OLD_ELM))) ;
F_PRT_ELM = TRUE ;
F_OUTPUT = TRUE ;
END ;
! unmatch reservation may be output
OUTRES(.R_BUF_TAB[.I_RESV,D_COM_LIN_LEN],
.R_BUF_TAB[.I_RESV,D_COM_LIN_PTR]) ;
END ; ! output
IF
.F_MAT_RES
THEN
F_MAT_RES = FALSE ;
END ; ! valid reservation record
I_RESV = .I_RESV + 1 ;
END ; ! outer loop of compare
! must now look for replacements
I_REPL = 0 ;
UNTIL
.I_REPL GTR .BUF_TAB_LST
DO
BEGIN ! replacement image search
IF
CH$RCHAR(.R_BUF_TAB[.I_REPL,D_COM_LIN_PTR])
EQL %C'*'
THEN
BEGIN ! replacement image
IF
NOT .F_PRT_REP
THEN
BEGIN
SAY(CAT(' Concurrent replacements')) ;
F_PRT_REP = TRUE ;
END ;
! put out complete line
OUTRES(.R_BUF_TAB[.I_REPL,D_COM_LIN_LEN],
.R_BUF_TAB[.I_REPL,D_COM_LIN_PTR]) ;
END ; ! replacement image
I_REPL = .I_REPL+1 ;
END ; ! replacement image scan
END; ! end of routine EXABUF
GLOBAL ROUTINE EXPARM(A_PARM): NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! The purpose of this routine is to analyze the parmeter of a
! SHOW Command. Depending on the format of the parameter appropriate
! flags are set and descriptors initialized to point to strings.
!
! FORMAL PARAMETERS:
!
! A_PARM Address of first parameter block.
!
! IMPLICIT INPUTS:
!
!
!
! IMPLICIT OUTPUTS:
!
!
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! No value returned
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
LOCAL
B_PARM: REF PARAMETER_BLOCK,
B_QUAL : REF QUALIFIER_BLOCK,
B_NODE: REF NODE_BLOCK,
B_SUB_NODE: REF NODE_BLOCK ;
! point address to block
B_PARM = .A_PARM ;
! examine the parameter
IF
(.B_PARM EQL K_NULL)
THEN
F_NO_PARM = TRUE
ELSE
BEGIN ! examine parameter tree
F_NO_PARM = FALSE ;
F_ELM_REF = FALSE ;
IF
.B_PARM[PAR_TEXT_PTR] NEQ K_NULL
THEN
BEGIN ! set up element name
$STR_DESC_INIT(DESCRIPTOR=D_ELM_NAM,
STRING=B_PARM[PAR_TEXT]) ;
F_ELM_REF = TRUE ;
END ! set up element name
ELSE
F_NO_PARM = TRUE ;
! check for wild card
$STR_DESC_INIT(DESCRIPTOR=D_WILD_REF,
STRING=('*.*')) ;
IF
CH$EQL(LEN_COMMA_PTR(D_ELM_NAM),
LEN_COMMA_PTR(D_WILD_REF),%C' ')
THEN
BEGIN
F_WILD_REF = TRUE ;
! clear single element ref flag
F_ELM_REF = FALSE ;
END ;
!Process command qualifiers
B_QUAL=.B_PARM[PAR_A_QUAL];
WHILE
.B_QUAL NEQ K_NULL
DO
BEGIN
SELECTONE .B_QUAL[QUA_CODE] OF
SET
[K_GEN_QUAL]:
BEGIN
!gen qualifier exists so clear the single element reference
!NOTE: this is a reference to a "single element qualifier"
! and a single element means that it contains element
! only and nothing else. When f_elm_ref is set, the
! meaning is that parser has found that element ONLY.
F_ELM_REF = FALSE;
IF
.B_QUAL[QUA_A_TREE] EQL K_NULL
THEN
BEGIN
F_PLUS_OPR = FALSE ;
$STR_DESC_INIT(DESCRIPTOR=D_GEN_CLS,
STRING=(.B_QUAL[QUA_VALUE_LEN],
.B_QUAL[QUA_VALUE_PTR]));
END
ELSE
BEGIN
LOCAL
B_SUB_QUAL : REF NODE_BLOCK;
F_PLUS_OPR = TRUE ;
B_SUB_QUAL=.B_QUAL[QUA_A_TREE];
$STR_DESC_INIT(DESCRIPTOR=D_GEN_CLS,
STRING=(.B_SUB_QUAL[NOD_DESC_1_LEN],
.B_SUB_QUAL[NOD_DESC_1_PTR]))
END ;
! determine if class or gen ref
F_GEN_REF = FALSE ;
F_CLS_REF = FALSE ;
IF
(CH$RCHAR(.D_GEN_CLS[DESC_PTR]) GEQ %C'0' AND
CH$RCHAR(.D_GEN_CLS[DESC_PTR]) LEQ %C'9' )
THEN
F_GEN_REF = TRUE
ELSE
F_CLS_REF = TRUE ;
IF
CH$RCHAR(D_GEN_CLS[DESC_PTR]) NEQ %C'*'
THEN
f_el_cls = TRUE ;
END;
[K_FROM_QUAL]:
BEGIN
F_FRM_QUA=TRUE;
$STR_DESC_INIT(DESCRIPTOR=D_FROM,
STRING=B_QUAL[QUA_VALUE])
END;
TES;
B_QUAL=.B_QUAL[QUA_A_NEXT]
END;
END ; ! examine parameter tree
END ; ! end of routine exparm
GLOBAL ROUTINE EXQUAL(A_QUAL) =
!++
! FUNCTIONAL DESCRIPTION:
!
! The purpose of this routine is to examine the qualifiers on a SHOW
! Command. If certain qualifiers are present appropriate flags are
! set and descriptors initialized to point to keywork strings.
!
! FORMAL PARAMETERS:
!
! A_QUAL Address of first qualifier block
!
! IMPLICIT INPUTS:
!
!
!
! IMPLICIT OUTPUTS:
!
!
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE = successful completion of routine
! FALSE = error in processing
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
LOCAL
B_QUAL: REF QUALIFIER_BLOCK,
F_APPEND_Q, ! append qual
F_OUTPUT_Q, ! output qual
F_APP_OUT_Q; ! both append and output qual
! initialize flags
F_APPEND_Q = FALSE ;
F_OUTPUT_Q = FALSE ;
F_APP_OUT_Q = FALSE ;
! initialize file name string to null
$STR_DESC_INIT(DESCRIPTOR=D_FIL_NAM,STRING=(0,K_NULL)) ;
! initialize qualifier pointer
B_QUAL = .A_QUAL ;
! examine each qualifier
WHILE
.B_QUAL NEQ K_NULL
DO
BEGIN !scan qual
SELECTONE .B_QUAL[QUA_CODE] OF
SET
[K_APPEND_QUAL,
K_OUTPUT_QUAL]:
BEGIN ! /APPEND OR /OUTPUT
IF (.B_QUAL[QUA_CODE] EQL K_APPEND_QUAL)
THEN
BEGIN ! str append
F_APPEND_Q = TRUE ;
IF
.F_OUTPUT_Q
THEN
F_APP_OUT_Q = TRUE ;
END ! end append
ELSE
BEGIN ! str output
F_OUTPUT_Q = TRUE ;
IF
.F_APPEND_Q
THEN
F_APP_OUT_Q = TRUE ;
! save keywork string
$STR_DESC_INIT(DESCRIPTOR=D_FIL_NAM,
STRING=(.B_QUAL[QUA_VALUE_LEN],
.B_QUAL[QUA_VALUE_PTR])) ;
END ; ! end output
END ; ! end /APPEND OR /OUTPUT
[K_NOOUTPUT_QUAL,K_NOAPPEND_QUAL]:
BEGIN
IF (.B_QUAL[QUA_CODE] EQL K_NOAPPEND_QUAL)
THEN
F_APPEND_Q = FALSE
ELSE
BEGIN
F_OUTPUT_Q = FALSE;
$STR_DESC_INIT(DESCRIPTOR=D_FIL_NAM,STRING=(0,K_NULL)) ;
END;
IF .F_APP_OUT_Q
THEN
F_APP_OUT_Q = FALSE;
END;
[K_BRIEF_QUAL]:
F_BRIEF_QUA = TRUE ;
[K_NOBRIEF_QUAL]:
F_BRIEF_QUA = FALSE;
[K_CLASS_QUAL]:
f_cl_qua = TRUE ;
[K_NOCLASS_QUAL]:
f_cl_qua = false;
[K_FORMAT_QUAL]:
BEGIN
! set format qualifier flag
F_FMT_QUA = TRUE ;
! save descriptor
$STR_DESC_INIT(DESCRIPTOR=D_FORMAT,
STRING=B_QUAL[QUA_VALUE]) ;
! remove quotes from the format value
DEQUOT(D_FORMAT) ;
END ;
[K_NOFORMAT_QUAL]:
F_FMT_QUA = FALSE;
[K_FROM_QUAL]:
BEGIN ! /from
F_FRM_QUA = TRUE ;
$STR_DESC_INIT(DESCRIPTOR=D_FROM,
STRING=B_QUAL[QUA_VALUE]) ;
END ; ! /from
! [K_INCLUDED_QUAL]:
! F_INC_QUA = TRUE ;
[K_SINCE_QUAL]:
BEGIN ! /since
! set flag
F_SINCE_QUA = TRUE ;
! setup desc
$STR_DESC_INIT(DESCRIPTOR=D_SINCE,
STRING=B_QUAL[QUA_VALUE]) ;
END ; ! /since
[K_UNUSUAL_QUAL] :
F_UNUSUAL_QUA = TRUE ;
[K_NOUNUSUAL_QUAL] :
F_UNUSUAL_QUA = FALSE;
[OTHERWISE]: ;
TES ;
! move to next qual
B_QUAL = .B_QUAL[QUA_A_NEXT] ;
END ; ! scan qualifiers
IF
.F_APPEND_Q OR
.F_OUTPUT_Q OR
.F_APP_OUT_Q
THEN
BEGIN ! redirect output
! set special output flag
F_SPEC_OUT = TRUE ;
! initialize default file name
$STR_DESC_INIT(DESCRIPTOR=D_SHW_DFLT,
STRING=('SHOW.SHO')) ;
END ; ! redirect output
IF
.F_APPEND_Q OR .F_APP_OUT_Q
THEN
BEGIN
IF NOT (SETOUT(K_SAY_APPEND,D_FIL_NAM,D_SHW_DFLT))
THEN
RETURN FALSE ;
END ;
IF
.F_OUTPUT_Q AND NOT .F_APP_OUT_Q
THEN
BEGIN
IF NOT (SETOUT(K_SAY_CREATE,D_FIL_NAM,D_SHW_DFLT))
THEN
RETURN FALSE ;
END ;
TRUE
END ; ! end routine exqual
END ! End of module
ELUDOM