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

MODULE ATTRIB	(
		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:
!
!	When called with a class name and an element name, find and
!	return the generation requested.
!
! ENVIRONMENT:	VAX/VMS, DS-20
!
! AUTHOR: D. Knight , CREATION DATE: 18-Sep-79
!
!--

!++
!			General Description
!
!	This module is used to access the CMS internal file ATF.
!	ATF contains all of the class related information for a
!	single library.  Each entry contains the following information.
!
!		1.  A single line entry containing the class
!		    name.
!
!		2.  One line for each element marked with the particular
!		    class which contains the element name and the
!		    generation of the element which is marked with
!		    the particular class.
!
!	All classes are stored in alphabetic order.  All element
!	references within each class are stored alphabetically also.
!
!--

!
! TABLE OF CONTENTS
!

FORWARD ROUTINE
	GETATR,				!get specified class
	GETNATR,			!get next class
	SETATR,				!set up for class calls
	GETCLS;				! get classes a particular 
					! generation of an element
					! belongs to

!
! INCLUDE FILES:
!

%if %bliss(bliss32) %then
    LIBRARY 'SYS$LIBRARY:STARLET';
%else
    REQUIRE 'jsys:';
%fi

LIBRARY 'XPORT:';

REQUIRE 'SCONFG:';

REQUIRE 'BLISSX:';

REQUIRE 'COMUSR:';

REQUIRE 'HOSUSR:';

!
! MACROS:
!

!
! EQUATED SYMBOLS:
!

LITERAL
	ATR_TAB_SIZ=1500;		!attribute table size in characters

!
! OWN STORAGE:
!

OWN
	ATR_END_PTR,			!pointer to end of table
	ATR_TAB_PTR,			!pointer to head of table
	ATR_T_SIZ,			!Current attribute table size
	ATR_T_PTR;			!working table pointer

!
! EXTERNAL REFERENCES:
!

EXTERNAL ROUTINE
	BADLIB,				!error in user's library
	badxpo,				!error in user's library
	BUG;				!Bug in code

GLOBAL ROUTINE GETATR (ELMLEN,ELMPTR,GENLEN,GENPTR) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Using the attribute string supplied to SETATR, fetch the
!	generation number which corresponds to the
!	specified attribute.
!
! FORMAL PARAMETERS
!
!	ELMLEN - length of element name.
!	ELMPTR - pointer to element name.
!	GENLEN - address of cell where generation length is stored
!	GENPTR - Character pointer to area where generation number is to be stored
!
! IMPLICIT INPUTS
!
!	The attribute data is stored in the table pointed to by ATR_TAB_PTR as retrieved from
!	the file ATF.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	TRUE - an entry was found
!	FALSE - No entry was found
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	EL_LEN,
	EL_BUF : VECTOR[CH$ALLOCATION(EL_NAM_SIZE)],
	FIRST,
	TMP_LEN,
	TMP_BUF : VECTOR[CH$ALLOCATION(GEN_SIZE)];

    FIRST=TRUE;

    !Try to find a matching element name
    WHILE
	GETNATR(.FIRST,EL_LEN,CH$PTR(EL_BUF),TMP_LEN,CH$PTR(TMP_BUF))
    DO
	BEGIN

	FIRST=FALSE;

	IF
	    CH$EQL(.ELMLEN,.ELMPTR,.EL_LEN,CH$PTR(EL_BUF))
	THEN
	    BEGIN
	    CH$MOVE(.TMP_LEN,CH$PTR(TMP_BUF),.GENPTR);
	    .GENLEN=.TMP_LEN;
	    RETURN TRUE
	    END

	END;

    FALSE

    END;				!End of GETATR

GLOBAL ROUTINE GETNATR (FIRST,ELMLEN,ELMPTR,GENLEN,GENPTR) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Using the attribute string supplied to SETATR, fetch the
!	generation number which corresponds to the
!	next attribute in the list.
!
! FORMAL PARAMETERS
!
!	FIRST - if TRUE, start at the beginning of the list.
!		if FALSE, continue from where left off after last
!		GETNATR call.
!	ELMLEN - address of cell where length of element name is to be stored
!	ELMPTR - character pointer to area where element name is to be stored
!	GENLEN - address of cell where length of generation is to be stored
!		 (area must be EL_NAM_SIZ characters long)
!	GENPTR - character pointer to area where generation is to be stored
!		 (area must be GEN_SIZE characters long)
!
! IMPLICIT INPUTS
!
!	The attribute data is stored in the table pointed to by ATR_TAB_PTR as retrieved from
!	the file ATF.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	TRUE - An entry was found
!	FALSE - No entry was found
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	COUNT,
	TXT_PTR;

    IF
	NOT .FIRST AND
	.ATR_T_PTR EQL 0
    THEN
	BUG(LIT('GETNATR not initialized'));

    !Initialize if starting over
    IF
	.FIRST
    THEN
	ATR_T_PTR=.ATR_TAB_PTR;

    !Make sure there is more text
    IF
	CH$DIFF(.ATR_END_PTR,.ATR_T_PTR) LEQ 0
    THEN
	!End of text
	BEGIN
	ATR_T_PTR=0;
	RETURN FALSE
	END;

    !Pick up the character count
    COUNT=CH$RCHAR_A(ATR_T_PTR);

    !Get the element name
    .ELMLEN=0;

    TXT_PTR=.ELMPTR;

    REPEAT
	BEGIN

	LOCAL
	    CHARACTER;

	CHARACTER=CH$RCHAR_A(ATR_T_PTR);
	COUNT=.COUNT-1;

	IF
	    .CHARACTER EQL %C' '
	THEN
	    EXITLOOP;

	if
	    ..elmlen geq el_nam_size
	then
	    bug(lit('Element name table overflow in GETNATR'));

	CH$WCHAR_A(.CHARACTER,TXT_PTR);
	.ELMLEN=..ELMLEN+1

	END;

    !Make sure the name is non-zero in length
    IF
	..ELMLEN EQL 0
    THEN
	BADLIB(LIT('Zero length class name'));

    !Get the generation
    .GENLEN=0;

    TXT_PTR=.GENPTR;

    if
	.count gtr gen_size
    then
	bug(lit('Generation number table overflow in GETNATR'));

    UNTIL
	.COUNT EQL 0
    DO
	BEGIN
	CH$WCHAR_A(CH$RCHAR_A(ATR_T_PTR),TXT_PTR);
	COUNT=.COUNT-1;
	.GENLEN=..GENLEN+1
	END;

    !It must exist
    IF
	..GENLEN EQL 0
    THEN
	BADLIB(LIT('Zero length generation number'));

    TRUE

    END;				!End of GETNATR

GLOBAL ROUTINE SETATR (ATRLEN,ATRPTR) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Initialize the attribute table with the attribute
!	specified in the argument.
!
! FORMAL PARAMETERS
!
!	ATRLEN - length of attribute string.
!	ATRPTR - pointer to attribute string.
!
! IMPLICIT INPUTS
!
!	The attribute data is contained in the file ATF.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	TRUE - Attribute information was found
!	FALSE - no such attribute.
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	$IO_BLOCK_DECL(ATR);		!declare iobs etc

    !Initialize IOB
    $IO_BLOCK_INIT(ATR);

    !make sure starting pointer is also clear
    atr_t_ptr=0;

    !Find the file, set no such attribute if not found
    IF
	NOT $STEP_OPEN(IOB=ATR_IOB,FILE_SPEC=(%STRING(LIB,ATF)),OPTIONS=INPUT,FAILURE=0)
    THEN
	RETURN FALSE;

    !Find the correct attribute
    UNTIL
	$step_get(IOB=ATR_IOB) EQL step$_eof
    DO
	BEGIN

	LOCAL
	    ATRPNT,
	    CLS_NM_LGT;

	ATRPNT=.ATR_IOB[IOB$A_STRING];

	CLS_NM_LGT=0;

	!Get length of class name only
	UNTIL
	    CH$RCHAR(CH$PLUS(.ATR_IOB[IOB$A_STRING],.CLS_NM_LGT)) EQL %C' ' OR
	    .CLS_NM_LGT EQL .ATR_IOB[IOB$H_STRING]
	DO
	    CLS_NM_LGT=.CLS_NM_LGT+1;

	!If this attribute is correct, build the attribute table
	IF
	    CH$RCHAR(.ATRPNT) NEQ %C' ' AND
	    CH$EQL(.CLS_NM_LGT,.ATR_IOB[IOB$A_STRING],.ATRLEN,.ATRPTR)
	THEN
	    BEGIN

	    !Initialize table
	    $XPO_GET_MEM(CHARACTERS=ATR_TAB_SIZ,RESULT=ATR_TAB_PTR);
	    ATR_T_SIZ=ATR_TAB_SIZ;
	    ATR_END_PTR=.ATR_TAB_PTR;

	    !Get contents of attribute list
	    REPEAT
		BEGIN

		!Get a line
		IF
		    $step_get(IOB=ATR_IOB) EQL step$_eof
		THEN
		    BEGIN
		    IF
			CH$DIFF(.ATR_END_PTR,.ATR_TAB_PTR) EQL 0
		    THEN
			!Attribute does not exist
			BEGIN
			$XPO_FREE_MEM(STRING=(ATR_TAB_SIZ,.ATR_TAB_PTR));
			RETURN FALSE
			END
		    ELSE
			EXITLOOP
		    END;

		ATRPNT=.ATR_IOB[IOB$A_STRING];

		!Non blank first character means end of list
		IF
		    CH$RCHAR_A(ATRPNT) NEQ %C' '
		THEN
		    EXITLOOP;

		!Make sure there is room
		IF
		    CH$DIFF(CH$PLUS(.ATR_END_PTR,.ATR_IOB[IOB$H_STRING]),
			CH$PLUS(.ATR_TAB_PTR,.ATR_T_SIZ)) GEQ 0
		THEN
		    !Get more room by reallocating the table
		    BEGIN

		    LOCAL
			T_PTR;

		    !Specify how much more is needed
		    ATR_T_SIZ=.ATR_T_SIZ+ATR_TAB_SIZ;

		    !Allocate new storage block
		    $XPO_GET_MEM(CHARACTERS=.ATR_T_SIZ,RESULT=T_PTR);

		    !Move data from old to new table
		    ATR_END_PTR=CH$MOVE(CH$DIFF(.ATR_END_PTR,.ATR_TAB_PTR),
					.ATR_TAB_PTR,.T_PTR);

		    !Release old table
		    $XPO_FREE_MEM(STRING=(.ATR_T_SIZ-ATR_TAB_SIZ,.ATR_TAB_PTR));

		    !Point to new table
		    ATR_TAB_PTR=.T_PTR

		    END;

		!Now store the data
		CH$WCHAR_A(.ATR_IOB[IOB$H_STRING]-1,ATR_END_PTR);
		ATR_END_PTR=CH$MOVE(.ATR_IOB[IOB$H_STRING]-1,.ATRPNT,.ATR_END_PTR)

		END;

	    !Terminate the file
	    $step_close(IOB=ATR_IOB);

	    RETURN TRUE
	    END;

	IF
	    CH$RCHAR(.ATRPNT) NEQ %C' ' AND
	    CH$GTR(.CLS_NM_LGT,.ATR_IOB[IOB$A_STRING],.ATRLEN,.ATRPTR)
	THEN
	    EXITLOOP

	END;

    !Close the working file
    $step_close(IOB=ATR_IOB);

    FALSE

    END;				!End of SETATR

GLOBAL ROUTINE GETCLS(GEN_LEN,GEN_PTR,ELM_LEN,ELM_PTR,A_DESC_OUT) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine examines the class file to find all the classes that
!	a particular generation of an element belongs. This routine also
!	supports a wild card character (*) for the generation number in
!	in the generation string.  This means a class is found if the element
!	name matches regardless of the generation number.
!
! FORMAL PARAMETERS:
!
!	GEN_LEN		    Length of generation string.
!
!	GEN_PTR		    Pointer to generation string.
!
!	ELM_LEN		    Length of element string.
!	
!	ELM_PTR		    Pointer to element string.
!
!	A_DESC_OUT	    Address of a descriptor that points to where
!			    output string is located.  This is assumed to
!			    to have been initialized by the calling routine.
!			    The output string consist of a concatentation of
!			    all the classes that the particular generation of
!			    the element belongs and are separated by blank
!			    delimiters.  The storage for this output string is
!			    allocated within this routine.
!
! IMPLICIT INPUTS:
!
!	
!
! IMPLICIT OUTPUTS:
!
!	
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
!	TRUE = Element belongs to at least one class.
!	FALSE = Element does not belong to any class.
!
! SIDE EFFECTS:
!
!	
!
!--

    BEGIN
    
    LITERAL
	N_ALLOC_FAC = 120;		! allocation factor for string expansion

	!+
	!    WARNING: The above value should be of sufficient size to 
	!	satisfy the request with one allocation.  That is to say its
	!	size should be at least as big as the maximum class name size
	! 	plus one(for the blank delimiter).
	!+

    BIND
	D_OUT=.A_DESC_OUT:DESC_BLOCK ;	! desc provided by caller(initialized)
	
    LOCAL
	$IO_BLOCK_DECL(ATR),		! file iob

	A_MEM_BLK,			! address of memory block
	CLS_CNT,			! number of classes found
	
	D_ELM: DESC_BLOCK,		! Desc of element string in file
	D_GEN: DESC_BLOCK,		! desc of generation string in file
	
	F_ELM_REC,			! Previous record was element record
	F_MAT_BOTH,			! Both element and gen match input
	F_1ST_ALL,			! first allocation of memory
	
	L_ELM_REC,			! current work length in element rec
	L_REM_OUT,			! remaining length in output area
	L_SAV_CLS,			! length of current class + blank
	L_VAL_STR,			! length of valid string in buf so far
	
	P_ELM_REC,			! current work pointer on element rec
	P_NXT_SPC,			! pointer to next space available
	P_SAV_CLS,			! pointer to current class in out area
	status;

	
    ! initialize iob
    $IO_BLOCK_INIT(ATR) ;
	
    ! open class file
    IF
	(status=$STEP_OPEN(IOB=ATR_IOB,FILE_SPEC=(%STRING(LIB,ATF)),
	 OPTIONS=INPUT,FAILURE=0)) NEQ step$_NORMAL
    THEN
	badxpo(.status,CAT('Unable to open class file')) ;
		
    ! initialize variables
    L_REM_OUT = 0;
    CLS_CNT = 0 ;
    F_1ST_ALL = FALSE ;
    F_MAT_BOTH = FALSE ;
    F_ELM_REC = FALSE ;
    
    UNTIL
	$step_get(IOB=ATR_IOB) EQL step$_eof
    DO
	BEGIN	    ! read class file loop

	LOCAL
	    CLS_NM_LGT;

	CLS_NM_LGT=0;

	!Get length of class name only
	UNTIL
	    CH$RCHAR(CH$PLUS(.ATR_IOB[IOB$A_STRING],.CLS_NM_LGT)) EQL %C' ' OR
	    .CLS_NM_LGT EQL .ATR_IOB[IOB$H_STRING]
	DO
	    CLS_NM_LGT=.CLS_NM_LGT+1;
	
	IF
	    (CH$RCHAR(.ATR_IOB[IOB$A_STRING]) NEQ %C' ')
	THEN
	    BEGIN	! non-blank means class record
	    
	    IF
		NOT .F_MAT_BOTH AND .F_1ST_ALL
	    THEN
		BEGIN	! no match,backup
		
		!+
		!	When there was no match among previous elements
		!	the output buffer is backed up to where last class
		!	string started so it over written by the next 
		!	valid match.
		!+
		
		L_REM_OUT = .L_REM_OUT + .L_SAV_CLS ;
		P_NXT_SPC = .P_SAV_CLS ;
		END ;	! no match,backup

	    IF 
		.F_ELM_REC
	    THEN
		BEGIN	    ! last rec was elm rec
		F_ELM_REC = FALSE ;
		
		IF
		    .F_MAT_BOTH
		THEN
		    BEGIN	! match
		    CLS_CNT = .CLS_CNT + 1 ;
		    F_MAT_BOTH = FALSE ;
		    END ;	! match
		
		END ;	    ! last rec was elm rec

	    
	    IF
		.L_REM_OUT EQL 0 OR
		.L_REM_OUT LSS (.CLS_NM_LGT+1)
	    THEN
		BEGIN	    ! allocation required
		IF
		    NOT .F_1ST_ALL
		THEN
		    BEGIN	    ! first allocation
		    D_OUT[DESC_LEN] = N_ALLOC_FAC ;
		    $XPO_GET_MEM(CHARACTERS=N_ALLOC_FAC,
				 RESULT=D_OUT[DESC_PTR]) ;
		    F_1ST_ALL = TRUE ;
		    L_REM_OUT = N_ALLOC_FAC ;
		    P_NXT_SPC = .D_OUT[DESC_PTR] ;
		    END	    ! first allocation
		ELSE
		    BEGIN	    ! 2nd + subsequent allocations
		    
		    !+
		    !   When another block is required it is allocated.  the 
		    !   string from the previous block is moved to the new 
		    !   block and the old block is released. Each new block
		    !   represents a character expansion by a factor of 
		    !	N_ALLOC_FAC over the old block.
		    !+
		    
		    $XPO_GET_MEM(CHARACTERS=(.D_OUT[DESC_LEN]+N_ALLOC_FAC),
			 	RESULT=A_MEM_BLK) ;    ! allocate new block
		    L_VAL_STR = .D_OUT[DESC_LEN]-.L_REM_OUT ;
		    P_NXT_SPC = CH$MOVE(.L_VAL_STR,.D_OUT[DESC_PTR],
					.A_MEM_BLK) ;   ! actual str len+ptr
		    !update remaining length and free old block
		    L_REM_OUT = .D_OUT[DESC_LEN] + N_ALLOC_FAC - .L_VAL_STR ;
		    $XPO_FREE_MEM(STRING=(.D_OUT[DESC_LEN],.D_OUT[DESC_PTR])) ;
		    
		    ! reset descriptor to new block
		    D_OUT[DESC_LEN] = .L_VAL_STR + .L_REM_OUT ;
		    D_OUT[DESC_PTR] = .A_MEM_BLK ;
		    END ;	    ! 2nd + subsequent allocation
		    
		END ;   ! allocation required

	    ! move new class to out buffer
	    P_NXT_SPC = CH$MOVE(.CLS_NM_LGT,.ATR_IOB[IOB$A_STRING],
				.P_NXT_SPC) ;
	    CH$WCHAR_A(%C' ',P_NXT_SPC) ;	    !put blank after class
	    L_REM_OUT = .L_REM_OUT - .CLS_NM_LGT - 1 ;

	    ! save len + ptr in case backup required
	    L_SAV_CLS = .CLS_NM_LGT+1;
	    P_SAV_CLS = CH$PLUS(.P_NXT_SPC,-.L_SAV_CLS) ;
	    
	    END 	! non-blank means class record
	ELSE

	    BEGIN	! blank means element gen record
	    
	    IF
		NOT .F_ELM_REC
	    THEN
		F_ELM_REC = TRUE ;
		
	    IF
		NOT .F_MAT_BOTH
	    THEN
		BEGIN	    ! no match yet
		! set up descriptor to point element in record
		D_ELM[DESC_PTR] = CH$PLUS(.ATR_IOB[IOB$A_STRING],1) ;
		P_ELM_REC = CH$FIND_CH(.ATR_IOB[IOB$H_STRING]-1,
				       .D_ELM[DESC_PTR],%C' ') ;
		D_ELM[DESC_LEN] = CH$DIFF(.P_ELM_REC,.D_ELM[DESC_PTR]) ;
		
		! set up generation descriptor
		P_ELM_REC = CH$PLUS(.P_ELM_REC,1) ;
		D_GEN[DESC_PTR] = .P_ELM_REC ;
		L_ELM_REC = .ATR_IOB[IOB$H_STRING] - .D_ELM[DESC_LEN] -2 ;
		P_ELM_REC = CH$FIND_CH(.L_ELM_REC,.D_GEN[DESC_PTR],%C' ') ;
		
		IF
		    (CH$FAIL(.P_ELM_REC) EQL 1 )
		THEN
		    ! nothing beyond generation number
		    D_GEN[DESC_LEN] = .L_ELM_REC 
		ELSE
		    D_GEN[DESC_LEN] = CH$DIFF(.P_ELM_REC,.D_GEN[DESC_PTR]) ;
		    
		IF
		    CH$RCHAR(.GEN_PTR) EQL %C'*'
		THEN
		    BEGIN	! wild card gen number

		    IF
			CH$EQL(.ELM_LEN,.ELM_PTR,LEN_COMMA_PTR(D_ELM),%C' ')
		    THEN
			F_MAT_BOTH = TRUE ;

		    END		! wild card gen number
		ELSE
		    BEGIN	! compare both element and generation

		    IF
			CH$EQL(.GEN_LEN,.GEN_PTR,LEN_COMMA_PTR(D_GEN),%C' ') AND
			CH$EQL(.ELM_LEN,.ELM_PTR,LEN_COMMA_PTR(D_ELM),%C' ')
		    THEN
			F_MAT_BOTH = TRUE ;
		    
		    END ;	! compare both element and generation

		END ;	    ! no match yet
		
	    END ;	! blank means element gen record
	    
	END ;	    ! read file loop

	
    ! end of file - verify that last class was valid
    IF
	NOT .F_MAT_BOTH
    THEN
	L_REM_OUT = .L_REM_OUT + .L_SAV_CLS 
    ELSE
	! last record matches
	CLS_CNT = .CLS_CNT + 1 ;
	
    !reset output descriptor to actual string length
    D_OUT[DESC_LEN] = .D_OUT[DESC_LEN] - .L_REM_OUT ;
    
    ! close class file before returning
    $step_close(IOB=ATR_IOB) ;
	    
    IF
	.CLS_CNT EQL 0
    THEN
	RETURN FALSE ;
	
	
    TRUE
    END;

END				!End of Module ATTRIB
ELUDOM