Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/shwlg2.bli
There are no other files named shwlg2.bli in the archive.
MODULE SHWLG2 (
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: The CMS Library Processor
!
!
! ABSTRACT:
!
! This module contains service routines used by the SHWLOG module
! in processing the history file.
!
!
! ENVIRONMENT: VAX/VMS, DS-20
!
!
! AUTHOR: R. WHEATER CREATION DATE: 9-SEP-80
!
! MODIFIED BY:
!
!--
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
GETMEM : NOVALUE, ! simulate XPORT dynamic memory functions
! for efficiency
NMONTH, ! generate numer of month
PRSDAT, ! parse date string
PARSTR, ! parse string and generate descriptor of
! lexemes in the line
REFQUA:NOVALUE, ! generate reference qualifiers
SELELM; ! select element
!
! INCLUDE FILES:
!
%if %bliss(bliss32) %then
library 'sys$library:starlet';
%else
require 'jsys:';
%fi
LIBRARY 'XPORT:';
REQUIRE 'BLISSX:';
REQUIRE 'COMUSR:';
REQUIRE 'HOSUSR:';
REQUIRE 'SCONFG:';
REQUIRE 'SHWUSR:';
!
! MACROS:
!
!
! LITERALS:
!
LITERAL
INIT_MEM_ALLOC = 120 * K_LOG_FLD_FULL,
INCR_MEM_ALLOC = 120 * K_LOG_FLD_FULL,
%if %bliss(bliss32) %then
CHARS_PER_FULLWORD = 4
%fi
%if %bliss(bliss36) %then
CHARS_PER_FULLWORD = 5
%fi ;
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
!
! EXTERNAL REFERENCES:
!
EXTERNAL LITERAL
s_spellerr; !month is misspelled
EXTERNAL ROUTINE
ASCDEC, ! convert ASCII to decimal(ASCDEC)
BADLIB, ! print bad library message(BADLIB)
BUG, ! print bug message(TERMIO)
DEQUOT, ! remove quotes(QUOTES)
ENDQUO, ! find end of quoted string(STRING)
ERS, ! print error message(TERMIO)
GET_LXM; ! get next lexeme(GETLXM)
GLOBAL ROUTINE GETMEM ( N_CHARS, N_FULWRDS, A_RESULT, OP_FLAG ): NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine simulates the XPORT dynamic memory functions to
! avoid thrashing and improve efficiency.
!
! FORMAL PARAMETERS:
!
! N_CHARS - number of characters to allocate
! N_FULWRDS - number of fullwords to allocate
! A_RESULT - result pointer
! OP_FLAG - operation to perform, CLEAR, NO_CLEAR, FREE_MEM
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
BIND
RESULT = .A_RESULT;
OWN
FIRST_TIME : INITIAL (TRUE), !true if dynamic memory needed
FIR_MEM_BLOCK : INITIAL(K_NULL), !pointer(ptr) to first block in chain
MEM_LOC, !ptr to beginning of current block
MEM_NXT, !ptr to next avail. cell in cur. block
MEM_LST, !ptr to last cell in current block
REM,
ROUNDED_UP;
LABEL
ALLOCATE;
IF
.OP_FLAG EQL NO_CLEAR
THEN
WHILE TRUE DO
ALLOCATE:
BEGIN !allocate space
!consistency check -- must only ask for either fullwords or characters.
IF
NOT ( (.N_CHARS EQL 0 AND .N_FULWRDS GTR 0) OR
(.N_CHARS GTR 0 AND .N_FULWRDS EQL 0) )
THEN
BUG(CAT('illegal GETMEM call in routine GETMEM.'));
IF
.FIRST_TIME
THEN
!get initial memory block
BEGIN
FIRST_TIME = FALSE;
$XPO_GET_MEM( FULLWORDS=INIT_MEM_ALLOC, RESULT=MEM_LOC);
FIR_MEM_BLOCK = .MEM_LOC;
!forward pointer to next block initialized to null
.MEM_LOC = K_NULL;
MEM_NXT = .MEM_LOC + %UPVAL ;
! point to beginning of last fullword in addressable units
MEM_LST = .MEM_LOC + (INIT_MEM_ALLOC - 1) * %UPVAL ;
END;
!is there enough space in present block ?
IF
.N_FULWRDS NEQ 0
THEN
!check for space in units of fullwords.
BEGIN
IF
.N_FULWRDS LEQ (.MEM_LST - .MEM_NXT)/%UPVAL + 1
THEN
!space exists
BEGIN
RESULT = .MEM_NXT; !set up return pointer
!update available space ptr.
MEM_NXT = .MEM_NXT + .N_FULWRDS * %UPVAL;
RETURN
END; !space exists
END !check for space in units of fullwords.
ELSE
BEGIN
!check for space in units of characters
IF
.N_CHARS LEQ ( (.MEM_LST - .MEM_NXT)/%UPVAL + 1) * CHARS_PER_FULLWORD
THEN !space exists
BEGIN
RESULT = ch$ptr(.MEM_NXT); !set up return pointer
ROUNDED_UP = ch$allocation(.N_CHARS);
MEM_NXT = .MEM_NXT + .ROUNDED_UP * %UPVAL;
RETURN
END; !space exists
END;
!If we get to this point, there was not enough space in the current block.
! We must either allocate more space (if we have no more blocks) or jump
! to the next one (via the forward block pointer at the beginning of the
! present block).
IF
..MEM_LOC NEQ K_NULL
THEN
MEM_LOC = ..MEM_LOC ! Memory exists; point to it
ELSE
BEGIN ! Get more memory and point to it (put in next block ptr cell)
$XPO_GET_MEM( FULLWORDS=INCR_MEM_ALLOC, RESULT= .MEM_LOC);
MEM_LOC = ..MEM_LOC;
END;
.MEM_LOC = K_NULL; ! zero forward block pointer
MEM_NXT = .MEM_LOC + %UPVAL;
MEM_LST = .MEM_LOC + (INCR_MEM_ALLOC - 1) * %UPVAL;
!try again , but make sure this space will do.
! (don't forget to take the cell used for forward pointer into account.)
IF
(.N_FULWRDS GEQ INCR_MEM_ALLOC OR
.N_CHARS GTR (INCR_MEM_ALLOC - 1) * CHARS_PER_FULLWORD )
THEN
BUG(CAT('Unexpected memory size request - Routine GETMEM'));
! otherwise, everything ok -- try again
LEAVE ALLOCATE;
END; ! end ALLOCATE block
! check if clear memory function desired
IF
.OP_FLAG EQL CLEAR AND
.FIR_MEM_BLOCK NEQ K_NULL
THEN
BEGIN !re-use memory
MEM_LOC = .FIR_MEM_BLOCK; !point to first block of chain
MEM_NXT = .MEM_LOC + %UPVAL; !skip forward pointer cell
MEM_LST = .MEM_LOC + (INIT_MEM_ALLOC - 1) * %UPVAL;
RETURN
END;
! check if free memory function desired
IF
.OP_FLAG EQL FREE_MEM
THEN
BEGIN
LOCAL
LENGTH;
LENGTH = INIT_MEM_ALLOC;
WHILE
(.FIR_MEM_BLOCK NEQ K_NULL)
DO
BEGIN
FIR_MEM_BLOCK = ..MEM_LOC; !save pointer to next block
$XPO_FREE_MEM ( BINARY_DATA= (.LENGTH,.MEM_LOC) ); !free block
IF
.LENGTH EQL INIT_MEM_ALLOC
THEN
LENGTH = INCR_MEM_ALLOC;
! update pointer
MEM_LOC = .FIR_MEM_BLOCK;
END;
! reset first_time flag (to enable subsequent calls, if any)
FIRST_TIME = TRUE;
END;
END; !end routine GETMEM
GLOBAL ROUTINE NMONTH(LEN,PTR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will take the alphabetic string representing the
! the month of the year and convert it to numeric value between
! one and twelve. It is assumed that the month string is an
! alphabetic string.
!
! FORMAL PARAMETERS:
!
! LEN length of month string, for this implementation
! should be 3 characters.
!
! PTR pointer to month string
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! Number represent month of year.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
%if %bliss(bliss32) %then
BIND
DATTAB = UPLIT('JANFEBMARAPR','MAYJUNJULAUG','SEPOCTNOVDEC') ;
%fi
%if %bliss(bliss36) %then
BIND
DATTAB = UPLIT('JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC') ;
%fi
LOCAL
MONTAB: REF $UNIT_BLOCKVECTOR[12,K_MON_FLDS_UNITS] FIELD(MON_FLDS),
F_MONTH,
M_INDEX,
RETVAL ;
! initialize
F_MONTH = FALSE ;
MONTAB = DATTAB ;
M_INDEX = 0 ;
UNTIL
.M_INDEX EQL 12
DO
BEGIN ! loop thru months
IF
CH$EQL(.LEN,.PTR,3,CH$PTR(MONTAB[.M_INDEX,MONTH]),%C' ')
THEN
BEGIN ! month string match
RETVAL = .M_INDEX ;
F_MONTH = TRUE ;
EXITLOOP ;
END ; ! month string match
M_INDEX = .M_INDEX + 1 ;
END ; ! loop thru months
IF
NOT .F_MONTH
THEN
BEGIN
ERS(s_spellerr,CAT('Month ',(.LEN,.PTR),' is misspelled'));
RETURN -1 ;
END ;
.RETVAL
END; ! end of routine NMONTH
GLOBAL ROUTINE PARSTR(LEN,PTR,DELIM,A_DESCS,O_COUNT) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will parse a string into its component parts and
! build descriptors for each of the component parts. The delimiter
! between the component parts of the string may be specified.
! memory for these descriptors is allocated within this routine.
! Quoted strings are treated as single characters that are
! indivisable and thus the quote mark(") cannot be specified as
! a delimiter. It should also be noted that two delimiters may not
! appear adjacent to each other.
!
! FORMAL PARAMETERS:
!
! LEN Length of input string.
!
! PTR Pointer to input string.
!
! DELIM Delimiter between lexemes of input string.
!
! A_DESCS Address of blockvector of descriptors(output value).
!
! A_COUNT Number of lexemes in string(output value).
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE = successful completion.
! FALSE = error encountered in processing
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
OWN
CHAR, ! character found on the scan
COUNT, ! count of number of lexemes
%if %bliss(bliss32) %then
D_SEARCH_C: REF DESC_BLOCK, ! character set to search for
! on the scan operation
%fi
%if %bliss(bliss36) %then
d_search_c: desc_block ,
search_char :vector[ch$allocation(4)] ,
ptr_search,
%fi
D_UNQ_STR: DESC_BLOCK, ! portion of string containing
! no quotes
L_LXM, ! length of this lexeme
L_QUO_STR, ! length of quoted string
L_REMAIN, ! remaining length
L_SCAN_Q, ! length to scan for quoted string
P_DELIM, ! pointer to delimiter found on scan
P_STR_LXM, ! pointer to start of current lexeme
P_STR_QUO, ! pointer to start of quoted string
P_STR_SCAN, ! pointer to start of scan
R_LEX_TAB: REF BLOCKVECTOR[,K_LOG_FLD_FULL] FIELD(LOG_FLD),
! table of descriptors
STATUS, ! status returned from scan
T_INDX ; ! table index
LOCAL
L_STR, ! length of original string
P_STR; ! pointer to original string
! set up initial values
L_STR = .LEN ;
P_STR = .PTR ;
%if %bliss(bliss32) %then
D_SEARCH_C = CAT('"',(1,ch$ptr(DELIM))) ;
%fi
%if %bliss(bliss36) %then
ptr_search = ch$ptr(search_char) ;
ch$wchar_a(%c'"', ptr_search) ;
ch$wchar_a(.delim, ptr_search) ;
$str_desc_init ( descriptor = d_search_c,
string = (2,ch$ptr(search_char))) ;
%fi
$STR_DESC_INIT(DESCRIPTOR=D_UNQ_STR,STRING=(0,K_NULL)) ;
! delimiter of a quote is illegal
IF
.DELIM EQL %C'"'
THEN
BUG(CAT('Illegal parameter submitted to (PARSTR)')) ;
! now determine if the first character is delimiter
IF
CH$RCHAR(.P_STR) EQL .DELIM
THEN
BEGIN ! skip over delimiter
L_STR = .L_STR - 1 ;
P_STR = CH$PLUS(.P_STR,1) ;
END ; ! skip over delimiter
INCR PASS_N FROM 1 TO 2 BY 1 DO
BEGIN ! multipass loop
!+
! This block makes 2 passes over the string. The first
! pass is to count the number of lexemes in the line
! so as to acquire the right amount of dynamic memory
! for the descriptors. The second pass builds the
! descriptor for each of the lexemes in the line.
!-
IF
.PASS_N EQL 1
THEN
COUNT = 0
ELSE
! get memory
SIMULATE_XPOGETMEM(FULLWORDS=K_LOG_FLD_FULL * .COUNT,
RESULT=R_LEX_TAB) ;
! initialize working variable
L_REMAIN = .L_STR ;
P_STR_LXM = .P_STR ;
P_STR_SCAN = .P_STR_LXM ;
T_INDX = 0 ;
! main parsing loop to separate line into lexemes
UNTIL
.L_REMAIN EQL 0
DO
BEGIN ! find extend of current lexeme
! find a character in the set quote or delimiter
%if %bliss(bliss32) %then
STATUS = $STR_SCAN(STRING=(.L_REMAIN,.P_STR_SCAN),
STOP=.D_SEARCH_C,
SUBSTRING=D_UNQ_STR,
DELIMITER=CHAR,
FAILURE=0) ;
%fi
%if %bliss(bliss36) %then
! find a character in the set quote or delimiter
STATUS = $STR_SCAN(STRING=(.L_REMAIN,.P_STR_SCAN),
STOP=D_SEARCH_C,
SUBSTRING=D_UNQ_STR,
DELIMITER=CHAR,
FAILURE=0) ;
%fi
IF
.STATUS EQL STR$_END_STRING
THEN
BEGIN ! end of string
IF
.PASS_N EQL 1
THEN
BEGIN
COUNT = .COUNT + 1 ;
L_REMAIN = 0 ;
END
ELSE
BEGIN ! set up last descriptor
L_LXM = CH$DIFF(CH$PLUS(.P_STR_SCAN,.L_REMAIN),
.P_STR_LXM) ;
$STR_DESC_INIT(DESCRIPTOR=R_LEX_TAB[.T_INDX,LOG_COMP],
STRING=(.L_LXM,.P_STR_LXM)) ;
IF
.COUNT NEQ (.T_INDX + 1)
THEN
BUG(CAT('Count,index mismatch in (PARSTR)')) ;
! force loop exit
L_REMAIN = 0 ;
END ; ! set up last descriptor
END ; ! end of string
IF
.STATUS EQL STR$_NORMAL
THEN
BEGIN ! successful scan
SELECTONE .CHAR OF
SET
[%C'"']:
BEGIN ! start of quoted string
P_STR_QUO = CH$PLUS(.P_STR_SCAN,
.D_UNQ_STR[DESC_LEN]) ;
L_SCAN_Q = .L_REMAIN - .D_UNQ_STR[DESC_LEN] ;
L_QUO_STR = ENDQUO(.L_SCAN_Q,P_STR_QUO) ;
!+
! if no matching quote return whole string
!-
IF
.l_quo_str EQL -1
THEN
l_quo_str = .l_scan_q;
! skip to end of quoted string
P_STR_SCAN = CH$PLUS(.P_STR_QUO,.L_QUO_STR) ;
L_REMAIN = .L_REMAIN - .L_QUO_STR
- .D_UNQ_STR[DESC_LEN] ;
! check for quote at very end of string
IF
.L_REMAIN EQL 0
THEN
BEGIN ! quote ends string
IF
.PASS_N EQL 1
THEN
COUNT = .COUNT + 1
ELSE
BEGIN ! set up very last descriptor
L_LXM = CH$DIFF(.P_STR_QUO,.P_STR_LXM) +
. L_QUO_STR ;
$STR_DESC_INIT(DESCRIPTOR=R_LEX_TAB[.T_INDX,
LOG_COMP],
STRING=(.L_LXM,.P_STR_LXM));
END ; ! set up very last descriptor
END ; ! quote end string
END ; ! start of quoted string
[.DELIM]:
BEGIN ! end of lexeme
P_DELIM = CH$PLUS(.P_STR_SCAN,.D_UNQ_STR[DESC_LEN]) ;
IF
.PASS_N EQL 1
THEN
COUNT = .COUNT + 1
ELSE
BEGIN ! set up descriptor
L_LXM = CH$DIFF(.P_DELIM,.P_STR_LXM);
IF
.L_LXM LEQ 0
THEN
BUG(CAT('Zero length lexeme in (PARSTR)'))
ELSE
$STR_DESC_INIT(DESCRIPTOR=R_LEX_TAB[.T_INDX,LOG_COMP],
STRING=(.L_LXM,.P_STR_LXM)) ;
END; ! set up descriptor
! update pointer and length for next scan
P_STR_SCAN = CH$PLUS(.P_DELIM,1) ;
P_STR_LXM = .P_STR_SCAN ;
L_REMAIN = .L_REMAIN - .D_UNQ_STR[DESC_LEN] - 1 ;
T_INDX = .T_INDX + 1 ;
END ; ! end of lexeme
! [00] : ! null
! p_str_scan = ch$plus(.p_delim,1) ;
! p_str_lxm = .p_str_scan ;
! l_remain = .l_remain - .d_unq_str[desc_len] - 1;
! t_indx = .t_indx - 1 ;
[OTHERWISE]:
BUG(CAT('Scan stopped on illegal character')) ;
TES ;
END ; ! successful scan
! eliminate scan failures
IF
.STATUS EQL STR$_FAILURE
THEN
BUG(CAT('Unable to scan string ',(.LEN,.PTR))) ;
END ; ! find extent of current lexeme
END ; ! multipass loop
! set up output values
.A_DESCS = .R_LEX_TAB ;
.O_COUNT = .COUNT ;
TRUE
END ; ! end of routine parstr
GLOBAL ROUTINE PRSDAT(D_INSTR,A_DAYOUT,A_MONOUT,A_YROUT) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will parse the date into three separate fields:
! Day,Month,Year. All values returned are numberic.
!
! FORMAL PARAMETERS:
!
! D_INSTR Descriptor of input string containing date in
! which the components are separated by a hyphen(-)
!
! A_DAYOUT Address of location to store the day
!
! A_MONOUT Address of location to store the month
!
! A_YROUT Address of location to store the year
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! True = parsing completed successfully
! false = error in parsing date string
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
LOCAL
D_IN_STR: REF DESC_BLOCK, ! desc for input string
L_EXCESS, ! length of year too long
L_LXM, ! temp length of lexeme
L_TMP, ! temp length
L_UPC, ! length upper case string
P_BUF, ! pointer to buffer
P_TMP, ! temp pointer
P_UPC, ! pointer to upper case string
P_YR, ! temp pointer to year
M_TMP: VECTOR[CH$ALLOCATION(3)],
N_DAY, ! number representing day
N_MON, ! number representing month
N_YR ; ! number representing yr
! initialize working pointer and length
D_IN_STR = .D_INSTR ;
L_TMP = .D_IN_STR[DESC_LEN] ;
P_TMP = .D_IN_STR[DESC_PTR] ;
! get day out of date string
P_BUF = CH$PTR(M_TMP) ;
L_LXM = GET_LXM(P_TMP,%C'-',.L_TMP,P_BUF) ;
L_TMP = .L_TMP-.L_LXM-1 ;
P_BUF = CH$PTR(M_TMP) ;
IF
CH$RCHAR(.P_BUF) EQL %C' '
THEN
BEGIN ! skip prefix blank
P_BUF = CH$PLUS(.P_BUF,1) ;
L_LXM = .L_LXM - 1 ;
END ; ! skip prefix blank
! convert day to decimal and store
N_DAY = ASCDEC(P_BUF,.L_LXM) ;
IF
.N_DAY EQL -1
THEN
RETURN FALSE
ELSE
.A_DAYOUT = .N_DAY ;
! now get month
P_BUF = CH$PTR(M_TMP) ;
L_LXM = GET_LXM(P_TMP,%C'-',.L_TMP,P_BUF) ;
L_TMP = .L_TMP-.L_LXM-1 ;
! now convert to uppercase
P_UPC = CH$PTR(M_TMP) ;
L_UPC = .L_LXM ;
UNTIL
.L_UPC EQL 0
DO
BEGIN ! upper case conversion loop
IF
CH$RCHAR(.P_UPC) GTR %C'Z'
THEN
CH$WCHAR_A(CH$RCHAR(.P_UPC)-(%C'a'-%C'A'),P_UPC)
ELSE
P_UPC = CH$PLUS(.P_UPC,1) ;
L_UPC = .L_UPC - 1;
END ; ! upper case conversion loop
! put month in output area after converting to a numeric value
N_MON = NMONTH(.L_LXM,CH$PTR(M_TMP)) ;
IF
.N_MON EQL -1
THEN
RETURN FALSE
ELSE
.A_MONOUT = .N_MON ;
! extract year
IF
.L_TMP GTR 2
THEN
BEGIN ! year too big
L_EXCESS = .L_TMP - 2 ;
P_YR = CH$PLUS(.P_TMP,.L_EXCESS) ;
L_TMP = 2 ;
END ! year too big
ELSE
P_YR = .P_TMP ;
! store year in output area
N_YR = ASCDEC(P_YR,.L_TMP) ;
IF
.N_YR EQL -1
THEN
RETURN FALSE
ELSE
.A_YROUT = .N_YR ;
! normal return
TRUE
END; ! end of routine PRSDAT
GLOBAL ROUTINE REFQUA(A_D_COMMAND,A_D_QUAL):NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will find the qualifier that is to be display for
! a given command. On subsequent calls it will provide the next
! qualifier in the list. When the "SUB" qualifier is returned this
! means that the subcommand name is to be printed.
!
! FORMAL PARAMETERS:
!
! A_D_COMMAND Address of descriptor of command. If zero or k_null
! this indicates a call for the next qualifier. This
! parameter is the input to this routine.
!
! A_D_QUAL Address of descriptor of qualifier found. If zero or
! k_null, this indicates no more qualifiers in the table
! for this command. This is one of the output values for
! this routine.
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
LITERAL
SCAN_LEN = 50, ! max length of entry in DISTAB
TAB_LEN = 12 ; ! number of entries in DISTAB(NOTE:
! this number must be change if entries
! are added.
BIND
DISTAB = UPLIT ( %STRING (
SPELLING(K_COPY_COM),'#/SUB#*',
SPELLING(K_CREATE_COM),'#/SUB#',
SPELLING(K_KEEP_QUAL),'#',
SPELLING(K_RESERVE_QUAL),'#*',
SPELLING(K_DELETE_COM),'#/SUB#*',
SPELLING(K_FETCH_COM),'#',
SPELLING(K_MERGE_QUAL),'#*',
SPELLING(K_INITIALIZE_COM),'#*',
SPELLING(K_INSERT_COM),'#/SUB#',
SPELLING(K_SUPERSEDE_QUAL),'#*',
SPELLING(K_REMOVE_COM),'#*',
SPELLING(K_REPLACE_COM),'#',
SPELLING(K_KEEP_QUAL),'#',
SPELLING(K_RESERVE_QUAL),'#*',
SPELLING(K_RESERVE_COM),'#',
SPELLING(K_MERGE_QUAL),'#*',
SPELLING(K_SET_COM),'#/SUB#',
SPELLING(K_READ_QUAL),'#',
SPELLING(K_NOREAD_QUAL),'#*',
SPELLING(K_UNRESERVE_COM),'#',
SPELLING(K_DELETE_QUAL),'#*',
SPELLING(K_VERIFY_COM),'#',
SPELLING(K_RECOVER_QUAL),'#',
SPELLING(K_REPAIR_QUAL),'#****'
) ) ;
! If entries are added the above literals must be changed.
OWN
A_PARSED_ENT, ! address of parsed entry
D_IN_COM: REF DESC_BLOCK, ! desc for command input to routine
D_QUAL_OUT: DESC_BLOCK, ! desc for outputted qualifier
D_END_MARK: DESC_BLOCK, ! desc for end mark of display table
D_ENT_MARK: DESC_BLOCK, ! desc for entry mark of display table
D_UNU_QUAL: DESC_BLOCK, ! unusual string: /u
F_COM_INIT: INITIAL(FALSE), ! set when command provide on input
F_FIRST: INITIAL(TRUE), ! first time through flag
F_MATCH: INITIAL(FALSE), ! set when a match occurs
I_LAST_QUAL, ! index of last qualifier for entry
I_CUR,
L_TMP, ! temporary length
P_TMP, ! temp pointer
P_NXT_TMP, ! temp pointer,next position
R_PARSE_TAB: REF BLOCKVECTOR[,K_LOG_FLD_FULL] FIELD(LOG_FLD) ;
! table of log fields
IF
.F_FIRST
THEN
BEGIN ! setup
! initialize descriptors
$STR_DESC_INIT(DESCRIPTOR=D_IN_COM,STRING=(0,K_NULL)) ;
$STR_DESC_INIT(DESCRIPTOR=D_QUAL_OUT,STRING=(0,K_NULL)) ;
$STR_DESC_INIT(DESCRIPTOR=D_END_MARK,STRING=('#****')) ;
$STR_DESC_INIT(DESCRIPTOR=D_ENT_MARK,STRING=('#*')) ;
F_FIRST = FALSE ;
END ; ! setup
! eliminate bad calls
IF
(.A_D_COMMAND EQL K_NULL) AND NOT .F_COM_INIT
THEN
BUG(CAT('Bad call to REFQUA'));
IF
(.A_D_COMMAND NEQ K_NULL) AND .F_COM_INIT
THEN
BUG(CAT('Bad call to REFQUA'));
! check for initial command call
IF
NOT .F_COM_INIT
THEN
BEGIN ! command call
F_COM_INIT = TRUE ;
F_MATCH = FALSE ;
D_IN_COM = .A_D_COMMAND ;
! begin search for this command
P_TMP = CH$PTR(DISTAB) ;
INCR TB_INDX FROM 1 TO TAB_LEN BY 1 DO
BEGIN ! search table
P_NXT_TMP = CH$FIND_SUB(SCAN_LEN,.P_TMP,LEN_COMMA_PTR(D_ENT_MARK));
IF
CH$FAIL(.P_NXT_TMP) EQL 1
THEN
BUG(CAT('Unable to find marker in display table. Error ',
'occurred in routine REFQUA of module SHWLOG'))
ELSE
BEGIN ! found end of entry
! check for right command
IF
CH$EQL(.D_IN_COM[DESC_LEN],.D_IN_COM[DESC_PTR],
.D_IN_COM[DESC_LEN],.P_TMP,%C' ')
THEN
BEGIN ! matching command
L_TMP = CH$DIFF(.P_NXT_TMP,.P_TMP) ;
F_MATCH = TRUE ;
EXITLOOP ;
END ; ! matching command
IF
CH$EQL(4,.P_NXT_TMP,LEN_COMMA_PTR(D_END_MARK),%C' ')
THEN
! end of table
EXITLOOP ;
END ; ! found end of entry
! set up for checking next command
P_TMP = CH$PLUS(.P_NXT_TMP,.D_ENT_MARK[DESC_LEN]);
END ; ! search table
! check for match
IF
NOT .F_MATCH
THEN
BEGIN ! exit
.A_D_QUAL = K_NULL ;
F_COM_INIT = FALSE ;
RETURN ;
END ; ! exit
! parse table entry into its components
IF
NOT PARSTR(.L_TMP,.P_TMP,%C'#',R_PARSE_TAB,I_LAST_QUAL)
THEN
BUG(CAT('There was an error in processing the display table entry ',
'into its components; error occurred in routine ',
'REFQUA of module SHWLOG')) ;
IF
.I_LAST_QUAL EQL 1
THEN
BEGIN ! no qualifiers on this command
.A_D_QUAL = K_NULL ;
F_COM_INIT = FALSE ;
RETURN ;
END ; ! no qualifiers on this command
! now set descriptor for 2nd parsed entry and return
I_CUR = 1 ;
.A_D_QUAL = R_PARSE_TAB[.I_CUR,LOG_COMP] ;
RETURN ;
END ; ! command call
!+
! Subsequent call -> advance to next qual
!+
IF
.F_COM_INIT
THEN
BEGIN ! subsequent calls,advance
I_CUR = .I_CUR + 1 ;
IF
.I_CUR EQL .I_LAST_QUAL
THEN
BEGIN ! last qual on previous call
.A_D_QUAL = K_NULL ;
F_COM_INIT = FALSE ;
RETURN ;
END ! last qual on previous call
ELSE
.A_D_QUAL = R_PARSE_TAB[.I_CUR,LOG_COMP] ;
END ; ! subsequent call, advance
END; ! end of routine REFQUA
GLOBAL ROUTINE SELELM(LEN,PTR,A_D_ELMNAM) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine determines whether or not a routine a log record is
! is to be selected based on a request to select by element name.
!
! FORMAL PARAMETERS:
!
! LEN Length of this record
!
! PTR Pointer to this record
!
! A_D_ELMNAM Address of descriptor which points to the requested
! element name.
!
! IMPLICIT INPUTS:
!
! None
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE = record contains element name being selected upon
! FALSE = element name not in this record
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
!+
! The following tables are used to eliminate log records
! based on their command name and subcommand name since
! they do not contain an element name in the parameter
! string.
!-
BIND
COM_TAB = UPLIT(%STRING(
SPELLING(K_DIFFERENCES_COM),'#',
SPELLING(K_INITIALIZE_COM),'#',
SPELLING(K_SET_COM),'#',
SPELLING(K_VERIFY_COM),'#'
)) ;
BIND
SUB_TAB = UPLIT(%STRING(
SPELLING(K_CLASS_SUB),'#'
)) ;
LITERAL
L_SCAN = 20, ! length to scan in table(characters)
COM_TAB_LEN = 4, ! number of entries in command table
SUB_TAB_LEN = 1; ! number of entries in subcommand table
BIND
D_ELMNAM = .A_D_ELMNAM: DESC_BLOCK ;
OWN
A_DESC: REF BLOCKVECTOR[,K_LOG_FLD_FULL] FIELD(LOG_FLD),
! descriptors of parsed lexemes
COUNT, ! number of lexeme descriptors
D_COMMAND:DESC_BLOCK, ! command name
D_SUBCOM:DESC_BLOCK, ! subcommand name
D_PARM: DESC_BLOCK, ! parameters in line
D_REC_CPY: DESC_BLOCK ; ! make copy of input record
OWN
L_TMP, ! remaining length for string processing
L_SCN_QUO, ! length for scanning quoted strings
L_TAB_ENT, ! length of table entry
P_MARK, ! pointer to mark character
P_SCN_QUO, ! pointer to quoted string being scanned
P_SUB, ! pointer to substring
P_TAB_ENT, ! pointer to table entry
P_TMP ; ! pointer for string processing
! make copy of record since it will be altered by dequot
$STR_DESC_INIT(DESCRIPTOR=D_REC_CPY,STRING=(.LEN,K_NULL)) ;
$XPO_GET_MEM(CHARACTERS=.LEN,RESULT=D_REC_CPY[DESC_PTR]) ;
CH$MOVE(.LEN,.PTR,.D_REC_CPY[DESC_PTR]) ;
! initialize
L_TMP = .D_REC_CPY[DESC_LEN] ;
P_TMP = .D_REC_CPY[DESC_PTR] ;
! check for first character of a blank
IF
CH$RCHAR(.P_TMP) EQL %C' '
THEN
BEGIN
P_TMP = CH$PLUS(.P_TMP,1) ;
L_TMP = .L_TMP - 1 ;
END ;
! skip out to subcommand field
INCR INDX FROM 1 TO 4 BY 1 DO
BEGIN ! find blank and loop
P_SUB = CH$FIND_CH(.L_TMP,.P_TMP,%C' ') ;
IF
CH$FAIL(.P_SUB) EQL 1
THEN
BADLIB(CAT('Illegal record ',(.LEN,.PTR),' found in history ',
'file'));
! set up command descriptor
IF
.INDX EQL 4
THEN
$STR_DESC_INIT(DESCRIPTOR=D_COMMAND,
STRING=(CH$DIFF(.P_SUB,.P_TMP),.P_TMP)) ;
L_TMP = .L_TMP - CH$DIFF(.P_SUB,.P_TMP) - 1 ;
P_TMP = CH$PLUS(.P_SUB,1) ;
END ; ! find blank and loop
! pointer now at start of subcommand
IF
CH$RCHAR(.P_TMP) NEQ %C'"'
THEN
BUG(CAT('This routine cannot be called for an old format record'))
ELSE
BEGIN ! new format record
L_SCN_QUO = .L_TMP ;
P_SCN_QUO = .P_TMP ;
L_SCN_QUO = ENDQUO(.L_SCN_QUO,P_SCN_QUO) ;
$STR_DESC_INIT(DESCRIPTOR=D_SUBCOM,
STRING=(.L_SCN_QUO,.P_SCN_QUO)) ;
L_TMP = .L_TMP - .L_SCN_QUO - 1 ;
P_TMP = CH$PLUS(.P_TMP,.L_SCN_QUO + 1) ;
END ; ! new format record
! now start at parameter
L_SCN_QUO = .L_TMP ;
P_SCN_QUO = .P_TMP ;
L_SCN_QUO = ENDQUO(.L_SCN_QUO,P_SCN_QUO) ;
$STR_DESC_INIT(DESCRIPTOR=D_PARM,
STRING=(.L_SCN_QUO,.P_SCN_QUO)) ;
! dequote subcommand and parameter
DEQUOT(D_SUBCOM) ;
DEQUOT(D_PARM) ;
! parse subcommand string
IF
.D_SUBCOM[DESC_LEN] GTR 0 AND
PARSTR(.D_SUBCOM[DESC_LEN],.D_SUBCOM[DESC_PTR],
%C'/',A_DESC,COUNT)
THEN
BEGIN ! find subcommand
IF
CH$RCHAR(.A_DESC[0,LOG_COMP_PTR]) NEQ %C'/'
THEN
$STR_DESC_INIT(DESCRIPTOR=D_SUBCOM,
STRING=(.A_DESC[0,LOG_COMP_LEN],
.A_DESC[0,LOG_COMP_PTR])) ;
END ! find subcommand
ELSE
$STR_DESC_INIT(DESCRIPTOR=D_SUBCOM,STRING=(0,K_NULL)) ;
! now eliminate commands not containing an element name
P_TAB_ENT = CH$PTR(COM_TAB) ;
INCR INDX FROM 1 TO COM_TAB_LEN BY 1 DO
BEGIN ! scan the command table
P_MARK = CH$FIND_CH(L_SCAN,.P_TAB_ENT,%C'#') ;
IF
CH$FAIL(.P_MARK)
THEN
BUG(CAT('Internal error in log command table')) ;
L_TAB_ENT = CH$DIFF(.P_MARK,.P_TAB_ENT) ;
IF
CH$EQL(.L_TAB_ENT,.P_TAB_ENT,
.D_COMMAND[DESC_LEN],.D_COMMAND[DESC_PTR])
THEN
BEGIN
$XPO_FREE_MEM(STRING=(LEN_COMMA_PTR(D_REC_CPY))) ;
RETURN FALSE ;
END ;
P_TAB_ENT = CH$PLUS(.P_TAB_ENT,.L_TAB_ENT + 1) ;
END ; ! scan command table
! now eliminate subcommands that do not contain an element name
P_TAB_ENT = CH$PTR(SUB_TAB) ;
INCR INDX FROM 1 TO SUB_TAB_LEN BY 1 DO
BEGIN ! scan the subcommand table
P_MARK = CH$FIND_CH(L_SCAN,.P_TAB_ENT,%C'#') ;
IF
CH$FAIL(.P_MARK)
THEN
BUG(CAT('Internal error in log subcommand table')) ;
L_TAB_ENT = CH$DIFF(.P_MARK,.P_TAB_ENT) ;
IF
CH$EQL(.L_TAB_ENT,.P_TAB_ENT,
.D_SUBCOM[DESC_LEN],.D_SUBCOM[DESC_PTR])
THEN
BEGIN
$XPO_FREE_MEM(STRING=(LEN_COMMA_PTR(D_REC_CPY))) ;
RETURN FALSE ;
END ;
P_TAB_ENT = CH$PLUS(.P_TAB_ENT,.L_TAB_ENT + 1) ;
END ; ! scan command table
! parse it
IF
.D_PARM[DESC_LEN] GTR 0 AND
PARSTR(.D_PARM[DESC_LEN],.D_PARM[DESC_PTR],%C' ',
A_DESC,COUNT)
THEN
BEGIN ! check parameter for element name
IF
.COUNT GTR 0
THEN
BEGIN ! parse first parameter
IF
.A_DESC[0,LOG_COMP_LEN] GTR 0 AND
PARSTR(.A_DESC[0,LOG_COMP_LEN],.A_DESC[0,LOG_COMP_PTR],
%C'/',A_DESC,COUNT)
THEN
BEGIN ! search for element
P_SUB = CH$FIND_SUB(.A_DESC[0,LOG_COMP_LEN],
.A_DESC[0,LOG_COMP_PTR],
.D_ELMNAM[DESC_LEN],
.D_ELMNAM[DESC_PTR]) ;
IF
CH$FAIL(.P_SUB) EQL 1
THEN
BEGIN
$XPO_FREE_MEM(STRING=(LEN_COMMA_PTR(D_REC_CPY))) ;
RETURN FALSE ;
END
ELSE
BEGIN ! found string
IF
.P_SUB NEQA .A_DESC[0,LOG_COMP_PTR]
THEN
BEGIN
$XPO_FREE_MEM(STRING=(LEN_COMMA_PTR(D_REC_CPY))) ;
RETURN FALSE ;
END
ELSE
BEGIN
$XPO_FREE_MEM(STRING=(LEN_COMMA_PTR(D_REC_CPY))) ;
RETURN TRUE ;
END ;
END ; ! found string
END ; ! search for element
END ; ! parse first parameter
END ! check parameter for element name
ELSE
BUG(CAT('Unable to parse parameter string')) ;
TRUE
END; ! end of routine SELELM
END ! End of module
ELUDOM