PDP-10 Archive: 6-1-sources/prgetkey.bli from BB-H138E-BM

Trailing-Edge - PDP-10 Archives - BB-H138E-BM - 6-1-sources/prgetkey.bli
There are 10 other files named prgetkey.bli in the archive. Click here to see a list.
 %TITLE 'PRGETKEY - parse a key name'
MODULE PRGETKEY (				! Parse a command
		IDENT = '3-004'			! File: PRGETKEY.B36 Edit:CJG3004
		) =
BEGIN
!
!			  COPYRIGHT (c) 1983, 1985 BY
!	      DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!		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:	EDT -- The DEC Standard Editor
!
! ABSTRACT:
!
!	Parse a key name.
!
! ENVIRONMENT:	Runs on TOPS-20 only
!
! AUTHOR: Chris Gill, CREATION DATE: March 15, 1983
!
! MODIFIED BY:
!
! 3-001 - Original. CJG 15-Mar-1983
! 3-002 - Fix key numbering for latest version. CJG 17-Jun-1983
! 3-003 - Allow quoted string in GOLD X formats. CJG 8-Jul-1983
! 3-004 - Check for control-C being typed. CJG 5-Jan-1984
!--

%SBTTL 'DECLARATIONS'
!
! TABLE OF CONTENTS:
!

REQUIRE 'EDTSRC:TRAROUNAM';

FORWARD ROUTINE
	EDT$$PA_GET_KEY,		! Parse a key name
	EDT$$PA_GET_CHAR;		! Get a single character

!
! INCLUDE FILES:
!

REQUIRE 'EDTSRC:EDTREQ';

REQUIRE 'SYS:JSYS';

REQUIRE 'EDTSRC:PARLITS';

LIBRARY 'EDTSRC:KEYPADDEF';

!
! EXTERNAL REFERENCES:
!
!	In the routines
!
!
! MACROS:
!
!	NONE
!
!
! OWN STORAGE
!
!	NONE
!

%SBTTL 'EDT$$PA_GET_KEY - Parse a key name'

GLOBAL ROUTINE EDT$$PA_GET_KEY =		! Parse a key name

BEGIN

!
!FUNCTIONAL DESCRIPTION
!
! This routine parses the key name in a SHOW KEY or DEFINE KEY command.
!
! Key values are defined as follows:
!
!	000 - 031 = CONTROL letter
!	032 - 255 = normal characters
!	300 - 399 = number
!	400 - 499 = FUNCTION number
!	500 - 531 = GOLD CONTROL letter
!	532 - 755 = GOLD character
!	800 - 899 = GOLD number
!	900 - 999 = GOLD FUNCTION number
!	127       = DELETE
!	627       = GOLD DELETE
!
!
!
!IMPLICIT INPUTS
!
!	NONE
!
!ROUTINE VALUE
!
!	0  - Reparse required
!	-1 - Error in parsing
!	1  - Good return
!

    EXTERNAL
	CSB : VECTOR [10],		! Command state block
	PA_CURCMD : REF NODE_BLOCK,
	PA_CURTOK,			! Pointer to atom
	PA_CURTOKLEN,			! Length of atom
	PA_ERRNO,			! Error number
	FD_KYS,
	FD_KYN,
	FD_SKY,
	FD_SKG,
	FD_SKV,
	CC;				! Control-C flag

    EXTERNAL ROUTINE
	EDT$$PA_SCANTOK;		! Find atom length and pointer

    MESSAGES ((KEYNOTDEF));

    LOCAL
	C_FLAG,				! COMND flags
	C_DATA,				! COMND data pointer
	C_FDB,				! COMND actual FDB used
	C1,
	C2,				! Offset for GOLD keys
	C3;				! Flag for quoted string

    BEGIN
	PA_ERRNO = EDT$_KEYNOTDEF;
	C2 = 0;
	C3 = 0;

!+
! Parse the next atom and set C1 (the atom identifier) accordingly
!-

	IF (NOT COMMAND (FD_SKY)) THEN RETURN (-1);
	IF (.CC NEQ 0) THEN RETURN (-1);
	IF ((.C_FLAG AND CM_RPT) NEQ 0) THEN RETURN (0);
	IF ((.C_FLAG AND CM_NOP) NEQ 0) THEN RETURN (-1);
	IF ((.C_FDB<0,18> EQL FD_KYN) OR (.C_FDB<0,18> EQL FD_KYS)) THEN RETURN (-1);
	IF (.C_FDB<0,18> EQL FD_SKV) THEN
	    C1 = KEY_NUM
	ELSE
	    C1 = .(.C_DATA)<0,18>;

	IF (.C1 EQL KEY_GOLD) THEN
	    BEGIN
	    C2 = K_GOLD_BASE;

!+
! The GOLD keyword may be followed by another keyword - parse it as well
!-

	    IF (NOT COMMAND (FD_SKG)) THEN RETURN (-1);
	    IF (.CC NEQ 0) THEN RETURN (-1);
	    IF ((.C_FLAG AND CM_RPT) NEQ 0) THEN RETURN (0);
	    IF ((.C_FLAG AND CM_NOP) NEQ 0) THEN RETURN (-1);
	    C1 = (SELECTONE .C_FDB<0,18> OF
		    SET
		    [ FD_SKV ] : KEY_NUM;
		    [ FD_SKG ] : .(.C_DATA)<0,18>;
		    [ FD_KYS ] : 0;
		    [ FD_KYN ] :
				BEGIN
				C3 = 1;
				0
				END;
		    TES );
	    END;

	CASE .C1 FROM 0 TO KEY_FUNC OF
	    SET

	[ 0 ] :

	    BEGIN

!+
! DEFINE GOLD x
!-

	    EDT$$PA_SCANTOK (.C3,1);
	    IF (.PA_CURTOKLEN EQL 0) THEN
		BEGIN
		C1 = CH$RCHAR_A (CSB [$CMPTR]);
		CSB [$CMINC] = .CSB [$CMINC] - 1;
		END
	    ELSE
		BEGIN
		IF (.PA_CURTOKLEN NEQ 1) THEN RETURN (-1);
		C1 = CH$RCHAR_A (PA_CURTOK);
		END;

	    IF ((.C1 LEQ ASC_K_SP) OR (.C1 GTR %C'^')) THEN RETURN (-1);
	    PA_CURCMD [KEY_VAL] = .C1 + .C2;
	    END;

	[ KEY_NUM ] :

	    BEGIN

!+
! DEFINE (GOLD) nn
!-

	    IF (.C_DATA GTR 21) THEN RETURN (-1);
	    PA_CURCMD [KEY_VAL] = .C_DATA + .C2 + K_KPAD_BASE;
	    END;

	[ KEY_DEL ] :

	    BEGIN

!+
! DEFINE (GOLD) DELETE
!-

	    PA_CURCMD [KEY_VAL] = 127 + .C2;
	    END;

	[ KEY_CONT ] :

	    BEGIN

!+
! DEFINE (GOLD) CONTROL x
!-

	    C1 = EDT$$PA_GET_CHAR ();
	    IF (.C1 LEQ 0) THEN RETURN (.C1);
	    IF ((.C1 LEQ %C'@') OR (.C1 GTR %C'Z')) THEN RETURN (-1);
	    PA_CURCMD [KEY_VAL] = .C1 - %C'@' + .C2;
	    END;

	[ KEY_FUNC ] :

	    BEGIN

!+
! (GOLD) FUNCTION nn
!-

	    IF (NOT COMMAND (FD_SKV)) THEN RETURN (-1);
	    IF (.CC NEQ 0) THEN RETURN (-1);
	    IF ((.C_FLAG AND CM_RPT) NEQ 0) THEN RETURN (0);
	    IF (.C_DATA GTR 99) THEN RETURN (-1);
	    PA_CURCMD [KEY_VAL] = .C_DATA + .C2 + K_FUN_BASE;
	    END;

	    TES;

	RETURN (1);

    END;
END;

%SBTTL 'EDT$$PA_GET_CHAR - Parse a single character'

GLOBAL ROUTINE EDT$$PA_GET_CHAR =			! Parse a character

BEGIN

!+
!FUNCTIONAL DESCRIPTION
!
! Since there is no COMND function to parse a single, arbitrary, character,
! this routine simulates it by parsing an alphanumeric field and returning
! either the first character or the break character if no field was parsed.
! If a COMND error occurs, the field was longer than one character, or a
! reparse is required, an error return is taken.
!-

!
!ROUTINE VALUE
!
!	0  - Reparse required
!	-1 - Error or field too long
!	1  - Good return
!

    EXTERNAL
	FD_KYN,
	FD_KYS,
	PA_CURTOK,
	PA_CURTOKLEN,
	CC,					! Control-C flag
	CSB : VECTOR [10];

    EXTERNAL ROUTINE
	EDT$$PA_SCANTOK;			! Get atom length and pointer

    LOCAL
	C_DATA,
	C_FDB,
	C_FLAG,
	C1;

    BEGIN

	IF (NOT COMMAND (FD_KYN)) THEN RETURN (-1);
	IF (.CC NEQ 0) THEN RETURN (-1);
	IF ((.C_FLAG AND CM_RPT) NEQ 0) THEN RETURN (0);
	IF (.C_FDB<0,18> EQL FD_KYN) THEN C1 = 1 ELSE C1 = 0;

	EDT$$PA_SCANTOK (.C1,1);
	IF (.PA_CURTOKLEN EQL 0) THEN
	    BEGIN
	    CSB [$CMINC] = .CSB [$CMINC] - 1;
	    C_DATA= CH$RCHAR_A (CSB [$CMPTR]);
	    END
	ELSE
	    BEGIN
	    IF (.PA_CURTOKLEN NEQ 1) THEN RETURN (-1);
	    C_DATA= CH$RCHAR_A (PA_CURTOK);
	    END;

	RETURN (.C_DATA);

    END;
END;

END
ELUDOM