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

MODULE GETELM	(
		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:
!
!	Element fetching controller.
!
! ENVIRONMENT:	VAX/VMS, DS-20
!
! AUTHOR: D. Knight , CREATION DATE: 12-Apr-79
!
! MODIFIED BY:
!
!	, : VERSION
! 01	- 12-Apr-79 First cut at the processor
!--

!
! TABLE OF CONTENTS
!

FORWARD ROUTINE
	GETELM;

!
! INCLUDE FILES:
!

%if
    %bliss(bliss32)
%then
    LIBRARY 'sys$library:starlet';
%else
    require 'jsys:';
%fi

LIBRARY 'XPORT:';

REQUIRE 'SCONFG:';

REQUIRE 'BLISSX:';

REQUIRE 'COMUSR:';

!
! MACROS:
!

!
! EQUATED SYMBOLS:
!

!
! OWN STORAGE:
!

GLOBAL
	PATLGT,				!Pattern length
	PATPTR,				!Pattern pointer
	PATTRN: VECTOR[CH$ALLOCATION(132+132+3)]; !Pattern storage

OWN
	$io_block(rd);			!Input IOB

!
! EXTERNAL REFERENCES:
!

EXTERNAL ROUTINE
	badxpo,
	GET_LXM;

GLOBAL ROUTINE GETELM (ELM,SIZE,ADR) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	Given an entry in the element control list, call the specified
!	processor with the names of the files contained in the element.
!	The named processor will be called once for each file in the element
!	list.
!
! FORMAL PARAMETERS:
!
!	ELM - string pointer to element name to be found
!	SIZE - length of element name
!	ADR - address of routine to be called each time a file name is found
!	      (if zero, no calls are made, only status is returned)
!
! IMPLICIT INPUTS:
!
!	NONE.
!
! IMPLICIT OUTPUTS:
!
!	NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
!	G_OK - actions successful
!	G_NO_ELM - no such element
!	G_ERROR - major processing error
!
! SIDE EFFECTS:
!
!	NONE.
!
!--

    BEGIN

    LOCAL
	F_QUO,
	LEX_LGT,
	LINE_LGT,
	LINE_PTR,
	status,
	TXT_BUF: VECTOR[CH$ALLOCATION(50)],
	TXT_PTR;


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

    !Initialize toggle for quoted strings
    F_QUO = FALSE;

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

	!Point to the working line
	LINE_PTR=.RD_IOB[IOB$A_STRING];
	LINE_LGT=.RD_IOB[IOB$H_STRING];
	TXT_PTR=CH$PTR(TXT_BUF);

	!Skip over element name
	LEX_LGT=GET_LXM(LINE_PTR,%C' ',.LINE_LGT,TXT_PTR);
	LINE_LGT=.LINE_LGT-.LEX_LGT-1;

	IF
	    CH$EQL(.SIZE,.ELM,.LEX_LGT,.RD_IOB[IOB$A_STRING])
	THEN
	    !The element has been found
	    BEGIN

	    !Now process files in list
	    WHILE
		.LINE_LGT GTR 0
	    DO
		BEGIN

		LOCAL
		    CHAR;

		TXT_PTR=CH$PTR(TXT_BUF);

		!Assemble the file name lexeme
		LEX_LGT=0;
		WHILE
		    .LINE_LGT NEQ 0
		DO
		    BEGIN

		    !Pick up a character for comparison
		    CHAR=CH$RCHAR_A(LINE_PTR);
		    LINE_LGT=.LINE_LGT-1;

		    !Look for end of scan
		    IF
			.CHAR EQL %C'/' OR
			.CHAR EQL %C','
		    THEN
			EXITLOOP;

		    !Save the character seen
		    CH$WCHAR_A(.CHAR,TXT_PTR);
		    LEX_LGT=.LEX_LGT+1

		    END;

		!See if a pattern exists also
		IF
		    .CHAR EQL %C'/'
		THEN
		    BEGIN
		    PATPTR=CH$PTR(PATTRN);
		    PATLGT=0;

		    ! transfer "/"
		    CH$WCHAR_A(.CHAR,PATPTR) ;
		    PATLGT = .PATLGT + 1 ;
			    
		    UNTIL
			.LINE_LGT EQL 0
		    DO
			BEGIN

			!Get a character
			CHAR=CH$RCHAR_A(LINE_PTR);
			LINE_LGT=.LINE_LGT-1;

			IF 
			    .CHAR EQL %C'"' 
			THEN
			    IF 
				.F_QUO
			    THEN
				F_QUO = FALSE
			    ELSE
				F_QUO = TRUE;

			!Does it end the pattern?
			IF
			    .CHAR EQL %C',' AND NOT .F_QUO
			THEN
			    EXITLOOP;

			!No, place it in the pattern string
			CH$WCHAR_A(.CHAR,PATPTR);
			PATLGT=.PATLGT+1

			END;


		    PATPTR=CH$PTR(PATTRN)

		    END
		ELSE
		    PATLGT=0;

		!Process the requested action
		IF
		    .LEX_LGT GTR 0
		THEN
		    BEGIN

		    LOCAL
			RVAL;		!Return value

		    IF
			.ADR NEQ 0
		    THEN
			RVAL=(.ADR)(.LEX_LGT,CH$PTR(TXT_BUF))
		    ELSE
			RVAL=G_OK;

		    IF
			.RVAL NEQ G_OK OR
			.ADR EQL 0
		    THEN
			BEGIN
			$step_close(IOB=RD_IOB,options=remember);
			RETURN .RVAL
			END
		    END

		END;

	    $step_close(IOB=RD_IOB,options=remember);
	    RETURN G_OK

	    END
	ELSE
	IF
	    CH$LSS(.SIZE,.ELM,.SIZE,.RD_IOB[IOB$A_STRING])
	THEN
	    EXITLOOP;

	END;

    $step_close(IOB=RD_IOB,options=remember);

    G_NO_ELM

    END;				!End of GETELM

END				!End of Module GETELM
ELUDOM