Google
 

Trailing-Edge - PDP-10 Archives - bb-h138f-bm - 7-sources/diulex.bli
There are 4 other files named diulex.bli in the archive. Click here to see a list.
MODULE DIULEX  (IDENT='253' %BLISS32 (,
		 ADDRESSING_MODE (EXTERNAL = 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.
!
!++
!
!  TITLE:  PARLEX
!
!  FACILITY:  Data Interchange Utility
!
!  ABSTRACT:
!
!	This module contains all the routines necessary to do a lexical
!	scan of the tokens for the Data Definition Utility language.
!
!  ENVIRONMENT:
!
!	All routines run in user access mode.
!
!	These routines are NOT AST reentrant.
!
!  AUTHOR:  Colleen Deininger,	28-MAY-81
!
!++
!
! MODIFICATION HISTORY:
!
!   Version 3.0
!	20-Jul-84       (CLR) Put XPORT use back in!  Use compatible Bliss!
!	23-Feb-84 01693 (CGM) Remove XPORT use from the CDDL.
!	 6-Jan-84 01506 (CDD) 
!	21-Dec-83 01296 (mrw) 
!	 9-Dec-83 01102 (mrw)  
!	23-Nov-83 01035 (CGM) FIX BUG WHERE THE STATUS FROM DDU$$P_LEX_NUMBER
!	                      IS NOT CHECKED.
!	21-Nov-83 00868 (CDD) 
!	30-Sep-83 00771 (MRW) moved imbedded CDDL messages to message file
!	 1-Sep-83 00755 (CGM) Adding the INDEXED FOR COBOL BY clause.
!	26-Jul-83 00730 (KJM) Added support for PL/I
!	 8-Apr-83 00653 (MAB) Allow CDD objects to have version numbers.
!
!	17-Feb-83 00475 (CDD) Promote to new version
!
!	12-Jan-83 00116 (CDD) Change the version number to X3.0
!
!	16-Sep-82 00033 (CDD) 
!
!    Version 2.0
!	29-Jul-82	(CGM)	Changed error severities, names and messages.
!
!	22-Jul-82	(CGM)	Added handling for DBMS datatype synonyms.
!
!	19-Jul-82	(CGM)	Added support for form feeds "<FF>".  Form
!				feeds are replaced with a space when parsing
!				the source.
!
!	23-Jun-82	(CGD)	Deleted support for back slashes since they
!				are no longer used in fully qualified names.
!
!	3-Mar-82	(CGD)	Made LEX check for redundant EOF token &
!				return.
!				Made CDDL$_VALUEOVFL warning continue with
!				the current token rather than ignoring it.
!				Changed CDDL$_BADDESC to CDDL$_BADCHAR.
!				Made LEX_COLUMN know about tabs and be
!				set accordingly.
!
!	13-JAN-82	(CGD)	Added /RECOMPILE option capabilities.
!
!  253  Rename file to DIULEX.
!       Gregory A. Scott 1-Jul-86
!
!--
BEGIN

!   INCLUDE FILES:

	require 'DIUPATPROLOG';
	library 'BLI:XPORT';
	%if %BLISS (BLISS32) %THEN
	require 'VMS';
	%FI
	library 'DIUPATDATA';
	library 'DIUDEB';
	library 'DIUPATLANGSP';

! Table of contents:

    FORWARD ROUTINE
	DDU$$P_LEX_NAME,		! Parse CDDname, pathname, or keyword
	DDU$$P_LEX_NUMBER,		! Parse numeric token
	DDU$$P_LEX_PERCENT,		! Parse token beginning with percent
	ENTER_TEXT	: NOVALUE,	! Store text in the heap
	GET_CHAR	: NOVALUE,	! Get next input character
	LEX		: NOVALUE,	! Get next token
	PAR_COLUMN_NUMBER,		! Column number for token
	PAR_GET_TOKEN,			! Manage token storage
	PAR_LINE_NUMBER,		! Line number of a token
	UTL_GET;			! Do heap allocation
! Declarations for lexical locator

%if %bliss (BLISS36) %then
    literal
	RMS$_EOF		= 9999,
	SS$_NORMAL		= 1;
%fi

    LITERAL
	DDU$K_SOURCE		= 0,
	COLUMNS_PER_TAB		= 8,
	MAX_NUM_LEX_TOKS	= 20;

    $FIELD
	LOC_COLUMN		= [$BYTE],
	LOC_LINENUM		= [$SHORT_INTEGER],
	LOC_UNUSED		= [$BYTE];

    literal
	LOC_SIZE		= $FIELD_SET_SIZE*%upval;

    MACRO
	LOC_STR =
	    BLOCK [LOC_SIZE/%upval]
		FIELD (LOC_COLUMN, LOC_LINENUM, LOC_UNUSED) %;

    literal
	BUF_SIZE		= 256;

! Information about the present lexical token

    OWN
	FILE_IOB :		ref $XPO_IOB (),
	END_OF_INPUT_LINE :	VOLATILE INITIAL (FALSE),
	START_LINE :		%BLISS32 (LONG),
	LEX_LINENUM :		%BLISS32 (LONG)	INITIAL (0),
	LEX_COLUMN :		%BLISS32 (LONG)	INITIAL (0),
	COLUMN :		%BLISS32 (LONG)	INITIAL (0),
	LEX_LOCATOR :		LOC_STR,
	LEX_TKNSTRT :		%BLISS32 (LONG),
	TOKEN_STORAGE :		BLOCKVECTOR [MAX_NUM_LEX_TOKS, TKN_SIZE]
				FIELD (TKN_FIELDS),
	NEXT_TOKEN_INDEX :	%BLISS32 (LONG)	INITIAL (0);
GLOBAL ROUTINE PAR_LINE_NUMBER (L) =
!++
! FUNCTIONAL DESCRIPTION:
!
!	Return the line number for a lexical token.
!
! INPUT PARAMETERS:
!
!	L		Lexical location structure
!
! OUTPUT PARAMETERS:
!
!	NONE
!
! IMPLICIT INPUTS:
!
!	NONE
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
!--
BEGIN

    MAP
	L :	LOC_STR;

    RETURN .L [LOC_LINENUM]
END;
GLOBAL ROUTINE LEX_INIT (file) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine sets up the file IOB of the file to be parsed.
!	It should be called from PAT$PARSER before parsing begins.
!
! INPUT PARAMETERS:
!
!	file	Address of the XPORT IOB for the file to be parsed.
!
! OUTPUT PARAMETERS:
!
!	None
!
! IMPLICIT INPUTS:
!
!	None
!
! IMPLICIT OUTPUTS:
!
!	file_iob	Set to the address of the XPORT IOB for the file to
!			be parsed.
!
!--
BEGIN

file_iob = .file;
END;
GLOBAL ROUTINE PAR_COLUMN_NUMBER (L) =
!++
! FUNCTIONAL DESCRIPTION:
!
!	Return the column number for a lexical token.
!
! INPUT PARAMETERS:
!
! 	L		Lexical location
!
! OUTPUT PARAMETERS:
!
!	NONE
!
! IMPLICIT INPUTS:
!
!	NONE
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
!--
BEGIN
    MAP
	L :	LOC_STR;

    RETURN .L [LOC_COLUMN]
END;
ROUTINE DDU$$P_LEX_NAME (TOKEN_PTR, CHAR_PTR) =
!++
!
! FUNCTIONAL DESCRIPTION:
!
!	This routine lexically parses a CDD_name, path name or keyword token.
!
!  PARAMETERS:
!
!	token_ptr		address of the token block being defined.
!	char_ptr		pointer to current character position.
!
!  IMPLICIT INPUTS:
!
!	END_OF_INPUT_LINE	TRUE if current character is at end of line
!	LEX_TKNSTRT		Starting character position of current token
!
!  IMPLICIT OUTPUTS:
!
!	END_OF_INPUT_LINE	Flag for last character on input line
!	LEX_TKNSTRT		Starting character position of current token
!
!  COMPLETION STATUS:
!
!	SS$_NORMAL if OK, FALSE if not
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	May cause more input lines to be read.
!
!--
BEGIN
    MAP
	TOKEN_PTR 	: REF	TKN_STR;

    BIND
	CHAR		= .CHAR_PTR;
! Classes of characters that might appear in input text:

    LITERAL
	I_ILLEGAL	= 0,
	I_OTHER		= 1,
	I_LETTER	= 2,
	I_L_PAREN	= 3,
	I_R_PAREN	= 4,
	I_DOT		= 5,
	I_PSSWORD	= 6,
	I_DIGIT		= 7,
	I_SEMICOLON	= 8;

! Class of each ASCII character:

    BIND
	IDENT = UPLIT %BLISS32 (BYTE) (
		I_ILLEGAL,	! 00 NUL
		I_ILLEGAL,	! 01 SOH
		I_ILLEGAL,	! 02 STX
		I_ILLEGAL,	! 03 ETX
		I_ILLEGAL,	! 04 EOT
		I_ILLEGAL,	! 05 ENQ
		I_ILLEGAL,	! 06 ACK
		I_ILLEGAL,	! 07 BEL
		I_ILLEGAL,	! 08 BS
		I_PSSWORD,	! 09 HT
		I_ILLEGAL,	! 0A LF
		I_ILLEGAL,	! 0B VT
		I_ILLEGAL,	! 0C FF
		I_ILLEGAL,	! 0D CR
		I_ILLEGAL,	! 0E SO
		I_ILLEGAL,	! 0F SI
		I_ILLEGAL,	! 10 DLE
		I_ILLEGAL,	! 11 DC1
		I_ILLEGAL,	! 12 DC2
		I_ILLEGAL,	! 13 DC3
		I_ILLEGAL,	! 14 DC4
		I_ILLEGAL,	! 15 NAK
		I_ILLEGAL,	! 16 SYN
		I_ILLEGAL,	! 17 ETB
		I_ILLEGAL,	! 18 CAN
		I_ILLEGAL,	! 19 EM
		I_ILLEGAL,	! 1A SUB
		I_ILLEGAL,	! 1B ESC
		I_ILLEGAL,	! 1C FS
		I_ILLEGAL,	! 1D GS
		I_ILLEGAL,	! 1E RS
		I_ILLEGAL,	! 1F US
		I_PSSWORD,	! 20 SP
		I_PSSWORD,	! 21 !
		I_PSSWORD,	! 22 "
		I_PSSWORD,	! 23 #
		I_OTHER,	! 24 $
		I_PSSWORD,	! 25 %
		I_PSSWORD,	! 26 &
		I_PSSWORD,	! 27 '
		I_L_PAREN,	! 28 (
		I_R_PAREN,	! 29 )
		I_PSSWORD,	! 2A *
		I_PSSWORD,	! 2B +
		I_PSSWORD,	! 2C ,
		I_OTHER,	! 2D -
		I_DOT,		! 2E .
		I_PSSWORD,	! 2F /
		I_DIGIT,	! 30 0
		I_DIGIT,	! 31 1
		I_DIGIT,	! 32 2
		I_DIGIT,	! 33 3
		I_DIGIT,	! 34 4
		I_DIGIT,	! 35 5
		I_DIGIT,	! 36 6
		I_DIGIT,	! 37 7
		I_DIGIT,	! 38 8
		I_DIGIT,	! 39 9
		I_PSSWORD,	! 3A :
		I_SEMICOLON,	! 3B ;
		I_PSSWORD,	! 3C <
		I_PSSWORD,	! 3D =
		I_PSSWORD,	! 3E >
		I_PSSWORD,	! 3F ?
		I_PSSWORD,	! 40 @
		I_LETTER,	! 41 A
		I_LETTER,	! 42 B
		I_LETTER,	! 43 C
		I_LETTER,	! 44 D
		I_LETTER,	! 45 E
		I_LETTER,	! 46 F
		I_LETTER,	! 47 G
		I_LETTER,	! 48 H
		I_LETTER,	! 49 I
		I_LETTER,	! 4A J
		I_LETTER,	! 4B K
		I_LETTER,	! 4C L
		I_LETTER,	! 4D M
		I_LETTER,	! 4E N
		I_LETTER,	! 4F O
		I_LETTER,	! 50 P
		I_LETTER,	! 51 Q
		I_LETTER,	! 52 R
		I_LETTER,	! 53 S
		I_LETTER,	! 54 T
		I_LETTER,	! 55 U
		I_LETTER,	! 56 V
		I_LETTER,	! 57 W
		I_LETTER,	! 58 X
		I_LETTER,	! 59 Y
		I_LETTER,	! 5A Z
		I_PSSWORD,	! 5B [
		I_PSSWORD,	! 5C \
		I_PSSWORD,	! 5D ]
		I_PSSWORD,	! 5E ^
		I_OTHER,	! 5F _
		I_PSSWORD,	! 60 `
		I_LETTER,	! 61 a
		I_LETTER,	! 62 b
		I_LETTER,	! 63 c
		I_LETTER,	! 64 d
		I_LETTER,	! 65 e
		I_LETTER,	! 66 f
		I_LETTER,	! 67 g
		I_LETTER,	! 68 h
		I_LETTER,	! 69 i
		I_LETTER,	! 6A j
		I_LETTER,	! 6B k
		I_LETTER,	! 6C l
		I_LETTER,	! 6D m
		I_LETTER,	! 6E n
		I_LETTER,	! 6F o
		I_LETTER,	! 70 p
		I_LETTER,	! 71 q
		I_LETTER,	! 72 r
		I_LETTER,	! 73 s
		I_LETTER,	! 74 t
		I_LETTER,	! 75 u
		I_LETTER,	! 76 v
		I_LETTER,	! 77 w
		I_LETTER,	! 78 x
		I_LETTER,	! 79 y
		I_LETTER,	! 7A z
		I_PSSWORD,	! 7B {
		I_PSSWORD,	! 7C |
		I_PSSWORD,	! 7D }
		I_PSSWORD,	! 7E ~
		I_ILLEGAL	! 7F DEL
%BLISS32 (	,REP 128 OF (I_ILLEGAL)))
	: VECTOR [%BLISS32 (,BYTE)];
! Table of keywords:

macro
%IF %BLISS (BLISS36) %THEN
zchar (foo, tok) = %ascii %string (%char (%charcount (foo)), foo,
    %char (tok)) %;
%ELSE
zchar (foo, tok) = %ascic foo, %char (tok) %;
%FI

    BIND
	RESERVED_TABLE = UPLIT (
	UPLIT %BLISS32 (BYTE) ( %STRING (		! A
		zchar (	'ALIGNED',	T_ALIGNED),
		zchar (	'ARE',		T_ARE),
		zchar (	'ARRAY',	T_ARRAY),
		zchar (	'AS',		T_AS),
		zchar ( 'ASCII_7',	T_ASCII_7),
		zchar ( 'ASCII_8',	T_ASCII_8),
		zchar ( 'ASCII_9',	T_ASCII_9),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! B
		zchar (	'BASE',		T_BASE),
		zchar (	'BASIC',	T_BASIC),
		zchar (	'BIT',		T_BIT),
		zchar (	'BLANK',	T_BLANK),
		zchar (	'BOUNDARY',	T_BOUNDARY),
		zchar (	'BY',		T_BY),
		zchar (	'BYTE',		T_BYTE),
		zchar (	'BYTES',	T_BYTES),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! C
		zchar (	'CHARACTER',	T_CHARACTER),
		zchar ( 'CHARACTERS',	T_CHARACTERS),
		zchar (	'COBOL',	T_COBOL),
		zchar (	'COLUMN_MAJOR',	T_COLUMN_MAJOR),
		zchar (	'COMPLEX',	T_COMPLEX),
		zchar (	'COMPUTED',	T_COMPUTED),
		zchar (	'CONDITION',	T_CONDITION),
		zchar (	'COPY',		T_COPY),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! D
		zchar (	'DATATRIEVE',	T_DATATRIEVE),
		zchar (	'DATATYPE',	T_DATATYPE),
		zchar (	'DATE',		T_DATE),
		zchar (	'DECIMAL',	T_DECIMAL),
		zchar (	'DEFAULT_VALUE', T_DEFAULT_VALUE),
		zchar (	'DEFINE',	T_DEFINE),
		zchar (	'DEPENDING',	T_DEPENDING),
		zchar (	'DESCRIPTION',	T_DESCRIPTION),
		zchar (	'DIGIT',	T_DIGIT),
		zchar (	'DIGITS',	T_DIGITS),
		zchar ( 'DTR',		T_DTR),
		zchar (	'D_FLOATING',	T_D_FLOATING),
		zchar (	'D_FLOATING_COMPLEX', T_D_FLOATING_COMPLEX),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! E
		zchar ( 'EBCDIC_8',	T_EBCDIC_8),
		zchar ( 'EBCDIC_9',	T_EBCDIC_9),
		zchar (	'EDIT_STRING',	T_EDIT_STRING),
		zchar (	'END',		T_END),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! F
		zchar (	'FIELD',	T_FIELD),
		zchar ( 'FILLER',	T_FILLER),
		zchar (	'FLOATING',	T_FLOATING),
		zchar (	'FLOATING_COMPLEX', T_FLOATING_COMPLEX),
		zchar (	'FOR',		T_FOR),
		zchar (	'FRACTION',	T_FRACTION),
		zchar (	'FRACTIONS',	T_FRACTIONS),
		zchar (	'FROM',		T_FROM),
		zchar (	'F_FLOATING',	T_F_FLOATING),
		zchar (	'F_FLOATING_COMPLEX', T_F_FLOATING_COMPLEX),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! G
		zchar (	'G_FLOATING',	T_G_FLOATING),
		zchar (	'G_FLOATING_COMPLEX', T_G_FLOATING_COMPLEX),
		zchar (	'GROUP',	T_GROUP),
		%char (0))),
	UPLIT  %BLISS32 (BYTE) ( %STRING (		! H
		zchar (	'H_FLOATING',	T_H_FLOATING),
		zchar (	'H_FLOATING_COMPLEX', T_H_FLOATING_COMPLEX),
		%char (0))),
	UPLIT  %BLISS32 (BYTE) ( %STRING (		! I
		zchar (	'IF',		T_IF),
		zchar (	'INDEXED',	T_INDEXED),
		zchar (	'INITIAL_VALUE', T_INITIAL_VALUE),
		zchar (	'IS',		T_IS),
		%char (0))),
	UPLIT  %BLISS32 (BYTE) ( %STRING (		! J
		zchar (	'JUSTIFIED',	T_JUSTIFIED),
		%char (0))),
	UPLIT %BLISS32 (BYTE) (0),			! No K
	UPLIT %BLISS32 (BYTE) ( %STRING (		! L
		zchar (	'LEFT',		T_LEFT),
		zchar (	'LONGWORD',	T_LONGWORD),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! M
		zchar ( 'MATCHING',	T_MATCHING),
		zchar (	'MISSING_VALUE', T_MISSING_VALUE),
		zchar ( 'MOVE',		T_MOVE),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! N
		zchar (	'NAME',		T_NAME),
		zchar (	'NUMERIC',	T_NUMERIC),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! O
		zchar (	'OCCURS',	T_OCCURS),
		zchar (	'OCTAWORD',	T_OCTAWORD),
		zchar (	'OF',		T_OF),
		zchar (	'ON',		T_ON),
		zchar ( 'OTHERS',	T_OTHERS),
		zchar (	'OVERPUNCHED',	T_OVERPUNCHED),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! P
		zchar (	'PACKED',	T_PACKED),
		zchar (	'PICTURE',	T_PICTURE),
		zchar (	'PLI',		T_PLI),
		zchar (	'POINTER',	T_POINTER),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! Q
		zchar (	'QUADWORD',	T_QUADWORD),
		zchar (	'QUERY_HEADER',	T_QUERY_HEADER),
		zchar (	'QUERY_NAME',	T_QUERY_NAME),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! R
		zchar (	'RECORD',	T_RECORD),
		zchar (	'RIGHT',	T_RIGHT),
		zchar ( 'ROUNDED',	T_ROUNDED),
		zchar (	'ROW_MAJOR',	T_ROW_MAJOR),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! S
		zchar (	'SCALE',	T_SCALE),
		zchar (	'SEPARATE',	T_SEPARATE),
		zchar (	'SIGNED',	T_SIGNED),
		zchar ( 'SIXBIT',	T_SIXBIT),
		zchar (	'SIZE',		T_SIZE),
		zchar (	'STRING',	T_STRING),
		zchar (	'STRUCTURE',	T_STRUCTURE),
		zchar ( 'SYNC',		T_SYNC),
		zchar ( 'SYNCHRONIZED',	T_SYNCHRONIZED),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! T
		zchar (	'TEXT',		T_TEXT),
		zchar (	'THRU',		T_THRU),
		zchar (	'TIME',		T_TIME),
		zchar (	'TIMES',	T_TIMES),
		zchar (	'TO',		T_TO),
		zchar ( 'TRANSFORM',	T_TRANSFORM),
		zchar ( 'TRUNCATED',	T_TRUNCATED),
		zchar (	'TYPE',		T_TYPE),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! U
		zchar (	'UNSIGNED',	T_UNSIGNED),
		zchar (	'UNSPECIFIED',	T_UNSPECIFIED),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! V
		zchar (	'VALID',	T_VALID),
		zchar (	'VALUE',	T_VALUE),
		zchar (	'VALUES',	T_VALUES),
		zchar (	'VARIANT',	T_VARIANT),
		zchar ( 'VARIANTS',	T_VARIANTS),
		zchar (	'VARYING',	T_VARYING),
		zchar (	'VIRTUAL',	T_VIRTUAL),
		%char (0))),
	UPLIT %BLISS32 (BYTE) ( %STRING (		! W
		zchar (	'WHEN',		T_WHEN),
		zchar (	'WORD',		T_WORD),
		%char (0))),
	UPLIT %BLISS32 (BYTE) (0),			! No X
	UPLIT %BLISS32 (BYTE) (0),			! No Y
	UPLIT %BLISS32 (BYTE) ( %STRING (		! Z
		zchar (	'ZERO',		T_ZERO),
		zchar (	'ZONED',	T_ZONED),
		%char (0))) )
	: VECTOR;
! Lower case to upper case and dash to underscore

    BIND
	    UPCASE = ch$transtable (
	    %c' ', %c' ', %c' ', %c' ',	! NUL, SOH, STX, ETX
	    %c' ', %c' ', %c' ', %c' ',	! EOT, ENQ, ACK, BEL
	    %c' ', %c' ', %c' ', %c' ',	!  BS,  HT,  LF,  VT
	    %c' ', %c' ', %c' ', %c' ',	!  FF,  CR,  SO,  SI
	    %c' ', %c' ', %c' ', %c' ',	! DLE, DC1, DC2, DC3
	    %c' ', %c' ', %c' ', %c' ',	! DC4, NAK, SYN, ETB
	    %c' ', %c' ', %c' ', %c' ',	! CAN,  EM, SUB, ESC
	    %c' ', %c' ', %c' ', %c' ',	!  FS,  GS,  RS,  US
	    %c' ', %c' ', %c' ', %c' ',	!  SP,   !,   ",   #
	    %c'$', %c' ', %c' ', %c' ',	!   $,   %,   &,   '
	    %c' ', %c' ', %c' ', %c' ',	!   (,   ),   *,   +
	    %c' ', %c'_', %c'.', %c' ',	!   ,,   -,   .,   /
	    %c'0', %c'1', %c'2', %c'3',	!   0,   1,   2,   3
	    %c'4', %c'5', %c'6', %c'7',	!   4,   5,   6,   7
	    %c'8', %c'9', %c' ', %c';',	!   8,   9,   :,   ;
	    %c' ', %c' ', %c' ', %c' ',	!   <,   =,   >,   ?
	    %c' ', %c'A', %c'B', %c'C',	!   @,   A,   B,   C
	    %c'D', %c'E', %c'F', %c'G',	!   D,   E,   F,   G
	    %c'H', %c'I', %c'J', %c'K',	!   H,   I,   J,   K
	    %c'L', %c'M', %c'N', %c'O',	!   L,   M,   N,   O
	    %c'P', %c'Q', %c'R', %c'S',	!   P,   Q,   R,   S
	    %c'T', %c'U', %c'V', %c'W',	!   T,   U,   V,   W
	    %c'X', %c'Y', %c'Z', %c' ',	!   X,   Y,   Z,   [
	    %c' ', %c' ', %c' ', %c'_',	!   \,   ],   ^,   _
	    %c' ', %c'A', %c'B', %c'C',	!   `,   a,   b,   c
	    %c'D', %c'E', %c'F', %c'G',	!   d,   e,   f,   g
	    %c'H', %c'I', %c'J', %c'K',	!   h,   i,   j,   k
	    %c'L', %c'M', %c'N', %c'O',	!   l,   m,   n,   o
	    %c'P', %c'Q', %c'R', %c'S',	!   p,   q,   r,   s
	    %c'T', %c'U', %c'V', %c'W',	!   t,   u,   v,   w
	    %c'X', %c'Y', %c'Z', %c' ',	!   x,   y,   z,   {
	    %c' ', %c' ', %c' ', %c' ');!   |,   },   ~, DEL
    LITERAL
	MINUS		= %C'-';

    LOCAL
	TEXT :		vector [ch$allocation (BUF_SIZE)],
	STATUS,
	PTR,
	LENGTH;

! Scan characters up to the end of the string of letters and digits.
! These characters form a CDD_name (variable name), a keyword, or part
! of a path_name.

    WHILE (NOT .END_OF_INPUT_LINE) AND
	(.IDENT [ch$rchar (.CHAR)] EQLU I_LETTER
	OR .IDENT [ch$rchar (.CHAR)] EQLU I_OTHER	!??
	OR .IDENT [ch$rchar (.CHAR)] EQLU I_DIGIT)
    DO GET_CHAR (CHAR, false);

    STATUS = FALSE;
! Check to see if the string of letters and digits is a path_name.
! If it is, the string is not at the end of an input line and is followed
! by a left parenthesis, a semicolon, or a dot followed by a letter (start
! of next piece of path_name) or a minus sign.

    IF NOT .END_OF_INPUT_LINE AND
	(.IDENT [ch$rchar (.CHAR)] EQLU I_L_PAREN
	OR .IDENT [ch$rchar (.CHAR)] EQLU I_SEMICOLON OR
	(.IDENT [ch$rchar (.CHAR)] EQLU I_DOT
	    AND (.IDENT [ch$rchar (ch$plus (.CHAR, 1))] EQLU I_LETTER OR
		CH$RCHAR (ch$plus (.CHAR, 1)) EQLU MINUS)))
    THEN		! We have a PATH_NAME
	BEGIN
	    TOKEN_PTR [TKN_TERM] = T_PATH_NAME;
	    PTR = ch$ptr (TEXT);
	    WHILE TRUE DO
		BEGIN		! Loop on pieces of path_name

		    ! Compute length of piece of path_name, convert it to
		    ! upper case, and store it.

		    LENGTH = ch$diff (.CHAR, .LEX_TKNSTRT);
		    CH$TRANSLATE (UPCASE, .LENGTH, .LEX_TKNSTRT, 0, .LENGTH,
			.PTR);
		    PTR = ch$plus (.PTR, .LENGTH);

		    ! Path_name followed by a semicolon, so eat the
		    ! version number which follows.

		    IF .IDENT [ch$rchar (.CHAR)] EQLU I_SEMICOLON THEN
			BEGIN
			    PTR = CH$MOVE (1, .CHAR, .PTR);
			    GET_CHAR (CHAR, false);
			    IF (NOT .END_OF_INPUT_LINE) AND
				(CH$RCHAR (.CHAR) EQLU MINUS) THEN
				BEGIN
				    PTR = CH$MOVE (1, .CHAR, .PTR);
				    GET_CHAR (CHAR, false);
				END;
			    WHILE (NOT .END_OF_INPUT_LINE) AND
				(.IDENT [ch$rchar (.CHAR)] EQLU I_DIGIT) DO
				BEGIN
				    PTR = CH$MOVE (1, .CHAR, .PTR);
				    GET_CHAR (CHAR, false);
				END;
			END;

		    ! Path_name piece followed by a left parenthesis.
		    ! Eat the characters within the parentheses.

		    IF .IDENT [ch$rchar (.CHAR)] EQLU I_L_PAREN THEN
			BEGIN
			    PTR = CH$MOVE (1, .CHAR, .PTR);
			    DO
				BEGIN
				    GET_CHAR (CHAR, false);
				    PTR = CH$MOVE (1, .CHAR, .PTR);
				END
			    WHILE NOT .END_OF_INPUT_LINE AND
				.IDENT [ch$rchar (.CHAR)] NEQU I_ILLEGAL AND
				.IDENT [ch$rchar (.CHAR)] NEQU I_L_PAREN AND
				.IDENT [ch$rchar (.CHAR)] NEQU I_R_PAREN AND
				.IDENT [ch$rchar (.CHAR)] NEQU I_DOT;

			    IF .IDENT [ch$rchar (.CHAR)] NEQU I_R_PAREN
				OR .END_OF_INPUT_LINE
				THEN EXITLOOP;
			    GET_CHAR (CHAR, false);
			END;

		    ! End of path_name: next character is not a dot, or
		    ! reached the end of the input line, or not at the end of
		    ! the input line and next character is a dot but following
		    ! character is neither a letter nor a minus sign.
		    ! Store the path name and exit the loop to collect
		    ! a path_name.

		    IF .IDENT [ch$rchar (.CHAR)] NEQU I_DOT OR
			.END_OF_INPUT_LINE OR
			(NOT .END_OF_INPUT_LINE AND
			.IDENT [ch$rchar (ch$plus (.CHAR, 1))] NEQU I_LETTER
			and CH$RCHAR (ch$plus (.CHAR, 1)) NEQU MINUS)
		    THEN
			BEGIN
			    STATUS = TRUE;
			    ENTER_TEXT (ch$diff (.PTR, ch$ptr (TEXT)),
				ch$ptr (TEXT), TOKEN_PTR [TKN_TEXT]);
			    EXITLOOP;
			END;

		    ! Here if we found a dot which is not at the end of the
		    ! input line and which is followed by a letter or a minus
		    ! sign.  There are more path_name pieces to come, so we
		    ! eat the dot and move the start of the path_name piece
		    ! up to the next character, and then eat up a string of
		    ! letters and digits.

		    PTR = CH$MOVE (1, .CHAR, .PTR);
		    LEX_TKNSTRT = ch$plus (.CHAR, 1);

		    IF NOT .END_OF_INPUT_LINE
			THEN DO  GET_CHAR (CHAR, false)
			    WHILE (NOT .END_OF_INPUT_LINE) AND
			    (.IDENT [ch$rchar (.CHAR)] EQLU I_LETTER
			    OR .IDENT [ch$rchar (.CHAR)] EQLU I_OTHER	!??
			    OR .IDENT [ch$rchar (.CHAR)] EQLU I_DIGIT)
		END;	! Loop on pieces of path_name
	END		! End of pathname
! These characters do not form a path_name, so they are either a CDD_name
! (that is, a variable) or a keyword.  We will convert the string to upper
! case, store it, and look for it in the keyword table (RESERVED_TABLE).
! The keyword table has an entry for each initial letter, and each entry
! ends with a zero character.  Within each alphabetic entry, the entry for
! a particular keyword has the legnth of the keyword, the characters which
! make up the keyword, and a character whose numerical value is the token
! number of the keyword.  This does constrain the token numbers available
! for keywords, especially on 10/20, which is why they are declared in the
! grammar with lower values than the symbols and other tokens; if this
! becomes a problem, rewrite the ZCHAR macro, which is defined just before
! the keyword table.

    ELSE		! We have a CDD_NAME or keyword
	WHILE TRUE DO
	    BEGIN
		LENGTH = ch$diff (.CHAR, .LEX_TKNSTRT);
		CH$TRANSLATE(UPCASE, .LENGTH, .LEX_TKNSTRT, 0, .LENGTH,
		    ch$ptr (TEXT));
		ENTER_TEXT (.LENGTH, ch$ptr (TEXT), TOKEN_PTR [TKN_TEXT]);
		IF .IDENT [ch$rchar (ch$ptr (TEXT))] NEQU I_LETTER THEN PTR = 0
		    ELSE PTR =
			ch$ptr(.RESERVED_TABLE[ch$rchar(ch$ptr(TEXT)) - %c'A']);
		IF ch$rchar (.PTR) NEQU 0 THEN	! Check for keyword
		    WHILE ch$rchar (.PTR) NEQU 0 DO
			BEGIN	! Look through alphabetic entry
			    IF ch$rchar (.PTR) EQLU .LENGTH THEN
				IF CH$EQL (ch$rchar (.PTR), ch$plus (.PTR, 1),
				    ch$rchar (.PTR), ch$ptr (TEXT))
				    THEN
					BEGIN	! Found it!
					    TOKEN_PTR [TKN_TERM] =
						ch$rchar (ch$plus (.PTR,
						ch$rchar (.PTR) + 1));
					    EXITLOOP;
					END;
			    PTR = ch$plus (.PTR, ch$rchar (.PTR) + 2);
			END;	! Looking through alphabetic entry

		STATUS = TRUE;
		IF .TOKEN_PTR [TKN_TERM] EQLU T_EOF THEN	! Left by LEX
		    TOKEN_PTR [TKN_TERM] = T_CDD_NAME;
		EXITLOOP;
	    END;
    RETURN .STATUS;
END;
ROUTINE DDU$$P_LEX_NUMBER (TOKEN_TYPE, CHAR_PTR) =
!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine lexically parses a numeric token.
!
!  INPUT PARAMETERS:
!
!	token_type	address of a word to be set to the type of
!			numeric token parsed.
!	char_ptr	pointer to current character position.
!
!  IMPLICIT INPUTS:
!
!	END_OF_INPUT_LINE	TRUE if current character is at end of line
!
!  IMPLICIT OUTPUTS:
!
!	END_OF_INPUT_LINE	Flag for last character in input line
!
!  COMPLETION STATUS:
!
!	TRUE if successful, FALSE otherwise.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	May cause input lines to be read.
!
!--
BEGIN
    BIND
	TKN_TYPE	= .TOKEN_TYPE	%BLISS32 (: LONG),
	CHAR		= .CHAR_PTR;

    LITERAL
	NINE		= %C'9',
	ZERO		= %C'0',
	E		= %C'E',
	PLUS		= %C'+',
	MINUS		= %C'-';

    LOCAL
	STATUS		%BLISS32 (: LONG),
	HAS_SIGN	%BLISS32 (: LONG);

    STATUS = TRUE;
! Determine if number is signed or unsigned.

    IF CH$RCHAR (.CHAR) EQLU MINUS OR CH$RCHAR (.CHAR) EQLU PLUS THEN
	BEGIN
	    HAS_SIGN = TRUE;
	    GET_CHAR (CHAR, false);
	END
    ELSE HAS_SIGN = FALSE;

    IF CH$RCHAR (.CHAR) LSSU ZERO OR CH$RCHAR (.CHAR) GTRU NINE THEN
	STATUS = FALSE;
    WHILE CH$RCHAR (.CHAR) GEQU ZERO AND CH$RCHAR (.CHAR) LEQU NINE
	AND NOT .END_OF_INPUT_LINE DO
	GET_CHAR (CHAR, false);

! See if it is a signed or unsigned integer.

    IF .STATUS AND CH$RCHAR (.CHAR) NEQU E AND
	(NOT CH$EQL (1, .CHAR, 1, ch$ptr (UPLIT ('.')), %c' ') OR
	.END_OF_INPUT_LINE OR
	(CH$EQL (1, .CHAR, 1, ch$ptr (UPLIT('.')), %c' ') AND
	(CH$RCHAR (ch$plus (.CHAR, 1)) LSSU ZERO OR
	    CH$RCHAR (ch$plus (.CHAR, 1)) GTRU NINE)))
    THEN
	BEGIN	! It's an integer
	    IF .HAS_SIGN THEN TKN_TYPE = T_SIGNED_INTEGER
	    ELSE TKN_TYPE = T_UNSIGNED_INTEGER;
	    RETURN SS$_NORMAL;
	END;
! See if it is a fixed-point number.

    IF CH$EQL (1, .CHAR, 1, ch$ptr (UPLIT('.')), %c' ') AND .STATUS THEN
	BEGIN
	    GET_CHAR (CHAR, false);
	    IF CH$RCHAR (.CHAR) LSSU ZERO OR CH$RCHAR (.CHAR) GTRU NINE THEN
		STATUS = FALSE;
	    WHILE CH$RCHAR (.CHAR) GEQU ZERO AND CH$RCHAR (.CHAR) LEQU NINE
		AND NOT .END_OF_INPUT_LINE DO
		GET_CHAR (CHAR, false);

	    IF (CH$RCHAR (.CHAR) LSSU ZERO OR CH$RCHAR (.CHAR) GTRU NINE) AND
		CH$RCHAR (.CHAR) NEQU E AND .STATUS
	    THEN
		BEGIN	! It's a fixed point number.
		    TKN_TYPE = T_FIXED_POINT;
		    RETURN SS$_NORMAL;
		END;
	END;

! See if it is a floating-point number.

    IF CH$RCHAR (.CHAR) EQLU E AND .STATUS THEN
	BEGIN
	    GET_CHAR (CHAR, false);
	    IF CH$RCHAR (.CHAR) EQLU MINUS OR CH$RCHAR (.CHAR) EQLU PLUS
	    THEN GET_CHAR (CHAR, false);
	    IF CH$RCHAR (.CHAR) LSSU ZERO OR CH$RCHAR (.CHAR) GTRU NINE THEN
		STATUS = FALSE;
	    WHILE CH$RCHAR (.CHAR) GEQU ZERO AND CH$RCHAR (.CHAR) LEQU NINE DO
		GET_CHAR (CHAR, false);

	    IF .STATUS THEN
		BEGIN	! It's a floating point number.
		    TKN_TYPE = T_FLOATING_POINT;
		    RETURN SS$_NORMAL;
		END;
	END;

!   No valid number found.

    LSLOCAL_SYNTAX_ERRORM (.lex_locator, 'Illegal number.');
    RETURN .STATUS;
END;
ROUTINE DDU$$P_LEX_PERCENT (CHAR_PTR, TOKEN_PTR) =
!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine lexically parses a token beginning with a percent sign.
!
!  PARAMETERS:
!
!	char_ptr		pointer to current character position.
!	token_ptr		address of the current token pointer.
!
!  IMPLICIT INPUTS:
!
!	END_OF_INPUT_LINE	TRUE if current character is at end of line
!	LEX_TKNSTRT		Pointer to first character in token
!
!  IMPLICIT OUTPUTS:
!
!	LEX_TKNSTRT		Updated pointer to first character in token.
!
!  COMPLETION STATUS:
!
!	TRUE if OK, FALSE otherwise.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	May read more input lines.
!
!--
BEGIN
    MAP
	TOKEN_PTR 	: REF	TKN_STR;
	
    BIND
	CHAR		= .CHAR_PTR;

    LITERAL
	ZERO		= %C'0',
	SEVEN		= %C'7',
	NINE		= %C'9',
	A		= %C'A',
	F		= %C'F',
	O		= %C'O',
	X		= %C'X',
	SGL_QUOTE	= %C'''';

    LOCAL
	STATUS		%BLISS32 (: LONG);
    GET_CHAR (CHAR, false);
    STATUS = TRUE;
    IF CH$RCHAR (.CHAR) EQLU X THEN		! Hex number
	BEGIN
	    TOKEN_PTR [TKN_TERM] = T_HEX_NUMBER;
	    GET_CHAR (CHAR, false);
	    IF CH$RCHAR (.CHAR) EQLU SGL_QUOTE THEN
		DO GET_CHAR (CHAR, false)
		    WHILE ((CH$RCHAR (.CHAR) GEQU ZERO AND
			    CH$RCHAR (.CHAR) LEQU NINE) OR
			(CH$RCHAR (.CHAR) GEQU A AND CH$RCHAR (.CHAR) LEQU F))
			AND NOT .END_OF_INPUT_LINE;
        END

    ELSE IF CH$RCHAR (.CHAR) EQLU O THEN	! Octal number
	    BEGIN
		TOKEN_PTR [TKN_TERM] = T_OCTAL_NUMBER;
		GET_CHAR (CHAR, false);
		IF CH$RCHAR (.CHAR) EQLU SGL_QUOTE THEN
		    DO GET_CHAR (CHAR, false)
			WHILE (CH$RCHAR (.CHAR) GEQU ZERO AND
			    CH$RCHAR (.CHAR) LEQU SEVEN
			    AND NOT .END_OF_INPUT_LINE);
	    END
	ELSE STATUS = FALSE;
			
    IF NOT .STATUS OR CH$RCHAR (.CHAR) NEQU SGL_QUOTE
	THEN
	    BEGIN
		LSLOCAL_SYNTAX_ERRORM (.lex_locator,
		    'Illegal hexadecimal or octal number');
		RETURN FALSE;
	    END;

    LEX_TKNSTRT = ch$plus (.LEX_TKNSTRT, 3);
    ENTER_TEXT (ch$diff (.CHAR, .LEX_TKNSTRT),
	.LEX_TKNSTRT, TOKEN_PTR [TKN_TEXT]);
    RETURN .STATUS;
END;
ROUTINE ENTER_TEXT (LENGTH, TEXT, TEXT_PTR) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
!	This is a hacked up routine for storing text strings in
!	the heap.
!
!  INPUT PARAMETERS:
!
!	length		is the length of the text to be stored.
!	text		is a pointer to the text string to be stored.
!
!  OUTPUT PARAMETERS:
!
!	text_ptr	is the address of the text descriptor to be set to
!			point to the text string.
!
!  IMPLICIT INPUTS:
!
!	none
!
!  IMPLICIT OUTPUTS:
!
!	none
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	The system may be called on to allocate more heap storage.
!
!--
BEGIN
    %IF %BLISS (BLISS32) %THEN
    MAP
	LENGTH : LONG;
	%FI

    BIND
	t_desc = utl_get (STR$K_D_BLN*%upval): $STR_DESCRIPTOR (class=dynamic);

    $STR_DESC_INIT (DESCRIPTOR = t_desc, class=dynamic);
    $STR_COPY (STRING=(.length, .text), TARGET=t_desc);
    .text_ptr = t_desc;
END;
ROUTINE GET_CHAR (CHAR_ADDR, SKIP_COMMENT) : NOVALUE =
!++
!  FUNCTIONAL DESCRIPTION:
!
!	This routine returns the next input character and sets the line and
!	column pointers.  It also skips over comments if requested.
!
!  INPUT PARAMETERS:
!
!	skip_comment	skip comments if TRUE
!
!  OUTPUT PARAMETERS:
!
!	char_addr	address of a pointer to be set to point to
!			the next input character.
!
!  IMPLICIT INPUTS:
!
!	file_iob	address of XPORT IOB for file being parsed.
!	LEX_LINENUM	Lexical line number
!	COLUMN		Column number
!	LEX_COLUMN	Lexical column number
!
!  IMPLICIT OUTPUTS:
!
!	START_LINE	TRUE if this is the first token on a line
!	LEX_LINENUM	Lexical line number
!	LEX_COLUMN	Lexical column number
!	END_OF_INPUT_LINE TRUE if character is last one on input line
!	COLUMN		Column number
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	Reads input lines.
!
!--
BEGIN
    MAP
	SKIP_COMMENT %BLISS32 ( : LONG);

    BIND
	CHAR		= .CHAR_ADDR;

    LITERAL
	TAB		= %X'09',	! a tab character
	COMMENT_DELIM	= %C'!';	! the character '!'

    OWN
	TEMP_BUFF	: $STR_DESCRIPTOR (CLASS=DYNAMIC, STRING=(0,0)),
	EOL_COLUMN	: %BLISS32 (BYTE) INITIAL (%CHAR (04)),	! ^D character
	EOF_COLUMN	: %BLISS32 (BYTE) INITIAL (%CHAR (26)),	! ^Z character
	FORM_FEED	: %BLISS32 (BYTE) INITIAL (%CHAR (12));	! ^L character

    LOCAL
	FF_PTR,
	STATUS;
!   Get the next character.  If the line has been totally scanned, then get
!   the first character on the next line.  This will point past the last
!   character on an end of line.

    START_LINE = FALSE;

    IF (.LEX_LINENUM EQL 0) OR (.COLUMN EQL .temp_buff [STR$H_LENGTH])
	OR (.END_OF_INPUT_LINE)
    THEN
	BEGIN				! Get another line
	    STATUS = $XPO_GET (IOB = .file_iob);
	    $STR_COPY (STRING = $STR_CONCAT (
		(.file_iob [IOB$H_STRING], .file_iob [IOB$A_STRING]),
		(1, ch$ptr (EOL_COLUMN))),
		TARGET = TEMP_BUFF);
	    LEX_LINENUM = .LEX_LINENUM + 1;
	    START_LINE = TRUE;
	    IF .STATUS EQLU XPO$_END_FILE THEN
		BEGIN
		    LEX_COLUMN = 1;
		    CHAR = ch$ptr (EOF_COLUMN);
		    END_OF_INPUT_LINE = TRUE;
		    RETURN;
		END;
	    IF NOT .STATUS THEN SIGNAL (.STATUS);

	    FF_PTR = CH$FIND_CH (.TEMP_BUFF [STR$H_LENGTH],
		.TEMP_BUFF [STR$A_POINTER], .FORM_FEED);
	    WHILE NOT CH$FAIL (.FF_PTR) DO
		BEGIN
		    CH$MOVE (1, ch$ptr (UPLIT %BLISS32 (BYTE) (' ')), .FF_PTR);
		    FF_PTR = CH$FIND_CH (
			(.TEMP_BUFF [STR$H_LENGTH] -
			ch$diff (.FF_PTR,
			   ch$plus (.TEMP_BUFF [STR$A_POINTER], 1))),
			ch$plus (.FF_PTR, 1), .FORM_FEED);
		END;
	    LEX_COLUMN = 1;
	    COLUMN = 1;
	END				! Get another line
    ELSE
	BEGIN				! Get character from current line
	    COLUMN = .COLUMN + 1;
	    IF (.COLUMN GTR 1) AND
		(CH$RCHAR (ch$plus (.temp_buff [STR$A_POINTER], .COLUMN - 2))
		EQLU TAB)
	    THEN	! next tab position
		LEX_COLUMN =
		    ((.LEX_COLUMN + (COLUMNS_PER_TAB - 1)
		    / COLUMNS_PER_TAB) * COLUMNS_PER_TAB) + 1
	    ELSE
		LEX_COLUMN = .LEX_COLUMN + 1;
	END;				! Get character from current line
!   Skip over comments if the SKIP_COMMENT flag has been set.  Treat the
!   comment as if it were an end of line.

    IF .SKIP_COMMENT THEN
	IF (.COLUMN LEQU .temp_buff [STR$H_LENGTH]) AND
	    CH$RCHAR (ch$plus (.temp_buff [STR$A_POINTER], .COLUMN - 1))
	    EQLU COMMENT_DELIM
	THEN
	    BEGIN
		COLUMN = .temp_buff [STR$H_LENGTH];
		LEX_COLUMN = .temp_buff [STR$H_LENGTH];
		END_OF_INPUT_LINE = TRUE;
	    END;

!   Set the character pointer to the current character.

    CHAR = ch$plus (.temp_buff [STR$A_POINTER], .COLUMN - 1);

!   Notice if we just read the last character on a line.

    IF .COLUMN EQL .temp_buff [STR$H_LENGTH]
	THEN END_OF_INPUT_LINE = TRUE
	ELSE END_OF_INPUT_LINE = FALSE;
END;
ROUTINE LEX (TOKEN_PTR) : NOVALUE =
!++
!  FUNCTIONAL DESCRIPTION:
!
!	This routine returns the next input token.
!
!  INPUT PARAMETERS:
!
!	None
!
!  OUTPUT PARAMETERS:
!
!	token_ptr	Pointer to a token data structure where the new token
!			information will be returned.
!
!  IMPLICIT INPUTS:
!
!	START_LINE	TRUE if token is the first token on a line
!	LEX_LOCATOR	Text source location for new lexeme
!	LEX_COLUMN	Source column
!	LEX_LINENUM	Source line number
!
!  IMPLICIT OUTPUTS:
!
!	LEX_COLUMN	Source column
!	LEX_LINENUM	Lexical line number, reset to zero when an end-of-file
!			token is produced -- see code in GET_CHAR, above.
!	LEX_TKNSTRT	Pointer to start of lexeme
!
!  COMPLETION STATUS:
!
!	none
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	Reads input file.
!
!--
BEGIN

    MAP
	TOKEN_PTR	: REF	TKN_STR;

! Classes of characters which might appear in the input:

    LITERAL
	C_IGNORABLE	=  0,
	C_DIGIT		=  1,
	C_LETTER	=  2,
	C_SLASH		=  3,
	C_QUOTE		=  4,
	C_PERCENT	=  5,
	C_STAR		=  6,
	C_DOT		=  7,
	C_COLON		=  8,
	C_SEMICOLON     =  9,
	C_L_PAREN	= 10,
	C_R_PAREN	= 11,
	C_MINUS		= 12,
	C_OTHERS	= 13,
	C_EOF		= 14;
! Class of each possible ASCII input character:

    BIND
	CLASS = UPLIT %BLISS32 (BYTE) (
		C_IGNORABLE,	! 00 NUL
		C_OTHERS,	! 01 SOH
		C_OTHERS,	! 02 STX
		C_OTHERS,	! 03 ETX
		C_IGNORABLE, 	! 04 EOT
		C_OTHERS,	! 05 ENQ
		C_OTHERS,	! 06 ACK
		C_OTHERS,	! 07 BEL
		C_OTHERS,	! 08 BS
		C_IGNORABLE,	! 09 HT
		C_IGNORABLE,	! 0A LF
		C_IGNORABLE,	! 0B VT
		C_IGNORABLE,	! 0C FF
		C_IGNORABLE,	! 0D CR
		C_OTHERS,	! 0E SO
		C_OTHERS,	! 0F SI
		C_OTHERS,	! 10 DLE
		C_OTHERS,	! 11 DC1
		C_OTHERS,	! 12 DC2
		C_OTHERS,	! 13 DC3
		C_OTHERS,	! 14 DC4
		C_OTHERS,	! 15 NAK
		C_OTHERS,	! 16 SYN
		C_OTHERS,	! 17 ETB
		C_OTHERS,	! 18 CAN
		C_OTHERS,	! 19 EM
		C_EOF,		! 1A SUB
		C_OTHERS,	! 1B ESC
		C_OTHERS,	! 1C FS
		C_OTHERS,	! 1D GS
		C_OTHERS,	! 1E RS
		C_OTHERS,	! 1F US
		C_IGNORABLE,	! 20 SP
		C_OTHERS,	! 21 !
		C_QUOTE,	! 22 "
		C_OTHERS,	! 23 #
		C_LETTER,	! 24 $
		C_PERCENT,	! 25 %
		C_OTHERS,	! 26 &
		C_QUOTE,	! 27 '
		C_L_PAREN,	! 28 (
		C_R_PAREN,	! 29 )
		C_STAR,		! 2A *
		C_DIGIT,	! 2B +
		C_IGNORABLE, 	! 2C ,
		C_MINUS,	! 2D -
		C_DOT,		! 2E .
		C_SLASH,	! 2F /
		C_DIGIT,	! 30 0
		C_DIGIT,	! 31 1
		C_DIGIT,	! 32 2
		C_DIGIT,	! 33 3
		C_DIGIT,	! 34 4
		C_DIGIT,	! 35 5
		C_DIGIT,	! 36 6
		C_DIGIT,	! 37 7
		C_DIGIT,	! 38 8
		C_DIGIT,	! 39 9
		C_COLON,	! 3A :
		C_SEMICOLON,	! 3B ;
		C_OTHERS,	! 3C <
		C_OTHERS,	! 3D =
		C_OTHERS,	! 3E >
		C_OTHERS,	! 3F ?
		C_OTHERS,	! 40 @
		C_LETTER,	! 41 A
		C_LETTER,	! 42 B
		C_LETTER,	! 43 C
		C_LETTER,	! 44 D
		C_LETTER,	! 45 E
		C_LETTER,	! 46 F
		C_LETTER,	! 47 G
		C_LETTER,	! 48 H
		C_LETTER,	! 49 I
		C_LETTER,	! 4A J
		C_LETTER,	! 4B K
		C_LETTER,	! 4C L
		C_LETTER,	! 4D M
		C_LETTER,	! 4E N
		C_LETTER,	! 4F O
		C_LETTER,	! 50 P
		C_LETTER,	! 51 Q
		C_LETTER,	! 52 R
		C_LETTER,	! 53 S
		C_LETTER,	! 54 T
		C_LETTER,	! 55 U
		C_LETTER,	! 56 V
		C_LETTER,	! 57 W
		C_LETTER,	! 58 X
		C_LETTER,	! 59 Y
		C_LETTER,	! 5A Z
		C_OTHERS,	! 5B [
		C_OTHERS,	! 5C \
		C_OTHERS,	! 5D ]
		C_OTHERS,	! 5E ^
		C_LETTER,	! 5F _
		C_OTHERS,	! 60 `
		C_LETTER,	! 61 a
		C_LETTER,	! 62 b
		C_LETTER,	! 63 c
		C_LETTER,	! 64 d
		C_LETTER,	! 65 e
		C_LETTER,	! 66 f
		C_LETTER,	! 67 g
		C_LETTER,	! 68 h
		C_LETTER,	! 69 i
		C_LETTER,	! 6A j
		C_LETTER,	! 6B k
		C_LETTER,	! 6C l
		C_LETTER,	! 6D m
		C_LETTER,	! 6E n
		C_LETTER,	! 6F o
		C_LETTER,	! 70 p
		C_LETTER,	! 71 q
		C_LETTER,	! 72 r
		C_LETTER,	! 73 s
		C_LETTER,	! 74 t
		C_LETTER,	! 75 u
		C_LETTER,	! 76 v
		C_LETTER,	! 77 w
		C_LETTER,	! 78 x
		C_LETTER,	! 79 y
		C_LETTER,	! 7A z
		C_OTHERS,	! 7B {
		C_OTHERS,	! 7C |
		C_OTHERS,	! 7D }
		C_OTHERS,	! 7E ~
		C_OTHERS	! 7F DEL
%BLISS32 (	,REP 128 OF (C_OTHERS)))
	: VECTOR [%BLISS32 (,BYTE)];
    LITERAL
	BUF_SIZE	= 256,
	END_OF_FILE	= %X'1A',
	END_OF_LINE	= %X'04',
	COMMENT		= %C'!';

    OWN
	WITHIN_DESC	: %BLISS32 (LONG)	INITIAL (FALSE),
	LOOK_AHEAD	: %BLISS32 (LONG)	INITIAL (FALSE),
	CHAR;		! Pointer to current character

    LOCAL
	PAST_CHAR,	! Pointer to previous character
	TEXT		: vector [ch$allocation (BUF_SIZE)],
	STATUS %BLISS32 (: LONG);
! Initialize the new token.

    TOKEN_PTR [TKN_TERM] = T_EOF;
    TOKEN_PTR [TKN_INTVALUE] = 0;
    TOKEN_PTR [TKN_START_LINE] = FALSE;
    IF .CHAR NEQU 0 THEN
	IF CH$RCHAR (.CHAR) EQLU END_OF_FILE THEN
	    BEGIN
		TOKEN_PTR [TKN_LOCATOR] = .LEX_LOCATOR;
		CHAR = 0;	! Prepare to read next file by clearing these
		LEX_LINENUM = 0;! -- see code in GET_CHAR, above
		RETURN;
	    END;

    WHILE TRUE DO		! Large loop to find next lexeme
	BEGIN			! Exit this loop when a lexeme is found
	    IF .CHAR EQLU 0 THEN
		GET_CHAR (CHAR, true)
	    ELSE
		BEGIN
		    IF .LOOK_AHEAD AND CH$RCHAR (.CHAR) EQLU COMMENT THEN
			BEGIN
			    LEX_COLUMN = .LEX_COLUMN - 1;
			    COLUMN = .COLUMN - 1;
			    LOOK_AHEAD = FALSE;
			END;
		    IF CH$RCHAR (.CHAR) NEQU END_OF_FILE AND NOT .LOOK_AHEAD
		    THEN
			IF .WITHIN_DESC THEN GET_CHAR (CHAR, false)
			ELSE GET_CHAR (CHAR, true);
		END;

	    LOOK_AHEAD = FALSE;
	    IF .START_LINE THEN TOKEN_PTR [TKN_START_LINE] = TRUE;
	    LEX_LOCATOR [LOC_LINENUM] = .LEX_LINENUM; ! Set the line and column
	    LEX_LOCATOR [LOC_COLUMN] = .LEX_COLUMN;   ! locations of the token.
	    LEX_TKNSTRT = .CHAR;	! Save location of 1st token character.

	    IF CH$RCHAR (.CHAR) EQLU END_OF_FILE AND NOT .WITHIN_DESC THEN
		BEGIN
		    TOKEN_PTR [TKN_TERM] = T_EOF;
		    TOKEN_PTR [TKN_LOCATOR] = .LEX_LOCATOR;
		    ENTER_TEXT (5, ch$ptr (UPLIT %BLISS32 (BYTE) ('<EOF>')),
			TOKEN_PTR [TKN_TEXT]);
		    CHAR = 0;		! Prepare to read next file by clearing
		    LEX_LINENUM = 0;	! these -- see code in GET_CHAR, above
		    RETURN;
		END;
! Code to collect DESCRIPTIONS.
! These are special lexemes.  Each line is made into a separate T_DESCR_TEXT
! token.  The description text ends with a '*/' or at end-of-file.

	    IF .WITHIN_DESC THEN	! Inside DESCRIPTION:
		BEGIN
		    PAST_CHAR = .LEX_TKNSTRT;
		    TOKEN_PTR [TKN_TERM] = T_DESCR_TEXT;
		    WHILE TRUE DO
			BEGIN
			    IF .END_OF_INPUT_LINE OR
				(CH$RCHAR (.CHAR) EQLU END_OF_LINE)
				THEN EXITLOOP;
			    IF .CLASS [ch$rchar (.CHAR)] EQLU C_STAR AND
				.CLASS [ch$rchar(ch$plus(.CHAR,1))] EQLU C_SLASH
			    THEN
				BEGIN
				    WITHIN_DESC = FALSE;
				    GET_CHAR (CHAR, false);
				    EXITLOOP;
				END;
			    IF CH$RCHAR (.CHAR) EQLU END_OF_FILE THEN
				BEGIN
				    LSLOCAL_SYNTAX_ERRORM (.lex_locator,
					'DESCRIPTION not terminated.');
				    TOKEN_PTR [TKN_TERM] = T_EOF;
				    TOKEN_PTR [TKN_LOCATOR] = .LEX_LOCATOR;
				    ENTER_TEXT (5,
					ch$ptr(UPLIT %BLISS32 (BYTE) ('<EOF>')),
					TOKEN_PTR [TKN_TEXT]);
				    CHAR = 0;		! Prepare for next file;
				    LEX_LINENUM = 0;	! See code in GET_CHAR.
				    RETURN;
				END;
			    PAST_CHAR = .CHAR;
			    GET_CHAR (CHAR, false);
			END;
		    IF .PAST_CHAR EQLU .LEX_TKNSTRT THEN
			ENTER_TEXT (ch$diff (.PAST_CHAR, .LEX_TKNSTRT),
			    .LEX_TKNSTRT, TOKEN_PTR [TKN_TEXT])
		    ELSE
			ENTER_TEXT (ch$diff (.PAST_CHAR, .LEX_TKNSTRT) + 1,
			    .LEX_TKNSTRT, TOKEN_PTR [TKN_TEXT]);
		    EXITLOOP;
		END;		! End of DESCRIPTION code
! Machine to handle collecting normal lexemes.

	    CASE .CLASS [ch$rchar (.CHAR)] FROM C_IGNORABLE TO C_EOF OF
		SET

		[C_IGNORABLE]:		! Skip these characters
		    TRUE;

		[C_DIGIT]:		! Expect a number
		    BEGIN
			LOCAL
			    TOKEN_TYPE;

			LOOK_AHEAD = TRUE;
			STATUS = DDU$$P_LEX_NUMBER (TOKEN_TYPE, CHAR);
			IF .STATUS THEN
			    BEGIN
				TOKEN_PTR [TKN_TERM] = .TOKEN_TYPE;
				ENTER_TEXT (ch$diff (.CHAR, .LEX_TKNSTRT),
				    .LEX_TKNSTRT, TOKEN_PTR [TKN_TEXT]);
				IF .TOKEN_TYPE EQLU T_SIGNED_INTEGER OR
				    .TOKEN_TYPE EQLU T_UNSIGNED_INTEGER
				THEN
				    BEGIN
					status = $STR_BINARY (string =
					    .token_ptr [TKN_TEXT],
					    result =
					    token_ptr [TKN_INTVALUE]);
					IF NOT .STATUS THEN
					    LSLOCAL_SYNTAX_ERRORM (.lex_locator,
						'value overflow.');
					STATUS = SS$_NORMAL;
				    END;
				EXITLOOP;
			    END;
		    END;

		[C_LETTER]:	! Expect a path_name, keyword, or CDD_name
		    BEGIN
			STATUS = DDU$$P_LEX_NAME (.TOKEN_PTR, CHAR);
			LOOK_AHEAD = TRUE;
			IF .STATUS THEN EXITLOOP;
			LSLOCAL_SYNTAX_ERRORM (.lex_locator, 'bad identifier.');
		    END;

		[C_MINUS]:	! Expect a path_name or a number
		    BEGIN
			LOCAL
			    TOKEN_TYPE;

			LOOK_AHEAD = TRUE;
			IF (NOT .END_OF_INPUT_LINE) AND
			    (.CLASS [ch$rchar (ch$plus (.CHAR, 1))] EQLU C_DOT)
			    THEN
			    BEGIN	! A path_name
				STATUS = DDU$$P_LEX_NAME (.TOKEN_PTR, CHAR);
				IF NOT .STATUS THEN
				    LSLOCAL_SYNTAX_ERRORM (.lex_locator,
					'bad identifier.');
			    END		! A path_name
			ELSE
			    BEGIN	! A number
				STATUS = DDU$$P_LEX_NUMBER (TOKEN_TYPE, CHAR);
				IF .STATUS THEN
				    BEGIN
					TOKEN_PTR [TKN_TERM] = .TOKEN_TYPE;
					ENTER_TEXT (ch$diff (.CHAR,
					    .LEX_TKNSTRT),
					    .LEX_TKNSTRT, TOKEN_PTR [TKN_TEXT]);
					IF .TOKEN_TYPE EQLU T_SIGNED_INTEGER OR
					    .TOKEN_TYPE EQLU T_UNSIGNED_INTEGER
					THEN
					    BEGIN
						status = $str_binary (
						    string =
						    .token_ptr [TKN_TEXT],
						    result =
						    token_ptr [TKN_INTVALUE]);
						IF NOT .STATUS THEN
						    LSLOCAL_SYNTAX_ERRORM (
							.lex_locator,
							'value overflow.');
						STATUS = SS$_NORMAL;
					    END;
					EXITLOOP;
				    END;
			    END;		! A number
		    END;

		[C_SLASH]:		! Expect a description
		    BEGIN
			GET_CHAR (CHAR, false);
			IF (NOT .END_OF_INPUT_LINE) AND
			    (.CLASS [ch$rchar (.CHAR)] EQLU C_STAR) THEN
			    WITHIN_DESC = TRUE
			ELSE
			    BEGIN
				LSLOCAL_SYNTAX_ERRORM (.lex_locator,
				    'bad character.');
				LOOK_AHEAD = TRUE;
			    END;
		    END;

		[C_QUOTE]:		! Expect a quoted string
		    BEGIN
			LOCAL
			    PTR,
			    TEST;

			PTR = ch$ptr (TEXT);
			TEST = .CHAR;
			TOKEN_PTR [TKN_TERM] = T_QUOTED_STRING;

			GET_CHAR (CHAR, false);
			WHILE (CH$RCHAR (.CHAR) NEQU CH$RCHAR (.TEST) OR
			    CH$RCHAR (ch$plus (.CHAR, 1)) EQLU CH$RCHAR (.TEST))
			    AND CH$RCHAR (.CHAR) NEQU END_OF_LINE 
			    AND NOT .END_OF_INPUT_LINE
			DO
			    BEGIN
				IF CH$RCHAR (.CHAR) EQLU CH$RCHAR (.TEST) THEN
				    GET_CHAR (CHAR, false);

				PTR = CH$MOVE (1, .CHAR, .PTR);
				GET_CHAR (CHAR, false);
			    END;

			IF CH$RCHAR (.CHAR) EQLU CH$RCHAR (.TEST) THEN
			    BEGIN
				ENTER_TEXT (ch$diff (.PTR, ch$ptr (TEXT)),
				    ch$ptr (TEXT), TOKEN_PTR [TKN_TEXT]);
				EXITLOOP;
			    END
			ELSE
			    BEGIN
				LOOK_AHEAD = TRUE;
				LSLOCAL_SYNTAX_ERRORM (.lex_locator,
				    'illegal quoted string.');
			    END;
		    END;

		[C_PERCENT]:		! Expect a hex or octal number
		    BEGIN
			STATUS = DDU$$P_LEX_PERCENT (CHAR, .TOKEN_PTR);
			IF .STATUS THEN EXITLOOP
			ELSE LOOK_AHEAD = TRUE;
		    END;

		[C_STAR, C_DOT, C_COLON, C_SEMICOLON, C_L_PAREN, C_R_PAREN]:
		    BEGIN		! A single-character lexeme
			TOKEN_PTR [TKN_TERM] =
			    (SELECTONE .CLASS [ch$rchar (.CHAR)] OF
				SET
				    [C_STAR]:		T_STAR;
				    [C_DOT]:		T_DOT;
				    [C_COLON]:		T_COLON;
				    [C_SEMICOLON]:	T_SEMICOLON;
				    [C_L_PAREN]:	T_L_PAREN;
				    [C_R_PAREN]:	T_R_PAREN;
				TES);
			ENTER_TEXT (1, .LEX_TKNSTRT, TOKEN_PTR [TKN_TEXT]);
			EXITLOOP;
		    END;

		[C_OTHERS]:		! Illegal character
		    LSLOCAL_SYNTAX_ERRORM (.lex_locator, 'bad character.');

		[C_EOF]:		! End-of-file (^Z)
		    BEGIN
		    TOKEN_PTR [TKN_TERM] = T_EOF;
		    CHAR = 0;		! Prepare to be called again on the
		    LEX_LINENUM = 0;	!  next file - see code in GET_CHAR.
		    EXITLOOP;
		    END;

	    TES;
	END;		! End of large loop to find next lexeme

    TOKEN_PTR [TKN_LOCATOR] = .LEX_LOCATOR;

END;
GLOBAL ROUTINE PAR_GET_TOKEN =
!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine manages the token storage and gets the next lexical
!	token.
!
!  INPUT PARAMETERS:
!
!	None
!
!  OUTPUT PARAMETERS:
!
!	None
!
!  IMPLICIT INPUTS:
!
!	none
!
!  IMPLICIT OUTPUTS:
!
!	None
!
!  COMPLETION STATUS:
!
!	The address of the lexical token.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	None
!
!--
BEGIN

    OWN
	TOKEN_PTR	: REF	TKN_STR;

    TOKEN_PTR = TOKEN_STORAGE [.NEXT_TOKEN_INDEX, TKN_BASE];
    NEXT_TOKEN_INDEX = .NEXT_TOKEN_INDEX + 1;
    IF .NEXT_TOKEN_INDEX EQLU MAX_NUM_LEX_TOKS THEN
	NEXT_TOKEN_INDEX = 0;

    LEX (.TOKEN_PTR);
    RETURN .TOKEN_PTR
END;
ROUTINE UTL_GET (SIZE_REQUEST) =
!++
! FUNCTIONAL DESCRIPTION:
!
!	This is a hacked up heap allocation routine.
!
!  INPUT PARAMETERS:
!
!	size_request	is the number of bytes to be allocated.
!
!  OUTPUT PARAMETERS:
!
!	DDU-status	is the completion status of the operation.
!
!  IMPLICIT INPUTS:
!
!	none
!
!  IMPLICIT OUTPUTS:
!
!	none
!
!  COMPLETION STATUS:
!
!	The address of the allocated storage.
!
!  SIGNALLED STATUS:
!
!	This routine does not intercept signals sent by routines it calls.
!
!  SIDE EFFECTS:
!
!	VMS or XPORT may be called on to allocate more heap storage.
!
!--
BEGIN
    MAP
	SIZE_REQUEST	%BLISS32 (: LONG);

    OWN
	ANCHOR : VECTOR [2] INITIAL (0, 0);

    LITERAL
	INITIAL_HEAP_SIZE = 1^14;		! In bytes

    LOCAL
	CURRENT : REF VECTOR,		! address of the current block from which storage is allocated
	FIRST_FREE,				! index of the first free byte
	HEAP_SIZE;

    LOCAL
	SIZE,					! Local for size_request
	NODE,					! Return Value
	L : REF VECTOR;				!

%if %bliss (bliss36) %then
macro
LIB$GET_VM (				! Get virtual memory
		num_bytes,		! Bytes to alocate, by reference
		base_addr ) =		! First address allocated, by reference
($XPO_GET_MEM (UNITS = .num_bytes, RESULT = base_addr); 1) %;
%fi

    CURRENT = .ANCHOR [0];

    IF .CURRENT EQL NULL
    THEN
	IF .ANCHOR [1] LEQ 0
	THEN
	    BEGIN

	    ! Use default values

		HEAP_SIZE = INITIAL_HEAP_SIZE/2;
		FIRST_FREE = INITIAL_HEAP_SIZE
	    END
	ELSE
	    BEGIN
		HEAP_SIZE = .ANCHOR [1]/2;
		FIRST_FREE = .ANCHOR [1]
	    END

    ELSE
	BEGIN
	    HEAP_SIZE = .CURRENT [1];
	    FIRST_FREE = .ANCHOR [1]
	END;

    SIZE = .SIZE_REQUEST;
    DEB_ASSERT (.SIZE GEQ 0 AND .SIZE LSS .HEAP_SIZE, 'Invalid storage request');

    IF (.FIRST_FREE + .SIZE) GTR .HEAP_SIZE
    THEN
	BEGIN

	! We double the size of the heap to prevent fragmentation.

	HEAP_SIZE = .HEAP_SIZE*2;

	IF NOT LIB$GET_VM (HEAP_SIZE, L) THEN DEB_ASSERT (FALSE, 'Storage overflow');

	L [0] = .ANCHOR [0];			! Chain old one in
	ANCHOR [0] = .L;
	FIRST_FREE = 8;
	L [1] = .HEAP_SIZE
	END;

    NODE = .ANCHOR [0] + .FIRST_FREE;		! Location of allocated node
    ANCHOR [1] = .FIRST_FREE + .SIZE;
    CH$FILL (%X'00', .SIZE, .NODE);
    .NODE
END;						!End of UTL_GET

END
ELUDOM