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

	LOGICAL*1 FUNCTION GET_FIELD(FIELD, SIZE, TERMINATOR)
	IMPLICIT NONE
C This subroutine is used to fetch a field from the input buffer.  The
C resulting field and terminator are returned to the caller.  The function
C returns a value of TRUE if there are more characters remaining in the
C buffer.  Fields are terminated by space, tab, comma, slash or plus.

	INTEGER*4 BUFF_SIZE, NUM_TERM, I, J
	PARAMETER (BUFF_SIZE = 255, NUM_TERM = 5)
	CHARACTER*(*) FIELD, TERMINATOR
	CHARACTER*1 CHAR, TERM_TABLE(NUM_TERM)
	CHARACTER*(BUFF_SIZE) BUFFER
	INTEGER*2 OFFSET, SIZE
	LOGICAL*1 LEAD

	DATA TERM_TABLE /' ',',','/','+','='/

	COMMON /BUFF/ OFFSET, BUFFER

	LEAD = .TRUE.			!Start with leading-blank flag true
	SIZE = 0			!Initialize pointer to field storage
	FIELD = ' '			!Initialize the receiving field to space
10	IF (OFFSET .GT. BUFF_SIZE) THEN	!If nothing more remains in the buffer,
	   GET_FIELD = .FALSE.		!  then indicate so and return
	   RETURN
	ENDIF

	CHAR = BUFFER(OFFSET:OFFSET)	!Get the next character
	IF (CHAR .EQ. '	') CHAR = ' '	!Convert any tabs to space
	OFFSET = OFFSET + 1		!Increment the pointer
C Ignore leading spaces and tabs
	IF (LEAD .AND. (CHAR .EQ. ' ')) GOTO 10
	LEAD = .FALSE.			!Reset lead-in flag after first real
					!  character is found
C See if this is a valid delimiter
	DO I = 1, NUM_TERM
	   IF (CHAR .EQ. TERM_TABLE(I)) THEN
	      TERMINATOR = CHAR		!Save the terminator
20	      CHAR = BUFFER(OFFSET:OFFSET)
	      IF (CHAR .EQ. '	') CHAR = ' '
	      IF (CHAR .EQ. ' ') THEN
		 OFFSET = OFFSET + 1
		 GOTO 20
	      ENDIF
	      IF (TERMINATOR .EQ. ' ') THEN
		 DO J=1, NUM_TERM
		    IF (CHAR .EQ. TERM_TABLE(J)) THEN
		       TERMINATOR = CHAR
		       OFFSET = OFFSET + 1
		    ENDIF
		 ENDDO
	      ENDIF
	      GET_FIELD = .TRUE.	!Assume there is more to come
	      IF (OFFSET .GT. BUFF_SIZE) GET_FIELD = .FALSE. !No more left
	      RETURN  			!And return
	   ENDIF
	ENDDO

	SIZE = SIZE + 1			!Point to the next output position
	FIELD(SIZE:SIZE) = CHAR		!Save the character in it
	GOTO 10				!Go check the next character
	END
	LOGICAL*1 FUNCTION GET_VALUE(FIELD, SIZE, TERMINATOR)
	IMPLICIT NONE
C This subroutine is used to fetch a value field from the input buffer.  The
C resulting field and terminator are returned to the caller.  The function
C returns a value of TRUE if there are more characters remaining in the
C buffer.  Fields are terminated by space, tab, comma, slash or plus.
C If the first non-blank character is an open parenthesis, all characters
C following it are included in the field until the matching closing
C parenthesis is encountered.

	INTEGER*4 BUFF_SIZE, NUM_TERM, I, J
	PARAMETER (BUFF_SIZE = 255, NUM_TERM = 5)
	CHARACTER*(*) FIELD, TERMINATOR
	CHARACTER*1 CHAR, TERM_TABLE(NUM_TERM)
	CHARACTER*(BUFF_SIZE) BUFFER
	INTEGER*2 OFFSET, SIZE, PAREN_COUNT
	LOGICAL*1 LEAD

	EXTERNAL CML_IVVALU

	DATA TERM_TABLE /' ',',','/','+','='/

	COMMON /BUFF/ OFFSET, BUFFER

	LEAD = .TRUE.			!Start with leading-blank flag true
	SIZE = 0			!Initialize pointer to field storage
	FIELD = ' '			!Initialize the receiving field to space
10	IF (OFFSET .GT. BUFF_SIZE) THEN	!If nothing more remains in the buffer,
	   GET_VALUE = .FALSE.		!  then indicate so and return
	   RETURN
	ENDIF

	CHAR = BUFFER(OFFSET:OFFSET)	!Get the next character
	IF (CHAR .EQ. '	') CHAR = ' '	!Convert any tabs to space
	OFFSET = OFFSET + 1		!Increment the pointer
C Ignore leading spaces and tabs
	IF (LEAD .AND. (CHAR .EQ. ' ')) GOTO 10
	LEAD = .FALSE.			!Reset lead-in flag after first real
					!  character is found
	IF (CHAR .EQ. '(') GOTO 100	!Process values enclosed in parens elsewhere

C See if this is a valid delimiter
	DO I = 1, NUM_TERM
	   IF (CHAR .EQ. TERM_TABLE(I)) THEN
	      TERMINATOR = CHAR		!Save the terminator
20	      CHAR = BUFFER(OFFSET:OFFSET)
	      IF (CHAR .EQ. '	') CHAR = ' '
	      IF (CHAR .EQ. ' ') THEN
		 OFFSET = OFFSET + 1
		 GOTO 20
	      ENDIF
	      IF (TERMINATOR .EQ. ' ') THEN
		 DO J=1, NUM_TERM
		    IF (CHAR .EQ. TERM_TABLE(J)) THEN
		       TERMINATOR = CHAR
		       OFFSET = OFFSET + 1
		    ENDIF
		 ENDDO
	      ENDIF
	      GET_VALUE = .TRUE.	!Assume there is more to come
	      IF (OFFSET .GT. BUFF_SIZE) GET_VALUE = .FALSE. !No more left
	      RETURN  			!And return
	   ENDIF
	ENDDO

	SIZE = SIZE + 1			!Point to the next output position
	FIELD(SIZE:SIZE) = CHAR		!Save the character in it
	GOTO 10				!Go check the next character

C Process values enclosed in parentheses
100	PAREN_COUNT = 1		!Initialize the paren count

110	SIZE = SIZE + 1		!Increment the character count
	FIELD(SIZE:SIZE) = CHAR	!Store the character
	IF (PAREN_COUNT .EQ. 0) THEN
	   IF (OFFSET .GT. BUFF_SIZE) THEN
	      GET_VALUE = .FALSE.
	      TERMINATOR = ' '
	      RETURN
	   ENDIF
	   TERMINATOR = BUFFER(OFFSET:OFFSET)
	   OFFSET = OFFSET + 1
	   GET_VALUE = .TRUE.	!Return true when parentheses are balanced
	   RETURN
	ENDIF
	IF (OFFSET .GT. BUFF_SIZE) 	!If the end of the buffer is here,
	1  CALL LIB$SIGNAL(CML_IVVALU,%VAL(1),FIELD) !  the syntax is invalid
	CHAR = BUFFER(OFFSET:OFFSET)	!Get the next character
	OFFSET = OFFSET + 1		!Increment the offset
	IF (CHAR .EQ. '(') PAREN_COUNT = PAREN_COUNT + 1
	IF (CHAR .EQ. ')') PAREN_COUNT = PAREN_COUNT - 1
	GOTO 110

	END