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"