	[ IDENT ('V04-000'),
{ ++
*****************************************************************************
**									    *
**  COPYRIGHT (c) 1978, 1980, 1982, 1984 BY				    *
**  DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS.		    *
**  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 WHICH IS NOT SUPPLIED BY DIGITAL.		    *
** 									    *
**									    *
*****************************************************************************





FACILITY:	VAX/VMS EDF (EDIT/FDL) UTILITY

ABSTRACT:	This facility is used to create, modify, and optimize
		FDL specification files.

ENVIRONMENT:	NATIVE/USER MODE

AUTHOR:		Ken F. Henderson Jr.

CREATION DATE:	27-Mar-1981

MODIFIED BY:

		V03-012 RRB0005		Rowland R. Bradley	16 Jan 1984
			Fix EDF$RESET_SCROLL to avoid overwriting the output 
			generated by a command procedure with SET VERIFY set.

		V03-011 RRB0004		Rowland R. Bradley	13 Jan 1984
			Fix MAX_FACTOR to prevent division by zero.

		V03-010	KFH0010		Ken Henderson		10 Sep 1983
			Support for named UICs.

		V03-009	KFH0009		Ken Henderson		 8 Aug 1983
			Changes for seperate compilation.

		V03-008	KFH0008		Ken Henderson		28 Jul 1983
			Added CALC_REC_OVERHEAD and CALC_BUC_OVERHEAD
			to centralize the arithmetic.
			Fixed EDF$LINE_PARSED to not invert the
			order of block comment lines.

		V03-007	KFH0007		Ken Henderson		26 Apr 1983
			Fix NUMBER_INPUT to set INPUT_VALUE
			and INPUT_NUMBER also. Modify
			SCAN_DEFINITION routine to accept
			FATAL parameter. Modify CURRENT_LT_TEST
			and CURRENT_GT_TEST routines to
			reverse precedence of SECONDARY
			and SECNUM
			- and make SEG_TYPE SECNUM = 7.

		V03-006	KFH0006		Ken Henderson		14 Apr 1983
			Added support for JOURNAL_ENABLED.
			Added MAX_FACTOR, DELETE_PRIMARY_SECTION
			routines.

		V03-005	KFH0005		Ken Henderson		31 Jan 1983
			Added XAB$C_BN8 and XAB$C_IN8 to
			EDF$LINE_PARSED. And changed the
			reference of FDL$TYPE to FDL3$TYPE.

		V03-004	KFH0004		Ken Henderson		11 Jan 1983
			Modified EDF$RESET_SCROLL to say
			"Created:" in reverse video.

		V03-003	KFH0003		Ken Henderson		8 Sept 1982
			Modified reference to some variables
			to fit with database reorganization.
			Also, modified call to ASK_RETURN.

		V03-002	KFH0002		Ken Henderson		2 April 1982
			Modified INSERT_IN_ORDER to not
			start at DEF_HEAD if it was already
			at the correct place.

		V03-001	KFH0001		Ken Henderson		23-Mar-1982
			Modified EDF$RESET_SCROLL to not
			reset the scrolling region unless
			it has been set.

-- }

ENVIRONMENT ('LIB$:EDFUTIL'),

INHERIT (

'SYS$LIBRARY:STARLET',
'SHRLIB$:FDLPARDEF',
'LIB$:EDFSDLMSG',
'LIB$:EDFSTRUCT',
'LIB$:EDFCONST',
'LIB$:EDFTYPE',
'LIB$:EDFVAR',
'LIB$:EDFEXTERN',
'LIB$:EDFCHF'

)]

MODULE EDFUTIL (INPUT,OUTPUT);

{ ++

NUM_LEN -- Calculate the field width of an integer.

This routine will return the number of characters an integer will take up
when printed.

CALLING SEQUENCE:

field-width	:= NUM_LEN (NUMBER);

INPUT PARAMETERS:

NUMBER

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

The field width

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] FUNCTION NUM_LEN (
		    NUMBER	: INTEGER
		    ) : INTEGER;

VAR
    TEST_VAR	: INTEGER;
    TEST_LEN	: INTEGER;

BEGIN

    IF NUMBER = 0 THEN

	{ +
	Just plug a width of 1 if the number is 0.
	- }
	NUM_LEN			:= 1

    ELSE

    BEGIN

	{ +
	Set the function value according to the magnitude of the number.
	- }
	TEST_VAR		:= 1000000000;
	TEST_LEN		:= 10;
    
	REPEAT
    
	    IF ABS (NUMBER) < TEST_VAR THEN
    
		TEST_LEN	:= TEST_LEN - 1;
    
	    TEST_VAR		:= TEST_VAR DIV 10;
    
	UNTIL ABS (NUMBER) >= TEST_VAR;
    
	{ +
	Allow for a - sign if negative.
	- }
	IF NUMBER < 0 THEN
    
	    TEST_LEN		:= TEST_LEN + 1;

	{ +
	Now stuff the function value.
	- }
	NUM_LEN			:= TEST_LEN;
    
    END;	{ IF FALSE NUMBER = 0 }

END;	{ NUM_LEN }

{ ++

MAX_FACTOR -- Produce a number that's a multiple of another.

This function will return the number that's a multiple of one of the
arguments, as long as it doesn't go over a maximum.

CALLING SEQUENCE:

NEWVALUE := MAX_FACTOR (BASE,VALUE,MAX);

INPUT PARAMETERS:

BASE
VALUE
MAX

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

The number (greater or equal to VALUE) that's a multiple of BASE,
unless that number would be greater than MAX - in which case it is MAX.

SIGNALS:

none

SIDE EFFECTS:

none

-- }

FUNCTION MAX_FACTOR (
		    BASE	: INTEGER;
		    VALUE	: INTEGER;
		    MAX		: INTEGER
		    ) : INTEGER;

VAR
    TEMP	: INTEGER;

BEGIN

    IF (VALUE < BASE) OR (BASE = 0) THEN

	TEMP	:= BASE

    ELSE

    BEGIN

	TEMP	:= VALUE DIV BASE;

	IF ((VALUE MOD BASE) <> 0) THEN

	    TEMP	:= TEMP + 1;

	TEMP	:= TEMP * BASE;

    END;

    IF TEMP > MAX THEN

	TEMP	:= MAX;

    MAX_FACTOR	:= TEMP;

END;	{ MAX_FACTOR }

{ ++

CALC_REC_OVERHEAD -- Do the arithmetic to figure out overheads.

This function will return the RECORD overhead for a given setup.

CALLING SEQUENCE:

RECORD_OVERHEAD := CALC_REC_OVERHEAD (INDEX_LEVEL);

INPUT PARAMETERS:

INDEX_LEVEL

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

The overhead, according to the RMS structure constants.

SIGNALS:

none

SIDE EFFECTS:

none

-- }

FUNCTION CALC_REC_OVERHEAD (
		    INDEX_LEVEL	: INTEGER
		    ) : INTEGER;

VAR
    RECORD_OVERHEAD : INTEGER;

BEGIN

    RECORD_OVERHEAD	:= 0;

    { +
    SIDR BUCKET
    - }
    IF (IDATA[EDF$K_ACTIVE_KEY] <> 0) AND (INDEX_LEVEL = 0) THEN

	RECORD_OVERHEAD	:= RECORD_OVERHEAD + IRC$C_SDROVHSZ3 + IRC$C_RRVOVHSZ3;

    { +
    ACCOUNT FOR KEY COMPRESSION
    - }
    IF (
    (BDATA[EDF$K_KEY_COMP_WANTED] AND (INDEX_LEVEL = 0))
    OR
    (BDATA[EDF$K_IDX_COMP_WANTED] AND (INDEX_LEVEL <> 0))
    ) THEN

	RECORD_OVERHEAD	:= RECORD_OVERHEAD + IRC$C_KEYCMPOVH;

    { +
    INDEX BUCKETS
    - }
    IF INDEX_LEVEL <> 0 THEN

	RECORD_OVERHEAD	:= RECORD_OVERHEAD + IRC$C_MAXVBNSZ;

    { +
    PRIMARY KEY DATA BUCKETS
    - }
    IF (IDATA[EDF$K_ACTIVE_KEY] = 0) AND (INDEX_LEVEL = 0) THEN

	BEGIN

	IF VARIABLE_RECORDS THEN

	    RECORD_OVERHEAD	:= RECORD_OVERHEAD + IRC$C_VAROVHSZ3

	ELSE

	    RECORD_OVERHEAD	:= RECORD_OVERHEAD + IRC$C_FIXOVHSZ3;

	IF BDATA[EDF$K_REC_COMP_WANTED] THEN

	    RECORD_OVERHEAD	:= RECORD_OVERHEAD + IRC$C_DATCMPOVH;

	IF BDATA[EDF$K_KEY_COMP_WANTED] OR BDATA[EDF$K_REC_COMP_WANTED] THEN

	    RECORD_OVERHEAD	:= RECORD_OVERHEAD + IDATA[EDF$K_KEY_SIZE];

	END;

    CALC_REC_OVERHEAD	:= RECORD_OVERHEAD;

END;	{ CALC_REC_OVERHEAD }

{ ++

CALC_BUC_OVERHEAD -- Do the arithmetic to figure out overheads.

This function will return the BUCKET overhead for a given setup.

CALLING SEQUENCE:

BUCKET_OVERHEAD := CALC_BUC_OVERHEAD (INDEX_LEVEL);

INPUT PARAMETERS:

INDEX_LEVEL

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

The overhead, according to the RMS structure constants.

SIGNALS:

none

SIDE EFFECTS:

none

-- }

FUNCTION CALC_BUC_OVERHEAD (
		    INDEX_LEVEL	: INTEGER
		    ) : INTEGER;

BEGIN

    IF INDEX_LEVEL = 0 THEN

	CALC_BUC_OVERHEAD	:= BKT$C_OVERHDSZ + BKT$C_DATBKTOVH

    ELSE

	CALC_BUC_OVERHEAD	:= BKT$C_OVERHDSZ + BKT$C_ENDOVHD;
    
END;	{ CALC_BUC_OVERHEAD }

{ ++

EDF$RESET_SCROLL -- Reset an ANSI terminal's scroll region.

This routine will put the scroll region back to full screen.
It also clears graphics mode.
It is a Global routine, which is called by the exit handler as well.

CALLING SEQUENCE:

EDF$RESET_SCROLL;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

LINE_ONE
LINES_PER_PAGE

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

SYS$OUTPUT: - the scroll region is reset, and possibly graphics mode reset

ROUTINES CALLED:

LIB$SET_SCROLL

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS,GLOBAL] PROCEDURE EDF$RESET_SCROLL;

BEGIN

    IF NOT AUTO_TUNE THEN

    BEGIN

	{ +
	Clear graphics mode if this is a Regis device.
	- }
	IF REGIS THEN

	BEGIN

	    CHFFLAGS	:= 0;
	    WRITEV (OUT_LINE,''(27)'\');
	    LIB$PUT_LINE (OUT_LINE,ONE,CHFFLAGS);

	END;

	{ +
	Now make the scroll region from top to bottom - if it was ever set.
	- }
	IF SCROLLING_SET THEN

	    LIB$SET_SCROLL (LINE_ONE,LINES_PER_PAGE);

    END;	{ IF NOT AUTO_TUNE }

    { +
    Announce that the file has been created.
    - }
    IF (
    (FILE_CREATED)
    AND
    (RES_OUTPUT_FILENAME_DESC.DSC$W_LENGTH > 0)
    ) THEN

    BEGIN

	CHFFLAGS	:= SCR$M_REVERSE;
	WRITEV (OUT_LINE,CRLF,
RES_OUTPUT_FILENAME_DESC.DSC$A_POINTER^:RES_OUTPUT_FILENAME_DESC.DSC$W_LENGTH,
'  ',LINES_SHOWN:NUM_LEN(LINES_SHOWN),' lines');
	LIB$PUT_LINE (OUT_LINE,ONE,CHFFLAGS);

    END;

END;	{ EDF$RESET_SCROLL }

{ ++

CLEAR -- Clear a designated area of the screen.

This routine clears a specific area on the screen and leaves the cursor there.
It bypasses screwing up non-CRT terminals.

CALLING SEQUENCE:

CLEAR (DESTINATION);

INPUT PARAMETERS:

DESTINATION

IMPLICIT INPUTS:

PROMPT_LINE
LINE_ONE

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

SYS$OUTPUT:

ROUTINES CALLED:

LIB$ERASE_PAGE
LIB$ERASE_LINE

ROUTINE VALUE:

none

SIGNALS:


SIDE EFFECTS:

The selected lines on the screen are cleared (unless hardcopy).

-- }

PROCEDURE CLEAR (
		DESTINATION : INTEGER
		);

BEGIN

    { +
    All this stuff affects only video terminals.
    - }
    IF (
    (VIDEO_TERMINAL)
    AND
    (NOT AUTO_TUNE)
    ) THEN

    BEGIN

	CASE DESTINATION OF
    
	    SCREEN :

		BEGIN

		    { +
		    The following sequence of junk to the screen
		    is overkill to make sure the titles don't
		    jump around. (interaction of Pascal I/O and
		    screen package I/O...)
		    - }
		    IF REGIS THEN
		
			WRITELN (''(27)'Pp;S(E);'(27)'\');

		    LIB$ERASE_PAGE (LINE_ONE,COL_ONE);
		    WRITELN (' ');
		    LIB$SET_CURSOR (LINE_ONE,COL_ONE);

		END;	{ SCREEN }

	    LOWER_AREA :

	    BEGIN

		IF REGIS THEN

		BEGIN

		    WRITELN (
		    ''(27)'PpP[27,320];V(W(I0,S1,E,S[,479]))[+767];'(27)'\');

		    LIB$SET_CURSOR (PROMPT_LINE,COL_ONE);

		END

		ELSE

		    LIB$ERASE_PAGE (LOWER_LINE,COL_ONE);

	    END;

	    IF_FULL_PROMPT :	IF FULL_PROMPT OR TEMP_FULL_PROMPT THEN

		BEGIN

		    IF TEMP_FULL_PROMPT THEN

			LIB$WAIT (1.3);

		    { +
		    The following sequence of junk to the screen
		    is overkill to make sure the titles don't
		    jump around. (interaction of Pascal I/O and
		    screen package I/O...)
		    - }

		    IF REGIS THEN

			WRITELN (''(27)'Pp;S(E);'(27)'\');

		    LIB$ERASE_PAGE (LINE_ONE,COL_ONE);
		    WRITELN (' ');
		    LIB$SET_CURSOR (LINE_ONE,COL_ONE);

		END;	{ IF_FULL_PROMPT }

	    PAUSE :		QUERY (EDF$K_RETURN);

	OTHERWISE
    
	    { NULL-STATMENT } ;
    
	END;		{ CASE }

    END;	{ IF VIDEO_TERMINAL AND NOT AUTO_TUNE }
	    
END;	{ CLEAR }

{ ++

CVT_QUAD_DESC -- Routine to convert a quadword to a descriptor.

This routine will take 2 longword arguments and stuff them into a descriptor.

CALLING SEQUENCE:

DESCRIPTOR_VAR	:= CVT_QUAD_DESC (LONG1,LONG2);

INPUT PARAMETERS:

LONG1
LONG2

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

DESCRIPTOR_VAR

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] FUNCTION CVT_QUAD_DESC (LONG1,LONG2 : LONG) : DESCRIPTOR;

BEGIN

    WITH QUAD_DESC DO

    BEGIN

	{ +
	Select the quadword type variant and stuff it.
	- }
	QWHICH			:= QWORD;
	TWOLONG.L1		:= LONG1;
	TWOLONG.L2		:= LONG2;

	{ +
	Now select the descriptor type variant and get it.
	- }
	QWHICH			:= DWORD;
	CVT_QUAD_DESC		:= DSC;

    END;

END;	{ CVT_QUAD_DESC }

{ ++

SCAN_DEFINITION -- Search for area and key primaries in the current definition
and log them.

CALLING SEQUENCE:

SCAN_DEFINITION (FATAL);

INPUT PARAMETERS:

FATAL

IMPLICIT INPUTS:

DEF_CURRENT

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

LOW_AREA
HIGH_AREA
LOW_KEY
HIGH_KEY
FOUND_0
FOUND_AREA
FOUND_KEY

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

PROCEDURE SCAN_DEFINITION (FATAL : BOOLEAN);

BEGIN

    { +
    Find out the range of existing keys (assume contiguous).
    - }
    DEF_CURRENT		:= DEF_HEAD;
    FOUND_0		:= FALSE;
    FOUND_AREA		:= FALSE;
    FOUND_KEY		:= FALSE;
    LOW_AREA		:= 0;
    HIGH_AREA		:= 0;
    LOW_KEY		:= 0;
    HIGH_KEY		:= 0;

    REPEAT

	WITH DEF_CURRENT^ DO

	BEGIN

	    IF (
	    (OBJECT_TYPE = PRI)
	    AND
	    (PRIMARY = KEY)
	    ) THEN

	    BEGIN

		IF PRINUM = 0 THEN

		    FOUND_0	:= TRUE;

		FOUND_KEY	:= TRUE;

		IF PRINUM < LOW_KEY THEN

		    LOW_KEY	:= PRINUM;

		IF PRINUM > HIGH_KEY THEN

		    HIGH_KEY	:= PRINUM;

	    END;

	    IF (
	    (OBJECT_TYPE = PRI)
	    AND
	    (PRIMARY = AREA)
	    ) THEN

	    BEGIN

		FOUND_AREA	:= TRUE;

		IF PRINUM < LOW_AREA THEN

		    LOW_AREA	:= PRINUM;

		IF PRINUM > HIGH_AREA THEN

		    HIGH_AREA	:= PRINUM;

	    END;

	END;	{ WITH DEF_CURRENT^ DO }

	DEF_CURRENT	:= DEF_CURRENT^.FORE;

    UNTIL DEF_CURRENT = NIL;

    IF (
    ((FATAL) OR (HIGH_KEY <> 0))
    AND
    (NOT FOUND_0)
    ) THEN

    BEGIN

	WRITELN (SHIFT,ANSI_REVERSE,
	' There is no Primary Key in the Current Definition. ',
	ANSI_RESET);

	IF AUTO_TUNE THEN

	    LIB$STOP (EDF$_INSFANL,0,0,0)

	ELSE

	BEGIN

	    LIB$WAIT (3.0);
	    LIB$SIGNAL (EDF$_CTRLZ,0,0,0);

	END;

    END;

END;	{ SCAN_DEFINITION }

{ ++

PARSE_INPUT -- Routine to parse input string.

This routine will look at the chosen LIB$TPARSE table.

CALLING SEQUENCE:

PARSE_INPUT (KEY_TABLE_PTR,STATE_TABLE_PTR,DEFAULT_OK,DEFAULT_VALUE);

INPUT PARAMETERS:

KEY_TABLE_PTR
STATE_TABLE_PTR

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

INPUT_VALUE

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

PROCEDURE PARSE_INPUT (
    			KEY_TABLE	: INTEGER;
    			STATE_TABLE	: INTEGER;
			DEFAULT_OK	: BOOLEAN;
			DEFAULT_VALUE	: INTEGER
    			);

BEGIN

    { +
    Get the input from the terminal.
    - }
    INPUT_DESC	:= NULL_STRING;

    { +
    If auto answers are enabled and this question has a default - use it.
    - }
    IF (
    (
    (TAKE_DEFAULTS)
    AND
    (IDATA[EDF$K_RESPONSES] = EDF$K_AUTO)
    AND
    (DEFAULT_OK)
    AND
    (NOT (QTAB_OFFSET = EDF$K_RETURN))
    )
    OR
    (AUTO_TUNE)
    ) THEN

    BEGIN

	IF NOT AUTO_TUNE THEN

	BEGIN

	    WRITELN (CRLF);
	    LIB$WAIT (0.7);

	END;

    END

    ELSE

    BEGIN

	IF EOF (INPUT) THEN

	BEGIN

	    RESET (INPUT);
	    LIB$SIGNAL (EDF$_CTRLZ,0,0,0);

	END;

	READLN (INPUT_STRING);
	WRITELN (CRLF);
	STR$TRIM (INPUT_DESC,INPUT_STRING);
	STR$UPCASE (INPUT_DESC,INPUT_DESC);

    END;

    { +
    If we're journaling our input, save a copy of it to the
    journal file.
    - }
    IF JOURNAL_ENABLED THEN

	IF INPUT_DESC.DSC$W_LENGTH > 0 THEN

	    WRITELN (
		JOURNAL_FILE,
		INPUT_DESC.DSC$A_POINTER^:INPUT_DESC.DSC$W_LENGTH
		)

	ELSE

	    WRITELN (JOURNAL_FILE);

    { +
    See if the answer was defaulted, and if it's allowed to be.
    - }
    IF INPUT_DESC.DSC$W_LENGTH = 0 THEN

	IF DEFAULT_OK THEN

	    INPUT_VALUE		:= DEFAULT_VALUE

	ELSE

	BEGIN

	    LIB$SIGNAL (EDF$_NODEFAULT,0,0,0);

	END

    ELSE

    BEGIN

	{ +
	See if it's valid and get it's value.
	- }
	PARAM_BLOCK.TPA$L_STRINGPTR	:= INPUT_DESC.DSC$A_POINTER::UNSIGNED;
	PARAM_BLOCK.TPA$L_STRINGCNT	:= INPUT_DESC.DSC$W_LENGTH;

	ISTATUS	:= LIB$TPARSE (
				PARAM_BLOCK,
				STATE_TABLE,
				KEY_TABLE
				);

	INPUT_VALUE	:= PARAM_BLOCK.TPA$L_PARAM::LONG;
	INPUT_NUMBER	:= PARAM_BLOCK.TPA$L_NUMBER::LONG;

	{ +
	Even Istatus (low bit clear) means failure.
	- }
	IF NOT ODD (ISTATUS) THEN

	BEGIN

	    IF PARAM_BLOCK.TPA$V_AMBIG THEN

		LIB$SIGNAL (EDF$_AMBIG,0,0,0)

	    ELSE

		LIB$SIGNAL (EDF$_BADSYNTAX,0,0,0);

	END;

    END;    { IF NOT INPUT_DESC.DSC$W_LENGTH = 0 }

END;	{ PARSE_INPUT }

{ ++

NUMBER_INPUT -- Routine to get a number from the input string.

This routine will return the integer typed.

CALLING SEQUENCE:

NUMBER_INPUT (NUM_VALUE,DEFAULT_OK,DEFAULT_VALUE);

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

NUM_VALUE

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

PROCEDURE NUMBER_INPUT (
    			VAR NUM_VALUE	: INTEGER;
			DEFAULT_OK	: BOOLEAN;
			DEFAULT_VALUE	: INTEGER
    			);

BEGIN

    { +
    Get the input from the terminal.
    - }
    INPUT_DESC	:= NULL_STRING;

    { +
    If auto answers are enabled and this question has a default - use it.
    - }
    IF (
    (
    (TAKE_DEFAULTS)
    AND
    (IDATA[EDF$K_RESPONSES] = EDF$K_AUTO)
    AND
    (DEFAULT_OK)
    )
    OR
    (AUTO_TUNE)
    ) THEN

    BEGIN

	IF NOT AUTO_TUNE THEN

	BEGIN

	    WRITELN (CRLF);
	    LIB$WAIT (0.7);

	END;

    END

    ELSE

    BEGIN

	IF EOF (INPUT) THEN

	BEGIN

	    RESET (INPUT);
	    LIB$SIGNAL (EDF$_CTRLZ,0,0,0);

	END;

	READLN (INPUT_STRING);
	WRITELN (CRLF);
	STR$TRIM (INPUT_DESC,INPUT_STRING);
	STR$UPCASE (INPUT_DESC,INPUT_DESC);
	PARAM_BLOCK.TPA$L_TOKENPTR	:= INPUT_DESC.DSC$A_POINTER::UNSIGNED;
	PARAM_BLOCK.TPA$L_TOKENCNT	:= INPUT_DESC.DSC$W_LENGTH;

    END;

    { +
    If we're journaling our input, save a copy of it to the
    journal file.
    - }
    IF JOURNAL_ENABLED THEN

	IF INPUT_DESC.DSC$W_LENGTH > 0 THEN

	    WRITELN (
		JOURNAL_FILE,
		INPUT_DESC.DSC$A_POINTER^:INPUT_DESC.DSC$W_LENGTH
		)

	ELSE

	    WRITELN (JOURNAL_FILE);

    { +
    See if the answer was defaulted, and if it's allowed to be.
    - }
    IF INPUT_DESC.DSC$W_LENGTH = 0 THEN

	IF DEFAULT_OK THEN

	    NUM_VALUE		:= DEFAULT_VALUE

	ELSE

	BEGIN

	    LIB$SIGNAL (EDF$_NODEFAULT,0,0,0);

	END

    ELSE

    BEGIN

	{ +
	Convert it to an integer.
	- }
	ISTATUS	:= OTS$CVT_TI_L (INPUT_DESC,NUM_VALUE);
    
	{ +
	Even Istatus (low bit clear) means failure.
	- }
	IF NOT ODD (ISTATUS) THEN
    
	BEGIN
    
	    LIB$SIGNAL (EDF$_BADSYNTAX,0,0,0);
    
	END;
    
    END;    { IF NOT INPUT_DESC.DSC$W_LENGTH = 0 }

    INPUT_VALUE		:= NUM_VALUE;
    INPUT_NUMBER	:= NUM_VALUE;

END;	{ NUMBER_INPUT }

{ ++

MAKE_SCRATCH -- Create a new peice of dynamic memory and init it.

This routine creates a new Line_object, and inits its various fields.

CALLING SEQUENCE:

MAKE_SCRATCH;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

LINE_OBJECT_TEMPLATE

OUTPUT PARAMETERS:

DEF_SCRATCH

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] PROCEDURE MAKE_SCRATCH;

BEGIN

    { +
    Allocate some dynamic memory.
    - }
    NEW (DEF_SCRATCH);

    { +
    Copy over the template.
    - }
    DEF_SCRATCH^	:= LINE_OBJECT_TEMPLATE;

END;	{ MAKE_SCRATCH }

{ ++

CURRENT_GT_TEST -- Compare def_current with test.

This function has the boolean value of the whether or not DEF_CURRENT is
greater than TEST.

CALLING SEQUENCE:

test-val	:= CURRENT_GT_TEST (TEST,SCOPE);

INPUT PARAMETERS:

SCOPE

IMPLICIT INPUTS:

DEF_CURRENT

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

True if DEF_CURRENT > TEST, false if not.

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] FUNCTION CURRENT_GT_TEST (
			    TEST		: LINE_OBJECT;
			    EXACT_COMPARISON	: BOOLEAN
			    ) : BOOLEAN;

BEGIN

    CURRENT_GT_TEST	:= FALSE;

    { +
    Just do a boolean assignment.
    - }
    IF EXACT_COMPARISON THEN

    BEGIN

	IF
	(PRI_SEQ[DEF_CURRENT^.PRIMARY] > PRI_SEQ[TEST.PRIMARY])
	THEN

	    CURRENT_GT_TEST	:= TRUE;

	IF
	(PRI_SEQ[DEF_CURRENT^.PRIMARY] = PRI_SEQ[TEST.PRIMARY])
	AND
	(DEF_CURRENT^.PRINUM > TEST.PRINUM)
	THEN

	    CURRENT_GT_TEST	:= TRUE;

	IF
	(PRI_SEQ[DEF_CURRENT^.PRIMARY] = PRI_SEQ[TEST.PRIMARY])
	AND
	(DEF_CURRENT^.PRINUM = TEST.PRINUM)
	AND
	(DEF_CURRENT^.SECNUM > TEST.SECNUM)
	THEN

	    CURRENT_GT_TEST	:= TRUE;

	IF
	(PRI_SEQ[DEF_CURRENT^.PRIMARY] = PRI_SEQ[TEST.PRIMARY])
	AND
	(DEF_CURRENT^.PRINUM = TEST.PRINUM)
	AND
	(DEF_CURRENT^.SECNUM = TEST.SECNUM)
	AND
	(DEF_CURRENT^.SECONDARY > TEST.SECONDARY)
	THEN

	    CURRENT_GT_TEST	:= TRUE;

    END

    ELSE

    BEGIN

	IF(
	PRI_SEQ[DEF_CURRENT^.PRIMARY] > PRI_SEQ[TEST.PRIMARY])
	THEN

	    CURRENT_GT_TEST	:= TRUE;

	IF
	(PRI_SEQ[DEF_CURRENT^.PRIMARY] = PRI_SEQ[TEST.PRIMARY])
	AND
	(DEF_CURRENT^.PRINUM > TEST.PRINUM)
	THEN

	    CURRENT_GT_TEST	:= TRUE;

    END;

END;	{ CURRENT_GT_TEST }

{ ++

CURRENT_LT_TEST -- Compare def_current and test.

This function has the boolean value of the whether or not TEST greater than
DEF_CURRENT.

CALLING SEQUENCE:

test-val	:= CURRENT_LT_TEST (TEST,SCOPE);

INPUT PARAMETERS:

TEST

IMPLICIT INPUTS:

DEF_CURRENT

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

True if DEF_CURRENT < TEST, false if not.

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] FUNCTION CURRENT_LT_TEST (
			    TEST		: LINE_OBJECT;
			    EXACT_COMPARISON	: BOOLEAN
			    ) : BOOLEAN;

BEGIN

    CURRENT_LT_TEST	:= FALSE;

    { +
    Just do a boolean assignment.
    - }
    IF EXACT_COMPARISON THEN

    BEGIN

	IF(
	PRI_SEQ[DEF_CURRENT^.PRIMARY] < PRI_SEQ[TEST.PRIMARY])
	THEN

	    CURRENT_LT_TEST	:= TRUE;

	IF
	(PRI_SEQ[DEF_CURRENT^.PRIMARY] = PRI_SEQ[TEST.PRIMARY])
	AND
	(DEF_CURRENT^.PRINUM < TEST.PRINUM)
	THEN

	    CURRENT_LT_TEST	:= TRUE;

	IF
	(PRI_SEQ[DEF_CURRENT^.PRIMARY] = PRI_SEQ[TEST.PRIMARY])
	AND
	(DEF_CURRENT^.PRINUM = TEST.PRINUM)
	AND
	(DEF_CURRENT^.SECNUM < TEST.SECNUM)
	THEN

	    CURRENT_LT_TEST	:= TRUE;

	IF
	(PRI_SEQ[DEF_CURRENT^.PRIMARY] = PRI_SEQ[TEST.PRIMARY])
	AND
	(DEF_CURRENT^.PRINUM = TEST.PRINUM)
	AND
	(DEF_CURRENT^.SECNUM = TEST.SECNUM)
	AND
	(DEF_CURRENT^.SECONDARY < TEST.SECONDARY)
	THEN

	    CURRENT_LT_TEST	:= TRUE;

    END

    ELSE

    BEGIN

	IF(
	PRI_SEQ[DEF_CURRENT^.PRIMARY] < PRI_SEQ[TEST.PRIMARY])
	THEN

	    CURRENT_LT_TEST	:= TRUE;

	IF
	(PRI_SEQ[DEF_CURRENT^.PRIMARY] = PRI_SEQ[TEST.PRIMARY])
	AND
	(DEF_CURRENT^.PRINUM < TEST.PRINUM)
	THEN

	    CURRENT_LT_TEST	:= TRUE;

    END;

END;	{ CURRENT_LT_TEST }

{ ++

CURRENT_EQ_TEST -- Compare def_current and test.

This function has the boolean value of the whether or not TEST is the
same as DEF_CURRENT.

CALLING SEQUENCE:

test-val	:= CURRENT_EQ_TEST (TEST,SCOPE);

INPUT PARAMETERS:

SCOPE

IMPLICIT INPUTS:

DEF_CURRENT

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

True if DEF_CURRENT = TEST, false if not.

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] FUNCTION CURRENT_EQ_TEST (
			    TEST		: LINE_OBJECT;
			    EXACT_COMPARISON	: BOOLEAN
			    ) : BOOLEAN;

BEGIN

    { +
    Just do a boolean assignment.
    - }
    IF EXACT_COMPARISON THEN

	CURRENT_EQ_TEST	:= (

	(TEST.OBJECT_TYPE = DEF_CURRENT^.OBJECT_TYPE)
	AND
	(TEST.PRIMARY = DEF_CURRENT^.PRIMARY)
	AND
	(TEST.PRINUM = DEF_CURRENT^.PRINUM)
	AND
	(TEST.SECONDARY = DEF_CURRENT^.SECONDARY)
	AND
	(TEST.SECNUM = DEF_CURRENT^.SECNUM)

	)

    ELSE

	CURRENT_EQ_TEST	:= (

	(TEST.PRIMARY = DEF_CURRENT^.PRIMARY)
	AND
	(TEST.PRINUM = DEF_CURRENT^.PRINUM)

	);

END;	{ CURRENT_EQ_TEST }

{ ++

INSERT_BEFORE_CURRENT -- Link the DEF_SCRATCH line_object into the list.

This routine adds DEF_SCRATCH into the list just before DEF_CURRENT.

CALLING SEQUENCE:

INSERT_BEFORE_CURRENT;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

DEF_SCRATCH
DEF_CURRENT
DEF_HEAD

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] PROCEDURE INSERT_BEFORE_CURRENT;

BEGIN

    { +
    Make it the new head, if we're adding it before the old head.
    - }
    IF DEF_CURRENT = DEF_HEAD THEN

	DEF_HEAD	:= DEF_SCRATCH;

    { +
    Update the fore and back pointers.
    - }
    DEF_PRED		:= DEF_CURRENT^.BACK;
    DEF_SCRATCH^.FORE	:= DEF_CURRENT;
    DEF_SCRATCH^.BACK	:= DEF_PRED;

    IF DEF_PRED <> NIL THEN

	DEF_PRED^.FORE	:= DEF_SCRATCH;

    DEF_CURRENT^.BACK	:= DEF_SCRATCH;

    { +
    Leave looking at the just inserted line_object.
    - }
    DEF_CURRENT		:= DEF_SCRATCH;

END;	{ INSERT_BEFORE_CURRENT }

{ ++

INSERT_AT_CURRENT -- Link the DEF_SCRATCH line_object into the list.

This routine adds DEF_SCRATCH into the list at DEF_CURRENT.

CALLING SEQUENCE:

INSERT_AT_CURRENT;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

DEF_SCRATCH
DEF_CURRENT
DEF_HEAD

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] PROCEDURE INSERT_AT_CURRENT;

BEGIN

    { +
    Make new head or tail, if we're replacing this one.
    - }
    IF DEF_CURRENT = DEF_HEAD THEN

	DEF_HEAD	:= DEF_SCRATCH;

    IF DEF_CURRENT = DEF_TAIL THEN

	DEF_TAIL	:= DEF_SCRATCH;

    { +
    Substitute the links to def_current with links to def_scratch.
    - }
    DEF_PRED		:= DEF_CURRENT^.BACK;
    DEF_SUCC		:= DEF_CURRENT^.FORE;
    DEF_SCRATCH^.FORE	:= DEF_CURRENT^.FORE;
    DEF_SCRATCH^.BACK	:= DEF_CURRENT^.BACK;

    IF DEF_PRED <> NIL THEN

	DEF_PRED^.FORE	:= DEF_SCRATCH;

    IF DEF_SUCC <> NIL THEN

	DEF_SUCC^.BACK	:= DEF_SCRATCH;

    { +
    Get rid of the old def_current, and point def_current to the new king.
    - }
    DISPOSE (DEF_CURRENT);

    DEF_CURRENT		:= DEF_SCRATCH;

END;	{ INSERT_AT_CURRENT }

{ ++

INSERT_AFTER_CURRENT -- Link the DEF_SCRATCH line_object into the list.

This routine adds DEF_SCRATCH to the list after DEF_CURRENT.

CALLING SEQUENCE:

INSERT_AFTER_CURRENT;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

DEF_CURRENT
DEF_SCRATCH
DEF_TAIL

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] PROCEDURE INSERT_AFTER_CURRENT;

BEGIN

    { +
    Make it the new tail if we're adding it after the old tail.
    - }
    IF DEF_CURRENT = DEF_TAIL THEN

	DEF_TAIL	:= DEF_SCRATCH;

    { +
    Update the fore and back pointers.
    - }
    DEF_SUCC		:= DEF_CURRENT^.FORE;
    DEF_SCRATCH^.FORE	:= DEF_SUCC;
    DEF_SCRATCH^.BACK	:= DEF_CURRENT;
    DEF_CURRENT^.FORE	:= DEF_SCRATCH;

    IF DEF_SUCC <> NIL THEN

	DEF_SUCC^.BACK	:= DEF_SCRATCH;

    { +
    Leave looking at the just inserted line_object.
    - }
    DEF_CURRENT		:= DEF_SCRATCH;

END;	{ INSERT_AFTER_CURRENT }

{ ++

INCR_CURRENT -- Bump DEF_CURRENT pointer one.

This routine makes DEF_CURRENT point to the next line_object in the list,
as long as it won't fall off the end.

CALLING SEQUENCE:

INCR_CURRENT;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

DEF_CURRENT

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

LIB$SIGNAL

ROUTINE VALUE:

none

SIGNALS:


SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] PROCEDURE INCR_CURRENT;

BEGIN

    { +
    .FORE points to the next line_object in the list.
    - }
    IF DEF_CURRENT <> NIL THEN

	DEF_CURRENT	:= DEF_CURRENT^.FORE;

END;	{ INCR_CURRENT }

{ ++

DECR_CURRENT -- Bump back the DEF_CURRENT pointer one.

This routine points DEF_CURRENT to the previous line_object in the list,
as long as it won't run off the end.

CALLING SEQUENCE:

DECR_CURRENT;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

DEF_CURRENT

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

LIB$SIGNAL

ROUTINE VALUE:

none

SIGNALS:


SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] PROCEDURE DECR_CURRENT;

BEGIN

    { +
    .BACK points to the previous line_object in the list.
    - }
    IF DEF_CURRENT <> NIL THEN

	DEF_CURRENT	:= DEF_CURRENT^.BACK;

END;	{ DECR_CURRENT }

{ ++

NEW_IDENT_LINE -- Make a new Ident and stuff it into the definition.

This routine gets the date and time from the system and makes a new Ident
Line_object, and puts it into the definition linked list.

IT ASSUMES THAT THE LIST IS COMPLETELY EMPTY!!!

CALLING SEQUENCE:

NEW_IDENT_LINE;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

DEF_SCRATCH
IDENT_STRING

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

DEF_SCRATCH
DEF_HEAD
DEF_TAIL
DEF_CURRENT

ROUTINES CALLED:

LIB$DATE_TIME
MAKE_SCRATCH

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

PROCEDURE NEW_IDENT_LINE;

VAR
    DATE_STRING	: STRING20;
    I		: INTEGER;

BEGIN

    { +
    Create a place for the Ident to go.
    - }
    MAKE_SCRATCH;

    { +
    Get system date and time to put into IDENT line.
    - }
    LIB$DATE_TIME (DATE_STRING);

    { +
    Now, copy it into the ident string.
    - }
    FOR I := 1 TO 20 DO

	IDENT_STRING[I]		:= DATE_STRING[I];

    { +
    Put an IDENT primary at the head of the linked list.
    - }
    WITH DEF_SCRATCH^ DO

    BEGIN

	TEMP_DESCRIPTOR			:= NULL_STRING;
	NEW (TEMP_DESCRIPTOR.DSC$A_POINTER);

	TEMP_DESCRIPTOR.DSC$W_LENGTH	:= IDENT_STRING_LENGTH;
	OBJECT_TYPE			:= PRI;
	PRIMARY				:= IDENT;

	FOR I := 1 TO IDENT_STRING_LENGTH DO

	    TEMP_DESCRIPTOR.DSC$A_POINTER^[I]	:= IDENT_STRING[I];

	LIB$SCOPY_DXDX (TEMP_DESCRIPTOR,STRING);
	DISPOSE (TEMP_DESCRIPTOR.DSC$A_POINTER);

    END;	{ WITH DEF_SCRATCH^ }

    { +
    Make the just created line_object the head (and only) one
    - }
    DEF_CURRENT		:= DEF_SCRATCH;
    DEF_HEAD		:= DEF_SCRATCH;
    DEF_TAIL		:= DEF_SCRATCH;

END;	{ NEW_IDENT_LINE }

{ ++

DELETE_CURRENT -- Unlink DEF_CURRENT from the list and kill it.

This routine removes the line_object pointed to by DEF_CURRENT from the list.

CALLING SEQUENCE:

DELETE_CURRENT;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

DEF_CURRENT
DEF_TAIL
DEF_HEAD

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

DEF_CURRENT
DEF_TAIL
DEF_HEAD

ROUTINES CALLED:

EXTRACT_CURRENT

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

PROCEDURE DELETE_CURRENT;

BEGIN

    IF DEF_CURRENT^.PRIMARY = TITLE THEN

    BEGIN

	{ +
	TITLE is always the very 1st line_object in the list.
	- }
	IF DEF_CURRENT^.FORE = NIL THEN

	BEGIN

	    DISPOSE (DEF_CURRENT);
	    NEW_IDENT_LINE;

	END	{ IF TRUE DEF_CURRENT^.FORE = NIL }

	ELSE

	BEGIN

	    DEF_HEAD		:= DEF_CURRENT^.FORE;
	    DEF_HEAD^.BACK	:= NIL;
	    DISPOSE (DEF_CURRENT);
	    DEF_CURRENT		:= DEF_HEAD;

	END;	{ IF FALSE DEF_CURRENT^.FORE = NIL }

    END		{ IF TRUE DEF_CURRENT^.PRIMARY = TITLE }

    ELSE

    BEGIN

    { +
    Make new tail, if we're deleting old tail.
    - }
    IF (DEF_CURRENT <> NIL) AND (DEF_CURRENT = DEF_TAIL) THEN

	DEF_TAIL	:= DEF_CURRENT^.BACK;

    { +
    Make new head, if we're deleting old head.
    - }
    IF (DEF_CURRENT <> NIL) AND (DEF_CURRENT = DEF_HEAD) THEN

	DEF_HEAD	:= DEF_CURRENT^.FORE;

    { +
    Update fore and back pointers.
    - }
    DEF_PRED		:= DEF_CURRENT^.BACK;
    DEF_SUCC		:= DEF_CURRENT^.FORE;

    IF DEF_PRED <> NIL THEN

	DEF_PRED^.FORE	:= DEF_SUCC;

    IF DEF_SUCC <> NIL THEN

	DEF_SUCC^.BACK	:= DEF_PRED;

    WITH DEF_CURRENT^ DO

    BEGIN

	IF STRING.DSC$W_LENGTH > 0 THEN

	    STR$FREE1_DX (STRING);

	IF COMMENT.DSC$W_LENGTH > 0 THEN

	    STR$FREE1_DX (COMMENT);

    END;

    DISPOSE (DEF_CURRENT);

    IF DEF_SUCC <> NIL THEN

	DEF_CURRENT	:= DEF_SUCC

    ELSE IF DEF_PRED <> NIL THEN

	DEF_CURRENT	:= DEF_PRED

    ELSE

	NEW_IDENT_LINE;

    END;	{ IF FALSE DEF_CURRENT^.PRIMARY = TITLE }

END;	{ DELETE_CURRENT }

{ ++

DELETE_PRIMARY_SECTION -- Get rid of a whole primary section.

This routine removes all the line_objects of particular primary from the
definition linked list.

CALLING SEQUENCE:

DELETE_PRIMARY_SECTION (PRIMARY,PRINUM);

INPUT PARAMETERS:

PRIMARY
PRINUM

IMPLICIT INPUTS:

DEF_CURRENT
DEF_TAIL
DEF_HEAD

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

DEF_CURRENT
DEF_TAIL
DEF_HEAD

ROUTINES CALLED:

EXTRACT_CURRENT

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

PROCEDURE DELETE_PRIMARY_SECTION (WHICHPRIMARY : PRIMARY_TYPE;
					WHICHPRINUM : INTEGER);

VAR
    DOING	: BOOLEAN;
    DONE	: BOOLEAN;

BEGIN

    DEF_CURRENT	:= DEF_HEAD;
    DOING	:= FALSE;
    DONE	:= FALSE;

    { +
    Cycle until we've deleted the section or we're at the end of the list.
    - }
    REPEAT

	{ +
	If this is the start of the right primary, flag it.
	- }
	IF (
	(DEF_CURRENT^.OBJECT_TYPE = PRI)
	AND
	(DEF_CURRENT^.PRIMARY = WHICHPRIMARY)
	AND
	(DEF_CURRENT^.PRINUM = WHICHPRINUM)
	) THEN

	    DOING	:= TRUE;

	{ +
	If we're in the right primary, delete the sucker!
	- }
	IF DOING THEN

	    DELETE_CURRENT

	ELSE

	    { +
	    Move on to the next line_object in the list.
	    - }
	    INCR_CURRENT;

	{ +
	If we're not already off the end, see if this is still the
	right primary. If not, flag that we're done.
	- }
	IF DEF_CURRENT <> NIL THEN

	    IF (
	    (DOING)
	    AND
	    (DEF_CURRENT^.OBJECT_TYPE = PRI)
	    AND
		(
		(DEF_CURRENT^.PRIMARY <> WHICHPRIMARY)
		OR
		(DEF_CURRENT^.PRINUM <> WHICHPRINUM)
		)
	    ) THEN

		DONE	:= TRUE;

    UNTIL (DONE) OR (DEF_CURRENT = NIL);

END;	{ DELETE_PRIMARY_SECTION }

{ ++

INIT_DEF -- Clear out the definition and setup for a new one.

This routine makes room to put a brand new definition in the linked list.

CALLING SEQUENCE:

INIT_DEF;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

DEF_CURRENT
DEF_HEAD

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

PROCEDURE INIT_DEF;

BEGIN

    { +
    Clear out the list starting at the beginning (if not already empty).
    - }
    DEF_CURRENT	:= DEF_HEAD;

    IF DEF_CURRENT <> NIL THEN

    BEGIN

	REPEAT

	    DELETE_CURRENT;

	UNTIL DEF_HEAD = DEF_TAIL;

	IF DEF_CURRENT <> NIL THEN

	    DELETE_CURRENT;

    END;

END;	{ INIT_DEF }

{ ++

INSERT_IN_ORDER -- Put DEF_SCRATCH into the list in proper order.

This routine places the line_object pointed to by def_scratch in the definition
linked list in its proper place.

CALLING SEQUENCE:

INSERT_IN_ORDER (COLLISION_ACTION);

INPUT PARAMETERS:

COLLISION_ACTION

IMPLICIT INPUTS:

DEF_CURRENT
DEF_TAIL
DEF_HEAD
DEF_SCRATCH

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

none

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS] PROCEDURE INSERT_IN_ORDER (
			    COLLISION_ACTION	: INTEGER
			    );

VAR
    BACKUP_WORKED	: BOOLEAN;

BEGIN

    { +
    1st, a little conditioning.
    - }
    IF (
    (DEF_SCRATCH^.OBJECT_TYPE = PRI)
    AND
    (DEF_SCRATCH^.PRIMARY <> TITLE)
    ) THEN

	DEF_SCRATCH^.STRING.DSC$W_LENGTH	:= 0;

    DEF_SCRATCH^.FORE	:= NIL;
    DEF_SCRATCH^.BACK	:= NIL;

    { +
    Now, find the proper place. Start looking at the previous line_object.
    - }
    BACKUP_WORKED	:= FALSE;

    IF DEF_CURRENT <> NIL THEN

	IF DEF_CURRENT^.BACK <> NIL THEN

	BEGIN

	    DECR_CURRENT;

	    WHILE NOT (
	    (CURRENT_GT_TEST(DEF_SCRATCH^,TRUE))
	    OR
	    (CURRENT_EQ_TEST(DEF_SCRATCH^,TRUE))
	    OR
	    (DEF_CURRENT^.FORE = NIL)
	    ) DO

		INCR_CURRENT;

	    BACKUP_WORKED	:= (
				(
				    (CURRENT_LT_TEST(DEF_SCRATCH^,TRUE))
				    AND
				    (DEF_CURRENT^.FORE = NIL)
				)
				OR
				    (CURRENT_EQ_TEST(DEF_SCRATCH^,TRUE))
	    			);

	END;	{ IF DEF_CURRENT^.BACK <> NIL }

    IF NOT BACKUP_WORKED THEN

    BEGIN

	{ +
	The quick look didn't work, now scan the entire list.
	- }
	DEF_CURRENT	:= DEF_HEAD;

	WHILE NOT (
	(CURRENT_GT_TEST(DEF_SCRATCH^,TRUE))
	OR
	(CURRENT_EQ_TEST(DEF_SCRATCH^,TRUE))
	OR
	(DEF_CURRENT^.FORE = NIL)
	) DO

	    INCR_CURRENT;

    END;	{ IF NOT BACKUP_WORKED }

    { +
    Now insert it according to how it was (found).
    - }
    IF CURRENT_GT_TEST(DEF_SCRATCH^,TRUE) THEN

	INSERT_BEFORE_CURRENT

    ELSE IF CURRENT_EQ_TEST(DEF_SCRATCH^,TRUE) THEN

    BEGIN

	IF COLLISION_ACTION = REPLACE_OBJ THEN

	    INSERT_AT_CURRENT

	ELSE IF COLLISION_ACTION = AFTER_OBJ THEN

	    INSERT_AFTER_CURRENT;

	{ IF COLLISION_ACTION = IGNORE_OBJ THEN 'NULL-STATEMENT' }

    END

    ELSE IF DEF_CURRENT^.FORE = NIL THEN

    BEGIN

	DEF_TAIL	:= DEF_CURRENT;
    	INSERT_AFTER_CURRENT;

    END;

END;	{ INSERT_IN_ORDER }

{ ++

FIND_OBJECT -- Locate a line_object in the definition list.

This function returns with DEF_CURRENT pointing to the desired line
object - if it finds it, in which case it's function value is true.

CALLING SEQUENCE:

BOOLEAN_VAR := FIND_OBJECT (LINE_OBJECT_TYPE,PRIMARY,PRINUM,SECONDARY,SECNUM);

INPUT PARAMETERS:

OBJECT_TYPE
PRIMARY
PRINUM
SECONDARY
SECNUM

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

DEF_CURRENT

ROUTINES CALLED:

none

ROUTINE VALUE:

TRUE/FALSE DEPENDING ON FOUND STATUS

SIGNALS:

none

SIDE EFFECTS:

none

-- }

FUNCTION FIND_OBJECT (
			OBJ_TYP		: LINE_OBJECT_TYPE;
			PRIM		: PRIMARY_TYPE;
			PRIMNUM		: INTEGER;
			SECO		: SECONDARY_TYPE;
			SECONUM		: INTEGER
			) : BOOLEAN;

VAR
    TEST	: LINE_OBJECT;
    FOUND_IT	: BOOLEAN;
    PAST_IT	: BOOLEAN;

BEGIN

    { +
    Stuff test object for comparison routine.
    - }
    TEST.OBJECT_TYPE	:= OBJ_TYP;
    TEST.PRIMARY	:= PRIM;
    TEST.PRINUM		:= PRIMNUM;
    TEST.SECONDARY	:= SECO;
    TEST.SECNUM		:= SECONUM;

    { +
    Start looking at head of list.
    - }
    DEF_CURRENT		:= DEF_HEAD;
    FOUND_IT		:= FALSE;
    PAST_IT		:= FALSE;

    IF DEF_CURRENT <> NIL THEN

    BEGIN

	REPEAT

	    FOUND_IT	:= CURRENT_EQ_TEST (TEST,TRUE);
	    PAST_IT	:= CURRENT_GT_TEST (TEST,TRUE);

	    IF NOT FOUND_IT THEN

		INCR_CURRENT;

	UNTIL (FOUND_IT) OR (PAST_IT) OR (DEF_CURRENT = NIL);

    END;

    { +
    Function value indicates whether we found it or not.
    - }
    FIND_OBJECT			:= FOUND_IT;

END;	{ FIND_OBJECT }

{ ++

POINT_AT_DEFINITION -- Setup the list pointers.

This routine makes the list pointers point at the Definition Linked List.

CALLING SEQUENCE:

POINT_AT_DEFINITION;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

DEF_HEAD
DEF_TAIL
DEF_ANL_HEAD
DEF_ANL_TAIL
POINTING_DIRECTION

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

the current list is the definition list

-- }

[GLOBAL] PROCEDURE POINT_AT_DEFINITION;

BEGIN

    IF NOT POINTING_AT_DEFINITION THEN

    BEGIN

	DEF_ANL_HEAD		:= DEF_HEAD;
	DEF_ANL_TAIL		:= DEF_TAIL;
	DEF_HEAD		:= DEF_SAVE_HEAD;
	DEF_TAIL		:= DEF_SAVE_TAIL;

	POINTING_AT_DEFINITION	:= TRUE;

    END;

END;	{ POINT_AT_DEFINITION }

{ ++

POINT_AT_ANALYSIS -- Setup the list pointers.

This routine makes the list pointers point at the Analysis Linked List.

CALLING SEQUENCE:

POINT_AT_ANALYSIS;

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

none

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

DEF_HEAD
DEF_TAIL
DEF_ANL_HEAD
DEF_ANL_TAIL
POINTING_DIRECTION

ROUTINES CALLED:

none

ROUTINE VALUE:

none

SIGNALS:

none

SIDE EFFECTS:

the current list is the analysis list

-- }

PROCEDURE POINT_AT_ANALYSIS;

BEGIN

    IF POINTING_AT_DEFINITION THEN

    BEGIN

	DEF_SAVE_HEAD		:= DEF_HEAD;
	DEF_SAVE_TAIL		:= DEF_TAIL;
	DEF_HEAD		:= DEF_ANL_HEAD;
	DEF_TAIL		:= DEF_ANL_TAIL;

	POINTING_AT_DEFINITION	:= FALSE;

    END;

END;	{ POINT_AT_ANALYSIS }

{ ++

EDF$LINE_PARSED -- Action routine for FDL$PARSE routine.

This routine stores into the definition database the values from FDL$PARSE.

CALLING SEQUENCE:

Called from the FDL$PARSE routine.

INPUT PARAMETERS:

none

IMPLICIT INPUTS:

FDL_BLOCK

OUTPUT PARAMETERS:

none

IMPLICIT OUTPUTS:

DEF_CURRENT
DEF_TAIL
DEF_HEAD
DEF_SCRATCH

ROUTINES CALLED:

MAKE_SCRATCH
LIB$SCOPY_DXDX

ROUTINE VALUE:

Always 1 (for success).

SIGNALS:

none

SIDE EFFECTS:

none

-- }

[ASYNCHRONOUS,GLOBAL] FUNCTION EDF$LINE_PARSED : INTEGER;

BEGIN

    { +
    This routine always succeeds.
    - }
    EDF$LINE_PARSED	:= 1;

    { +
    Create a new line object to be added to the list.
    - }
    MAKE_SCRATCH;

    { +
    Get the control longword.
    - }
    TEMP_FDL3$TYPE	:= FDL_BLOCK^[FDL$L_CTRL]::FDL3$TYPE;

    { +
    Completely ignore a line if it's an IDENT, or if the Warning bit is set.
    - }
    IF ( NOT (
    ((TEMP_FDL3$TYPE.FDL$V_NEWPRI)
    AND
    (FDL_BLOCK^[FDL$L_PRIMARY]::PRIMARY_TYPE = IDENT))
    OR
    (TEMP_FDL3$TYPE.FDL$V_WARNING)
    )) THEN

    WITH DEF_SCRATCH^ DO

    BEGIN

	{ +
	Set the type of this line_object.
	- }
	IF TEMP_FDL3$TYPE.FDL$V_NEWPRI THEN
    
	    OBJECT_TYPE	:= PRI
    
	ELSE
    
	    OBJECT_TYPE	:= SEC;
    
	{ +
	Check for a full line comment, as it is a 3rd object type.
	- }
	IF TEMP_FDL3$TYPE.FDL$V_LINECMT THEN
    
	    OBJECT_TYPE	:= COM;
    
	{ +
	Fetch the primary and secondary values.
	- }
	PRIMARY		:= FDL_BLOCK^[FDL$L_PRIMARY]::PRIMARY_TYPE;
	SECONDARY	:= FDL_BLOCK^[FDL$L_SECONDARY]::SECONDARY_TYPE;

	{ +
	Store the comment string if a comment was detected.
	- }
	IF TEMP_FDL3$TYPE.FDL$V_COMMENT OR TEMP_FDL3$TYPE.FDL$V_LINECMT THEN
    
	BEGIN

	    TEMP_DESCRIPTOR	:= NULL_STRING;
	    TEMP_DESCRIPTOR	:= CVT_QUAD_DESC (
	    					FDL_BLOCK^[FDL$Q_COMMENT],
	    					FDL_BLOCK^[FDL$Q_COMMENT+1]
	    					);
	    LIB$SCOPY_DXDX (TEMP_DESCRIPTOR,COMMENT);

	END;

	{ +
	Store the string if it's an attribute with a string value.
	- }
	IF (

	((NOT TEMP_FDL3$TYPE.FDL$V_NEWPRI) AND (SEC_TYPE[SECONDARY].STR))

	OR
		{ for positioning by file_name }
	((NOT TEMP_FDL3$TYPE.FDL$V_NEWPRI) AND (SECONDARY = POSITION$))

	OR

	((TEMP_FDL3$TYPE.FDL$V_NEWPRI) AND (PRIMARY = TITLE))

	) THEN
    
	BEGIN

	    TEMP_DESCRIPTOR	:= NULL_STRING;
	    TEMP_DESCRIPTOR	:= CVT_QUAD_DESC (
	    					FDL_BLOCK^[FDL$Q_STRING],
	    					FDL_BLOCK^[FDL$Q_STRING+1]
	    					);
	    LIB$SCOPY_DXDX (TEMP_DESCRIPTOR,STRING);
    
	END;

	{ +
	Now stuff the new line_object with the remaining data from FDL$PARSE.
	- }
	IF PRIMARY IN [ AREA, KEY, ANALYSIS_OF_AREA, ANALYSIS_OF_KEY ] THEN

	    PRINUM	:= FDL_BLOCK^[FDL$L_PRINUM]

	ELSE

	    PRINUM	:= 0;

	IF SECONDARY IN [ SEG_LENGTH, SEG_POSITION ] THEN

	    SECNUM	:= FDL_BLOCK^[FDL$L_SECNUM]

	{ +
	Until RMS supports different types per segment,
	make the Type secondary that last one in the Key primary.
	(SECNUM is higher sorting priority than SECONDARY)
	- }
	ELSE IF SECONDARY = SEG_TYPE THEN

	    SECNUM	:= 7

	ELSE

	    SECNUM	:= 0;

{ ++

IF RMS EVER IMPLEMENTS DIFFERENT DATA TYPES FOR EACH KEY SEGMENT,
USE THE FOLLOWING CODE.

	IF SECONDARY IN [ SEG_LENGTH, SEG_POSITION, SEG_TYPE ] THEN

	    SECNUM	:= FDL_BLOCK^[FDL$L_SECNUM]

	ELSE

	    SECNUM	:= 0;

-- }

	{ +
	Qualifiers values are more complicated.
	- }
	IF (
	(SECONDARY = MT_PROTECTION)
	OR
	(SECONDARY = NULL_VALUE)
	) THEN

	BEGIN

	    { +
	    These two come back in a funny place.
	    - }
	    QUALIFIER	:= 0;
	    NUMBER	:= FDL_BLOCK^[FDL$L_QUALIFIER];

	END

	ELSE

	BEGIN

	    { +
	    See which secondary we have.
	    - }
	    CASE SECONDARY OF
	
		ORGANIZATION :
	
		    CASE FDL_BLOCK^[FDL$L_QUALIFIER] OF
	
			FAB$C_IDX :	QUALIFIER	:= FDL$C_IDX;
			FAB$C_REL :	QUALIFIER	:= FDL$C_REL;
			FAB$C_SEQ :	QUALIFIER	:= FDL$C_SEQ;
	
		    OTHERWISE
	
			{ NULL-STATEMENT } ;
	
		    END;	{ CASE FDL_BLOCK^[FDL$L_QUALIFIER] }
	
		FORMAT :
	
		    CASE FDL_BLOCK^[FDL$L_QUALIFIER] OF
	
			FAB$C_FIX :	QUALIFIER	:= FDL$C_FIX;
			FAB$C_STM :	QUALIFIER	:= FDL$C_STM;
			FAB$C_STMCR :	QUALIFIER	:= FDL$C_STMCR;
			FAB$C_STMLF :	QUALIFIER	:= FDL$C_STMLF;
			FAB$C_UDF :	QUALIFIER	:= FDL$C_UDF;
			FAB$C_VAR :	QUALIFIER	:= FDL$C_VAR;
			FAB$C_VFC :	QUALIFIER	:= FDL$C_VFC;
	
		    OTHERWISE
	
			{ NULL-STATEMENT } ;
	
		    END;	{ CASE FDL_BLOCK^[FDL$L_QUALIFIER] }
	
		SEG_TYPE :
	
		    CASE FDL_BLOCK^[FDL$L_QUALIFIER] OF
	
			XAB$C_BN2 :	QUALIFIER	:= FDL$C_BN2;
			XAB$C_BN4 :	QUALIFIER	:= FDL$C_BN4;
			XAB$C_BN8 :	QUALIFIER	:= FDL$C_BN8;
			XAB$C_PAC :	QUALIFIER	:= FDL$C_PAC;
			XAB$C_IN2 :	QUALIFIER	:= FDL$C_IN2;
			XAB$C_IN4 :	QUALIFIER	:= FDL$C_IN4;
			XAB$C_IN8 :	QUALIFIER	:= FDL$C_IN8;
			XAB$C_STG :	QUALIFIER	:= FDL$C_STG;
	
		    OTHERWISE
	
			{ NULL-STATEMENT } ;
	
		    END;	{ CASE FDL_BLOCK^[FDL$L_QUALIFIER] }
	
	    OTHERWISE
	
		QUALIFIER	:= FDL_BLOCK^[FDL$L_QUALIFIER];
	
	    END;	{ CASE SECONDARY }

	    NUMBER	:= FDL_BLOCK^[FDL$L_NUMBER];

	END;

	{ +
	Now store the other information coming back from FDL$PARSE.
	- }
	IF ODD (FDL_BLOCK^[FDL$L_SWITCH]) THEN
    
	    SWITCH	:= TRUE
    
	ELSE
    
	    SWITCH	:= FALSE;
    
	OWNER_UIC	:= FDL_BLOCK^[FDL$L_OWNER_UIC];
	PROT_MASK	:= FDL_BLOCK^[FDL$L_PROTECTION]::CTRL_ARRAY;
	FID1		:= FDL_BLOCK^[FDL$L_FID1];
	FID2		:= FDL_BLOCK^[FDL$L_FID2];
	FID3		:= FDL_BLOCK^[FDL$L_FID3];

	{ +
	Now put def_scratch into the linked list. Depending upon whether
	we're inputting an FDL file or a analysis file.
	CLUSTER_SIZE must go into both the analysis definition and the
	main definition.
	- }
	IF (
	(ANALYSIS_ONLY AND (PRIMARY IN [ ANALYSIS_OF_KEY, ANALYSIS_OF_AREA ]))
	OR
	((NOT ANALYSIS_ONLY) AND (NOT (PRIMARY IN [ ANALYSIS_OF_KEY,
	ANALYSIS_OF_AREA ])))
	OR
	(SECONDARY IN [ CLUSTER_SIZE ])
	) THEN

	    IF OBJECT_TYPE = COM THEN

	    BEGIN

		DEF_CURRENT	:= DEF_TAIL;
		INSERT_AFTER_CURRENT;

	    END

	    ELSE

		INSERT_IN_ORDER (IGNORE_OBJ);

    END;	{ IF NOT IDENT PRIMARY; ALSO WITH DEF_SCRATCH^ DO }

END;	{ EDF$LINE_PARSED }

END.
    { End of file: SRC$:EDFUTIL.PAS }
