Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/stshow.bli
There are no other files named stshow.bli in the archive.
MODULE STSHOW (
IDENT = '1',
%IF
%BLISS(BLISS32)
%THEN
LANGUAGE(BLISS32),
ADDRESSING_MODE(EXTERNAL=LONG_RELATIVE,
NONEXTERNAL=LONG_RELATIVE)
%ELSE
LANGUAGE(BLISS36)
%FI
) =
BEGIN
!
! COPYRIGHT (C) 1982, 1983 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:
!
! Portions of the SHOW command are here.
!
!
! ENVIRONMENT: VAX/VMS, DS-20
!
! AUTHOR: D. Knight , CREATION DATE: 30-Apr-79
!
! MODIFIED BY: R. Wheater,11-Jan-80,VERSION 2
! 1 - Implement format qualifier.
! 2 - change to handle elements names with note strings
! and multiple file names.
!
! D. Knight, : VERSION 00
!--
!
! TABLE OF CONTENTS
!
FORWARD ROUTINE
SHWCLS, !SHOW CLASSES
SHWELM, !SHOW ELEMENT
SHWGEN, ! show generation processing
SHWVER, !SHOW VERSION
STSHOW; !START SHOW COMMAND ANALYSIS
!
! INCLUDE FILES:
!
%if %bliss(bliss32) %then
library 'sys$library:starlet';
%else
require 'jsys:';
%fi
LIBRARY 'XPORT:'; !XPORT I/O macros
REQUIRE 'SCONFG:'; !CMS configuration options
REQUIRE 'BLISSX:';
REQUIRE 'COMUSR:';
REQUIRE 'HOSUSR:';
REQUIRE 'SHRUSR:';
REQUIRE 'SHWUSR:';
REQUIRE 'TERUSR:' ;
!
! MACROS:
!
MACRO
STG(L,M,F) = OUTSHW(CH$PTR(UPLIT(L)),%CHARCOUNT(L),M,F) %;
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
GLOBAL
f_show : initial(0), ! CMS SHOW x is runing
FIRST ; ! first time -
! used for headers
! in unformatted output
OWN
$io_block(AATF),
$io_block(CCDIR),
$io_block(RD) ;
!
! EXTERNAL REFERENCES:
!
external literal
s_badcls,
s_brfwldcls, !brief qual needs wild cd & class
s_clnotfnd, !cannot find class
s_clswelem, !/CLASS only used w elem parameter
s_crneedsw, !class ref needs elem wild card
s_elnotfnd,
s_enotincls, !element does not exist in class
s_generr, !no generation
s_genfalse, !gen can't be used w/o wild card ref
s_geninv, !no such generations in specif class
s_genneedsc, !gen can't use wild cd w/o class ref
s_genref, !gen ref doesn't satisfy sel criteria
s_noelem,
s_nosuchel,
s_nyi, !not implemented
s_shwsucc, !successful show
s_wldquals; !/GEN:c & /BRIEF required w/*.*
EXTERNAL
! declared in module SHWEXA
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
F_BRIEF_QUA, ! brief qual flag
f_cl_qua, ! class qual flag
F_CLS_REF, ! class ref flag
f_el_nam, ! element name flag
F_ELM_REF, ! single element
! ref flag(elem only)
F_FMT_QUA, ! format qual flag
F_FRM_QUA, ! from qual flag
F_GEN_REF, ! gen reference flag
F_INC_QUA, ! include qual flag
F_NO_PARM, ! no parameter flag
F_PLUS_OPR, ! plus operator flag
F_SPEC_OUT, ! special output flag
F_WILD_REF; ! wild card reference
EXTERNAL ROUTINE
ASCDEC, ! convert ascii to decimal
BADLIB, ! print library bad message(TERMIO)
badxpo,
BUG,
COMAND,
CMPGEN, ! compare to gen expressions(CHKGEN)
DIRDES, ! ck direct line of descent(SHWEXA)
DONLIB, ! release library
ERS,
exits, ! exit silently
EXPARM, ! examine parameter
EXQUAL, ! examine qualifier
FILLSP, ! fill with spaces(SHWSER)
FMTOUT, ! generated formatted listing(SHWSER)
GENLIN, ! output generation line(SHWSER)
GETATR, ! get attribute
GETCLS, ! get class
GET_LXM, !Get text lexeme
OUTSHW, ! build output buffer(SHWSER)
SAFLIB, ! request access to library
SAY,
SETATR, ! setup attributes
SETOUT,
SHOLIB, ! SHOW LIBRARY command
SHWLOG, ! SHOW LOG command
SHWRES, ! SHOW RESERVATIONS command
sysmsg,
trnlog, ! translate a logical name
UNFMTO, ! generate unformatted listing(SHWSER)
VERSON ; ! return desc of CMS version number(VERSON)
GLOBAL ROUTINE STSHOW =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine gets control first when a show is issued. Its purpose
! is to determine which subcommand is present and call the appropriate
! routine.
!
! FORMAL PARAMETERS:
!
! NONE.
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! K_INFORMATION = alternate success but no data sent to user
! K_SILENT_ERROR = error such as command syntax !Have taken such code
! !out if after an ERS
! !command since never
! !accessed.
! K_SUCCESS = successful completion
! K_WARNING = warning
! K_WARN_ELM = warning, with missing element
! K_WARN_CLS = warning, with class missing
! K_WARN_GEN = warning, with generation number missing
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
CMD,
SUB_CMD,
FIRST_PAR,
FIRST_QUAL,
RETRN,
USR_REM;
!indicate that a show is running
f_show = true;
!Find out which function it is
IF
COMAND(CMD,SUB_CMD,FIRST_QUAL,FIRST_PAR,USR_REM)
THEN
!Success
begin
!Process proper sub-command
RETRN = (SELECTONE .SUB_CMD OF
SET
[K_LIBRARY_SUB]:
SHOLIB(.FIRST_QUAL) ;
[K_VERSION_SUB]:
SHWVER(.FIRST_QUAL) ;
[OTHERWISE]:
BEGIN
LOCAL
retrn1 ; ! local return status to be passed to outer selectone
! Request read access to library
IF NOT SAFLIB(k_read_lib)
THEN
RETURN k_silent_severe ;
retrn1 = (SELECTONE .sub_cmd OF
SET
[K_ANCESTORS_SUB]:
SHWGEN(.FIRST_QUAL,.FIRST_PAR,K_ANCESTORS_SUB) ;
[K_CLASS_SUB]:
SHWCLS(.FIRST_QUAL,.FIRST_PAR) ;
[K_DESCENDANTS_SUB]:
SHWGEN(.FIRST_QUAL,.FIRST_PAR,K_DESCENDANTS_SUB) ;
[K_ELEMENT_SUB]:
SHWELM(.FIRST_QUAL,.FIRST_PAR);
[K_GENERATION_SUB]:
SHWGEN(.FIRST_QUAL,.FIRST_PAR,K_GENERATION_SUB) ;
[K_HISTORY_SUB]:
SHWLOG(.FIRST_QUAL,.FIRST_PAR);
[K_RESERVATIONS_SUB]:
SHWRES(.FIRST_QUAL,.FIRST_PAR);
[OTHERWISE]:
ERS(s_nyi,LIT('Not yet implemented'));
TES) ;
DONLIB () ;
exits(.retrn1)
END ;
TES);
exits(.retrn)
end
ELSE
RETURN K_SILENT_ERROR
END; !End of SHOW
ROUTINE SHWCLS(A_QUAL,A_PARM) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will print out a list of the classes that appear
! in the class file. They will be printed in the order that they
! appear in the file.
!
! FORMAL PARAMETERS:
!
! A_QUAL Address of first qualifier block
!
! A_PARM Address of first parameter block
!
! IMPLICIT INPUTS:
!
! none.
!
! IMPLICIT OUTPUTS:
!
! none
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! K_SUCCESS = successful completion
!
! SIDE EFFECTS:
!
! none.
!
!--
BEGIN
LOCAL
CLS_CNT, ! count of numer of classes
F_OUTPUT, ! set when output issued
F_PRT_LIN, ! when set line is to be printed
F_1ST_HDR, ! set when header printed
KEY_STR : DESC_BLOCK, ! save keyword string
OUTSET, ! special output flg
QUAL: REF QUALIFIER_BLOCK, ! scan qualifiers
SHOW_DEFLT: DESC_BLOCK , ! default file name
status;
! initialize flags
F_OUTPUT = FALSE ;
F_PRT_LIN = FALSE ;
F_1ST_HDR = FALSE ;
CLS_CNT = 0 ;
! examine qualifiers
IF
NOT EXQUAL(.A_QUAL)
THEN
RETURN K_SILENT_ERROR ;
! examine parameter
EXPARM(.A_PARM) ;
! open atf and read it
if
(status=$STEP_OPEN(IOB=AATF_IOB,FILE_SPEC=(%STRING(LIB,ATF)),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.status,lit('Cannot open class file'));
UNTIL
$step_get(IOB=aatf_iob,failure=0) EQL step$_eof
DO
BEGIN ! class record
! Check for control string
IF CH$EQL(4,CH$PTR(UPLIT('*/C:')),4,.aatf_iob[IOB$A_STRING])
THEN
EXITLOOP;
IF
(CH$RCHAR(.aatf_iob[IOB$A_STRING]) NEQ %C' ')
THEN
BEGIN ! not element record
CLS_CNT = .CLS_CNT + 1 ; ! increment class count
IF
.F_ELM_REF
THEN
BEGIN ! element reference
LOCAL
L_STR,
M_STR: VECTOR[CH$ALLOCATION(FILE_SPEC_SIZE)],
P_CLS,
P_IOB ;
P_CLS = CH$PTR(M_STR) ;
P_IOB = .aatf_iob[IOB$A_STRING] ;
L_STR = GET_LXM(P_IOB,%C' ',.aatf_iob[IOB$H_STRING],
P_CLS) ;
P_CLS = CH$PTR(M_STR) ;
IF
CH$EQL(LEN_COMMA_PTR(D_ELM_NAM),
.L_STR,.P_CLS,%C' ')
THEN
F_PRT_LIN = TRUE ;
END ; ! element reference
IF
NOT .F_1ST_HDR AND NOT .F_ELM_REF
THEN
BEGIN
STG('The current class names are:',TRUE,TRUE) ;
F_1ST_HDR = TRUE ;
END ;
IF
.F_PRT_LIN OR NOT .F_ELM_REF
THEN
BEGIN
OUTSHW(.aatf_iob[IOB$A_STRING],
.aatf_iob[IOB$H_STRING],TRUE,TRUE) ;
F_PRT_LIN = FALSE ;
F_OUTPUT = TRUE ;
END ;
END ; ! not element record
END ; ! class record
! reset output to terminal
IF .F_SPEC_OUT
THEN
IF NOT (SETOUT(K_SAY_CLOSE,K_NULL,K_NULL))
THEN
BUG(CAT('Unable to close output file. Error in routine ',
'SHWCLS of module STSHOW')) ;
! report if no classes
IF
NOT .F_OUTPUT
THEN
BEGIN
IF
.F_ELM_REF
THEN
ERS(s_clnotfnd,CAT('Class ',D_ELM_NAM,' does not exist'))
ELSE
ERS(s_clnotfnd,CAT('No classes found'));
RETURN s_clnotfnd;
END ;
$step_close(IOB=aatf_iob) ;
s_shwsucc
END; ! end routine shwcls
ROUTINE SHWELM(A_QUAL,A_PARM) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will analyze the SHOW ELEMENTS command and generate the
! appropriate output as requested by the command. If the format
! qualifier is not present the element names and associated file names
! are output with appropriate headings. When the format qualifier is
! present the element names are substituted in the format string upon
! the occurrance of a # and the resulting string outputted.
!
! FORMAL PARAMETERS:
!
! A_QUAL Address of first qualifier block.
!
! A_PARM Address of first parameter block.
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! It is assumed that the order of appearance of element names in
! control directory file is the same order as appears in the class
! file.
!
!--
BEGIN
OWN
CDIR_MAT, ! element name match in CDIR
CLS_MAT, ! match on class string
ELE_CNTR, ! counter for elements in class
ELE_NAM_LEN, ! work area for element length
ELE_NAM_PTR, ! work area for element pointer
EXIT_LP, ! exit loop flg for nested loops
F_OUTPUT, ! set when output issued
FMT_LEN, ! length of str
FMT_PTR, ! format work pointer
OPEN_ATF, ! flags indicating input
OPEN_CDIR, ! file opening
REC_LEN, ! record length
REC_PTR, ! record pointer
STAT ; ! return status on xport close
FIRST=TRUE;
! set flags initially false
CLS_MAT=FALSE ;
OPEN_ATF=FALSE ;
OPEN_CDIR=FALSE ;
EXIT_LP=FALSE ;
F_OUTPUT=FALSE ;
! examine qualifier
IF
NOT EXQUAL(.A_QUAL)
THEN
RETURN K_SILENT_ERROR ;
! examine parameter
EXPARM(.A_PARM) ;
!check for /gen:n with no wild card !This modification has been made
!because a user could use SHO ELE
!and specify an element and then
!try to use qualifier /gen:n, and
!code would fall through and in-
!correctly give message "no ele fnd"
!Code now inhibits a /GEN qualifier
!unless a wild card ref is given,
!and then only allows /GEN:class
IF .F_GEN_REF
THEN
BEGIN !/gen:n not allowed with SHOW ELEMENT
ERS(s_genfalse,CAT('/GEN not allowed without wild card ',
'reference and then only /GEN=class-name'))
END; !end /gen:n not allowed with SHOW ELEMENT
!Class processing again means that the
!SHOW ELEMENT /GEN:class-name is going to be
!processed
! process class if present
IF .F_CLS_REF
THEN
BEGIN ! process class
! check for wild card
IF
NOT .F_WILD_REF
THEN
BEGIN
ERS(s_crneedsw,CAT('Class reference requires ',
'element wild card')) ;
END ;
! open and read class file
if
(stat=$STEP_OPEN(IOB=aatf_iob,FILE_SPEC=(%STRING(LIB,ATF)),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.stat,lit('Cannot open class file'));
OPEN_ATF = TRUE ;
UNTIL
$step_get(IOB=aatf_iob,failure=0) EQL step$_eof
DO
BEGIN ! read atf
! set up record pointers
REC_PTR = .aatf_iob[IOB$A_STRING] ;
REC_LEN = .aatf_iob[IOB$H_STRING] ;
! Check for control string
IF CH$EQL(4,CH$PTR(UPLIT('*/C:')),4,.REC_PTR)
THEN
EXITLOOP;
! examine first character of record
IF
(CH$RCHAR(.REC_PTR) NEQ %C' ')
THEN
BEGIN ! class record
IF .CLS_MAT
THEN
EXITLOOP ;
! get only class name
REC_PTR = CH$FIND_CH(.REC_LEN,.REC_PTR,%C' ') ;
IF
CH$FAIL(.REC_PTR) EQL 1
THEN
REC_PTR = .aatf_iob[IOB$A_STRING]
ELSE
BEGIN ! remark string on class
REC_LEN = CH$DIFF(.REC_PTR,.aatf_iob[IOB$A_STRING]) ;
REC_PTR = .aatf_iob[IOB$A_STRING] ;
END ; ! remark string on class
IF
CH$COMPARE(LEN_COMMA_PTR(D_GEN_CLS),
.REC_LEN,.REC_PTR,%C' ') EQL 0
THEN
CLS_MAT = TRUE
END ! class record
ELSE
BEGIN ! element record in atf
REC_PTR = CH$PLUS(.REC_PTR,1) ; ! adjust pointer for
REC_LEN = .REC_LEN-1 ; ! 1 column indent
ELE_NAM_PTR = CH$FIND_CH(.REC_LEN,.REC_PTR,%C' ') ;
IF
(CH$FAIL(.ELE_NAM_PTR) EQL 1)
THEN
BUG(CAT('There is no blank following the element',
' name in the class file. Error occurred',
' in routine SHWELM of module STSHOW')) ;
REC_LEN = CH$DIFF(.ELE_NAM_PTR,.REC_PTR) ; ! element len
IF .CLS_MAT
THEN
BEGIN ! open and read control directory
IF NOT .OPEN_CDIR
THEN
BEGIN
if
(stat=$STEP_OPEN(IOB=ccdir_iob,FILE_SPEC=(%STRING(LIB,CDIR)),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.stat,lit('Cannot open definition file'));
OPEN_CDIR = TRUE ;
END ;
UNTIL
$step_get(IOB=ccdir_iob,failure=0) EQL step$_eof
DO
BEGIN ! scan control dir for match
! Check for control string
IF CH$EQL(4,CH$PTR(UPLIT('*/C:')),4,.ccdir_iob[IOB$A_STRING])
THEN
EXITLOOP;
! find length of element name in cdir
ELE_NAM_PTR = CH$FIND_CH(.ccdir_iob[IOB$H_STRING],
.ccdir_iob[IOB$A_STRING],%C' ') ;
IF
(CH$FAIL(.ELE_NAM_PTR) EQL 1)
THEN
! error in control directory
BADLIB(CAT('Definition file error')) ;
ELE_NAM_LEN = CH$DIFF(.ELE_NAM_PTR,
.ccdir_iob[IOB$A_STRING]) ;
! check for match
IF
(CH$COMPARE(.REC_LEN,.REC_PTR,.ELE_NAM_LEN,
.ccdir_iob[IOB$A_STRING]) EQL 0)
THEN
BEGIN ! match occurred
CDIR_MAT = TRUE ;
IF
NOT .F_FMT_QUA
THEN
BEGIN ! no format qual
IF
NOT UNFMTO(.ccdir_iob[IOB$H_STRING],
.ccdir_iob[IOB$A_STRING])
THEN
EXIT_LP = TRUE
ELSE
F_OUTPUT = TRUE ;
EXITLOOP ;
END ; ! no format qual
IF
.F_FMT_QUA
THEN
BEGIN
IF
NOT FMTOUT(.REC_LEN,.REC_PTR,D_FORMAT)
THEN
EXIT_LP = TRUE
ELSE
F_OUTPUT = TRUE ;
EXITLOOP ;
END ;
END ; ! match occurred
END; ! scan control directory for match
IF NOT .CDIR_MAT
THEN
BADLIB(CAT('Element ',(.REC_LEN,.REC_PTR),
' in class file does not',
' have a matching element name in the',
' definition file'));
CDIR_MAT = FALSE ;
END ; ! open and read control directory
IF .EXIT_LP
THEN
EXITLOOP ;
END ; ! element record atf
END ; ! read atf
IF NOT .CLS_MAT
THEN
BEGIN
ers(s_badcls,
CAT('Class ',D_GEN_CLS,' does not exist')) ;
RETURN s_badcls;
END ;
END ; ! process class
IF (.F_WILD_REF OR .F_ELM_REF OR .F_NO_PARM) AND NOT .F_CLS_REF
THEN
BEGIN ! wild or element ref
! check for illegal syntax
IF
(.F_WILD_REF OR .F_NO_PARM) AND .F_GEN_REF
THEN
BEGIN ! bad syntax on command
ERS(s_genneedsc,CAT('Wild card requires that you specify /GEN=',
'class-name rather than /GEN=generation- number' )) ;
END ; ! bad syntax on command
! read control directory
if
(stat=$STEP_OPEN(IOB=ccdir_iob,FILE_SPEC=(%STRING(LIB,CDIR)),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.stat,lit('Cannot open definition file'));
OPEN_CDIR = TRUE ;
ELE_CNTR = 0 ; !init cntr of elements in class
UNTIL
$step_get(IOB=ccdir_iob,failure=0) EQL step$_eof
DO
BEGIN ! read file loop
! Check for control string
ELE_CNTR = .ELE_CNTR + 1 ;
IF CH$EQL(4,CH$PTR(UPLIT('*/C:')),4,.ccdir_iob[IOB$A_STRING])
THEN
EXITLOOP;
IF .F_ELM_REF
THEN
BEGIN ! check for element match
! find length of element name in control directory
ELE_NAM_LEN = CH$FIND_CH(.ccdir_iob[IOB$H_STRING],
.ccdir_iob[IOB$A_STRING],%C' ') ;
IF
(CH$FAIL(.ELE_NAM_LEN) EQL 1)
THEN
! error in control directory
BADLIB(CAT('Definition file error. Blank delimiter',
' does not exist after element name' )) ;
ELE_NAM_LEN = CH$DIFF(.ELE_NAM_LEN,.CCDIR_IOB[IOB$A_STRING]) ;
IF
CH$EQL(.ELE_NAM_LEN,.ccdir_iob[IOB$A_STRING],
LEN_COMMA_PTR(D_ELM_NAM),%C' ')
THEN
BEGIN ! format select
IF .F_FMT_QUA
THEN
BEGIN
IF
NOT FMTOUT(.ccdir_iob[IOB$H_STRING],
.ccdir_iob[IOB$A_STRING],D_FORMAT)
THEN
EXITLOOP
ELSE
F_OUTPUT = TRUE ;
END
ELSE
BEGIN
IF
NOT UNFMTO(.ccdir_iob[IOB$H_STRING],
.ccdir_iob[IOB$A_STRING])
THEN
EXITLOOP
ELSE
F_OUTPUT = TRUE ;
END ;
END ; ! format select
END ; ! check for element match
IF .F_WILD_REF OR .F_NO_PARM
THEN
BEGIN ! print all elements
IF .F_FMT_QUA
THEN
BEGIN
IF
NOT FMTOUT(.ccdir_iob[IOB$H_STRING],
.ccdir_iob[IOB$A_STRING],D_FORMAT)
THEN
EXITLOOP
ELSE
F_OUTPUT = TRUE ;
END
ELSE
BEGIN
IF
NOT UNFMTO(.ccdir_iob[IOB$H_STRING],
.ccdir_iob[IOB$A_STRING])
THEN
EXITLOOP
ELSE
F_OUTPUT = TRUE ;
END ;
END ; ! print all elements
END ; ! read file loop
END ; ! wild or element ref
! clean up before terminating
! reset output to terminal
IF .F_SPEC_OUT
THEN
IF NOT (SETOUT(K_SAY_CLOSE,K_NULL,K_NULL))
THEN
BUG(CAT(('Unable to close output file. Error called in '),
('routine SHWELM of module SHOW'))) ;
! report no output
IF
NOT .F_OUTPUT
THEN
BEGIN ! empty set output
IF .ELE_CNTR GTR 1
THEN
begin
ers(s_nosuchel,CAT('No such element')) ;
return k_silent_error;
end
ELSE
begin
ers(s_elnotfnd,CAT('No elements found'));
return s_elnotfnd;
end;
END ; ! empty set output
IF .OPEN_CDIR
THEN
STAT = $step_close(IOB=ccdir_iob) ;
IF .OPEN_ATF
THEN
STAT = $step_close(IOB=aatf_iob) ;
s_shwsucc
END; !End of SHWELM
ROUTINE SHWGEN(A_QUAL,A_PARM,SUB_COM) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will generate the output for the SHOW GENERATION,
! SHOW ANCESTORS, and SHOW DESCENDANTS
! Commands as required by the functional specification.
!
! FORMAL PARAMETERS:
!
! A_QUAL Address of first qualifier block.
!
! A_PARM Address of first parameter block.
!
! SUB_COM Name of the subcommand. It should be one of the
! following:
!
! K_ANCESTORS_SUB SHOW ANCESTORS
! K_DESCENDANTS_SUB SHOW DESCENDENTS
! K_GENERATION_SUB SHOW GENERATION
!
! IMPLICIT INPUTS:
!
!
!
! IMPLICIT OUTPUTS:
!
!
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! Returns the status word from xport close of file.
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
OWN
F_1ST_OUT:INITIAL(TRUE) ; ! first output?
LOCAL
ELE_LEN, ! length of element name
ELE_NAM_PTR, ! pointer to element name
ELM_LEN, ! length of element string
F_CLS_EXI, ! set when one or more classes for the element
! exist
F_CLS_MAT, ! set when matching class name found
F_ELM_FND, ! element found flag
F_EXT_PRT, ! exit loop flag after printing
F_OUTPUT, ! output issued flag
F_PLUS_FND, ! set when plus generation found
F_PRT_GEN, ! set if printing of gen line required
GEN_LEN, ! length of generation string in record
GEN_PTR, ! pointer to generation string in record
P_NXT, ! pointer to next delimiting character
P_PLUS_GEN, ! pointer to plus generation string
PLUS_GEN_LEN, ! length of a possible plus generation string
PLUS_GEN_PTR, ! pointer to a possible plus generation string
REC_LEN, ! length remaining in the record
REC_PTR, ! pointer to remaining positions in record
SAV_LEN, ! length + pointer of class string
SAV_PTR, ! in case of search failure
status;
! examine qualifiers, parameters, set flags, and initialize descriptors
IF
NOT EXQUAL(.A_QUAL)
THEN
RETURN K_SILENT_ERROR ;
EXPARM(.A_PARM) ;
! initialize flags
F_CLS_MAT = FALSE ;
F_ELM_FND = FALSE ;
F_OUTPUT = FALSE ;
F_EXT_PRT = FALSE ;
F_PRT_GEN = FALSE ;
F_PLUS_FND = FALSE ;
F_CLS_EXI = FALSE ;
! check for presence of wild card AND /CLASS. In this version, /CLASS
! can only be used with an element parameter
IF .F_CL_QUA AND .F_WILD_REF
THEN
BEGIN
ERS(s_clswelem,CAT('/CLASS may only be used with element name ',
'parameter'));
END;
! process class if present: *.*/brief/gen:classname[+]
!
! In this format, we go to the class definition file (00cms.atr) and read
! until find the specific class name. Then use the element names and
! generations as provided in the class definition file.
! If plus operator is used, we have to go to the element file to obtain
! the latest generation.
!
! The class definition file is in the format of:
!
! classname1 "remark1"
! elem1 gen1
! elem2 gen2
! elem3 gen3
! classname2 "remark2"
! classname3 "remark3"
! elem4 gen4
! */C:xxxxxxxx
IF .F_CLS_REF AND.F_WILD_REF AND NOT .F_ELM_REF
THEN
BEGIN ! process *.*/brief/gen:classname[+]
IF
NOT .F_BRIEF_QUA
THEN
ERS(s_wldquals,lit(%string('/GEN:class-name and /BRIEF required with ',
'use of wild card'))) ;
! open and read class file
if
(status=$STEP_OPEN(IOB=aatf_iob,FILE_SPEC=(%STRING(LIB,ATF)),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.status,lit('Cannot open class file'));
UNTIL
($step_get(IOB=aatf_iob,failure=0) EQL step$_eof)
OR
.F_CLS_MAT
DO
BEGIN ! find class in .atr
! set up record pointers
REC_PTR = .aatf_iob[IOB$A_STRING] ;
REC_LEN = .aatf_iob[IOB$H_STRING] ;
! Check for control string, indicates last line of file
IF CH$EQL(4,CH$PTR(UPLIT('*/C:')),4,.REC_PTR)
THEN
EXITLOOP;
! examine first character of record
IF
(CH$RCHAR(.REC_PTR) NEQ %C' ')
THEN
BEGIN ! class record
IF .F_CLS_MAT
THEN
EXITLOOP ;
! get only class name
REC_PTR = CH$FIND_CH(.REC_LEN,.REC_PTR,%C' ') ;
IF
CH$FAIL(.REC_PTR) EQL 1
THEN
REC_PTR = .aatf_iob[IOB$A_STRING]
ELSE
BEGIN ! remark string on class
REC_LEN = CH$DIFF(.REC_PTR,.aatf_iob[IOB$A_STRING]) ;
REC_PTR = .aatf_iob[IOB$A_STRING] ;
END ; ! remark string on class
IF
CH$COMPARE(LEN_COMMA_PTR(D_GEN_CLS),
.REC_LEN,.REC_PTR,%C' ') EQL 0
THEN
F_CLS_MAT = TRUE ;
END; ! class record
END; ! find class in .atr
IF .F_CLS_MAT
THEN
DO
BEGIN ! get elements in class
! set up record pointers
REC_PTR = .aatf_iob[IOB$A_STRING] ;
REC_LEN = .aatf_iob[IOB$H_STRING] ;
IF ((CH$EQL(4,CH$PTR(UPLIT('*/C:')),4,.REC_PTR))) ! this is control string
OR
(CH$RCHAR(.REC_PTR) NEQ %C' ') ! this is a class record
THEN
EXITLOOP;
REC_PTR = CH$PLUS(.REC_PTR,1) ; ! adjust pointer for
REC_LEN = .REC_LEN-1 ; ! 1 column indent
! get element name
P_NXT = CH$FIND_CH(.REC_LEN,.REC_PTR,%C' ') ;
IF
CH$FAIL(.P_NXT) EQL 1
THEN
BUG(lit(%string('There is no blank following the element',
' name in the class file. Error occurred',
' in routine SHWGEN of module STSHOW'))) ;
ELE_LEN = CH$DIFF(.P_NXT,.REC_PTR) ;
ELE_NAM_PTR = .REC_PTR ;
REC_LEN = .REC_LEN - .ELE_LEN - 1 ;
REC_PTR = CH$PLUS(.REC_PTR,(.ELE_LEN + 1)) ;
! get gen number from class defn file
P_NXT = CH$FIND_CH(.REC_LEN,.REC_PTR,%C' ') ;
IF
CH$FAIL(.P_NXT) EQL 1
THEN
BEGIN ! no blanks after gen number
GEN_LEN = .REC_LEN ;
GEN_PTR = .REC_PTR ;
END ! no blanks after gen number
ELSE
BEGIN ! blank after gen number
GEN_LEN = CH$DIFF(.P_NXT,.REC_PTR) ;
GEN_PTR = .REC_PTR ;
END ; ! blank after gen number
IF .F_PLUS_OPR
THEN ! scan element file to determine if a more recent
! generation exists
begin ! check element file for later generation
if
(status=$STEP_OPEN(IOB=RD_IOB,FILE_SPEC=(.ele_len,.ele_nam_ptr),DEFAULT=%STRING(LIB),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.status,CAT('Cannot open file ',d_elm_nam));
F_PLUS_FND = FALSE;
UNTIL
$step_get(IOB=RD_IOB,failure=0) EQL step$_eof
DO
BEGIN ! read element file record
! examine first character
IF
(CH$RCHAR(.RD_IOB[IOB$A_STRING]) NEQ %C'+')
OR
.F_PLUS_FND
THEN
EXITLOOP ;
! setup pointers to gen reference
PLUS_GEN_LEN = CH$FIND_CH(.RD_IOB[IOB$H_STRING],
.RD_IOB[IOB$A_STRING],%C' ') ;
PLUS_GEN_LEN = (CH$DIFF(.plus_GEN_LEN,.RD_IOB[IOB$A_STRING]))-1 ;
PLUS_GEN_PTR = CH$PLUS(.RD_IOB[IOB$A_STRING],1) ;
! if plus operator exists check for direct line of decent
! from that in the class
IF
DIRDES(.GEN_LEN,.GEN_PTR,
.PLUS_GEN_LEN,.PLUS_GEN_PTR)
THEN
BEGIN ! found a plus generation
F_PLUS_FND = TRUE ;
$xpo_get_mem(characters=.plus_gen_len,
result=gen_ptr);
ch$move(.plus_gen_len,.plus_gen_ptr,.gen_ptr);
END ; ! found a plus generation
END ; ! read element file record
$step_close(IOB=RD_IOB) ;
end; ! check element file for a later generation
IF
.F_1ST_OUT
THEN
BEGIN ! first time for printing
If .f_plus_opr
then
SAY(CAT(D_GEN_CLS,'+ contains the ',
' following elements'))
else
SAY(CAT('The class ',D_GEN_CLS,' contains the ',
' following elements')) ;
SAY(lit(' Element Generation Number'));
F_1ST_OUT = FALSE ;
END ; ! first time for printing
! print this record
STG(' ',FALSE,TRUE) ;
OUTSHW(.ELE_NAM_PTR,.ELE_LEN,FALSE,TRUE) ;
FILLSP(20 - .ELE_LEN) ;
OUTSHW(.GEN_PTR,.GEN_LEN,TRUE,TRUE) ;
IF
NOT .F_OUTPUT
THEN
F_OUTPUT = TRUE ;
END ! get elements in class
UNTIL
($step_get(IOB=aatf_iob,failure=0) EQL step$_eof);
IF
NOT .F_OUTPUT AND NOT .F_CLS_MAT
THEN
ERS(s_clnotfnd,CAT('Class ',D_GEN_CLS,' does not exist')) ;
IF
NOT .F_OUTPUT AND .F_CLS_MAT
THEN
ERS(s_enotincls,CAT('No elements exist in class ',D_GEN_CLS)) ;
END ; ! process *.*/brief/gen:classname[+]
IF
.F_WILD_REF AND NOT .F_CLS_REF
THEN
ERS(s_wldquals,CAT('/GEN:class-name and /BRIEF required with ',
'use of wild card')) ;
IF
.F_BRIEF_QUA AND .F_ELM_REF AND NOT .F_WILD_REF
THEN
ERS(s_brfwldcls,CAT('The ',SPELLING(K_BRIEF_QUAL),
' Qualifier must be ',
'accompanied by a wild card and a /GEN=class-name')) ;
IF
NOT .F_NO_PARM and not .f_wild_ref
THEN
BEGIN ! element name given
! verify that element is in control directory
if
(status=$STEP_OPEN(IOB=ccdir_iob,FILE_SPEC=(%STRING(LIB,CDIR)),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.status,lit('Cannot open definition file'));
UNTIL
$step_get(IOB=ccdir_iob,failure=0) EQL step$_eof
DO
BEGIN ! check for element match
! Check for control string
IF CH$EQL(4,CH$PTR(UPLIT('*/C:')),4,.ccdir_iob[IOB$A_STRING])
THEN
EXITLOOP;
! find length of element name
ELM_LEN = CH$FIND_CH(.ccdir_iob[IOB$H_STRING],
.ccdir_iob[IOB$A_STRING],%C' ') ;
IF
CH$FAIL(.ELM_LEN)
THEN
BUG(CAT('Bad record in the master control directory. ',
'There is no blank delimiter following the ',
'element name. The error occurred in the routine ',
'SHWGEN of module STSHOW')) ;
ELM_LEN = CH$DIFF(.ELM_LEN,.CCDIR_IOB[IOB$A_STRING]) ;
IF
(CH$COMPARE(LEN_COMMA_PTR(D_ELM_NAM),
.ELM_LEN,.ccdir_iob[IOB$A_STRING],
%C' ') NEQ 0)
THEN
F_ELM_FND = FALSE
ELSE
BEGIN !found
F_ELM_FND = TRUE ;
EXITLOOP ;
END; !found
END ; ! check for element match
$step_close(iob = ccdir_iob);
END ; ! element name given
IF
NOT .F_ELM_FND and not .f_wild_ref
THEN
BEGIN
local
d_log_nam : $str_desc(),
d_log_trn : $str_desc(),
log_trn_buf : vector[ch$allocation(log_nam_value_size)];
$str_desc_init(descriptor = d_log_nam,
string=(len_comma_ptr(lib)));
$str_desc_init(descriptor = d_log_trn,
string=(log_nam_value_size,ch$ptr(log_trn_buf)));
trnlog(d_log_nam,d_log_trn);
ERS(s_noelem,CAT(('Element '),d_elm_nam,
(' does not exist in the CMS library '),d_log_trn));
END;
IF
.F_ELM_FND and not .f_wild_ref
THEN
BEGIN ! element name exists
! translate class name on /from if present
IF
.F_FRM_QUA AND NOT
(CH$RCHAR(.D_FROM[DESC_PTR]) GEQ %C'0' AND
CH$RCHAR(.D_FROM[DESC_PTR]) LEQ %C'9')
THEN
BEGIN ! /from=class
! save pointer to from string
SAV_LEN = D_FROM[DESC_LEN] ;
SAV_PTR = D_FROM[DESC_PTR] ;
IF
NOT SETATR(LEN_COMMA_PTR(D_FROM))
THEN
ERS(s_clnotfnd,CAT('Class ',D_FROM,' does not exist'));
! now get memory for generation number
D_FROM[DESC_LEN] = GEN_SIZE ;
$XPO_GET_MEM(CHARACTERS=GEN_SIZE,RESULT=D_FROM[DESC_PTR]) ;
IF
NOT GETATR(LEN_COMMA_PTR(D_ELM_NAM),
D_FROM[DESC_LEN],.D_FROM[DESC_PTR])
THEN
ERS(s_enotincls,CAT('Element ',D_ELM_NAM,' does not exist ',
'in class ',(.SAV_LEN,.SAV_PTR))) ;
END ; ! /from=class
IF
.F_CLS_REF
THEN
BEGIN ! look for class in file
! save ptr and len in case of search failure
SAV_LEN = .D_GEN_CLS[DESC_LEN] ;
SAV_PTR = .D_GEN_CLS[DESC_PTR] ;
IF
NOT SETATR(LEN_COMMA_PTR(D_GEN_CLS))
THEN
ERS(s_clnotfnd,CAT('Class ',(.SAV_LEN,.SAV_PTR),
' does not exist')) ;
! get some memory for updated generation
D_GEN_CLS[DESC_LEN] = 50 ;
$XPO_GET_MEM(CHARACTERS=50,RESULT=D_GEN_CLS[DESC_PTR]) ;
! resolve class to gen ref and update descriptor
IF
NOT GETATR(LEN_COMMA_PTR(D_ELM_NAM),
D_GEN_CLS[DESC_LEN],.D_GEN_CLS[DESC_PTR])
THEN
ERS(s_enotincls,CAT('The element ',D_ELM_NAM,' does not exist',
' in class ',(.SAV_LEN,.SAV_PTR))) ;
END ; ! look for class in file
! element reference by itself
IF
.F_ELM_REF
THEN
BEGIN ! convert to 1+
IF
.SUB_COM NEQ K_DESCENDANTS_SUB
THEN
F_PLUS_OPR = TRUE ;
F_ELM_REF = FALSE;
$STR_DESC_INIT(DESCRIPTOR=D_GEN_CLS,STRING=('1')) ;
END ; ! convert to 1+
IF
.F_PLUS_OPR
THEN
BEGIN ! resolve plus operator
! prescan element file for resolution of plus operator
if
(status=$STEP_OPEN(IOB=RD_IOB,FILE_SPEC=D_ELM_NAM,DEFAULT=%STRING(LIB),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.status,CAT('Cannot open file ',d_elm_nam));
UNTIL
$step_get(IOB=RD_IOB,failure=0) EQL step$_eof
DO
BEGIN ! read element file record
! examine first character
IF
(CH$RCHAR(.RD_IOB[IOB$A_STRING]) NEQ %C'+')
THEN
EXITLOOP ;
! setup pointers to gen reference
GEN_LEN = CH$FIND_CH(.RD_IOB[IOB$H_STRING],
.RD_IOB[IOB$A_STRING],%C' ') ;
GEN_LEN = (CH$DIFF(.GEN_LEN,.RD_IOB[IOB$A_STRING]))-1 ;
GEN_PTR = CH$PLUS(.RD_IOB[IOB$A_STRING],1) ;
! if plus operator exists check for direct line of decent
IF
DIRDES(LEN_COMMA_PTR(D_GEN_CLS),
.GEN_LEN,.GEN_PTR)
THEN
BEGIN ! found plus generation
! save string representing plus generation
$XPO_GET_MEM(CHARACTERS=.GEN_LEN,
RESULT = P_PLUS_GEN) ;
CH$MOVE(.GEN_LEN,.GEN_PTR,.P_PLUS_GEN) ;
$STR_DESC_INIT(DESCRIPTOR=D_GEN_CLS,
STRING=(.GEN_LEN,.P_PLUS_GEN)) ;
F_PLUS_FND = TRUE ;
END ; ! found plus generation
END ; ! read element file record
$step_close(IOB=RD_IOB) ;
END ; ! resolve plus operator
! verify that plus generation was found
IF
NOT .F_PLUS_FND AND .F_PLUS_OPR
THEN
BEGIN
ers(s_genref,CAT('Generation ',
D_GEN_CLS,'+ does not exist')) ;
RETURN K_WARN_GEN ;
END ;
! open element file
$io_block_init(rd);
if
(status=$STEP_OPEN(IOB=RD_IOB,FILE_SPEC=D_ELM_NAM,DEFAULT=%STRING(LIB),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.status,cat('Cannot open file ',d_elm_nam));
F_OUTPUT = FALSE ;
! read loop of element file
UNTIL
$step_get(IOB=RD_IOB,failure=0) EQL step$_eof
DO
BEGIN ! element file record
! examine first character
IF
(CH$RCHAR(.RD_IOB[IOB$A_STRING]) NEQ %C'+')
THEN
EXITLOOP ;
! setup pointers to gen reference
GEN_LEN = CH$FIND_CH(.RD_IOB[IOB$H_STRING],
.RD_IOB[IOB$A_STRING],%C' ') ;
GEN_LEN = (CH$DIFF(.GEN_LEN,.RD_IOB[IOB$A_STRING]))-1 ;
GEN_PTR = CH$PLUS(.RD_IOB[IOB$A_STRING],1) ;
! initialize class found descriptor for GETCLS calls
$STR_DESC_INIT(DESCRIPTOR=D_CLS_FND,
STRING=(0,K_NULL)) ;
! get string of classes if it exists
IF
.F_INC_QUA OR .f_cl_qua
THEN
F_CLS_EXI = GETCLS(.GEN_LEN,.GEN_PTR,LEN_COMMA_PTR(D_ELM_NAM),
D_CLS_FND) ;
!+
! COMMAND SELECTION
!+
SELECTONE .SUB_COM OF
SET
[K_ANCESTORS_SUB]:
BEGIN ! check for ancestors
IF
CMPGEN(.GEN_PTR,.GEN_LEN,.D_GEN_CLS[DESC_PTR],
.D_GEN_CLS[DESC_LEN])
OR
CH$EQL(LEN_COMMA_PTR(D_GEN_CLS),.GEN_LEN,
.GEN_PTR,%C' ')
THEN
BEGIN ! valid ancestor
IF
.F_FRM_QUA AND
CH$EQL(LEN_COMMA_PTR(D_FROM),
.GEN_LEN,.GEN_PTR,%C' ')
THEN
F_EXT_PRT = TRUE ;
IF
.F_INC_QUA
THEN
BEGIN ! included qual
IF
.F_CLS_EXI
THEN
F_PRT_GEN = TRUE ;
END ! included qual
ELSE
F_PRT_GEN = TRUE ;
END ! valid ancestor
ELSE
F_CLS_EXI = FALSE ;
END ; ! check for ancestors
[K_DESCENDANTS_SUB]:
BEGIN ! check descendants
IF
CMPGEN(.D_GEN_CLS[DESC_PTR],.D_GEN_CLS[DESC_LEN],
.GEN_PTR,.GEN_LEN)
OR
CH$EQL(LEN_COMMA_PTR(D_GEN_CLS),.GEN_LEN,
.GEN_PTR,%C' ')
THEN
BEGIN ! valid descendent
IF
.F_INC_QUA
THEN
BEGIN ! included qualifier
IF
.F_CLS_EXI
THEN
F_PRT_GEN = TRUE ;
END ! included qualifier
ELSE
F_PRT_GEN = TRUE ;
! force read loop exit after target gen reached
IF
CH$EQL(LEN_COMMA_PTR(D_GEN_CLS),.GEN_LEN,
.GEN_PTR,%C' ')
THEN
F_EXT_PRT = TRUE ;
END ! valid descendant
ELSE
F_CLS_EXI = FALSE ;
END ; ! check descendants
[K_GENERATION_SUB]:
BEGIN ! check generation
IF
.F_GEN_REF OR .F_CLS_REF OR .F_PLUS_FND
THEN
BEGIN ! single generation reference
IF
CH$EQL(LEN_COMMA_PTR(D_GEN_CLS),
.GEN_LEN,.GEN_PTR,%C' ')
THEN
BEGIN ! generation match
F_PRT_GEN = TRUE ;
F_EXT_PRT = TRUE ;
END ! generation match
ELSE
F_CLS_EXI = FALSE ;
END ; ! single generation reference
END ; ! check generation
[OTHERWISE]: ;
TES ;
IF
.F_PRT_GEN
THEN
BEGIN ! common print code
GENLIN(LEN_COMMA_PTR(D_ELM_NAM),
.RD_IOB[IOB$H_STRING],
.RD_IOB[IOB$A_STRING]) ;
F_OUTPUT = TRUE ;
END ; ! common print code
! check for classes qual
IF
.F_CLS_EXI
THEN
BEGIN ! classes output req
STG(' ',FALSE,TRUE);
OUTSHW(.D_CLS_FND[DESC_PTR],
.D_CLS_FND[DESC_LEN],TRUE,TRUE) ;
END ; ! classes output req
IF
.F_EXT_PRT
THEN
EXITLOOP ;
! clear flag for next record read
F_PRT_GEN = FALSE ;
F_EXT_PRT = FALSE ;
F_CLS_EXI = FALSE ;
END ; ! element file record
$step_close(iob = rd_iob);
END ; ! element name exists
IF
NOT .F_OUTPUT AND
NOT .F_NO_PARM AND
.F_INC_QUA and not .f_wild_ref
THEN
BEGIN
sysmsg(s_geninv,CAT('No such generations in specified class'),0) ;
RETURN s_geninv;
END ;
IF
NOT .F_OUTPUT AND NOT .F_NO_PARM and not .f_wild_ref
THEN
ERS(s_genref,CAT('Generation ',D_GEN_CLS,' does not exist')) ;
IF
.F_NO_PARM and not .f_wild_ref
THEN
ERS(s_generr,CAT('Missing generation reference')) ;
! reset output to terminal
IF
.F_SPEC_OUT
THEN
BEGIN
IF
NOT (SETOUT(K_SAY_CLOSE,K_NULL,K_NULL))
THEN
BUG(CAT('Unable to close output file. Error occurred in ',
'routine SHWGEN of module STSHOW')) ;
END ;
s_shwsucc
END; ! end of routine SHWGEN
ROUTINE SHWVER(A_QUAL) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Display the current version of CMS.
!
! FORMAL PARAMETERS:
!
! a_qual : address of first parameter block
!
! IMPLICIT INPUTS:
!
! none
!
! IMPLICIT OUTPUTS:
!
! The current version of CMS is displayed on the terminal, or
! in a file if /output is specified.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! none
!
! SIDE EFFECTS:
!
! none
!
!--
BEGIN
!Examine qualifiers
if
not exqual (.a_qual)
then
return k_silent_error ;
!Tell users which version he's using
say(cat(verson())) ;
!Close special output file if necessary
if
.f_spec_out
then
if not setout(k_say_close, k_null, k_null)
then
bug(lit('SHWVER in STSHOW could not close output file')) ;
s_shwsucc
END; ! end of routine SHWVER
END !End of Module STSHOW
ELUDOM