Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/outchr.bli
There are no other files named outchr.bli in the archive.
MODULE OUTCHR (
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:
! Output the generation chronology at the end of the file delivered
! to the user's area, surrounded by the user-specified pattern string.
!
! ENVIRONMENT:
! VAX/VMS, DS-20
!
! AUTHOR: Susan Millar, CREATION DATE: Aug, 1980
!
! MODIFIED BY:
!
!--
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
OUT_CHR : novalue ; ! Output generation chronology
!
! INCLUDE FILES:
!
LIBRARY 'XPORT:' ;
%if %bliss(bliss32) %then
LIBRARY 'sys$library:starlet';
%else
REQUIRE 'jsys:';
%fi
REQUIRE 'SCONFG:' ;
REQUIRE 'BLISSX:' ;
REQUIRE 'COMUSR:' ;
REQUIRE 'HOSUSR:' ;
!
! MACROS:
MACRO
STG(L,M) = OUTTXT(CH$PTR(UPLIT(L)),%CHARCOUNT(L),M) %;
!
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
!
! EXTERNAL REFERENCES:
!
external literal
s_isthere; !File already exists
EXTERNAL
CHRONO, !If on, chronology is desired
CHR_LS, !Left side of chronology pattern
CHR_LLS, !Length of left side
CHR_RS, !Right side of chronology pattern
CHR_LRS, !Length of right side
CHRLEN , !Length of entire chronology pattern
FETSTS, !Used to return special status
INPUT_IOB : $XPO_IOB() ,
OUTPUT_IOB : $XPO_IOB() ;
EXTERNAL ROUTINE
BADLIB, !Something wrong with user's library
BADXPO, !Error return from XPORT
CMPGEN, !Generation comparison
FIND_NEXT_WORDS, !Break string at EOL
GET_LXM, !Parse string
OUTTXT, !Output a string of text
PAT_SETUP , !Set up chronology pattern
sysmsg, !Speak to user
VERNUM ; !Determines version number of resultant file
GLOBAL ROUTINE OUT_CHR ( FIL_LEN, FIL_PTR, GEN_LEN, GEN_PTR ) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Output the chronology at the end of the user's file.
! Each line is preceded and succeded by the user's specified
! pattern string.
!
! FORMAL PARAMETERS:
!
! GEN_LEN - Length of buffer with generation number
! GEN_PTR - Pointer to buffer
!
! IMPLICIT INPUTS:
!
! External inputs for the chronology pattern string and the
! buffers containing the generations.
! The output iob is assumed open.
!
! IMPLICIT OUTPUTS:
!
! The chronology is appended to the user's file
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! none
!
! SIDE EFFECTS:
!
! The input buffer is re-opened and closed.
! The output buffer is closed.
!
!--
BEGIN !routine OUT_CHR
OWN
END_MST_HDR,
END_MRG_HDR,
FIL : VECTOR[CH$ALLOCATION(EXTENDED_FILE_SPEC)] ,
FIL_P,
FIL_SIZ,
STS,
S_PTR,
S_SIZE,
TAG,
TG_BUF : VECTOR[CH$ALLOCATION (50)],
TG_LGT ;
END_MST_HDR = FALSE ;
END_MRG_HDR = FALSE ;
!re_open files
FIL_P=CH$PTR(FIL);
FIL_P=CH$MOVE(%CHARCOUNT(LIB),CH$PTR(UPLIT(LIB)),.FIL_P);
FIL_P=CH$MOVE(.FIL_LEN,.FIL_PTR,.FIL_P);
FIL_SIZ=CH$DIFF(.FIL_P,CH$PTR(FIL));
STS=$STEP_OPEN(IOB=INPUT_IOB,FILE_SPEC=(.FIL_SIZ,CH$PTR(FIL)),OPTIONS=INPUT,FAILURE=0);
IF
NOT .STS
THEN
BADXPO(.STS,CAT(('Cannot open input file '),(.FIL_SIZ,CH$PTR(FIL))));
! Output header
IF
.CHR_LLS NEQ 0
THEN
OUTTXT( CH$PTR(CHR_LS), .CHR_LLS, FALSE ) ;
IF
.CHR_LRS NEQ 0
THEN
BEGIN
OUTPUT_IOB[IOB$G_SEQ_NUMB] = .OUTPUT_IOB[IOB$G_SEQ_NUMB] + 1 ;
STG(%string(' ',fac_name,' REPLACEMENT HISTORY ') , FALSE);
OUTTXT(CH$PTR(CHR_RS), .CHR_LRS, TRUE);
END
ELSE
BEGIN
OUTPUT_IOB[IOB$G_SEQ_NUMB] = .OUTPUT_IOB[IOB$G_SEQ_NUMB] + 1 ;
STG(%string(' ',fac_name,' REPLACEMENT HISTORY '), TRUE ) ;
END ;
!Output two blank lines
INCR I FROM 1 TO 2 DO
BEGIN
OUTPUT_IOB[IOB$G_SEQ_NUMB] = .OUTPUT_IOB[IOB$G_SEQ_NUMB] + 1 ;
OUTTXT(0, 0, TRUE) ;
END ;
!Now process history lines
REPEAT
BEGIN
LOCAL
S_L_PTR,
S_SIZ ;
!Get a header record
$step_get(IOB = INPUT_IOB) ;
S_L_PTR = .INPUT_IOB[IOB$A_STRING] ;
S_SIZ = .INPUT_IOB[IOB$H_STRING] ;
!Look for required header record
IF
CH$RCHAR_A(S_L_PTR) NEQ %C'+'
THEN
BADLIB(LIT('Illegal library file format'))
ELSE
BEGIN
LOCAL
TG_PTR ,
FIRST_LOOP, !flag
LNSIZE, !size of output line
LOOP_AGAIN, !loop again if true
REMARK: $STR_DESCRIPTOR(), !points to string
R_SUBLINE: $STR_DESCRIPTOR(); !points to substring
TG_PTR = CH$PTR(TG_BUF) ;
TG_LGT = GET_LXM ( S_L_PTR, %C' ', .S_SIZ - 1, TG_PTR) ;
IF
CH$EQL(.GEN_LEN, .GEN_PTR, .TG_LGT, CH$PTR(TG_BUF) )
THEN
END_MST_HDR = TRUE ;
!
! IF
! CH$EQL(.MRG_LEN, .MRG_PTR, .TG_LGT, CH$PTR(TG_BUF) )
! THEN
! END_MRG_HDR = TRUE ;
IF
.CHR_LLS NEQ 0
THEN
OUTTXT(CH$PTR(CHR_LS), .CHR_LLS, FALSE ) ;
TG_PTR = CH$PTR(TG_BUF) ;
IF
.END_MST_HDR AND
CMPGEN (CH$PTR(TG_BUF), .TG_LGT, .GEN_PTR, .GEN_LEN)
THEN
STG ('*', FALSE)
ELSE
STG (' ', FALSE) ;
!Skip the "+" so it won't be printed
$STR_DESC_INIT(DESCRIPTOR=REMARK);
$STR_DESC_INIT(DESCRIPTOR=R_SUBLINE);
REMARK[STR$A_POINTER] = CH$PLUS(.INPUT_IOB[IOB$A_STRING],1);
REMARK[STR$H_LENGTH] = .INPUT_IOB[IOB$H_STRING]-1;
LNSIZE = 132; !delete this line if line-size of
! output ever provided
LNSIZE = .LNSIZE - .CHR_LLS - 1; !subtract 8 spaces
LOOP_AGAIN = TRUE;
FIRST_LOOP = TRUE;
WHILE .LOOP_AGAIN
DO
BEGIN
LOOP_AGAIN = NOT FIND_NEXT_WORDS(REMARK,.LNSIZE,R_SUBLINE);
OUTTXT(.R_SUBLINE[STR$A_POINTER],.R_SUBLINE[STR$H_LENGTH],FALSE);
OUTPUT_IOB[IOB$G_SEQ_NUMB] = .OUTPUT_IOB[IOB$G_SEQ_NUMB] + 1 ;
IF .CHR_LRS NEQ 0
THEN
OUTTXT(CH$PTR(CHR_RS), .CHR_LRS, TRUE )
ELSE
OUTTXT (0, 0, TRUE) ;
IF .LOOP_AGAIN
THEN
IF .CHR_LLS NEQ 0
THEN
OUTTXT(CH$PTR(CHR_LS), .CHR_LLS, FALSE) ;
IF .FIRST_LOOP
THEN
BEGIN
FIRST_LOOP = FALSE;
LNSIZE = .LNSIZE - .CHR_LLS ;
END
END
END;
!See if there are no more header records
IF
.TG_LGT EQL 1 AND
CH$EQL(1,CH$PTR(UPLIT('1')),.TG_LGT,CH$PTR(TG_BUF))
THEN
EXITLOOP
END ;
$step_close(IOB = INPUT_IOB) ;
IF
VERNUM( OUTPUT_IOB[IOB$T_RESULTANT] ) GTR 1
THEN
BEGIN
FETSTS = s_isthere;
sysmsg(s_isthere,CAT((.FIL_LEN, .FIL_PTR),
%string(' already exists, so the next ',
%if VaxVms %then 'version', %fi
%if Tops20 %then 'file generation', %fi
' has been created')),0) ;
END ;
$step_close(IOB = OUTPUT_IOB) ;
END; ! end of routine OUT_CHR
END ! End of module OUTCHR
ELUDOM