Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/repfil.bli
There are no other files named repfil.bli in the archive.
MODULE REPFIL (
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:
!
! Compare a master file with a variation file and generate an updated
! master file showing all of the corrections or changes implied by the
! variation.
!
! ENVIRONMENT: VAX/VMS, DS-20
!
! AUTHOR: D. Knight , CREATION DATE: 10-Nov-78
!
!--
!++
! General Description
!
!nyi
!
! File Structures
!
!nyi
!
! Data Structures
!
!nyi
!
!--
!
! TABLE OF CONTENTS
!
FORWARD ROUTINE
REPFIL, !Basic REPLACE algorithm
CHK_MST : NOVALUE, !Check master file line for inclusion or exclusion
CHR_FOUND, !Check input record for chronology information
GET_CUR_MST, !Get a line from the master buffer
GET_L_NOAUDIT, !Get line and remove audit marks if any
OUTDIFF: NOVALUE, !Output the differences found to the output file
SETUP, !Initialize the world
TERMINATE : NOVALUE, !Terminate the world
TSTGEN; !Check generation for legal form
!
! INCLUDE FILES:
!
%if
%bliss(bliss32)
%then
library 'sys$library:starlet';
%else
require 'jsys:';
%fi
LIBRARY 'XPORT:'; !XPORT I/O macros
REQUIRE 'SCONFG:'; !configuration options
REQUIRE 'BLISSX:';
REQUIRE 'COMUSR:';
REQUIRE 'HOSUSR:';
!
! MACROS:
!
MACRO
STG(L,M) = OUTSTG(CH$PTR(UPLIT(L)),%CHARCOUNT(L),M) %;
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
OWN
BAD_AUDIT, !Number of bad audit marks seen
FIRST_CALL : INITIAL(0), !Set to 1 for first call only
I_OPN, !Input file open flag
KEEP, !CHK_MST keep flag
M_OPN, !Master file open flag
O_OPN; !Output file open flag
!
! EXTERNAL REFERENCES:
!
!Source audit pattern string control
EXTERNAL
CHRLEN, !Non-zero if chronology (history) needs watching
CHR_LS, !Left chronology pattern pointer
CHR_LLS, !Left chronology pattern length
CHR_RS, !Right chronology pattern pointer
CHR_LRS, !Right chronology pattern length
PAT_FIL,
PAT_GEN,
PAT_LS,
PAT_LLS,
PATPOS,
PAT_RS,
PAT_LRS;
EXTERNAL
in_crc_total, ! Total CRC so for for input file
lib_rd_flg, !indicates that the master file is a lib file
calc_crc, ! Calculated CRC to be placed in output file
CHANGES, !Set to true if user made changes to file
f_perf_crc, !Perform CRC calc. in OUTSTG if on
GEN_BUF, !Address of buffer where generation reserved is stored
GEN_LGT, !Length of string in GEN_BUF
ignore_control,
INPUT_IOB : $XPO_IOB(), !Variation file IOB
LIN_MST, !Current line in master buffer
LIN_VAR, !Current line in variation buffer
L_LN_MST, !Last line in master buffer
L_LN_VAR, !Last line in variation buffer
MASTER_IOB : $XPO_IOB(), !Master file IOB
MAX_G_LGT, !Longest generation string that can be seen
MST_EOF, !EOF seen on master file
MST_PTR: REF VECTOR, !Source buffer pointer
MST_SEQ, !master file has sequence information
NOTLEN, !Length of note string
USE_NOTES, !Process notes if true, don't if false
OUTPUT_IOB : $XPO_IOB(), !Output file IOB
RESRPTR, !Pointer to generation reserved string
RESRSIZ, !size of generation reserved string
USR_REM : REF DESC_BLOCK, !Pointer to location of user remark
VAR_EOF, !EOF seen on variation file
VARIANT,
VAR_PTR: REF VECTOR; !Variation buffer pointer
!Error control
EXTERNAL LITERAL
s_biggen, !generation string too long
s_gnconflct, !gen conflicts w/existing gen
s_illeftmar, !illegal left margin audits
s_noopen, !not able to open
s_unexphis; !Unexpected history record
EXTERNAL ROUTINE
BADLIB, !Error in library
BADXPO, !XPORT error in library
BUG, !Error
BYEXPO, !XPORT error
ERS, !User error
ERSXPO; !XPORT user error
EXTERNAL ROUTINE
ASCDEC, !Convert ASCII to decimal
CHKGEN, !Process generation expression
CMPINI, !Set up comparison algorithm
CMPTXT, !Text comparison processor
CRCTABLE : NOVALUE, ! Set up polynomial table for CRC
DATTIM, !Get current date and time
DECASC, !Decimal to ASCII
GEN_SETUP, !Initialize CHKGEN
GETACT, !Get user's name
GET_CGEN, !Get correct sequence number for this generation
GET_LXM, !Get text lexeme
get_mst_line, ! get a line from the master file
GET_STG_CT, !Get size of string
HEXASZ, !Convert hex to ASCII
OUTINI, !Initialize text output
OUTNUM, !Output decimal field
OUTSTG, !Output text string
PACK, !Repack buffers
PAT_SETUP, !Set up source audit pattern
TRNFIL; !Set protection, etc.
GLOBAL ROUTINE REPFIL (FIL_NAM_LGT,FIL_NAM_STR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Compare two files, one being the "master", the other
! being the "variation". Generate an updated master file from the
! differences.
!
! The algorithm is relatively simple. First, look for two lines that
! match in the two files. Once they are found, make sure that they
! comprise a unique match, namely, there are no other lines which
! could also match similarly (if they are not unique, assume that no
! match exists). Once a unique match is found, scan the text backwards
! and find as many matching lines as possible (this gets rid of redundant
! non-unique matches). This establishes the boundaries of matched lines
! which then can be passed to OUTDIFF to place in the output file.
!
! The purpose of this procedure is to prevent false matches which may
! occur because of multiple blank lines or multiple lines of "boilerplate"
! which so often occur and cause unwarranted matches.
!
! FORMAL PARAMETERS:
!
! FIL_NAM_LGT - length of file name to be processed
! FIL_NAM_STR - pointer to file name to be processed
!
! IMPLICIT INPUTS:
!
! L_LN_MST - last line +1 in master buffer
! L_LN_VAR - last line +1 in variation buffer
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! Standard GETELM returns as described in SCONFG.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
RETVAL; !Return value temp
!Mark first time through
FIRST_CALL=.FIRST_CALL+1;
! Set up CRC table
crctable();
! Turn on Flag so CRC will get calculated in OUTSTG
f_perf_crc = true;
ignore_control = true;
calc_crc = 0;
! also initialize to compute the crc of the input file
in_crc_total = 0;
lib_rd_flg = true;
!Start up the world
IF
NOT SETUP(.FIL_NAM_LGT,.FIL_NAM_STR)
THEN
BEGIN
TERMINATE();
RETURN G_ERMSG
END;
!Generate the updated master file
!This always starts at the beginning
RETVAL=CMPTXT(L_LN_MST,L_LN_VAR);
!All is complete, exit quietly
TERMINATE();
!tell user if his left margin audits were funny
IF
.BAD_AUDIT NEQ 0
THEN
ERS(s_illeftmar,CAT(('Illegal left margin notes in '),
(.FIL_NAM_LGT,.FIL_NAM_STR)));
.RETVAL
END; !End of REPFIL
ROUTINE CHK_MST (SRC_PTR,S_SIZ) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Keep track of any lines in the master file which have been
! inserted or deleted by the respective generations. Mark the
! line if it is useable for the comparisons to follow.
! Note that this routine keeps its own stack of information about
! the input data, so don't try to pass it lines not in sequence, or
! don't try to back up using it.
!
! FORMAL PARAMETERS:
!
! SRC_PTR - pointer to line of text from master file
! S_SIZ - number of characters in line.
!
! IMPLICIT INPUTS:
!
! Information is kept about the previous lineage commands which have
! been encountered, this is used to keep overall track of the insertion
! or deletion status.
!
! IMPLICIT OUTPUTS:
!
! The stack is updated to reflect the current insertion or deletion status.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! The control character position (column 1) is set to "-" if the line
! can be used for further comparisons.
!
!--
BEGIN
LOCAL
S_L_PTR, !Working line pointer
TAG; !Character at start of line is stored here
!Remember start of line
S_L_PTR=.SRC_PTR;
!Get tag character
TAG=CH$RCHAR_A(S_L_PTR);
!Ignore header control line
IF
CH$EQL(3,CH$PTR(UPLIT('*/S')),.S_SIZ,.SRC_PTR)
THEN
RETURN;
IF
CH$EQL(4,CH$PTR(UPLIT('*/C:')),4,.SRC_PTR)
THEN
RETURN;
!See if it is a control command
IF
.TAG EQL %C'*'
THEN
!Return with the status of the command
RETURN CHKGEN(S_L_PTR,.S_SIZ-1,KEEP,CH$PTR(GEN_BUF),.GEN_LGT)
ELSE
!A data line has a blank control character
!Output the line without the blank
IF
.TAG EQL %C' '
THEN
!Data line
BEGIN
IF
.KEEP
THEN
!Mark line as being useful and go away
CH$WCHAR(%C'-',.SRC_PTR)
END
ELSE
!Anything left over in column 1 other than "+" is an error
IF
.TAG NEQ %C'+'
THEN
!Error in library file
BADLIB(LIT('Illegal control record in library file.'))
!Comment lines (+) are discarded automatically by being ignored
END; !End of CHK_MST
ROUTINE CHR_FOUND =
!++
! FUNCTIONAL DESCRIPTION:
!
! See if a line is a source history line at the end of the file.
! If it appears to be so, continue to read lines until the actual
! end of file occurs. All lines must be acceptable as history lines
! or there is a serious error.
!
! FORMAL PARAMETERS:
!
! NONE.
!
! IMPLICIT INPUTS:
!
! INPUT_IOB - pointer to IOB which has line of interest.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - Chronology was found and processed.
! FALSE - Line was not a chronology line.
!
! SIDE EFFECTS:
!
! If history records are seen, no more lines will be allowed to
! be processed, (CHR_FOUND will drop them in the bit-bucket
! automatically).
!
!--
BEGIN
BIND
MSG_LEN=%charcount(fac_name)+22,
MSG_STG=UPLIT(%string(' ',fac_name,' REPLACEMENT HISTORY '));
LOCAL
COMPLETION,
HST_LEN,
HST_PTR;
HST_LEN=.INPUT_IOB[IOB$H_STRING];
HST_PTR=.INPUT_IOB[IOB$A_STRING];
!Look for left part correspondence
IF
NOT (.CHR_LLS EQL .HST_LEN-MSG_LEN-.CHR_LRS AND
CH$EQL(.HST_LEN-MSG_LEN-.CHR_LRS,.HST_PTR,.CHR_LLS,CH$PTR(CHR_LS)))
THEN
RETURN FALSE;
!Advance over left part
HST_PTR=CH$PLUS(.HST_PTR,.CHR_LLS);
HST_LEN=.HST_LEN-.CHR_LLS;
!Look for message correspondence
IF
NOT (MSG_LEN EQL .HST_LEN-.CHR_LRS AND
CH$EQL(MSG_LEN,CH$PTR(MSG_STG),.HST_LEN-.CHR_LRS,.HST_PTR))
THEN
RETURN FALSE;
!Advance over message
HST_PTR=CH$PLUS(.HST_PTR,MSG_LEN);
HST_LEN=.HST_LEN-MSG_LEN;
!Check for right part
IF
NOT (.CHR_LRS EQL .HST_LEN AND
CH$EQL(.HST_LEN,.HST_PTR,.CHR_LRS,CH$PTR(CHR_RS)))
THEN
RETURN FALSE;
!+
! At this point we have seen a valid header line, it is now necessary
! to validate (and throw away) the rest of the lines in the history.
!-
!+
! Check all of the lines which follows.
! Issue an error if a nonblank line does not
! start and end with history markers.
!-
UNTIL
$step_get(IOB=INPUT_IOB) EQL STEP$_EOF
DO
BEGIN
HST_LEN=.INPUT_IOB[IOB$H_STRING];
HST_PTR=.INPUT_IOB[IOB$A_STRING];
!Is the line non-blank ?
IF
.hst_len GTR 0
THEN
BEGIN
IF
.HST_LEN LSS .CHR_LLS+.CHR_LRS
THEN
ERS(s_unexphis,CAT('Unexpected line in history, "',
(.hst_len,.hst_ptr),'"'));
!Left part must match
IF
CH$NEQ(.CHR_LLS,CH$PTR(CHR_LS),.CHR_LLS,.HST_PTR)
THEN
ERS(s_unexphis,CAT('Unexpected line in history, "',
(.hst_len,.hst_ptr),'"'));
!Right part must match too (ignore remainder of text)
IF
CH$NEQ(.CHR_LRS,CH$PTR(CHR_RS),.CHR_LRS,CH$PLUS(.HST_PTR,.HST_LEN-.CHR_LRS))
THEN
ERS(s_unexphis,CAT('Unexpected line in history, "',
(.hst_len,.hst_ptr),'"'));
END;
END;
TRUE
END; !End of CHR_FOUND
ROUTINE GET_CUR_MST (LINE_NUM) =
!++
! FUNCTIONAL DESCRIPTION:
!
! See if a master line is a legal text line which can be processed
!
! FORMAL PARAMETERS:
!
! LINE_NUM - line number of line in master buffer
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - line is legal line for processing
! FALSE - line is not to be processed
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
S_L_PTR, !Working line pointer
S_SIZ, !Working line size
TAG; !Character at start of line is stored here
!Is this the null line at the bitter end?
IF
.LINE_NUM GEQ .L_LN_MST
THEN
RETURN FALSE;
IF
.LINE_NUM LSS .LIN_MST
THEN
BUG(LIT('LINE_NUM out of range in GET_CUR_MST.'));
!Read a line
S_L_PTR=.MST_PTR[.LINE_NUM-.LIN_MST];
S_SIZ=GET_STG_CT(S_L_PTR);
!Get tag character
TAG=CH$RCHAR_A(S_L_PTR);
!If the line starts with a "-", it is legal.
.TAG EQL %C'-'
END; !End of GET_CUR_MST
ROUTINE GET_L_NOAUDIT (LGT,PTR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Get a variation line from the input file
!
! FORMAL PARAMETERS:
!
! LGT - address of cell where length is to be placed
! PTR - address of cell where pointer to data is placed
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - line is legal line for processing
! FALSE - line is not to be processed
!
! SIDE EFFECTS:
!
! Any source audit marks which may exist on the line are removed.
!
!--
BEGIN
OWN
COMPLETION; !XPORT completion code
!Read a line
COMPLETION=$step_get(IOB=INPUT_IOB,FAILURE=0);
!If history is enabled, look for chronology records which need
!discarding.
IF
.CHRLEN NEQ 0
THEN
BEGIN
IF
CHR_FOUND()
THEN
!Fake an end-of-file
RETURN STEP$_EOF
END;
IF
.NOTLEN NEQ 0 AND
.USE_NOTES
THEN
!Pattern exists, watch for audit marks and remove them
!if they exist
BEGIN
LOCAL
LIN_LGT, !Length of source line
LIN_PTR; !Pointer to source line
LIN_LGT=.INPUT_IOB[IOB$H_STRING];
LIN_PTR=.INPUT_IOB[IOB$A_STRING];
IF
.PATPOS EQL 0
THEN
!Left margin audit, remove the audit field
BEGIN
LOCAL
CHAR,
COUNT,
FILL_SEEN;
FILL_SEEN=FALSE;
!Blank line needs no checking
IF
.LIN_LGT EQL 0
THEN
BEGIN
.PTR=.LIN_PTR;
.LGT=.LIN_LGT;
RETURN .COMPLETION
END;
!if line is too short, set message flag and go away
COUNT=0;
REPEAT
BEGIN
CHAR=CH$RCHAR_A(LIN_PTR);
LIN_LGT=.LIN_LGT-1;
IF
.CHAR EQL %C' '
THEN
COUNT=.COUNT-(.COUNT MOD 8)+8
ELSE
IF
.CHAR EQL %C' '
THEN
COUNT=.COUNT+1
ELSE
EXITLOOP;
IF
.COUNT EQL .PAT_FIL
THEN
!We are at the end of the field, so quit
BEGIN
.PTR=.LIN_PTR;
.LGT=.LIN_LGT;
RETURN .COMPLETION
END
ELSE
IF
.COUNT GTR .PAT_FIL
THEN
EXITLOOP
END;
!Reset pointer to start of line
LIN_PTR=.INPUT_IOB[IOB$A_STRING];
LIN_LGT=.INPUT_IOB[IOB$H_STRING];
COUNT=0;
!look for left part of pattern
IF
.PAT_LLS NEQ 0
THEN
BEGIN
IF
CH$NEQ(.PAT_LLS,CH$PTR(PAT_LS),.PAT_LLS,.LIN_PTR)
THEN
BEGIN
BAD_AUDIT=.BAD_AUDIT+1;
.PTR=.LIN_PTR;
.LGT=.LIN_LGT;
RETURN .COMPLETION
END;
!Skip over left part
LIN_PTR=CH$PLUS(.LIN_PTR,.PAT_LLS);
LIN_LGT=.LIN_LGT-.PAT_LLS;
COUNT=.COUNT+.PAT_LLS
END;
!See if generation exists
IF
.PAT_GEN
THEN
BEGIN
LOCAL
G_FLD_LEN;
G_FLD_LEN=.PAT_FIL-.PAT_LLS-.PAT_LRS-1;
!Now check the generation number for believability
IF
NOT TSTGEN(.G_FLD_LEN,.LIN_PTR)
THEN
BEGIN
BAD_AUDIT=.BAD_AUDIT+1;
.PTR=.INPUT_IOB[IOB$A_STRING];
.LGT=.INPUT_IOB[IOB$H_STRING];
RETURN .COMPLETION
END;
!Skip over generation field
LIN_PTR=CH$PLUS(.LIN_PTR,.G_FLD_LEN);
LIN_LGT=.LIN_LGT-.G_FLD_LEN;
COUNT=.COUNT+.G_FLD_LEN
END;
!See if right part exists
IF
.PAT_LRS NEQ 0
THEN
BEGIN
FILL_SEEN=FALSE;
IF
CH$NEQ(.PAT_LRS,CH$PTR(PAT_RS),.PAT_LRS,.LIN_PTR)
THEN
BEGIN
BAD_AUDIT=.BAD_AUDIT+1;
.PTR=.INPUT_IOB[IOB$A_STRING];
.LGT=.INPUT_IOB[IOB$H_STRING];
RETURN .COMPLETION
END;
!Skip over right part
LIN_PTR=CH$PLUS(.LIN_PTR,.PAT_LRS);
LIN_LGT=.LIN_LGT-.PAT_LRS;
COUNT=.COUNT+.PAT_LRS
END;
!Now that it matches, make sure there is trailing white space
WHILE
BEGIN
CHAR=CH$RCHAR(.LIN_PTR);
.COUNT LSS .PAT_FIL AND
(.CHAR EQL %C' ' OR
.CHAR EQL %C' ')
END
DO
BEGIN
LIN_PTR=CH$PLUS(.LIN_PTR,1);
LIN_LGT=.LIN_LGT-1;
FILL_SEEN=TRUE;
IF
.CHAR EQL %C' '
THEN
COUNT=.COUNT-(.COUNT MOD 8)+8
ELSE
COUNT=.COUNT+1;
IF
.LIN_LGT EQL 0
THEN
EXITLOOP
END;
IF
.COUNT EQL .PAT_FIL AND
.FILL_SEEN AND
.LIN_LGT GEQ 0
THEN
BEGIN
.PTR=.LIN_PTR;
.LGT=.LIN_LGT;
RETURN .COMPLETION
END
ELSE
BEGIN
BAD_AUDIT=.BAD_AUDIT+1;
.PTR=.INPUT_IOB[IOB$A_STRING];
.LGT=.INPUT_IOB[IOB$H_STRING];
RETURN .COMPLETION
END
END
ELSE
!Right margin audit
BEGIN
LOCAL
FILL_SEEN;
FILL_SEEN=FALSE;
!If line is too short for audit, go away with the raw line
IF
BEGIN
IF
.PAT_GEN
THEN
.PAT_LRS+.PAT_LLS+.MAX_G_LGT GTR .LIN_LGT
ELSE
.PAT_LLS+.PAT_LRS GTR .LIN_LGT
END
THEN
BEGIN
.PTR=.INPUT_IOB[IOB$A_STRING];
.LGT=.INPUT_IOB[IOB$H_STRING];
RETURN .COMPLETION
END;
!Point to end of line
LIN_PTR=CH$PLUS(.LIN_PTR,.LIN_LGT);
!See if right part of pattern exists
IF
.PAT_LRS NEQ 0
THEN
BEGIN
!Back up over right part of pattern
LIN_PTR=CH$PLUS(.LIN_PTR,-.PAT_LRS);
!Make sure right part matches pattern
IF
CH$NEQ(.PAT_LRS,CH$PTR(PAT_RS),.PAT_LRS,.LIN_PTR)
THEN
BEGIN
.PTR=.INPUT_IOB[IOB$A_STRING];
.LGT=.INPUT_IOB[IOB$H_STRING];
RETURN .COMPLETION
END
END;
!Back up over generation and left part of pattern
IF
.PAT_GEN
THEN
LIN_PTR=CH$PLUS(.LIN_PTR,-(.PAT_LLS+.MAX_G_LGT))
ELSE
LIN_PTR=CH$PLUS(.LIN_PTR,-(.PAT_LLS+.PAT_LRS));
!See if left part of pattern exists
IF
.PAT_LLS NEQ 0
THEN
BEGIN
!Make sure left part matches
IF
CH$NEQ(.PAT_LLS,CH$PTR(PAT_LS),.PAT_LLS,.LIN_PTR)
THEN
!No match, return raw line
BEGIN
.PTR=.INPUT_IOB[IOB$A_STRING];
.LGT=.INPUT_IOB[IOB$H_STRING];
RETURN .COMPLETION
END
END;
!Now check the generation number for believability
IF
.PAT_GEN
THEN
BEGIN
IF
NOT TSTGEN(.MAX_G_LGT,CH$PLUS(.LIN_PTR,.PAT_LLS))
THEN
BEGIN
.PTR=.INPUT_IOB[IOB$A_STRING];
.LGT=.INPUT_IOB[IOB$H_STRING];
RETURN .COMPLETION
END
END;
!We now have a complete match, back up over any filler
LIN_PTR=CH$PLUS(.LIN_PTR,-1);
WHILE
BEGIN
LOCAL
CHAR;
CHAR=CH$RCHAR(.LIN_PTR);
.CHAR EQL %C' ' OR
.CHAR EQL %C' '
END
DO
BEGIN
LIN_PTR=CH$PLUS(.LIN_PTR,-1);
FILL_SEEN=TRUE
END;
!There are no filler characters left, compute the line
!length left over and return
.PTR=.INPUT_IOB[IOB$A_STRING];
!If there is no fill, audit cannot be legal
IF
NOT .FILL_SEEN
THEN
.LGT=.INPUT_IOB[IOB$H_STRING]
ELSE
.LGT=CH$DIFF(.LIN_PTR,.INPUT_IOB[IOB$A_STRING])+1
END
END
ELSE
!There is no pattern string, simply return the raw line
BEGIN
.PTR=.INPUT_IOB[IOB$A_STRING];
.LGT=.INPUT_IOB[IOB$H_STRING];
END;
.COMPLETION
END; !End of GET_L_NOAUDIT
ROUTINE OUTDIFF (M_LINE,V_LINE) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Output any differences between the master and variation files seen
! so far. This recognizes both deletions and insertions. Comments
! and control lines are ignored (and output).
!
! Note that the two lines pointed to by M_LINE and V_LINE are
! always either a match or are the end of buffer.
!
! FORMAL PARAMETERS:
!
! M_LINE - Source line pointer
! V_LINE - Variation line pointer
!
! IMPLICIT INPUTS:
!
! The lines of text are stored in the master and variation buffers.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! PACK is called to repack the buffer and get rid of the lines that
! have been output.
!
!--
BEGIN
LOCAL
L_PTR, !pointer to working line
L_SIZ, !size of working line
TXT_SEEN; !TRUE means that text has been
!seen which needs to be bounded by
!"*" control commands
IF
.M_LINE EQL -1 AND
.V_LINE EQL -1
THEN
BUG(LIT('Two null OUTDIFF pointers (REPFIL).'));
!Check for potential bug
IF
.M_LINE LSS .LIN_MST AND
.M_LINE NEQ -1
THEN
BUG(LIT('Master line pointer out of range in OUTDIFF (REPFIL).'));
IF
.V_LINE LSS .LIN_VAR AND
.V_LINE NEQ -1
THEN
BUG(LIT('Variation line pointer out of range in OUTDIFF (REPFIL).'));
!Process line deletions from master text.
!Skip over leading comments and control records
!No text seen so far
TXT_SEEN=FALSE;
!Run through the master text and process any deletions
IF
.M_LINE NEQ -1
THEN
BEGIN
INCR I FROM .LIN_MST TO .M_LINE-1 DO
!Process one master line
BEGIN
!Get one line
L_PTR=.MST_PTR[.I-.LIN_MST];
L_SIZ=GET_STG_CT(L_PTR);
!Ignore control and comment lines
IF
CH$RCHAR(.L_PTR) NEQ %C'-'
THEN
BEGIN
!Terminate the deletion if we have seen text
IF
.TXT_SEEN
THEN
BEGIN
STG('*',FALSE);
OUTSTG(CH$PTR(GEN_BUF),.GEN_LGT,FALSE);
STG('E',TRUE);
TXT_SEEN=FALSE
END
END
ELSE
BEGIN
!Remember that changes have been made for later message
CHANGES=TRUE;
!See if command character needs to be issued
IF
NOT .TXT_SEEN
THEN
!Issue control command
BEGIN
STG('*',FALSE);
OUTSTG(CH$PTR(GEN_BUF),.GEN_LGT,FALSE);
STG('D',TRUE);
TXT_SEEN=TRUE
END;
!Convert tag marker from '-' to ' ' if it exists
IF
CH$RCHAR(.L_PTR) EQL %C'-'
THEN
CH$WCHAR(%C' ',.L_PTR)
END;
!If input file is sequenced and master file is not, make
!sure all text entries get a sequence marker added.
IF
NOT .MST_SEQ AND
.INPUT_IOB[IOB$V_SEQUENCED] AND
CH$RCHAR(.L_PTR) EQL %C' '
THEN
BEGIN
!Skip over original character
CH$RCHAR_A(L_PTR);
L_SIZ=.L_SIZ-1;
!Put out modified control
STG(' 1;',FALSE)
END;
!Put out the line of text
OUTSTG(.L_PTR,.L_SIZ,TRUE)
END;
!Now end the command
IF
.TXT_SEEN
THEN
BEGIN
STG('*',FALSE);
OUTSTG(CH$PTR(GEN_BUF),.GEN_LGT,FALSE);
STG('E',TRUE)
END
END;
!Process line insertions into master text
IF
.LIN_VAR NEQ .V_LINE AND
.V_LINE NEQ -1
THEN
BEGIN
!Issue control command
STG('*',FALSE);
OUTSTG(CH$PTR(GEN_BUF),.GEN_LGT,FALSE);
STG('I',TRUE);
!Output the text proper
INCR I FROM .LIN_VAR TO .V_LINE-1 DO
BEGIN
!Remember that changes have been made for a later message
CHANGES=TRUE;
L_PTR=.VAR_PTR[.I-.LIN_VAR];
L_SIZ=GET_STG_CT(L_PTR);
STG(' ',FALSE);
!check for a sequenced file
IF
.MST_SEQ OR
.INPUT_IOB[IOB$V_SEQUENCED]
THEN
BEGIN
!Add the generation field
OUTSTG(CH$PTR(GEN_BUF),.GEN_LGT,FALSE);
IF
.INPUT_IOB[IOB$V_SEQUENCED]
THEN
!Variation line already sequenced, we only need the ':' separator
!added
STG(':',FALSE)
ELSE
!No sequence, the ";" is not yet in the line
STG(';',FALSE)
END;
OUTSTG(.L_PTR,.L_SIZ,TRUE)
END;
!Terminate control record
STG('*',FALSE);
OUTSTG(CH$PTR(GEN_BUF),.GEN_LGT,FALSE);
STG('E',TRUE)
END;
!Now output the unchanged entries.
IF
.M_LINE LSS .L_LN_MST AND
.M_LINE NEQ -1 AND
.V_LINE NEQ -1
THEN
BEGIN
LOCAL
V_LEN,
V_PTR;
!Now output the unchanged line
L_PTR=.MST_PTR[.M_LINE-.LIN_MST];
L_SIZ=GET_STG_CT(L_PTR);
V_PTR=.VAR_PTR[.V_LINE-.LIN_VAR];
V_LEN=GET_STG_CT(V_PTR);
!Convert tag marker from '-' to ' ' if it exists
IF
CH$RCHAR(.L_PTR) EQL %C'-'
THEN
CH$WCHAR(%C' ',.L_PTR);
!Reconcile the sequence number fields if they exist
IF
.MST_SEQ OR
.INPUT_IOB[IOB$V_SEQUENCED]
THEN
BEGIN
LOCAL
M_SEQ, !Sequence number seen in master file
V_SEQ; !Sequence number seen in variation file
!Get correct sequence number for this generation of the master file
IF
.MST_SEQ
THEN
M_SEQ=GET_CGEN(.L_SIZ-1,CH$PLUS(.L_PTR,1),.GEN_LGT,CH$PTR(GEN_BUF))
ELSE
M_SEQ=0;
!Get sequence number from variation if it exists
IF
.INPUT_IOB[IOB$V_SEQUENCED]
THEN
V_SEQ=ASCDEC(V_PTR,0)
ELSE
V_SEQ=0;
!The field must exist
IF
.V_SEQ EQL -1
THEN
BUG(LIT('Sequenced file must have sequence numbers (OUTDIFF).'));
IF
.M_SEQ NEQ .V_SEQ OR
(NOT .MST_SEQ AND
.INPUT_IOB[IOB$V_SEQUENCED])
THEN
!The most recent master sequence is not the same
!as the new sequence number required, so it is
!necessary to add to the field
BEGIN
!New sequence numbers ARE a change
CHANGES=TRUE;
!Output leading blank and skip the blank in the original file
!(This makes it easier to place the sequence number at the line
!head)
STG(' ',FALSE);
L_PTR=CH$PLUS(.L_PTR,1);
L_SIZ=.L_SIZ-1;
!Get the current generation and output it
OUTSTG(CH$PTR(GEN_BUF),.GEN_LGT,FALSE);
!Don't put out a sequence number if it is zero
IF
.V_SEQ NEQ 0
THEN
BEGIN
STG(':',FALSE);
OUTNUM(.V_SEQ,FALSE)
END;
!If original master file was not sequenced, end with ';'
!otherwise use a ','
IF
.MST_SEQ
THEN
STG(',',FALSE)
ELSE
STG(';',FALSE)
END
END;
!Now output the line
OUTSTG(.L_PTR,.L_SIZ,TRUE)
END
else
!Handle cases where only one buffer is dumped
begin
if
.m_line neq -1 and
.m_line lss .l_ln_mst and
.v_line eql -1
then
!master line gets dumped
begin
l_ptr=.mst_ptr[.m_line-.lin_mst];
l_siz=get_stg_ct(l_ptr);
outstg(.l_ptr,.l_siz,true)
end;
if
.v_line lss .l_ln_var and
.m_line eql -1
then
!The variation line is MUCH more difficult since
! there might be sequence numbers that have to be pasted on
BEGIN
L_PTR=.VAR_PTR[.V_LINE-.LIN_VAR];
L_SIZ=GET_STG_CT(L_PTR);
!process the variation sequence number field if it exists
IF
.INPUT_IOB[IOB$V_SEQUENCED]
THEN
!There is no master sequence number, so add the
!field when the line is written
BEGIN
LOCAL
V_SEQ; !Sequence number seen in variation file
!Get sequence number from variation
V_SEQ=ASCDEC(L_PTR,0);
!The field must exist
IF
.V_SEQ EQL -1
THEN
BUG(LIT('Sequenced file must have sequence numbers (OUTDIFF).'));
!Get the current generation and output it
STG(' ',FALSE);
OUTSTG(CH$PTR(GEN_BUF),.GEN_LGT,FALSE);
!Don't put out a sequence number if it is zero
IF
.V_SEQ NEQ 0
THEN
BEGIN
STG(':',FALSE);
OUTNUM(.V_SEQ,FALSE)
END;
!If original master file was not sequenced, end with ';'
!otherwise use a ','
IF
.MST_SEQ
THEN
STG(',',FALSE)
ELSE
STG(';',FALSE)
END;
!Now output the line
OUTSTG(.L_PTR,.L_SIZ,TRUE)
END
end;
!Repack the text
PACK(.M_LINE,.V_LINE)
END; !End of OUTDIFF
ROUTINE SETUP (LGT,STR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Initialize the tables, get the command line, and initially fill
! the buffers.
!
! FORMAL PARAMETERS:
!
! LGT - length of file name to be processed
! STR - pointer to file name to be processed
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - files opened OK
! FALSE - files not opened successfully
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
FIL: VECTOR[CH$ALLOCATION(EXTENDED_FILE_SPEC)], !working buffer
FIL_PTR, !pointer to working buffer
FIL_SIZ, !size of text in working buffer
GENERATION, !Pointer to generation text
S_L_PTR, !Temporary line pointer
S_L_SIZ, !Temporary string size
STS; !XPORT status
!Mark files not yet open
M_OPN=FALSE;
I_OPN=FALSE;
O_OPN=FALSE;
!Point to the library directory to get master file
FIL_PTR=CH$PTR(FIL);
FIL_PTR=CH$MOVE(%CHARCOUNT(LIB),CH$PTR(UPLIT(LIB)),.FIL_PTR);
FIL_PTR=CH$MOVE(.LGT,.STR,.FIL_PTR);
FIL_SIZ=CH$DIFF(.FIL_PTR,CH$PTR(FIL));
!Open the master file
STS=$STEP_OPEN(IOB=MASTER_IOB,FILE_SPEC=(.FIL_SIZ,CH$PTR(FIL)),OPTIONS=INPUT,FAILURE=0);
IF
NOT .STS
THEN
BADXPO(.STS,CAT(('Cannot open input library file '),(.FIL_SIZ,CH$PTR(FIL))));
!Master is now open
M_OPN=TRUE;
!If we skip the library logical name,
!we get the modified source file name.
S_L_PTR=CH$PLUS(CH$PTR(FIL),%CHARCOUNT(LIB));
S_L_SIZ=.FIL_SIZ-%CHARCOUNT(LIB);
STS=$STEP_OPEN(IOB=INPUT_IOB,FILE_SPEC=(.S_L_SIZ,.S_L_PTR),FAILURE=0);
IF
NOT .STS
THEN
BYEXPO(s_noopen,.STS,CAT(('Cannot open '),(.FIL_SIZ,.FIL_PTR)));
!Variation is now open
I_OPN=TRUE;
!Remember maximum generation number length for pattern processing
MAX_G_LGT=.RESRSIZ;
!Get the generation reserved
GENERATION=CH$PTR(GEN_BUF);
GENERATION=CH$MOVE(.RESRSIZ,.RESRPTR,.GENERATION);
!Make it ASCIZ
CH$WCHAR(0,.GENERATION);
!Variant is just appended to the end if it exists
IF
.VARIANT NEQ 0
THEN
BEGIN
if
.resrsiz+3 gtr gen_size
then
begin
if
.first_call eql 1
then
begin
ers(s_biggen,lit('Generation string is too long'));
return false
end;
badlib(lit('Generation mismatch in the element'));
end;
CH$WCHAR_A(.VARIANT,GENERATION);
CH$WCHAR_A(%C'1',GENERATION);
ch$wchar(0,.generation);
GEN_LGT=CH$DIFF(.GENERATION,CH$PTR(GEN_BUF));
GENERATION=CH$PTR(GEN_BUF)
END
ELSE
!No variant, bump the counter instead
BEGIN
LOCAL
COUNT,
GEN_VAL,
TMP_PTR;
!Back up over trailing digits
REPEAT
BEGIN
LOCAL
CHAR;
IF
CH$DIFF(.GENERATION,CH$PTR(GEN_BUF)) EQL 0
THEN
EXITLOOP;
CHAR=CH$RCHAR(CH$PLUS(.GENERATION,-1));
IF
.CHAR LSS %C'0' OR
.CHAR GTR %C'9'
THEN
EXITLOOP;
GENERATION=CH$PLUS(.GENERATION,-1)
END;
!Now get the value and bump it
TMP_PTR=.GENERATION;
GEN_VAL=ASCDEC(TMP_PTR,0)+1;
!Place new value in the string
COUNT=DECASC(.GEN_VAL,.GENERATION);
!Remember length and start
GEN_LGT=CH$DIFF(.GENERATION,CH$PTR(GEN_BUF))+.COUNT;
GENERATION=CH$PTR(GEN_BUF)
END;
!Initialize CHKGEN
GEN_SETUP(KEEP);
!Look up source file pattern
PAT_SETUP();
!Now open a new master file
STS=$STEP_OPEN(IOB=OUTPUT_IOB,FILE_SPEC=(.FIL_SIZ,CH$PTR(FIL)),OPTIONS=OUTPUT,FAILURE=0);
IF
NOT .STS
THEN
BADXPO(.STS,CAT(('Cannot open new master file '),(.FIL_SIZ,CH$PTR(FIL))));
TRNFIL(OUTPUT_IOB);
!new master file is now open
O_OPN=TRUE;
!Initialize output routine
OUTINI(OUTPUT_IOB);
!Start the new header line
STG('+',FALSE);
!Output generation number to the header
OUTSTG(.GENERATION,.GEN_LGT,FALSE);
!Now pick up the user name
STG(' ',FALSE);
FIL_SIZ=GETACT(FIL);
OUTSTG(CH$PTR(FIL),.FIL_SIZ,FALSE);
!Time stamp the entry
STG(' ',FALSE);
FIL_SIZ=DATTIM(FIL);
OUTSTG(CH$PTR(FIL),.FIL_SIZ,FALSE);
!Now output the command comment
IF
.USR_REM[DESC_LEN] NEQ 0
THEN
STG(' ',FALSE);
OUTSTG(.USR_REM[DESC_PTR],.USR_REM[DESC_LEN],TRUE);
!Assume no sequencing to start
MST_SEQ=FALSE;
!Read through the file header and
!See if the requested generation conflicts with one already there
REPEAT
BEGIN
LOCAL
L_PTR, !line pointer
L_SIZ, !line size
T_PTR, !temporary line pointer
TAG; !contains the first character of the line
!Get the line
if
not (sts=get_mst_line(l_siz,l_ptr))
then
badxpo(.sts,cat(('Failure reading library file '),
master_iob[iob$t_resultant]));
!Output the line
OUTSTG(.L_PTR,.L_SIZ,TRUE);
!The header line MUST begin with "+"
TAG=CH$RCHAR_A(L_PTR);
IF
.TAG NEQ %C'+'
THEN
BADLIB(LIT('Illegal input library file header format.'));
!Find end of the generation value string
T_PTR=.L_PTR;
WHILE
CH$RCHAR_A(T_PTR) NEQ %C' '
DO;
L_SIZ=CH$DIFF(.T_PTR,.L_PTR)-1;
!If it matches an existing generation, there is an error
IF
CH$EQL(.GEN_LGT,.GENERATION,.L_SIZ,.L_PTR)
THEN
BEGIN
IF
.FIRST_CALL NEQ 1
THEN
!If this isn't the first time through, something
!is horribly wrong.
BADLIB(LIT('Generation mismatch within the element files.'));
ERS(s_gnconflct,CAT(('Generation '),(.GEN_LGT,.GENERATION),
(' conflicts with existing generation')))
END;
!Quit when generation 1 is reached
IF
CH$EQL(1,CH$PTR(UPLIT('1')),.L_SIZ,.L_PTR)
THEN
EXITLOOP
END;
!Initialize comparison algorithm and fill the buffer
CMPINI(TRUE,CHK_MST,GET_CUR_MST,OUTDIFF,GET_L_NOAUDIT);
!Now add the sequence mark if either master or variation is sequenced.
if
.lin_mst lss .l_ln_mst
then
BEGIN
LOCAL
L_PTR, !line pointer
L_SIZ; !Line size
!Point to the first record in the buffer
L_PTR=.MST_PTR[0];
L_SIZ=GET_STG_CT(L_PTR);
!Look for control record, set sequenced flag accordingly
IF
CH$EQL(3,CH$PTR(UPLIT('*/S')),.L_SIZ,.L_PTR)
THEN
BEGIN
MST_SEQ=TRUE;
PACK(.lin_mst,-1)
END
END;
!Place sequence switch in output if needed
IF
.MST_SEQ OR
.INPUT_IOB[IOB$V_SEQUENCED]
THEN
STG('*/S',TRUE);
TRUE
END; !End of SETUP
ROUTINE TERMINATE : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Clean up the loose ends and go away.
!
! FORMAL PARAMETERS:
!
! NONE.
!
! IMPLICIT INPUTS:
!
! All of the logical unit numbers of open files.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! All of the files are closed.
!
!--
BEGIN
IF
.I_OPN
THEN
$step_close(IOB=INPUT_IOB);
IF
.M_OPN
THEN
$step_close(IOB=MASTER_IOB);
! Output the CRC - but do it directly so the CRC doesn't get CRC'd
IF
.O_OPN
THEN
begin
local
len,
num_buf : vector[ch$allocation(max_num_size + 5)] ,
ptr ;
! Build control line
ptr = ch$move(4,ch$ptr(uplit('*/C:')),ch$ptr(num_buf)) ;
len = hexasz( .calc_crc, .ptr, 8 ) ;
ptr = ch$plus(.ptr, .len);
ch$wchar(%c' ',.ptr); ! Write out a space afterwards
len = .len + 5; ! Add in */C:
$step_put(iob=output_iob,string=( .len, ch$ptr(num_buf)),failure = 0);
$step_close(IOB=OUTPUT_IOB);
end;
END; !End of TERMINATE
ROUTINE TSTGEN (G_L,G) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Test a string to see if it could possibly be a generation number.
! This routine assumes that the generation field consists of the
! generation number starting in the first position of the string
! and is padded out with blanks at the end if the generation number
! does not completely file the field.
!
! FORMAL PARAMETERS:
!
! G_L - length of string
! G - pointer to string
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! True = valid generation number
! false = bad generation number
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
G_CHR,
G_LEN, ! length remaining
G_PTR,
G_TMP; ! length of numeric characters
!setup
G_PTR=.G;
G_LEN=.G_L;
!Ignore leading white space
WHILE
CH$RCHAR(.G_PTR) EQL %C' ' OR
CH$RCHAR(.G_PTR) EQL %C' '
DO
BEGIN
CH$RCHAR_A(G_PTR);
G_LEN=.G_LEN-1
END;
!Process entire expression
REPEAT
BEGIN
!Get length of integer parts
G_TMP=0;
INCR I FROM 1 TO .G_LEN DO
BEGIN
G_CHR=CH$RCHAR_A(G_PTR);
IF
.G_CHR GEQ %C'0' AND
.G_CHR LEQ %C'9'
THEN
G_TMP=.G_TMP+1
ELSE
EXITLOOP
END;
G_LEN=.G_LEN-.G_TMP-1;
!The numeric field length must be non-zero
IF
.G_TMP EQL 0
THEN
RETURN FALSE;
!OK if nothing follows numeric field (field len=gen len)
IF
.G_LEN EQL -1
THEN
RETURN TRUE;
IF
.G_CHR NEQ %C' '
THEN
BEGIN ! non-blank after number
IF
NOT ((.G_CHR GEQ %C'A' AND
.G_CHR LEQ %C'Z') OR
(.G_CHR GEQ %C'a' AND
.G_CHR LEQ %C'z'))
THEN
RETURN FALSE;
END
ELSE
! generation number shorter than field length but valid
RETURN TRUE ;
END
END; !End of Routine TSTGEN
END !End of Module REPFIL
ELUDOM