Google
 

Trailing-Edge - PDP-10 Archives - bb-h138f-bm - 7-sources/diutpa.b36
There are 4 other files named diutpa.b36 in the archive. Click here to see a list.
%TITLE 'DIUTPA - Common BLISS table driven parser'
MODULE tparse (IDENT = '253'
		%BLISS32( ,ADDRESSING_MODE(EXTERNAL=GENERAL,
					    NONEXTERNAL=GENERAL))
		)=
!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1986.
!	ALL RIGHTS RESERVED.
!
!	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 THAT IS NOT SUPPLIED BY DIGITAL.
BEGIN

!++
!
! FACILITY:  System Library
!
! ABSTRACT:
!
!	TPARSE is a general purpose state table driven parser. Its
!	general design is that of a finite state parser; however,
!	some of its features allow non-deterministic parsing and
!	limited use as a push-down parser. The input string is parsed
!	by interpreting the transitions in the user suppled state
!	table; user supplied action routines are called as indicated
!	in the state table to provide the semantics associated with
!	the table specified syntax.
!
! COMPILATION OPTIONS:						       !* 7  *
!								       !* 7  *
!	The variant switch controls whether the ascii to binary	       !* 8  *
!	conversion routines are internal routines or external routines !* 8  *
!	supplied by the user and whether a debug routine is called after !* 12 *
!	matching a token.  The values of the variant switch are	       !* 12 *
!	defined as follows:					       !* 7  *
!								       !* 7  *
!	Bit	Value		Meaning				       !* 12 *
!	---	-----		-------				       !* 12 *
!	 0	  0		Conversion routines are internal       !* 12 *
!		  1		Conversion routines are external,      !* 12 *
!					user supplied		       !* 12 *
!								       !* 12 *
!	 1	  0		Do not call debug routine	       !* 12 *
!		  1		Call Debug routine		       !* 12 *
!								       !* 12 *
!	The debug routine is a user supplied routine with the name TPA$DB. !* 12 *
!	It is called with four parameters. The first parameter contains !* 12 *
!	the address of the tparse state vector. The second parameter   !* 12 *
!	contains the token type code for the token just parsed.  The third !* 12 *
!	parameter is the length of the keyword token if the token type is !* 12 *
!	a keyword.  The fourth parameter is the pointer to the keyword string !* 12 *
!	if the token type is a keyword.				       !* 12 *
!								       !* 7  *
! ENVIRONMENT:
!
!	Transportable, user mode				       !* 7  *
!
!--

!
!
! AUTHOR:  Andrew C. Goldstein, CREATION DATE:  14-Oct-1976  13:55
!
! REVISION HISTORY:
!
!   Andrew C. Goldstein, 7-Oct-1977  15:50
!   X0002 - Add action routine parameter, minimal keyword abbreviation.
!
!   Andrew C. Goldstein, 21-Feb-1978  16:31
!   X0003 - State table format changes (BL5)
!
!   Dennis E. Phillips, 13-May-1981
!   X0103 - Convert to BLISS COMMON
!
!								       !* 6  *
!   Richard V. Whalen, 5-Nov-1981				       !* 6  *
!   X0104 - Modified to return the value returned by the action routine if the !* 6  *
!	action routine does not return true.  If the action routine returns !* 6  *
!	0 (false) then it returns lib$_syntaxerr.		       !* 6  *
!								       !* 7  *
!   Dennis E. Phillips, 9-Nov-1981				       !* 7  *
!   X0105 - Get rid of Xport ascii to binary conversion routines,  use !* 7  *
!	internal routines or user supplied external routines.	       !* 7  *
!								       !* 12 *
!   Dennis E. Phillips, 19-Jul-1982				       !* 12 *
!   X0106 - Add call to debug routine				       !* 12 *
!								       !* 12 *
!  253  Rename file to DIUTPA.
!       Gregory A. Scott 1-Jul-86
!
!**
MACRO								       !* 12 *
    test_bit(bn,val) =						       !* 12 *
	((val ^ -(bn)) and 1 ) %;				       !* 12 *
								       !* 12 *
%if test_bit(0,%variant)					       !* 12 *
%then								       !* 7  *
    %print('Compiling using external ascii to binary conversion routines') !* 15 *
%else								       !* 15 *
    %print('Compiling using internal ascii to binary conversion routines') !* 7  *
%fi								       !* 7  *

%if test_bit(1,%variant)					       !* 12 *
%then								       !* 12 *
    %print('Compiling with call to debug routine')		       !* 15 *
%else								       !* 15 *
    %print('Compiling without call to debug routine')		       !* 12 *
%fi								       !* 12 *
								       !* 12 *
library 'diutpamac';						       !* 3  *

FORWARD ROUTINE
    TPARSE,					! main parser routine
    GETSTRING;					! extract a basic string token

%if test_bit(0,%variant)					       !* 12 *
%then								       !* 7  *
    EXTERNAL ROUTINE						       !* 15 *
%else								       !* 7  *
    FORWARD ROUTINE						       !* 15 *
%fi								       !* 7  *
    cvtdtb,				!decimal to binary conversion  !* 7  *
    cvthtb,				!hex to binary conversion      !* 7  *
    cvtotb;				!octal to binary conversion    !* 7  *

%if test_bit(1,%variant)					       !* 12 *
%then								       !* 12 *
    EXTERNAL ROUTINE						       !* 12 *
	tpa$db : novalue;					       !* 12 *
%fi								       !* 12 *
								       !* 12 *
! Local macros and symbol definitions
!

LITERAL
! Character codes
!
    SPACE = %O'40',				! space character
    TERMINATOR = %O'377',			! keyword string terminator
    TAB = %O'11',				! tab character
! String types (input to GETSTRING routine)
!
    SPACES = 0,
    NUMERIC = 1,
    ALPHANUMERIC = 2,
    SYMBOL = 3,
! Token types
!
    $ANY = %X'FF' AND TPA$_ANY,			! any single character
    $ALPHA = %X'FF' AND TPA$_ALPHA,		! any alphabetic character
    $DIGIT = %X'FF' AND TPA$_DIGIT,		! any numeric character
    $TSTRING = %X'FF' AND TPA$_STRING,		! any alphanumeric string
    $SYMBOL = %X'FF' AND TPA$_SYMBOL,		! any symbol constituent set string
    $BLANK = %X'FF' AND TPA$_BLANK,		! any string of spaces and tabs
    $DECIMAL = %X'FF' AND TPA$_DECIMAL,		! decimal number
    $OCTAL = %X'FF' AND TPA$_OCTAL,		! octal number
    $HEX = %X'FF' AND TPA$_HEX,			! hexadecimal number
    $LAMBDA = %X'FF' AND TPA$_LAMBDA,		! empty string
    $EOS = %X'FF' AND TPA$_EOS,			! end of string
    $SUBEXPR = %X'FF' AND TPA$_SUBEXPR,		! subexpression
    NULL_MATCH = TPA$_LAMBDA,			! codes geq match null strings
    HIGH_ASCII = 255,				! highest ASCII character code
    KEYWORD = 256,				! start of keyword codes
    HIGH_KEYWORD = 475,				! highest keyword code
    LOW_SPECIAL = $ANY,				! first special type code
    HIGH_SPECIAL = $SUBEXPR;			! last special type code
! Macros to determine character types
!

MACRO
    IS_ALPHABETIC (CHAR) =
    (
    SELECTONE CHAR OF
    SET

    [%C'A' TO %C'Z' , %C'a' TO %C'z'] : 1;

    [OTHERWISE] : 0;

   TES
   )%,
    IS_NUMERIC (CHAR) =
    (
	SELECTONE CHAR OF
	SET
	[%C'0' TO %C'9'] : 1;
	[OTHERWISE] : 0;
	TES
    )%,
    IS_SYMBOL (CHAR) =
 (SELECTONE CHAR OF
	    SET
	    [%C'_', %C'$'] : 1;
	    [OTHERWISE] : 0;
	    TES)
	%,
    IS_SPACE (CHAR) =
 (SELECTONE CHAR OF
		SET
		[SPACE, TAB] : 1;
		[OTHERWISE] : 0;
		TES)
	    %;
%SBTTL 'TPARSE - main routine'					       !* 14 *
GLOBAL ROUTINE tparse (state_vector, start_state) =		       !* 14 *

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine is the main parser routine.
!
!
! CALLING SEQUENCE:
!	TPARSE (ARG1, ARG2)
!
!
! INPUT PARAMETERS:
!	ARG1 = address of state vector, containing:
!		options longword
!		    bit 0 set to match blanks and tabs
!		          clear to ignore blanks and tabs
!		    bit 1 set to allow minimum abbreviation of keywords
!			  clear to use match count
!		    high byte = keyword match count (0 = exact)
!		string descriptor of string to be parsed
!		data made available to action routines:
!		    string descriptor of matching token
!		    single character token
!		    numerical value of numeric token
!	ARG2 = address of starting state in state table
!
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	string descriptor pointed to by ARG1 updated to indicate
!	string not processed by the parser
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	1 if successful parse
!	0 if syntax error
!
! SIDE EFFECTS:
!	none except as produced by user's action routines
!
!--
    BEGIN

OWN								       !* 13 *
	action_value;				! value returned by the action routine !* 13 *
    LOCAL
	STATE,					! state table pointer
	curpos,					! offset in state table pointer
	TYPE : BLOCK [1],			! syntax type of current transition !* 12 *
	keylength,						       !* 12 *
	KEY;							       !* 12 *

    MAP
	STATE_VECTOR : REF BLOCK;		! state vector
!

! TPARSE data area available to action routines.
!

    MACRO
	STATE_LENGTH =
 STATE_VECTOR [TPA$L_COUNT]
	    %,					! length of user supplied state vector
	STRING_COUNT =
 STATE_VECTOR [TPA$L_STRINGCNT]
	%,					! byte count of string being parsed
	STRING_POINTER =
 STATE_VECTOR [TPA$L_STRINGPTR]
	%,					! address of string being parsed
	TOKEN_COUNT =
 STATE_VECTOR [TPA$L_TOKENCNT]
	%,					! byte count of current token
	TOKEN_POINTER =
 STATE_VECTOR [TPA$L_TOKENPTR]
	%,					! address of current token
	STATE_CHAR =
 STATE_VECTOR [TPA$L_CHAR]
	%,					! current single character token
	STATE_NUMBER =
 STATE_VECTOR [TPA$L_NUMBER]
	%,					! numerical value of number token
	STATE_PARAM =
 STATE_VECTOR [TPA$L_PARAM]
	%,					! action routine parameter from state table
	MCOUNT =
 STATE_VECTOR [TPA$B_MCOUNT]
	%,					! match abbreviation count
	SPACE_FLAG =
 STATE_VECTOR [TPA$V_BLANKS]
	%,					! process spaces explicitly
	ABBRFM_FLAG =
 STATE_VECTOR [TPA$V_ABBRFM]
	%,					! allow first match abbreviations
	ABBREV_FLAG =
 STATE_VECTOR [TPA$V_ABBREV]
	%,					! allow minimal abbreviations
	AMBIG_FLAG =
 STATE_VECTOR [TPA$V_AMBIG]
	%;					! ambiguous keyword in this state
!
! Contents of the type word - code and flags.
!

    MACRO
	TYPECODE =
 0,0,9,0%,					! full token type code
	TYPEBYTE =
 0,0,8,0%,					! token type byte
	keywordFLAG =
 0,8,1,0%,					! keyword present
	codeflag =
0,8,1,0%,					! transition is special code
	LASTFLAG =
 0,9,1,0%,					! last transition in state
	OPTION_BITS =
 0,10,6,0%,					! transition option flags
	EXTFLAG =
 0,10,1,0%,					! type extension present
	TRANFLAG =
 0,11,1,0%,					! transition target present
	MASKFLAG =
 0,12,1,0%,					! bitmask present
	ADDRFLAG =
 0,13,1,0%,					! data address present
	ACTFLAG =
 0,14,1,0%,					! action routine present
	PARMFLAG =
 0,15,1,0%;					! parameter longword present

    GLOBAL
	CHAR_COUNT;				! character count in string token
    %if %bliss(bliss32)
		%then
		EXTERNAL LITERAL
			SS$_INSFARG,
			lib$_syntaxerr,
			lib$_invtype;
		%fi
!+
!
! Entry initialization consists of loading the starting state
! into the state pointer. Then we proceed into the main
! loop that attempts to match transitions in the state table to
! the current string contents.
!
!-

    IF .STATE_LENGTH LSSU TPA$K_COUNT0 THEN RETURN SS$_insfarg;	! check minimum length of state vector

    AMBIG_FLAG = 0;
    STATE = ..START_STATE;
    action_value = 0;						       !* 6  *

    WHILE 1 DO
	BEGIN

	if
	    begin
!
! The following horrendous expression attempts to match the token type
! of the current transition to the current string position.
!
	    TYPE = ..STATE;			! get basic type code
	    curpos = .state;			! point to address in START_STATE

	    IF ( NOT .SPACE_FLAG AND .TYPE [TYPECODE] NEQ TPA$_LAMBDA)
	    THEN
		BEGIN
		GETSTRING (STRING_COUNT, SPACES);
		STRING_COUNT = .STRING_COUNT - .CHAR_COUNT;	! update string pointer
		STRING_POINTER = ch$plus (.string_pointer, .char_count);
		END;

	    CHAR_COUNT = 0;			! init matching string descriptor
	    TOKEN_POINTER = .STRING_POINTER;
	    keylength = 0;					       !* 12 *
	    key = 0;						       !* 12 *
	    IF (.TYPE [TYPECODE] LSSU NULL_MATCH AND .STRING_COUNT EQL 0)
	    THEN
		0				! no match if at end
	    ELSE

		SELECTONEU .TYPE [TYPECODE] OF
		    SET
! Single characters are matched by token types whose numerical value is
! the ASCII code of the character.
!

		    [0 TO HIGH_ASCII] : 	! single ASCII character

			IF .TYPE [TYPEBYTE] EQLU CH$RCHAR (.STRING_POINTER)
			THEN
			    (STATE_CHAR = CH$RCHAR (.STRING_POINTER); CHAR_COUNT = 1)
			ELSE
			    0;
! Keywords are matched by token types whose bits 0-6 contain the keyword
! number. A keyword token may be either (1) an exact match or
! (2) abbreviated to some number of characters fixed for the call or
! (3) arbitrarily abbreviated (such that the first match wins) or
! (4) abbreviated to the minimum which is locally unambiguous. Condition
! (4) is tested for ambiguity by finding the next entry in the keyword table
! and matching it against the token string. The keyword strings for each
! state are padded with a filler to prevent false matches across states.
!

		    [KEYWORD] : 		! keyword match

			IF NOT .AMBIG_FLAG AND GETSTRING (STRING_COUNT, SYMBOL)
			THEN
			    BEGIN

			    curpos = .curpos + %UPVAL;	!move to keyword address
			    keylength = ...curpos;	!get length of keyword
			    key = ch$ptr (..curpos + %UPVAL);	!get keyword ptr

			    IF CH$EQL (.CHAR_COUNT, .TOKEN_POINTER, .CHAR_COUNT, .KEY, 0)
			    THEN

				IF (.char_count eql .keylength OR (.MCOUNT NEQ 0 AND .CHAR_COUNT GEQU .MCOUNT)
				    )
				THEN
				    1
				ELSE

				    IF .ABBRFM_FLAG	!first match allowed
				    THEN
					1
				    else

					if .type [lastflag]	!last transition
					then
					    1
					ELSE
					    BEGIN

					    IF .ABBREV_FLAG	!search for ambigious match
					    THEN
						BEGIN

						LOCAL
						    offset,
						    temp_length,
						    temp_key,
						    temp_type : block [1];

						offset = .curpos + (.type [parmflag] + .type [addrflag] +
						.type [maskflag] + .type [actflag] + 2)*%UPVAL;
						temp_type = ..offset;

						while not .temp_type [lastflag] do
						    begin

						    if (.temp_type [typecode] eql keyword)
						    then
							begin
							offset = .offset + %UPVAL;
							temp_length = ...offset;
							temp_key = CH$PTR (..offset + %UPVAL);

							if ch$eql (.char_count, .token_pointer, .char_count,
								.temp_key)
							then
							    BEGIN
							    AMBIG_FLAG = 1;
							    END;

							end;

						    begin
						    offset = .offset + (.temp_type [parmflag] + .temp_type [
							actflag] + .temp_type [maskflag] + .temp_type [
							addrflag] + 2)*%UPVAL;
						    temp_type = ..offset;
						    end
						    END;

						if not .ambig_flag then 1 else 0

						end
					    else
						0

					    END

			    ELSE
				0

			    end
			ELSE
			    0;
! All other token types are special cases, representing commonly occurring
! composites and other useful artifacts.
!

		    [OTHERWISE] : 		! all other types

			CASE .TYPE [TYPEBYTE] FROM LOW_SPECIAL TO HIGH_SPECIAL OF
			    SET

			    [$LAMBDA] : 	! empty string
				1;

			    [$EOS] : 		! end of input
				.STRING_COUNT EQL 0;

			    [$ANY] : 		! any single character
				(STATE_CHAR = CH$RCHAR (.STRING_POINTER); CHAR_COUNT = 1);

			    [$ALPHA] : 		! alphabetic

				IF IS_ALPHABETIC (CH$RCHAR (.STRING_POINTER))
				THEN
				    (STATE_CHAR = CH$RCHAR (.STRING_POINTER); CHAR_COUNT = 1)
				ELSE
				    0;

			    [$DIGIT] : 		! single digit

				IF IS_NUMERIC (CH$RCHAR (.STRING_POINTER))
				THEN
				    (STATE_CHAR = CH$RCHAR (.STRING_POINTER); CHAR_COUNT = 1)
				ELSE
				    0;

			    [$TSTRING] : 	! alphanumeric string
				GETSTRING (STRING_COUNT, ALPHANUMERIC);

			    [$SYMBOL] : 	! symbol constituent set string
				GETSTRING (STRING_COUNT, SYMBOL);

			    [$BLANK] : 		! blanks or tabs
				GETSTRING (STRING_COUNT, SPACES);

			    [$DECIMAL] : 	! decimal number

				IF GETSTRING (STRING_COUNT, NUMERIC)
				THEN
				    BEGIN

				    if cvtdtb(.char_count, .token_pointer, state_number) !* 7  *
				    then
					1
				    else
					0

				    END
				ELSE
				    0;
			    [$OCTAL] : 		! octal number

				IF GETSTRING (STRING_COUNT, NUMERIC)
				THEN
				    BEGIN

				    if cvtotb(.char_count, .token_pointer, state_number) !* 7  *
				    then
					1
				    else
					0

				    END
				ELSE
				    0;

			    [$HEX] : 		! hexa-decimal number

				IF GETSTRING (STRING_COUNT, ALPHANUMERIC)
				THEN
				    BEGIN

				    if cvthtb(.char_count, .token_pointer, state_number) !* 7  *
				    then
					1
				    else
					0

				    END
				ELSE
				    0;

			    [$SUBEXPR] : 	! subexpression
				BEGIN

				LOCAL
				    SAVECOUNT,
				    SAVEPOINTER;

				SAVECOUNT = .STRING_COUNT;	! save current position
				SAVEPOINTER = .STRING_POINTER;
				curpos = .curpos + %UPVAL;

				IF TPARSE (.STATE_VECTOR, ..curpos)
				THEN
				    (CHAR_COUNT = .SAVECOUNT - .STRING_COUNT; TOKEN_POINTER = .SAVEPOINTER;
				    STRING_COUNT = .SAVECOUNT; STRING_POINTER = .SAVEPOINTER; 1)
				ELSE
				    (STRING_COUNT = .SAVECOUNT; STRING_POINTER = .SAVEPOINTER; 0)

				end;

			    [INRANGE] :
				RETURN LIB$_invtype;	! just for completeness

			    [OUTRANGE] :
				RETURN LIB$_invtype;
			    TES			! end of special types case
		    TES				! end of select on .TYPE

	    END
!+
!
! The type code in this transition matches the current string,
! which is now described by the global string descriptor. Call
! the user's action routine, if it exists, and if it returns true,
! gobble the string and take the transition. Note that we set R0
! to 1 going into the call, making it easier for the routine to
! return success.
!
!-
	THEN
	    BEGIN
	    STRING_COUNT = .STRING_COUNT - .CHAR_COUNT;	! update string pointer
	    STRING_POINTER = ch$plus (.string_pointer, .char_count);
	    TOKEN_COUNT = .CHAR_COUNT;		! skip extension if present

	    IF (.TYPE [PARMFLAG])		! set parameter longword if present
	    THEN
		begin
		curpos = .curpos + %UPVAL;
		state_param = ..curpos;				       !* 10 *
		end;

	    IF
		BEGIN

		If (.TYPE [ACTFLAG])
		THEN
		    BEGIN
		    curpos = .curpos + %UPVAL;
		    action_value = (..curpos) (.state_vector) !call action routine !* 6  *
		    END
		ELSE
		    1

		end				!of action condition block
	    then
		begin
		%if test_bit(1,%variant)			       !* 12 *
		%then						       !* 12 *
		local						       !* 12 *
		    token_type;					       !* 12 *
		%fi						       !* 12 *
								       !* 12 *
!
! Either there was no action routine, or the action routine has returned
! success; we take the transition. First we get the data address, if present.
! If present, store whatever data is called for: the mask, if supplied, or
! type dependent data if not - either the matching character, the number
! value, or the string descriptor of the matching string.
!

		IF .TYPE [ADDRFLAG]
		THEN
		    BEGIN

		    LOCAL
			ADDRESS,
			mask;

		    curpos = .curpos + %UPVAL;
		    ADDRESS = ..curpos;

		    IF .TYPE [MASKFLAG]
		    THEN
			BEGIN
			curpos = .curpos + %UPVAL;
			mask = ..curpos;
			.ADDRESS = ..ADDRESS OR .mask
			END
		    ELSE
			BEGIN

			IF NOT .TYPE [CODEFLAG]
			THEN
			    (.ADDRESS)<0, 8> = .STATE_CHAR
			ELSE
			    BEGIN

			    CASE .TYPE [TYPEBYTE] FROM LOW_SPECIAL TO HIGH_SPECIAL OF
				SET

				[$ANY, $ALPHA, $DIGIT] :
				    (.ADDRESS)<0, 8> = .STATE_CHAR;

				[$DECIMAL, $OCTAL, $HEX] :
				    .ADDRESS = .STATE_NUMBER;

				[INRANGE, OUTRANGE] :
				    BEGIN
				    (.ADDRESS) = .TOKEN_COUNT;
				    (.ADDRESS + %UPVAL) = .TOKEN_POINTER;
				    END;
				TES;

			    END;

			END;

		    END;
!
! Take the transition. If an explicit target exists, follow it.
! If an explicit target does not exist then target should contain a -1
! or a -2.  A -1 means exit with success, -2 means exit with failure.
!
		%if test_bit(1,%variant)			       !* 12 *
		%then						       !* 12 *
		    token_type = .type[typecode];		       !* 12 *
		    if tpa$db neqa 0				       !* 12 *
		    then					       !* 12 *
			tpa$db(					       !* 12 *
			    .state_vector,			       !* 12 *
			    .token_type,			       !* 12 *
			    .keylength,				       !* 12 *
			    .key				       !* 12 *
			    );					       !* 12 *
		%fi						       !* 12 *
								       !* 12 *
		AMBIG_FLAG = 0;

		if .type [tranflag]
		THEN
		    state = ..(.curpos + %UPVAL)	!follow target
		ELSE
		    begin
		    curpos = .curpos + %UPVAL;	!point to target

		    IF ..curpos EQL tpa$_EXIT	! tpa$_EXIT means exit
		    THEN
			RETURN 1
		    ELSE

			IF ..curpos EQL tpa$_FAIL	! tpa$_FAIL means exit
			THEN
			    RETURN LIB$_syntaxerr;

		    end;

		end				!of action then block
! The action routine has rejected the transition. Make like it never matched.
!
	    ELSE
		BEGIN				! return characters to string
		STRING_COUNT = .STRING_COUNT + .CHAR_COUNT;
		STRING_POINTER = ch$plus (.string_pointer, -.char_count);
						! skip the rest of the transition
		state = .state + (.type [actflag] + .type [parmflag] + .type [addrflag] + .type [maskflag] + (
		.TYPE [TYPECODE] EQLU KEYWORD) + (.TYPE [TYPECODE] EQLU TPA$_SUBEXPR) + 2)*%UPVAL;

		IF .TYPE [LASTFLAG]
		THEN
		    BEGIN
		    GETSTRING (STRING_COUNT, SYMBOL);
		    TOKEN_COUNT = .CHAR_couNT;

		    if .token_count eql 0 and .string_count neq 0 then token_count = .token_count + 1;
		    if .action_value eql 0 or	!false (0) means syntax error !* 6  *
			.action_value				       !* 6  *
		    then					       !* 6  *
			RETURN LIB$_syntaxerr			       !* 6  *
		    else			!syntax was ok, something else was wrong !* 6  *
			return .action_value			       !* 6  *
		    END;

		end				!of action else block
	    end					!of transition match then block
!+
!
! If the transition does not match, we execute this code. It skips
! the current transition to set up to try the next one in the state.
! If this was the last transition in the state, a syntax error has
! occurred and TPARSE returns the value 0.
!
!-
	ELSE
	    BEGIN
	    state = .state + (.type [actflag] + .type [parmflag] + .type [addrflag] + .type [maskflag] + (
	    .TYPE [TYPECODE] EQLU KEYWORD) + (.TYPE [TYPECODE] EQLU TPA$_SUBEXPR) + 2)*%UPVAL;

	    IF .TYPE [LASTFLAG]
	    THEN
		BEGIN
		GETSTRING (STRING_COUNT, SYMBOL);
		TOKEN_COUNT = .CHAR_COUNT;

		IF .TOKEN_COUNT EQL 0 AND .STRING_COUNT NEQ 0 THEN TOKEN_COUNT = .TOKEN_COUNT + 1;

		if .action_value eql 0 or			       !* 6  *
		    .action_value				       !* 6  *
		then						       !* 6  *
		    RETURN LIB$_syntaxerr			       !* 6  *
		else						       !* 6  *
		    return .action_value			       !* 6  *
		END;

	    END					!of transition match else block
	END					! end of outside loop

    END;					! end of routine TPARSE
%SBTTL 'GETSTRING - get a string of characters'			       !* 14 *
ROUTINE getstring (string, type) =				       !* 14 *

!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine extracts a string of the indicated type from
!	the front of the string being parsed.
!
!
! CALLING SEQUENCE:
!	GETSTRING (ARG1, ARG2)
!
!
! INPUT PARAMETERS:
!	ARG1 = address of string descriptor of source string
!	ARG2 = string type code
!
! IMPLICIT INPUTS:
!	NONE
!
! OUTPUT PARAMETERS:
!	NONE
!
! IMPLICIT OUTPUTS:
!	NONE
!
! ROUTINE VALUE:
!	1 if string is not empty
!	0 if string is null
!
! SIDE EFFECTS:
!	NONE
!
!--
    BEGIN

    MAP
	STRING : REF VECTOR;

    EXTERNAL
	CHAR_COUNT;				! character count of found string

!+
!
! To extract the string we simply scan through the input string
! until we hit a character that is not in the class.
! We count the characters in the global string count.
!
!-
    CHAR_COUNT = 0;

    WHILE .STRING [0] GTRU .CHAR_COUNT AND ((IF .TYPE EQL SPACES THEN IS_SPACE (CH$RCHAR (CH$PLUS (.STRING [1]
		    , .CHAR_COUNT))) ELSE 0) OR (IF .TYPE GEQU NUMERIC THEN IS_NUMERIC (CH$RCHAR (CH$PLUS (
			.STRING [1], .CHAR_COUNT))) ELSE 0) OR (IF .TYPE GEQU ALPHANUMERIC THEN IS_ALPHABETIC
	    (CH$RCHAR (CH$PLUS (.STRING [1], .CHAR_COUNT))) ELSE 0) OR (IF .TYPE EQL SYMBOL THEN IS_SYMBOL (
		CH$RCHAR (CH$PLUS (.STRING [1], .CHAR_COUNT))) ELSE 0)) DO
	(CHAR_COUNT = .CHAR_COUNT + 1);

    RETURN .CHAR_COUNT GTRU 0;
    END;					! end of routine GETSTRING
%if not test_bit(0,%variant)					       !* 15 *
%then								       !* 7  *
%SBTTL 'CVTDTB - convert decimal string to binary'		       !* 14 *
ROUTINE cvtdtb(len,string,result) =	!decimal to binary conversion  !* 7  *
!++								       !* 7  *
! FUNCTIONAL DESCRIPTION:					       !* 7  *
!								       !* 7  *
!	This routine returns a binary representation of the ASCII text !* 7  *
!	string representation of a decimal number.		       !* 7  *
!								       !* 7  *
! FORMAL PARAMETERS:						       !* 7  *
!								       !* 7  *
!	Len - character count of input ascii text string	       !* 7  *
!								       !* 7  *
!	string - pointer to the start of input ascii text string       !* 7  *
!								       !* 7  *
!	result - address to receive result.			       !* 7  *
!								       !* 7  *
! IMPLICIT INPUTS:						       !* 7  *
!								       !* 7  *
!	NONE							       !* 7  *
!								       !* 7  *
! IMPLICIT OUTPUTS:						       !* 7  *
!								       !* 7  *
!	NONE							       !* 7  *
!								       !* 7  *
! ROUTINE VALUE:						       !* 7  *
! COMPLETION CODES:						       !* 7  *
!								       !* 7  *
!	1 - procedure successfully completed			       !* 7  *
!								       !* 7  *
!	0 - nonradix character in the input string.  Blanks and tabs are !* 7  *
!		invalid characters.  An overflow from %bpval bits      !* 7  *
!		(unsigned) will cause an error			       !* 7  *
!								       !* 7  *
! SIDE EFFECTS:							       !* 7  *
!								       !* 7  *
!	NONE							       !* 7  *
!								       !* 7  *
!--								       !* 7  *
    BEGIN							       !* 7  *
    LOCAL							       !* 7  *
	char;		!current character			       !* 7  *
								       !* 7  *
    .result = 0;	!initialize the result to zero		       !* 7  *
								       !* 7  *
    if ( incr i from 0 to .len - 1 by 1 do			       !* 7  *
	    begin						       !* 7  *
		char = ch$rchar_a(string);			       !* 7  *
		if (.char lssu %c'0' or .char gtru %c'9')!see if not valid char !* 7  *
		then exitloop 0	!exit with failure		       !* 7  *
		else						       !* 7  *
		    begin					       !* 7  *
		    local					       !* 7  *
			tmp;					       !* 7  *
								       !* 7  *
		    if .(.result)<%bpval-3,3,0> nequ 0	!see if will overflow !* 7  *
		    then exitloop 0;			!exit with failure !* 7  *
								       !* 7  *
		    .result = (..result ^ 2)+ (..result);!mult by 5    !* 7  *
								       !* 7  *
		    if .(.result)<%bpval-1,1,0> nequ 0	!see if will overflow !* 7  *
		    then exitloop 0;			!exit with failure !* 7  *
								       !* 7  *
		    tmp = ..result ^ 1;			!complete mult by 10 !* 7  *
								       !* 7  *
		    .result = .tmp + (.char - %c'0');	! add in digit !* 7  *
								       !* 7  *
		    if ..result lssu .tmp		!see if overflowed !* 7  *
		    then exitloop 0;			!exit with failure !* 7  *
								       !* 7  *
		    end;					       !* 7  *
	    end						!successful conversion !* 7  *
	) eql -1						       !* 7  *
	then return 1						       !* 7  *
	else return 0						       !* 7  *
								       !* 7  *
    END;			!End of cvtotb			       !* 7  *
%fi								       !* 7  *
%if not test_bit(0,%variant)					       !* 15 *
%then								       !* 7  *
%SBTTL 'CVTHTB - Convert Hex string to binary'			       !* 14 *
ROUTINE cvthtb(len,string,result) =	!hex to binary conversion      !* 7  *
!++								       !* 7  *
! FUNCTIONAL DESCRIPTION:					       !* 7  *
!								       !* 7  *
!	This routine returns a binary representation of the ASCII text !* 7  *
!	string representation of a hex number.			       !* 7  *
!								       !* 7  *
! FORMAL PARAMETERS:						       !* 7  *
!								       !* 7  *
!	Len - character count of input ascii text string	       !* 7  *
!								       !* 7  *
!	string - pointer to the start of input ascii text string       !* 7  *
!								       !* 7  *
!	result - address to receive result.			       !* 7  *
!								       !* 7  *
! IMPLICIT INPUTS:						       !* 7  *
!								       !* 7  *
!	NONE							       !* 7  *
!								       !* 7  *
! IMPLICIT OUTPUTS:						       !* 7  *
!								       !* 7  *
!	NONE							       !* 7  *
!								       !* 7  *
! ROUTINE VALUE:						       !* 7  *
! COMPLETION CODES:						       !* 7  *
!								       !* 7  *
!	1 - procedure successfully completed			       !* 7  *
!								       !* 7  *
!	0 - nonradix character in the input string.  Blanks and tabs are !* 7  *
!		invalid characters.  An overflow from %bpval bits      !* 7  *
!		(unsigned) will cause an error			       !* 7  *
!								       !* 7  *
! SIDE EFFECTS:							       !* 7  *
!								       !* 7  *
!	NONE							       !* 7  *
!								       !* 7  *
!--								       !* 7  *
    BEGIN							       !* 7  *
    LOCAL							       !* 7  *
	char;		!current character			       !* 7  *
								       !* 7  *
    .result = 0;	!initialize the result to zero		       !* 7  *
								       !* 7  *
    if (							       !* 7  *
	incr i from 0 to .len - 1 by 1 do			       !* 7  *
	    begin						       !* 7  *
		char = ch$rchar_a(string);			       !* 7  *
								       !* 7  *
		if (.char gequ %c'a' and .char lequ %c'f')	       !* 7  *
		then char = .char - %c' ';		!upcase character !* 7  *
								       !* 7  *
		if (.char lssu %c'0' or .char gtru %c'G'	!see if not valid char !* 7  *
		    or (.char gtru %c'9' and .char lssu %c'A') )       !* 7  *
		then exitloop 0	!exit with failure		       !* 7  *
		else						       !* 7  *
		    if .(.result)<%bpval-4,4,0> nequ 0	!see if will overflow !* 7  *
		    then exitloop 0	!exit with failure	       !* 7  *
		    else					       !* 7  *
			begin					       !* 7  *
			char = .char - 			!convert digit to binary !* 7  *
			    (if .char lequ %c'9'		       !* 7  *
			    then %c'0'				       !* 7  *
			    else %c'7');			       !* 7  *
								       !* 7  *
			.result = (..result) ^ 4		!convert digit !* 7  *
			    or .char;				       !* 7  *
			end;					       !* 7  *
	    end						!successful conversion !* 7  *
	) eql -1						       !* 7  *
	then return 1						       !* 7  *
	else return 0						       !* 7  *
								       !* 7  *
    END;			!End of cvtotb			       !* 7  *
%fi								       !* 7  *
%if not test_bit(0,%variant)					       !* 15 *
%then								       !* 7  *
%SBTTL 'CVTOTB - Convert Octal string to binary'		       !* 14 *
ROUTINE cvtotb (len,string,result) =	!octal to binary conversion    !* 7  *
!++								       !* 7  *
! FUNCTIONAL DESCRIPTION:					       !* 7  *
!								       !* 7  *
!	This routine returns a binary representation of the ASCII text !* 7  *
!	string representation of a octal number.		       !* 7  *
!								       !* 7  *
! FORMAL PARAMETERS:						       !* 7  *
!								       !* 7  *
!	Len - character count of input ascii text string	       !* 7  *
!								       !* 7  *
!	string - pointer to the start of input ascii text string       !* 7  *
!								       !* 7  *
!	result - address to receive result.			       !* 7  *
!								       !* 7  *
! IMPLICIT INPUTS:						       !* 7  *
!								       !* 7  *
!	NONE							       !* 7  *
!								       !* 7  *
! IMPLICIT OUTPUTS:						       !* 7  *
!								       !* 7  *
!	NONE							       !* 7  *
!								       !* 7  *
! ROUTINE VALUE:						       !* 7  *
! COMPLETION CODES:						       !* 7  *
!								       !* 7  *
!	1 - procedure successfully completed			       !* 7  *
!								       !* 7  *
!	0 - nonradix character in the input string.  Blanks and tabs are !* 7  *
!		invalid characters.  An overflow from %bpval bits      !* 7  *
!		(unsigned) will cause an error			       !* 7  *
!								       !* 7  *
! SIDE EFFECTS:							       !* 7  *
!								       !* 7  *
!	NONE							       !* 7  *
!								       !* 7  *
!--								       !* 7  *
    BEGIN							       !* 7  *
    LOCAL							       !* 7  *
	char;		!current character			       !* 7  *
								       !* 7  *
    .result = 0;	!initialize the result to zero		       !* 7  *
								       !* 7  *
    if ( incr i from 0 to .len - 1 by 1 do			       !* 7  *
	    begin						       !* 7  *
		char = ch$rchar_a(string);			       !* 7  *
		if (.char lssu %c'0' or .char gtru %c'7')!see if not valid char !* 7  *
		then exitloop 0	!exit with failure		       !* 7  *
		else						       !* 7  *
		    if .(.result)<%bpval-3,3,0> nequ 0	!see if will overflow !* 7  *
		    then exitloop 0	!exit with failure	       !* 7  *
		    else .result = (..result) ^ 3		!convert digit !* 7  *
			or (.char - %c'0');			       !* 7  *
	    end						!successful conversion !* 7  *
	) eql -1						       !* 7  *
	then return 1						       !* 7  *
	else return 0						       !* 7  *
								       !* 7  *
    END;			!End of cvtotb			       !* 7  *
%fi								       !* 7  *
END

ELUDOM
						! end of module TPARSE
!  CMS REPLACEMENT HISTORY 


! *16 WHALEN 30-NOV-1982 13:51:45 "fixed addressing_mode declaration for use with COVER"
! *15 PHILLIPS  3-SEP-1982 10:53:24 "FIX USAGE OF TEST_BIT MACRO"
! *14 WHALEN 24-AUG-1982 12:35:32 "added Addressing_modde for bliss32"
! *13 PHILLIPS 26-JUL-1982 20:26:05 "FIX ACTION ROUTINE RETURN VALUE"
! *12 PHILLIPS 20-JUL-1982 13:07:42 "ADD TRACING OPTION"
! *11 WHALEN  6-JUN-1982 17:54:59 "REMOVED PRECOMPILATION OF REQ FILE FROM COM FILE"
! *10 PHILLIPS  7-JAN-1982 15:58:40 "FIX ACTION ROUTINE PARAMETER PASSING"
! *9 PHILLIPS  7-JAN-1982 10:15:21 "CORRECTED DEF OF TPA$K_COUNT0 AND TPA$K_LENGTH0 IN REQUIRE FILE"
! *8 PHILLIPS 18-NOV-1981 18:08:13 "change name of module (old gen 8 deleted by cms)"
! *7 PHILLIPS  9-NOV-81 13:48:35 "CONVERSION ROUTINES ADDED"
! *6 WHALEN  5-NOV-81 16:00:18 "CHANGED SO THAT IT RETURNS THE FAILURE CODE RETURNED BY THE ACTION ROUTINE"
! *5 PHILLIPS 15-OCT-81 14:59:30 "COMPLETE CORRECTION"
! *4 SIM11 14-OCT-81 17:35:14 "COMPLETE COMMAND FILE UPDATE"
! *3 PHILLIPS 14-OCT-81 09:08:53 "UPDATE COMPLETE"
! *2 PHILLIPS 29-SEP-81 14:26:38 "CORRECT COMPILE COMMAND FILE"
! *1 PHILLIPS 29-SEP-81 14:10:54 "add bliss common tparse"