Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

MODULE CRELM	(
		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:
!
!	CREATE ELEMENT command.
!
!	Load an element into the project library from the specified
!	files in the command string.
!
! ENVIRONMENT:	VAX/VMS, DS-20
!
! AUTHOR: D. Knight , CREATION DATE: 23-Apr-79
!
!--

!
! TABLE OF CONTENTS
!

FORWARD ROUTINE
	CRELM,				!CREATE ELEMENT command
	CHKLIB,				!Check for existence of element
	GETQUAL: NOVALUE,		!Get qualifier pointers
	GENAUDIT: NOVALUE,		!Generate an audit control record
	MRKLIB,				!Enter an element into the master list
	OUTFIL: NOVALUE,		!Generate the remainder of the master file
	TST_PAT;			!See if audit control record is legal

!
! 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 'LOGUSR:';

REQUIRE 'SHRUSR:';

!
! MACROS:
!

MACRO
	STG(L,M) = OUTSTG(CH$PTR(UPLIT(L)),%CHARCOUNT(L),M) %;

!
! EQUATED SYMBOLS:
!

!
! OWN STORAGE:
!

OWN
	CHR_LEN,			!Chronology length
	CHR_PTR,			!Chronology pointer
	EXISTING_CRC : INITIAL(0),	!CRC already in def file
	found_crc,
    	KEEP_FLG,			!KEEP flag
	$IO_BLOCK(LLIB),
	LIB_EOF,
	$IO_BLOCK(LIB_W),
	NOT_LEN,			!Note length
	NOT_PTR,			!Note pointer
    	NOTES,				!Notes specified
	nonotes_found,			!Nonotes specified
	NEW_DEF_CRC : INITIAL(0),
	OLD_DEF_CRC : INITIAL(0),
	POS_LEN,			!Note position length
	POS_PTR,			!Note position pointer
	$IO_BLOCK(RD),
	RES_FLG,			!RESERVE flag
	$IO_BLOCK(WRT);

!
! EXTERNAL REFERENCES:
!

external literal

	s_ecreres,			!element created and reserved
	s_elcreate,			!element created
	s_elemexist,			!element already exists
	s_errfile,			!file is missing or invalid
	s_ilposval,			!illlegal position value
	s_ilstring,			!illegal string
	s_invcksum,			!defn file has invalid cksum
	s_invGs,			!invalid # of Gs in string
	s_invHs,			!invalid # of Hs in string
	s_nofile,			!file(s) not found
	s_nocksum,			!chksum missing or invalid
	s_posextran,			!position qualif is extraneous
	s_posnotdef,			!position qualif must be spec & have 
        s_readerr;			!read error

external
	calc_crc,			!CRC calculated by OUTSTG
	f_perf_crc ;			!If on, OUTSTG will calculate CRC

EXTERNAL ROUTINE
	ASCDEC,
	ASCHEX,
	BEGTRN,				!Mark beginning of transaction
	badxpo,
	BUG,
	BUGXPO,
	CANTRN,				!Cancel transaction
	CHKRES,				!Start reservation process
	COMAND,
	crctable,			!Set up polynomial table
	crccalc,			!Calculate the CRC of a line
	DATTIM,
    	DELRES,				!Delete obsolete reservation file
	DELVRS,
	DEQUOT : NOVALUE,		!Remove quotation marks.
	DONLIB,
	ENDTRN,				!Mark end of transaction
	ERS,
        ersiob,
	ERSXPO,
	exits,				!exit silently
	FILTYP,				!Check file for correct attributes
    	FINDPS,				!Check /chrono pattern string
	GETACT,				!Get user account name
	GET_LXM,			!Get text lexeme
	GET_STG_CT,			!Get string size
	hexasz,				!Convert hex to ascii (decasc)
	LOGTRN,				! log transaction(IOLOG)
    	MRKRES,				!mark the reservation
	OUTINI,
	OUTNUM,
	OUTSTG,
	PUT_STG_CT,			!Save string size
	SAFLIB,				!Lock library
	sysmsg,
	TRNFIL,				!Mark file transaction
	VALFIL;				!Check filenames for validity

GLOBAL ROUTINE CRELM (QUAL,PAR,USR_REM) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	CREATE ELEMENT command processing.
!
! FORMAL PARAMETERS:
!
!	QUAL - Address of qualifier block
!	PAR - address of parameter block
!	USR_REM - address of user remark
!
! IMPLICIT INPUTS:
!
!	NONE.
!
! IMPLICIT OUTPUTS:
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	K_SUCCESS
!	K_SILENT_ERROR
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    OWN
	D_GEN:DESC_BLOCK ,	! save generation number for logging.
	D_FIL_SPC: DESC_BLOCK , ! file spec for def file
	pos_value;		! decimal value of position qualifier

    MAP
	PAR : REF PARAMETER_BLOCK,
	QUAL : REF QUALIFIER_BLOCK,
	USR_REM : REF DESC_BLOCK;

    LOCAL
	f_any_keep_qual_present,! set true if /keep or /nokeep seen in command
	CONDX,
	FIL_CNT,
	PAR_TMP,
	ret_val,
	STS;

!+
! Initial setup and command parsing
!-

    !Initialize qualifiers
    RES_FLG=FALSE;
    F_ANY_KEEP_QUAL_PRESENT = FALSE;
    KEEP_FLG = FALSE ;
    NOTES = FALSE ;

    !Set up qualifiers, if any
    WHILE
	.QUAL NEQ K_NULL
    DO
	BEGIN

	IF
	    .QUAL[QUA_CODE] EQL K_RESERVE_QUAL
	THEN
	    RES_FLG=TRUE;

    	IF 
	    .QUAL[QUA_CODE] EQL K_KEEP_QUAL
    	THEN
	    BEGIN
	    f_any_keep_qual_present = true;
    	    KEEP_FLG = TRUE ;
	    END;

	IF
	    .QUAL[QUA_CODE] EQL K_NORESERVE_QUAL
	THEN
	    RES_FLG=FALSE;
	
	IF 
	    .QUAL[QUA_CODE] EQL K_NOKEEP_QUAL
	THEN
	    BEGIN
	    f_any_keep_qual_present = true;
	    KEEP_FLG = FALSE ;
	    END;
	    

	QUAL=.QUAL[QUA_A_NEXT]

	END;

    !if /[no]keep not specified, determine default based on presence of /RESERVE
    IF NOT .f_any_keep_qual_present
    THEN
	keep_flg = (IF .res_flg
		    THEN true		! /RESERVE   --> /KEEP
		    ELSE false);	! /NORESERVE --> /NOKEEP

    $IO_BLOCK_INIT(LLIB);
    $IO_BLOCK_INIT(LIB_W);
    LIB_EOF=FALSE;

    !Initialize output routine
    OUTINI(WRT_IOB);

    !Remember head of list
    PAR_TMP=.PAR;

    !Lock the library
    IF
	NOT SAFLIB(K_UPDATE_LIB)
    THEN
	RETURN K_SILENT_SEVERE ;

    !Examine filenames in library for validity
    IF
	NOT VALFIL(.PAR,FIL_CNT)
    THEN
	BEGIN
	DONLIB();
	RETURN K_SILENT_ERROR
	END;

    !Mark beginning of transaction for possible crash recovery
    BEGTRN();

    !Set up polynomial
    crctable();

    !Try to find the element in the master list
    IF
	CHKLIB(.PAR[PAR_TEXT_PTR],.PAR[PAR_TEXT_LEN])
    THEN
	BEGIN
	ERS(s_elemexist,CAT(('Element '),PAR[PAR_TEXT],(' already exists')));
	!cancel transaction
	CANTRN();
	!Turn off exclusive lock
	DONLIB();
	RETURN K_SILENT_ERROR
	END;

!+
! See if the files exist in the user's area.  It is not
! allowable to partially create an element and find it impossible to complete.
!-

    REPEAT
	BEGIN

	LOCAL
	    FIL : VECTOR[CH$ALLOCATION(extended_file_spec)],
	    FILPTR,
	    FILSIZ,
    	    NUM_FOUND ;

	!Make sure the block is clear
	$IO_BLOCK_INIT(RD);

	!Each user file must exist and be openable
	STS=$STEP_OPEN(IOB=RD_IOB,FILE_SPEC=PAR[PAR_TEXT],FAILURE=0);
	IF
	    NOT .STS
	THEN
	    BEGIN
	    IF step$_no_access eql .STS
	    THEN 
		ERS(s_nofile,CAT('File ',PAR[PAR_TEXT],
			' is protected from access'))
	    ELSE
	        ERS(s_nofile,CAT(('File '),PAR[PAR_TEXT],(' does not exist')));
	    EXITLOOP
	    END
	ELSE
	    BEGIN
	    !Make sure format and attributes are OK
	    IF
		NOT FILTYP(RD_IOB)
	    THEN
		BEGIN
		$step_close(IOB=RD_IOB);
		ERS(s_errfile,CAT(('File '),PAR[PAR_TEXT],
		    (' has incorrect record format or attributes')));
		EXITLOOP
		END;

	    $step_CLOSE(IOB=RD_IOB)
	    END;

	!Make sure file qualifiers, if any, are legal
	GETQUAL(.PAR);
	
    	NUM_FOUND = 0 ;

	IF
	    NOT FINDPS(.NOT_LEN, .NOT_PTR, %C'G', NUM_FOUND)
	THEN
	    EXITLOOP;

    	IF 
    	    .NOT_LEN NEQ 0
    	THEN
    	    IF 
    		.NUM_FOUND GTR 1
    	    THEN 
    	  	BEGIN
    		ERS(s_invGs,CAT('Exactly one "#G" required in ',
			(.NOT_LEN,.NOT_PTR))) ;
    		EXITLOOP;
    		END ;    		


	IF .POS_LEN NEQ 0 
	    then
	    	if .NOT_LEN EQL 0
		THEN
		    BEGIN
		    ERS(s_posextran,LIT('/POSITION qualifier is extraneous'));
		    EXITLOOP
		    END
		else
		    begin ! check that position qualifier value is from 0 to 511
	    	    pos_value = ascdec(pos_ptr,.pos_len);
	    	    if (.pos_value lss 0) or (.pos_value gtr 511)
		    then
			begin
			ers(s_ilposval,lit(%string('/POSITION qualifier value must',
				' be from 0 to 511')));
			exitloop
			end
		    end; ! check that position qualifier value is from 0 to 511


	IF
	    .POS_LEN EQL 0 AND
	    .NOT_LEN NEQ 0
	THEN
	    BEGIN
	    ERS(s_posnotdef,CAT('/POSITION qualifier must be specified ',
			'and have a value'));
	    EXITLOOP
	    END;


    	NUM_FOUND = 0;

    	IF 
    	    NOT FINDPS( .CHR_LEN, .CHR_PTR, %C'H', NUM_FOUND)
    	THEN
    	    EXITLOOP ;
    
    	IF 
    	    .CHR_LEN NEQ 0
    	THEN
    	    IF
       	        .NUM_FOUND NEQ  1
     	    THEN
    	        BEGIN
    	        ERS(s_invHs,CAT('Exactly one "#H" required in ',
				(.CHR_LEN, .CHR_PTR))) ;
                EXITLOOP ;
    	        END ;

    	
	PAR=.PAR[PAR_A_NEXT];

	IF
	    .PAR EQL K_NULL
	THEN
	    EXITLOOP

	END;

    !See if premature exit was taken from the loop
    IF
	.PAR NEQ K_NULL
    THEN
	!Error exit
	BEGIN
	$step_close(IOB=LIB_W_IOB,OPTIONS=REMEMBER);
	$STEP_DELETE(IOB=LIB_W_IOB);
	$step_close(IOB=llib_iob);
	!Cancel whole transaction
	CANTRN();
	!Unlock the library
	DONLIB();
	RETURN K_SILENT_ERROR
	END;

    !Reset pointer to head of list
    PAR=.PAR_TMP;

!+
! Process the files proper, note that the element name is also
! the name of the first file.
!-

    REPEAT
	BEGIN

	LOCAL
	    FIL : VECTOR[CH$ALLOCATION(extended_file_spec)],
	    FILPTR,
	    FILSIZ,
	    len,
	    num_buf: vector[ch$allocation(max_num_size+5)],
	    ptr ;

	!Clear the input block
	$IO_BLOCK_INIT(RD);

	!Open the input file
	STS=$STEP_OPEN(IOB=RD_IOB,FILE_SPEC=PAR[PAR_TEXT],FAILURE=0);
	IF
	    NOT .STS
	THEN
	    BUGXPO(.STS,CAT(PAR[PAR_TEXT],(' does not exist')));

	!Get output file name and location
	FILPTR=CH$PTR(FIL);
	FILPTR=CH$MOVE(%CHARCOUNT(LIB),CH$PTR(UPLIT(LIB)),.FILPTR);
	FILPTR=CH$MOVE(.PAR[PAR_TEXT_LEN],.PAR[PAR_TEXT_PTR],.FILPTR);
	FILSIZ=CH$DIFF(.FILPTR,CH$PTR(FIL));

	!Clear the output block
	$IO_BLOCK_INIT(WRT);

	!Now open the new master file
	CONDX=$STEP_OPEN(IOB=WRT_IOB,FILE_SPEC=(.FILSIZ,CH$PTR(FIL)),
			 OPTIONS=OUTPUT,FAILURE=0);
	IF
	    NOT .CONDX
	THEN
	    BUGXPO(.CONDX,CAT(('Cannot open new master file '),(.FILSIZ,CH$PTR(FIL))));

	!Mark the file transaction
	TRNFIL(WRT_IOB);

	calc_crc = 0;
	!Turn on CRC calculations in OUTSTG
	f_perf_crc = true ;
	!Put header on the file

	!Output the generation number "1" to the correction file header.
	STG('+1 ',FALSE);

	!Now pick up the user name
	FILSIZ=GETACT(FIL);
	OUTSTG(CH$PTR(FIL),.FILSIZ,FALSE);

	!Time stamp the entry
	STG(' ',FALSE);
	FILSIZ=DATTIM(FIL);
	OUTSTG(CH$PTR(FIL),.FILSIZ,FALSE);

	!Now output the command comment
	IF
	    .USR_REM[DESC_LEN] NEQ 0
	THEN
	    BEGIN
	    STG(' ',FALSE);
	    OUTSTG(.USR_REM[DESC_PTR],.USR_REM[DESC_LEN],TRUE)
	    END
	ELSE
	    OUTSTG(0,0,TRUE);

	!Put in the sequence control line if the input file is sequenced
	IF
	    .RD_IOB[IOB$V_SEQUENCED]
	THEN
	    STG('*/S',TRUE);

	!Place the file in the library
	OUTFIL();

	!Close the files
	$step_close(IOB=RD_IOB);
	!Write out calculated CRC
	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) ;
	len = .len + 5;
	$step_put ( iob = wrt_iob, string = (.len,ch$ptr(num_buf)),
		   failure = 0);
	$step_CLOSE(IOB=WRT_IOB);
	f_perf_crc = false ;

	!Quit if no more files
	PAR=.PAR[PAR_A_NEXT];

	IF
	    .PAR EQL K_NULL
	THEN
	    EXITLOOP

	END;

    !Place entry in element control table
    MRKLIB(.PAR_TMP);

    !Remember this transaction
    PAR=.PAR_TMP;

    ! set up generation number for logging
    $STR_DESC_INIT(DESCRIPTOR=D_GEN,STRING=('1')) ;

    ! log this transaction
    IF
	NOT LOGTRN(K_NORMAL_LOG,LEN_COMMA_PTR(D_GEN))
    THEN
	BUG(CAT('Unable to write log record (CRELM)'));

!+
! Now clean up the transaction
!-
    ! Check the CRC count in the old def file
    if not .found_crc
    then
	sysmsg(s_nocksum,cat('Definition file has no checksum'),0)
    else
      if .existing_crc neq .old_def_crc
      then
	sysmsg(s_invcksum,cat('Definition file has an invalid checksum'),0);
    
    ! Turn off the calculations in  OUTSTG
    f_perf_crc = false;
    calc_crc = 0;

    !Close and delete the old version of the definition file
    $step_close(IOB=llib_iob);
    $STR_DESC_INIT(DESCRIPTOR=D_FIL_SPC,STRING=(%STRING(LIB,CDIR))) ;
    DELVRS(FILVRS,.D_FIL_SPC[DESC_LEN],.D_FIL_SPC[DESC_PTR]) ;

    !If /KEEP was specified, don't delete files from users area
    IF
	NOT .KEEP_FLG
    THEN
    	BEGIN
    	PAR = .PAR_TMP ;

        REPEAT
    	    BEGIN

	    !Delete the files from the user's area
	    DELVRS(0,.PAR[PAR_TEXT_LEN],.PAR[PAR_TEXT_PTR]);

            PAR=.PAR[PAR_A_NEXT];

	    IF
	        .PAR EQL K_NULL
    	    THEN
	        EXITLOOP

	    END;    
    	END ;    
    !check for /reserve qualifier
    IF
	.RES_FLG
    THEN
    	BEGIN
    	LOCAL
    	    RES_LIST;		!POINTER TO RESERVATION LIST

        ! reset pointer to head of list
        PAR = .PAR_TMP ;
    	
	!call chkres to get pointer into reservation file
	!call mrkres to insert reservation - putting /nonotes inte reservation
    	!file only if /notes was specified.
	!call delres to delete obsolete reservation file
        CHKRES(.PAR[PAR_TEXT_PTR], .PAR[PAR_TEXT_LEN], RES_LIST) ;
    	IF 
    	    .NOTES
    	THEN
        MRKRES(.PAR[PAR_TEXT_PTR], .PAR[PAR_TEXT_LEN],
    		.D_GEN[desc_ptr], .D_GEN[DESC_LEN], 
    		.USR_REM[DESC_PTR],.USR_REM[DESC_LEN],
    		CH$PTR(UPLIT('/NONOTES')),8)
    	ELSE
        MRKRES(.PAR[PAR_TEXT_PTR], .PAR[PAR_TEXT_LEN],
    		.D_GEN[desc_ptr], .D_GEN[DESC_LEN], 
    		.USR_REM[DESC_PTR],.USR_REM[DESC_LEN],
    		0,0) ;
        DELRES () ;

    	END;
    !Reset pointer to top of list
    PAR = .PAR_TMP ;

    ! Tell user what is happening
    IF
	.RES_FLG
    THEN
	begin
	ret_val=s_ecreres;
        sysmsg(s_ecreres,
	    CAT(('Element '),par[par_text],(' created and reserved')),0) 
	end
    ELSE
	begin
	ret_val=s_elcreate;
        sysmsg(s_elcreate,CAT(('Element '),PAR[PAR_TEXT],(' created')),0);
	end;

    !Mark the end of the transaction
    ENDTRN();

    !Unlock the library
    DONLIB();

    exits(.ret_val)

    END;				!End of CRELM

ROUTINE CHKLIB (ELM,SIZE) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Check for existence of element
!
! FORMAL PARAMETERS:
!
!	ELM - string pointer to element name to be found
!	SIZE - length of element name
!
! IMPLICIT INPUTS:
!
!	NONE.
!
! IMPLICIT OUTPUTS:
!
!	INSRT_POS - points to position where new element can be inserted
!		    (0 if end of text).
!	MARK - Contains pointer to element control record (0 if none)
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	TRUE - element found
!	FALSE - element not found
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	LAST_LINE,
	status;

    !Open reservation control files
    if
	(status=$STEP_OPEN(IOB=llib_iob,FILE_SPEC=(%STRING(LIB,CDIR)),
		OPTIONS=INPUT,failure=0)) neq step$_normal
    then
	badxpo(.status,lit('Cannot open definition file'));
    if
	(status=$STEP_OPEN(IOB=LIB_W_IOB,FILE_SPEC=(%STRING(LIB,CDIR)),
		OPTIONS=OUTPUT,failure=0)) neq step$_created
    then
	badxpo(.status,lit('Cannot open new definition file'));

    TRNFIL(LIB_W_IOB);

    !Search for the correct name
    UNTIL
	$step_get(IOB=llib_iob) EQL STEP$_EOF
    DO
	BEGIN

	LOCAL
	    CRC,
	    ELM_NAM : VECTOR[CH$ALLOCATION(EL_NAM_SIZE)],
	    ELM_PTR,
	    ELM_SIZ,
	    TMP_PTR;

	!Initialize
	crc = 0;
	! See if we have the last transactions CRC count
	if ch$eql(4,ch$ptr(uplit('*/C:')),4,.llib_iob[iob$a_string])
	then
	    begin
	    local
		len,
		ptr ;
	    found_crc = true ;
	    len = .llib_iob[iob$h_string] ;
	    ptr = ch$plus(.llib_iob[iob$a_string], 4) ;
	    existing_crc = aschex(ptr, len);
	    exitloop
	    end;

	! Else calculate the CRC of this input line and the next output line
	crc = crccalc(.llib_iob[iob$h_string],.llib_iob[iob$a_string]);
	old_def_crc = .crc + .old_def_crc ;
	!Get the element name from the control line
	TMP_PTR=.llib_iob[IOB$A_STRING];
	ELM_PTR=CH$PTR(ELM_NAM);
	ELM_SIZ=GET_LXM(TMP_PTR,%C' ',.llib_iob[IOB$H_STRING],ELM_PTR);

	IF
	    CH$EQL(.SIZE,.ELM,.ELM_SIZ,CH$PTR(ELM_NAM))
	THEN
	    !The element already exists, it cannot be loaded
	    BEGIN

	    $step_close(IOB=LIB_W_IOB,OPTIONS=REMEMBER);
	    RETURN TRUE

	    END
	ELSE
	IF
	    CH$LSS(.SIZE,.ELM,.ELM_SIZ,CH$PTR(ELM_NAM))
	THEN
	    !We are at the correct position for an insertion
	    RETURN FALSE;

	!Write out the line
	$step_put(IOB=LIB_W_IOB,STRING=llib_iob[IOB$T_STRING]);
	! The new def file's total crc is the same until the new element is added
	new_def_crc = .crc + .new_def_crc ;


	END;

    LIB_EOF=TRUE;

    !The line goes at the bitter end
    FALSE

    END;				!End of CHKLIB

ROUTINE GETQUAL (PAR) : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Get pointers to qualifiers for individual name.
!
! FORMAL PARAMETERS:
!
!	NONE.
!
! IMPLICIT INPUTS:
!
!	NONE.
!
! IMPLICIT OUTPUTS:
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    MAP
	PAR : REF PARAMETER_BLOCK;

    LOCAL
	QUAL : REF QUALIFIER_BLOCK;

    !Get the appropriate qualifier list
    QUAL=.PAR[PAR_A_QUAL];

    !Initialize qualifiers
    CHR_LEN=0;
    NOT_LEN=0;
    POS_LEN=0;

				!This next section of code is very similar to
				!code in STSET in routine SAVPAR.  If any
				!modification is done to the following code,
				!SAVPAR in STSET must also be looked at to see
				!if corresponding changes must be made.
    !Set up qualifiers, if any
    WHILE
	.QUAL NEQ K_NULL
    DO
	BEGIN

	!Process each qualifier individually
	SELECTONE .QUAL[QUA_CODE] OF
	    SET

	    [K_NOTES_QUAL]:
		BEGIN
    		NOTES = TRUE ;
		NOT_PTR=.QUAL[QUA_VALUE_PTR] ;
		NOT_LEN=.QUAL[QUA_VALUE_LEN] ;
		END;

	    [K_NONOTES_QUAL]:
		BEGIN
    		NOTES = FALSE;
		NOT_PTR=K_NULL;
		NOT_LEN=0;
		POS_PTR=K_NULL;
		POS_LEN=0;
		END;

	    [K_HISTORY_QUAL]:
		BEGIN
		CHR_PTR=.QUAL[QUA_VALUE_PTR] ;
		CHR_LEN=.QUAL[QUA_VALUE_LEN] ;
		END;
	    [K_NOHISTORY_QUAL]:
		BEGIN
		CHR_PTR=K_NULL;
		CHR_LEN=0;
		END;

	    [K_POSITION_QUAL]:
		BEGIN
		POS_PTR=.QUAL[QUA_VALUE_PTR];
		POS_LEN=.QUAL[QUA_VALUE_LEN]
		END;

	    TES;

	QUAL=.QUAL[QUA_A_NEXT]

	END

    END;				!End of GETQUAL

ROUTINE GENAUDIT (NAME_PTR) : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Generate an audit control record.
!
! FORMAL PARAMETERS:
!
!	NONE.
!
! IMPLICIT INPUTS:
!
!	NONE.
!
! IMPLICIT OUTPUTS:
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    !Get qualifiers required for name
    GETQUAL(.NAME_PTR);

    !See if note was requested
    IF
	.NOT_LEN NEQ 0
    THEN
	BEGIN

	! put out position
	STG('/P=',FALSE) ;
	OUTSTG(.POS_PTR,.POS_LEN,FALSE) ;

	! put out note
	STG('/N=',FALSE) ;
	OUTSTG(.NOT_PTR,.NOT_LEN,FALSE) ;

	END;

    !Process history if requested
    IF
	.CHR_LEN NEQ 0
    THEN
	BEGIN

	! put out history
	STG('/H=',FALSE) ;
	OUTSTG(.CHR_PTR,.CHR_LEN,FALSE) ;

	END

    END;				!End of GENAUDIT

ROUTINE MRKLIB (ELM) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Make entry in master control table corresponding
!	to specified element.
!
! FORMAL PARAMETERS:
!
!	ELM - Address of element name list as set up in CRELM
!
! IMPLICIT INPUTS:
!
!
! IMPLICIT OUTPUTS:
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	COUNT,
	ELMPTR : REF PARAMETER_BLOCK,
	len,
	num_buf:VECTOR[CH$ALLOCATION(max_num_size+5)],
	ptr ,
	TXBUF: VECTOR[CH$ALLOCATION(40)];

    ELMPTR=.ELM;

    !Set up to do output to new control file
    OUTINI(LIB_W_IOB);
    
    !Tell OUTSTG to calculate CRC's again, but initialize the total to zero
    f_perf_crc = true;
    calc_crc = 0;

    !Enter element into the list
    OUTSTG(.ELMPTR[PAR_TEXT_PTR],.ELMPTR[PAR_TEXT_LEN],FALSE);
    STG(' ',FALSE);

    !Now generate the element contents
    REPEAT
	BEGIN

	!Output the file or element name
	OUTSTG(.ELMPTR[PAR_TEXT_PTR],.ELMPTR[PAR_TEXT_LEN],FALSE);

	!Generate the source audit markers, if any
	GENAUDIT(.ELMPTR);

	!Advance to next entry
	ELMPTR=.ELMPTR[PAR_A_NEXT];

	IF
	    .ELMPTR EQL K_NULL
	THEN
	    BEGIN
	    OUTSTG(0,0,TRUE);
	    new_def_crc = .new_def_crc + .calc_crc ;
	    EXITLOOP
	    END;

	STG(',',FALSE)

	END;

    !Now output the remainder of the file
    IF
	NOT .LIB_EOF
    THEN
	BEGIN

	!(Don't forget the left over line)
	$step_put(IOB=LIB_W_IOB,STRING=llib_iob[IOB$T_STRING]);
	! OK , I won't 
	new_def_crc = crccalc(.llib_iob[iob$h_string],.llib_iob[iob$a_string]) 
			+ .new_def_crc ;

	UNTIL
	    $step_get(IOB=llib_iob) EQL STEP$_EOF
	DO
	    begin
	    ! See if we have the last transactions CRC count
	    if ch$eql(4,ch$ptr(uplit('*/C:')),4,.llib_iob[iob$a_string])
	    then
	    	begin
	    	local
		    len,
		    ptr ;
		found_crc = true;
	    	len = .llib_iob[iob$h_string] ;
	    	ptr = ch$plus(.llib_iob[iob$a_string], 4) ;
	    	existing_crc = aschex(ptr, len);
	    	exitloop
	    	end;

	    new_def_crc = crccalc(.llib_iob[iob$h_string],.llib_iob[iob$a_string]) 
			+ .new_def_crc ;
	    old_def_crc = crccalc(.llib_iob[iob$h_string],.llib_iob[iob$a_string]) 
			+ .old_def_crc ;

	    $step_PUT(IOB=LIB_W_IOB,STRING=llib_iob[IOB$T_STRING])
	    end ;
	END;

    !Write out newly calculated CRC
    ptr = ch$move (4,ch$ptr(uplit('*/C:')),ch$ptr(num_buf)) ;
    len = hexasz(.new_def_crc, .ptr, 8) ;
    ptr = ch$plus ( .ptr, .len) ;
    ch$wchar (%c' ', .ptr) ;
    len = .len + 5;
    $step_put ( iob = lib_w_iob, string = (.len,ch$ptr(num_buf)),
		   failure = 0);

    $step_CLOSE(IOB=LIB_W_IOB)

    END;				!End of MRKLIB

ROUTINE OUTFIL : NOVALUE =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Finish the master control file.
!
! FORMAL PARAMETERS:
!
!	NONE.
!
! IMPLICIT INPUTS:
!
!	NONE.
!
! IMPLICIT OUTPUTS:
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	NONE.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN
    LOCAL
        status;

    WHILE
	(status =$step_get(IOB=RD_IOB))
    DO
	BEGIN

	IF
	    .RD_IOB[IOB$V_SEQUENCED]
	THEN
	    !Don't lose the sequence information
	    BEGIN
	    !See if it is a page mark
		BEGIN
		!This generation number is always 1 for LOAD
		STG(' 1:',FALSE);

		!Put out the actual sequence number
		OUTNUM(.RD_IOB[IOB$G_SEQ_NUMB],FALSE);

		!And put in the field terminator
		STG(';',FALSE);
		!Output remainder of line
		OUTSTG(.RD_IOB[IOB$A_STRING],.RD_IOB[IOB$H_STRING],TRUE);
		END
	    END
	ELSE
	    !Filler character only
	    begin
	    STG(' ',FALSE);
	    !Output remainder of line
	    OUTSTG(.RD_IOB[IOB$A_STRING],.RD_IOB[IOB$H_STRING],TRUE);
	    end;
	END;
    IF
        .status NEQ STEP$_EOF
    THEN
	ersxpo(s_readerr,.status,
	  cat('Error reading file ',rd_iob[iob$t_resultant]));


   END;				!End of OUTFIL

ROUTINE TST_PAT (TMP_PTR,TMP_LEN) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Check pattern string for legality.
!
! FORMAL PARAMETERS:
!
!	NONE.
!
! IMPLICIT INPUTS:
!
!	NONE.
!
! IMPLICIT OUTPUTS:
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	G_OK - no errors
!	G_ERMSG - illegal pattern string
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	UNS;

    !Make sure the pattern contains no more than one underscore
    !(what about quotes?)
    UNS=FALSE;

    INCR I FROM 1 TO .TMP_LEN DO
	BEGIN

	LOCAL
	    CHAR;

	CHAR=CH$RCHAR_A(TMP_PTR);

	IF
	    .CHAR EQL %C'_'
	THEN
	    BEGIN
	    IF
		.UNS
	    THEN
		BEGIN
		!Only one underscore allowed per pattern
		ERS(s_ilstring,LIT('Illegal pattern string'));
		RETURN G_ERMSG
		END;

	    UNS=TRUE

	    END

	END;

    G_OK

    END;				!End of TST_PAT

END					!End of Module CRELM
ELUDOM