Google
 

Trailing-Edge - PDP-10 Archives - SRI_NIC_PERM_SRC_1_19910112 - 6-exec/execpx.b36
There are 2 other files named execpx.b36 in the archive. Click here to see a list.
!<5.1.EXEC>EXECPX.B36.5, 15-Nov-82 02:39:52, Edit by PA0B
!Allow integer arguments to DISPLAY, Add OUTRANGE to CASE
!Try to fix up some of the problems with the PCL stack handling
!(in particular, don't destroy stack when a procedure does a
!DOCOMMAND of a user-defined command):
! - Use PCLSTF only to determine if PCL is initialized (it used
!   to be used to keep track of free space on the stack, but it
!   was incorrectly initialized and then not updated properly
!   anyway).
! - Use STKP where PCLSTF was used to find info about the PCL
!   stack.
! - Move PCIRUN here from EXECPI.
! - Check for PCL stack overflow/underflow in more places.
!<5.1.EXEC>EXECPX.B36.4,  8-Nov-82 03:39:07, Edit by PA0B
!Move the call to CLRINV at the end of the executor to be
!before the call to be before PCICLP.  This was necessary
!because PCICLP zeroes PCCURC[ECB_CFK].
!<5.1.EXEC>EXECPX.B36.3,  9-Sep-82 23:40:00, Edit by PA0B
!Add FK%INV (fork is INVOKE'd) flag to fork table
!<5.1.EXEC>EXECPX.B36.2,  4-Aug-82 23:34:29, Edit by PA0B
!Redo the PCFORK stuff
!<4.EXEC>EXECPX.B36.101, 27-Feb-82 02:40:03, Edit by PA0B
!Make EXIT SAVE and EXIT TOPROGRAM set PCFORK to -1 to avoid
!confusion.
!<4.EXEC>EXECPX.B36.100,  8-Oct-81 13:41:40, Edit by DK32
!Exec output stringblocks may be empty
!<4.EXEC>EXECPX.B36.99, 20-May-81 16:09:03, Edit by DK32
!Reset fork on Abort and error
!<4.EXEC>EXECPX.B36.98, 10-Mar-81 16:51:58, Edit by DK32
!New parse-in-progress logic so commands do confirmation,
!Fix multiple-CR commands, Fix command argument reparse
!<4.EXEC>EXECPX.B36.97, 25-Feb-81 21:52:40, Edit by DK32
!Prompt, PassOutput
!<4.EXEC>EXECPX.B36.96, 15-Jan-81 17:26:36, Edit by DK32
!Pass both arguments to variable-routines
!<4.EXEC>EXECPX.B36.95, 23-Dec-80 18:04:03, Edit by DK32
!Use Exec linkage, Parse Invisible
!<4.EXEC>EXECPX.B36.94, 15-Dec-80 17:51:50, Edit by DK32
!Respect preserved context for procedures and commands
!<4.EXEC>EXECPX.B36.93,  9-Dec-80 00:31:46, Edit by DK32
!Save and ToProgram options to Exit
!<4.EXEC>EXECPX.B36.92, 26-Nov-80 20:11:28, Edit by DK32
!Allow for superceded global symbols
!<4.EXEC>EXECPX.B36.91, 16-Nov-80 22:31:27, Edit by DK32
!Read remainder of line after failed command argument,
!Handle running out of memory for PDS typeout
!<4.EXEC>EXECPX.B36.90, 30-Oct-80 14:07:24, Edit by DK32
!Insert null after command in buffer
!<4.EXEC>EXECPX.B36.89, 25-Oct-80 23:03:07, Edit by DK32
!Cleanup invoked forks properly
!<4.EXEC>EXECPX.B36.88, 18-Oct-80 15:53:07, Edit by DK32
!Parse FileList, Get operands to subtract in proper order
!<4.EXEC>EXECPX.B36.87,  9-Oct-80 18:37:16, Edit by DK32
!Parsed JFN list, Fix substring overrun
!<4.EXEC>EXECPX.B36.86,  2-Oct-80 20:16:23, Edit by DK32
!Add Parse NoIndirect, Fix writeable system variables
!<4.EXEC>EXECPX.B36.85, 24-Sep-80 17:08:59, Edit by DK32
!Remove service routines to EXECPU
!<4.EXEC>EXECPX.B36.84, 17-Sep-80 17:23:14, Edit by DK32
!<4.EXEC>EXECPX.B36.83, 15-Sep-80 16:03:26, Edit by DK32
!Use correct byte count in Typein
!<4.EXEC>EXECPX.B36.82, 11-Sep-80 14:16:08, Edit by DK32
!Strip linefeeds from Typein
!<4.EXEC>EXECPX.B36.81,  7-Sep-80 20:50:03, Edit by DK32
!Add $SearchRaised, Fix String[1:*], Fix message for substring
!start less than 1, Add optional starting position argument
!to $Search and $SearchRaised
!<4.EXEC>EXECPX.B36.80, 20-Aug-80 16:55:26, Edit by DK32
!Handle multiple line DoCommand with final null line,
!Add $TermNumber
!<DK32.CG>EXECPX.B36.79, 10-Aug-80 14:12:17, Edit by DK32
!Keep PCT details in ECB, Handle multiple-line Docommand
!better, Handle null DoCommand
!<DK32.CG>EXECPX.B36.78,  1-Aug-80 15:09:42, Edit by DK32
!Fix $TermWidth, Call PCITIN with real string
!<DK32.CG>EXECPX.B36.77, 29-Jul-80 14:54:57, Edit by DK32
!Don't kill user fork, just disengage it from PCL
!<DK32.CG>EXECPX.B36.76, 17-Jul-80 13:30:59, Edit by DK32
!Handle multi-line DoCommands
!<DK32.CG>EXECPX.B36.75, 10-Jul-80 10:40:30, Edit by DK32
!Add $ConnectedDirectory
!<DK32.CG>EXECPX.B36.74,  3-Jul-80 14:10:02, Edit by DK32
!SBS never returns error for length too long, Make MERGETAD a function,
!Add INPUTTAD, Fix Abort to handle expressions, Have substring handle length -1
MODULE EXECPX =
BEGIN

!++
!
!  This is the first attempt at the Programmable Command Language executer
!
!  Dave King, Carnegie-Mellon University Computation Center
!
!  January, 1980
!
!  Copyright (C) 1980, Carnegie-Mellon University
!
!--

!++
!    This module contains the bulk of the code necessary to actually
!  run a stored command.  Its only entry is the routine PCEXCT, which
!  enters a fetch-execute cycle on the internal representation of the
!  user's command.  This module provides all the facilities of fetching
!  instructions, decoding and fetching operands, performing the
!  instruction, and storing the results.  It calls routines in module
!  EXECPI to provide services which could be called "system interfacing,"
!  such as running user programs and writing to the terminal.  Originally,
!  I intended to divide things up so that there would be no need for
!  this module to contain any JSYS instructions, but this rule has not
!  been uniformly followed; it was not instituted in the interests of
!  code purity, but to provide a rule of thumb to keep the modules
!  of reasonable size.
!--


!
! Standard definitions
!

LIBRARY 'EXECPD';		! Get common definitions
LIBRARY 'BLI:TENDEF';		! Get system definitions
LIBRARY 'BLI:MONSYM';
SWITCHES LINKAGE(EXEC);

!
! Table of contents:
!

FORWARD ROUTINE
    PCEERR,			! Report execution error
    PCEAST,			! Allocate string storage
    PCEFST: NOVALUE,		! Free string storage
    PCECST,			! Make copy of a string
    PCIRUN,			! Entry point for command invocation
    SETCTX: NOVALUE,		! Switch procedure context
    PCEGOP,			! Get value of operand
    PCESOP: NOVALUE,		! Store datum in operand
    CALPRC: NOVALUE,		! Call another procedure
    RETPRC: NOVALUE,		! Return from procedure
    DOCASE: NOVALUE,		! Indexed jump
    CLNVAR: NOVALUE,		! Clean up local string variables
    DOSBSS: NOVALUE,		! Extract substring
    DOCMND,			! DoCommand instruction
    PUTDCL,			! Send additional DoCommand lines
    DOCARG: NOVALUE,		! Get command arguments
    DPARSE: NOVALUE,		! Parse instruction
    COPFDB,			! Make real FLDDB from prototype
    COPKWT,			! Copy keyword table
    COPFDF: NOVALUE,		! Copy FILE defaults
    RELFDB: NOVALUE,		! Free storage for real FLDDB
    DPRMPT: NOVALUE,		! Prompt instruction
    GETEOP: NOVALUE,		! Get Exec output
    DOTINP: NOVALUE,		! Typein instruction
    DOGTYO: NOVALUE,		! Gettypout instruction
    DODPLY: NOVALUE,		! Display instruction
    CLIPRC: NOVALUE,		! Call internal routine
    PCEXCT;			! Main executer loop

!
! Macros:
!

MACRO ERROR(TXT) = PCEERR(UPLIT(%ASCIZ TXT)) %;

!
! External references:
!

EXTERNAL ROUTINE
    PCMGMM,			! General memory allocator
    RETMEM,			! EXECSU General memory release
    GETBUF,			! EXECSU Temporary memory allocate
    ERESET: NOVALUE,		! EXECP routine to reset program environment
    CLRINV: NOVALUE,		! EXECP routine to clear INVOKE'd fork flag
    PCIFGS,			! Find global symbol
    PCIPRS,			! Do COMND% for Parse
    PCIIVK: NOVALUE,		! Get and start up user program
    PCICLP: NOVALUE,		! Clean up all PTY/PDS's and forks
    PCIKIF: NOVALUE,		! Kill invoked fork
    PCITIN: NOVALUE,		! Type in to user program
    PCIPEO: NOVALUE,		! Prepare for Exec output
    PCIPSO: NOVALUE,		! Fake PTY-output pseudointerrupt
    PCIDPY: NOVALUE,		! Display string on real terminal
    PCIRPL: NOVALUE,		! Release Parsed JFN list
    DIVFNM,			! Get filename of current parsed JFN
    PCMITS,			! CVTBDO routine
    PCMXER,			! Report execution error
    PCMPER;			! Report parsing error

EXTERNAL
    PCCURC: REF ECB_BLK,	! Current Execution Context Block
    PCSFRE,			! Pointer to first free string block
    PCGBST: GST_TBL,		! Global symbol table
    PCTEXT: VECTOR,		! Text region
    PCSTAK: STKFRM,		! Run time stack
    PCLSTF,			! First unused word of run stack
    XDICT,			! Permanent storage pool
    DICT,			! Temporary storage pool
    CSBUFP: STR_VAL,		! Temporary string buffer pointer
    CJFNBK: VECTOR,		! Long-GTJFN block
    PCPOTP: VOLATILE,		! Address of block of user program output
    PCPEOP: VOLATILE,		! Address of block of Exec output
    PCLDCO,			! Flag to do command in original mode
    PSDEFN: SYN_TBL,		! System name table
    PCVVAL,			! Number parsed by last Parse
    PCVATM,			! Atom parsed by last Parse
    FORK:   VOLATILE,		! Exec's current fork handle
    PCFORK: VOLATILE,		! Saved value of FORK
    PCRNFK: VOLATILE;		! Saved value of RUNFK

EXTERNAL LITERAL
    PCGBLN: UNSIGNED(3),	! Pages in global symbol table
    PCSTKL: UNSIGNED(3),	! Pages in run time stack
    PSDEFL: UNSIGNED(6);	! Length of system name table
!
! Equated symbols:
!

BIND
    CFM_FLDDB = UPLIT(%O'010000000000',0,0,0),
    GBSTLN=PCGBLN*512/GST_LEN,	! Maximum GST index possible
    STAKLN=PCSTKL*512,		! Execution stack length
    PC = PCSTAK,		! Program counter, relative to routine text
    FP = PCSTAK+1,		! Stack frame pointer, relative to PCSTAK
    STKP = FP+1,		! Stack pointer, relative to PCSTAK
    INSTR = STKP+1: BLOCK[2] FIELD(COD_FLD),	! Instruction being performed
    LSTPMT = INSTR+2,		! Location of last Prompt instruction
    CURGST = LSTPMT+1: REF GST_BLK, ! GST of current routine
    CURCOD = CURGST+1: REF COD_BLK, ! Pointer to code for current routine
    CURCDL = CURCOD+1,		    ! Its length
    CURCNS = CURCDL+1: REF VECTOR,  ! Pointer to constants for routine
    CURCNL = CURCNS+1,		    ! Its length
    CURSMT = CURCNL+1: REF SYMENT,  ! Symbol table for routine
    CURSML = CURSMT+1,		    ! Its length
    CMPTR = CURSML+1;		    ! Pointer to Exec's command buffer

GLOBAL LITERAL
    PCEOWN = 13;		    ! Length of executor context
GLOBAL ROUTINE PCEERR(MSG,PAR1) =   ! Report execution error

!++
! Functional description:
!	Clean up, issue error message and stop.  The error message is
!	provided as an ASCIZ string; anywhere a #n appears the n'th
!	message parameter is inserted.
!
! Formal parameters:
!	Address of error message string
!	Address of parameter string #1
!
! Implicit inputs:
!	Instruction being executed, global symbol for current procedure
!
! Implicit outputs:
!	None
!
! Routine value:
!	Really, none; does not return.   I wish I could convince BLISS of that.
!
! Side effects:
!	Kills current controlled program, frees string variables
!
!--

%( Presently only works with one insert )%

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	IPT,			! String pointers
	OPT,
	CHR,			! Character
	INSRT,			! Insertion pointer
	BUFF: VECTOR[25];	! Message buffer
    PCICLP(1);
    CLNVAR();
    OPT = BYTPTR(BUFF);
    IPT = BYTPTR(.CURGST[GST_NMA]);
    WHILE (CHR = CH$RCHAR_A(IPT)) NEQ 0 DO CH$WCHAR_A(.CHR,OPT);
    IPT = CH$PTR( UPLIT (%ASCIZ ' Line '));
    WHILE (CHR = CH$RCHAR_A(IPT)) NEQ 0 DO CH$WCHAR_A(.CHR,OPT);
    OPT = PCMITS(.INSTR[COD_LNO],.OPT);
    CH$WCHAR_A(%C':', OPT);
    CH$WCHAR_A(%C' ', OPT);
    IPT = BYTPTR(.MSG);
    DO
	IF (CHR = CH$RCHAR_A(IPT)) EQL %C'#'
	THEN
	    BEGIN
	    CH$RCHAR_A(IPT);	! Skip the 1 which must follow
	    INSRT = BYTPTR(.PAR1);
	    WHILE (CHR = CH$RCHAR_A(INSRT)) NEQ 0 DO CH$WCHAR_A(.CHR,OPT);
	    CHR = -1
	    END
	ELSE
	    CH$WCHAR_A(.CHR,OPT)
      UNTIL .CHR EQL 0;
    PCMXER(BUFF)
    END;
GLOBAL ROUTINE PCEAST (LEN) =	! Allocate string storage

!++
! Functional description:
!	  Allocate from string storage a block large enough to store
!	LEN+1 characters.
!	  Strings are ALWAYS stored in ASCIZ format, but the final
!	null is never seen by the user.  This makes things much easier
!	when we have to deal with the rest of the system.  All real
!	stringvalues consist of a length and an 18-bit address; the
!	final null is NOT included in the length.
!	  This system does not collect garbage, but requires all users
!	of the string pool to return strings when they are done with
!	them.  This means that every user string variable and every
!	string system variable, if they contain pointers to strings
!	at all, contain the ONLY pointers to those strings; LET A=B
!	gives A a copy of the string in B, not a duplicate pointer.
!	That allows a later LET A=C to release the string in A without
!	requiring reference counters and other complexities.
!	  To keep the string pool under control, whenever ANY string
!	variable is destroyed (that is, whenever a routine with
!	string variables is exited) it should be freed.  As a last
!	resort, whenever the Exec exits from its outermost command
!	context, we (will) free the entire string pool and start afresh.
!
! Formal parameters:
!	Number of bytes the block should be able to store, excluding the null
!
! Implicit inputs:
!	None
!
! Implicit outputs:
!	Free space list
!
! Routine value:
!	Real string value of block allocated.  If desired length is not
!	positive, value is zero.
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	PTR,
	STR: STR_VAL;
    IF .LEN LEQ 0 THEN RETURN 0;
    PTR = PCMGMM((.LEN+5)/5, PCSFRE);
    IF .PTR LEQ 0 THEN ERROR('Out of execution string space');
    STR[STV_ADR] = .PTR;
    STR[STV_LEN] = .LEN;
    .STR
    END;
GLOBAL ROUTINE PCEFST (STR): NOVALUE=	! Free string storage

!++
! Functional description:
!	Release block obtained from free space by PCEAST.
!
! Formal parameters:
!	String value of block to be freed
!
! Implicit inputs:
!	None
!
! Implicit outputs:
!	Free space list
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    MAP
	STR: STR_VAL;
    IF .STR[STV_LEN] NEQ 0
    THEN
	RETMEM((.STR[STV_LEN]+5)/5, .STR[STV_ADR], PCSFRE)
    END;
GLOBAL ROUTINE PCECST (STR) =	! Make copy of a string

!++
! Functional description:
!	  Given a real stringvalue, get a free block of appropriate size,
!	copy the string, and return the real stringvalue of the copy.
!
! Formal parameters:
!	String value of original
!
! Implicit inputs:
!	None
!
! Implicit outputs:
!	None
!
! Routine value:
!	Real string value of string copy.  If original string has no length,
!	value is zero.
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    MAP
	STR: STR_VAL;		! Original string
    LOCAL
	NEW: STR_VAL;		! Copy being created
    IF .STR[STV_LEN] EQL 0 THEN RETURN 0;
    NEW = PCEAST(.STR[STV_LEN]);
    CH$COPY(.STR[STV_LEN], BYTPTR(.STR[STV_ADR]),
	    0, .STR[STV_LEN]+1, BYTPTR(.NEW[STV_ADR]));
    .NEW
    END;
GLOBAL ROUTINE PCIRUN (RUNECB,RUNNAM) =	! Start command procedure

!++
! Functional description:
!	  Control reaches here to execute a command.
!	I initialize the system to execute a command, filling in an
!	Execution Context Block and in general establishing all the
!	context which the Executer will require to begin executing
!	instructions.  I don't actually start the Executer now, but merely
!	prepare it to "continue" execution of this command.  The caller
!	will return to the Exec after causing it to forget that it was
!	just starting to parse a command, and after defining NUL: as the
!	command input device.  The Exec will then ask us for a whole new
!	command, and at that point the command will be executed to
!	generate a command.
!
! Formal parameters:
!	Address of Execution Context Block
!	Stringvalue of name of command
!
! Implicit inputs:
!	Global symbol table
!
! Implicit outputs:
!	Execution Context Block
!
! Routine value:
!	True if command executed, False if could not be found
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	EP: REF ECB_BLK,	! ECB pointer
	GS: REF GST_BLK;	! Global symbol table entry
    IF .PCCURC EQL 0		! If top-level PCL command
    THEN
	STKP = PCEOWN;		! Initialize stack pointer
    IF .STKP + FRM_LOC + .GS[GST_SLN] GTR STAKLN
    THEN
	ERROR('Stack full');
    EP = .RUNECB;
    GS = .EP[ECB_GSC];
    EP[ECB_PC] = 0;
    EP[ECB_PRC] = .GS;
    EP[ECB_FP] = 0;
    EP[ECB_SP] = .STKP + FRM_LOC + .GS[GST_SLN];
    EP[ECB_STK] = .STKP + 1;
    EP[ECB_CTN] = 0;
    EP[ECB_CTJ] = 0;
    EP[ECB_DTN] = 0;
    EP[ECB_DTJ] = 0;
    EP[ECB_DCB] = 0;
    EP[ECB_DTO] = %O'777777';
    EP[ECB_RCL] = 0;
    EP[ECB_PFL] = 0;
    EP[ECB_CFK] = 0;
    EP[ECB_PAR] = 1;
    EP[ECB_SCM] = 0;
    EP[ECB_ECO] = 0;
    TRUE
    END;
ROUTINE SETCTX: NOVALUE =	! Switch procedure context

!++
! Functional description:
!	Given the address of a routine's global symbol table entry in
!	CURGST, load the other pointers required for normal operation
!	within that routine, defining the locations of the routine's
!	instructions, constants, and symbols.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	CURGST, Global symbol table
!
! Implicit outputs:
!	CURCOD, CURCDL, CURCNS, CURCNL, CURSMT, CURSML
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    LOCAL
	GST: REF GST_BLK;	! Pointer to global symbol table entry
    GST = .CURGST;
    CURCOD = .GST[GST_TXT];
    CURCDL = .GST[GST_COD];
    IF .GST[GST_CLS] EQL GST_CLS_CMD
    THEN
	CURCNS = .CURCOD + .CURCDL
    ELSE
	CURCNS = .CURCOD + .CURCDL + .GST[GST_PCT];
    CURCNL = .GST[GST_CNS];
    CURSMT = .CURCNS + .CURCNL;
    CURSML = .GST[GST_SML]
    END;
GLOBAL ROUTINE PCEGOP (OPND,TYP) =	! Get value of operand

!++
! Functional description
!	Given an operand descriptor taken from an instruction, identifies
!	the object being referenced, locates the datum, and returns it.
!	Possible data are integers and string values; caller provides
!	expected type.
!
! Formal parameters:
!	Operand descriptor
!	Type to be fetched (STE_TYP_INT or STE_TYP_STR)
!
! Implicit inputs:
!	Local symbol table, global symbol table, stack frame, constant area,
!	string space
!
! Implicit outputs:
!	None
!
! Routine value:
!	Datum, either integer or stringvalue
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    MAP
	OPND: OPRAND;
    LOCAL
	OPA,			! Address of datum
	OPV;			! Value being located
    OPA = .OPND[OPN_ADR];
    CASE .OPND[OPN_CLS] FROM OPN_CLS_VAR TO OPN_CLS_TMP OF
	SET
[OPN_CLS_VAR]:	BEGIN
		! User variable; OPA has local symbol table index
		LOCAL
		    STE: REF STE_BLK;
		STE = CURSMT[.OPA,STE_WRD];
		IF .STE[STE_TYP] NEQ .TYP THEN ERROR('Incorrect operand type');
		CASE .STE[STE_CLS] FROM STE_CLS_VAR TO STE_CLS_FCN OF
		    SET
    [STE_CLS_VAR]:  BEGIN
		    OPV = .PCSTAK[.FP+.STE[STE_LOC],FRM_WRD];
		    END;
    [STE_CLS_GBL]:  BEGIN
		    LOCAL
			GST: REF GST_BLK;	! Global symbol table entry
		    GST = PCIFGS(.STE[STE_NAM]+.CURCNS,0);
		    IF .GST GEQ 0
		    THEN
			IF .GST[GST_CLS] NEQ GST_CLS_VAR THEN GST = -1;
		    IF .GST LSS 0
		    THEN
			ERROR('Undefined global variable referenced');
		    IF .GST[GST_TYP] NEQ .TYP
		    THEN
			ERROR('Incorrect operand type');
		    OPV = .GST[GST_VAL]
		    END;
    [STE_CLS_FML]:  BEGIN
		    LOCAL
			OPN: OPRAND,	! Operand descriptor
			SAVEFP,	! Save for current FP
			SAVEGS;	! ... CURGST
		    OPN[OPN_WRD] = .PCSTAK[.FP+.STE[STE_LOC],FRM_WRD];
		    IF .OPN[OPN_CLS] EQL OPN_CLS_TMP
		    THEN
			BEGIN
			OPA = .OPN[OPN_ADR];
			OPV = .PCSTAK[.OPA,FRM_WRD]
			END
		    ELSE
			BEGIN
			SAVEFP = .FP;
			SAVEGS = .CURGST;
			CURGST = .PCSTAK[.FP,FRM_PRC];
			FP = .PCSTAK[.FP,FRM_PRV];
			SETCTX();
			OPV = PCEGOP(.OPN[OPN_WRD],.TYP);
			FP = .SAVEFP;
			CURGST = .SAVEGS;
			SETCTX()
			END
		    END;
    [STE_CLS_PRC,
     STE_CLS_FCN]:  ERROR('Attempt to fetch from routine')
		    TES
		END;
[OPN_CLS_SYN]:	BEGIN
		! System variable
		IF .PSDEFN[.OPA,SYN_CLS] NEQ SYN_CLS_VAR
		THEN
		    ERROR('Fetch from system procedure');
		IF .PSDEFN[.OPA,SYN_TYP] NEQ .TYP
		THEN
		    ERROR('Incorrect operand type');
		IF .PSDEFN[.OPA,SYN_RTV]
		THEN
		    OPV = (.PSDEFN[.OPA,SYN_ADR])(0,0)
		ELSE
		    OPV = ..PSDEFN[.OPA,SYN_ADR]
		END;
[OPN_CLS_CNS]:	BEGIN
		! Constant
		IF .TYP NEQ .OPND[OPN_STR]
		THEN
		    ERROR('Incorrect operand type');
		OPV = .CURCNS[.OPA];
		IF .OPND[OPN_STR] THEN OPV = .OPV + .CURCNS
		END;
[OPN_CLS_TMP]:	BEGIN
		! Temporary variable to be popped from stack
		OPV = .PCSTAK[.STKP,FRM_WRD];
		IF .STKP EQL PCEOWN
		THEN
		    ERROR('PCL internal error - stack underflow');
		STKP = .STKP - 1
		END
	TES;
    .OPV
    END;
GLOBAL ROUTINE PCESOP (OPND,OPV,TYP): NOVALUE =	! Store datum in operand

!++
! Functional description:
!	Given an operand descriptor taken from an instruction, identifies
!	the object being referenced and stores the datum in the appropriate
!	location.  Requires that the destination is a fit repository for
!	the type of datum.
!
! Formal parameters:
!	Operand descriptor
!	Datum, either integer or string value
!	Type of datum (STE_TYP_INT or STE_TYP_STR)
!
! Implicit inputs:
!	Symbol tables, stack frame
!
! Implicit outputs:
!	Symbol tables, stack frame
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    MAP
	OPND: OPRAND;
    LOCAL
	OLD,
	OPA,
	OPS,
	STE: REF STE_BLK;	! Pointer to symbol table entry
    OPA = .OPND[OPN_ADR];
    CASE .OPND[OPN_CLS] FROM OPN_CLS_VAR TO OPN_CLS_TMP OF
	SET
[OPN_CLS_VAR]:	BEGIN
		! User variable
		STE = CURSMT[.OPA,STE_WRD];
		IF .STE[STE_TYP] NEQ .TYP THEN ERROR('Incorrect operand type');
		CASE .STE[STE_CLS] FROM STE_CLS_VAR TO STE_CLS_FCN OF
		    SET
    [STE_CLS_VAR]:  BEGIN
		    OLD = .PCSTAK[.FP+.STE[STE_LOC],FRM_WRD];
		    PCSTAK[.FP+.STE[STE_LOC],FRM_WRD] = .OPV;
		    IF .TYP EQL STE_TYP_STR THEN PCEFST(.OLD)
		    END;
    [STE_CLS_GBL]:  BEGIN
		    LOCAL
			GST: REF GST_BLK,	! Global symbol table entry
			NEWV: STR_VAL,
			STRO: STR_VAL;
		    GST= PCIFGS(.STE[STE_NAM]+.CURCNS,0);
		    IF .GST GEQ 0
		    THEN
			IF .GST[GST_CLS] NEQ GST_CLS_VAR THEN GST = -1;
		    IF .GST LSS 0
		    THEN
			ERROR('Undefined global variable referenced');
		    IF .GST[GST_TYP] NEQ .TYP
		    THEN
			ERROR('Incorrect operand type');
		    IF .TYP EQL STE_TYP_INT
		    THEN
			GST[GST_VAL] = .OPV
		    ELSE
			BEGIN
			STRO = .GST[GST_VAL];
			IF .STRO NEQ 0
			THEN
			    BEGIN
			    RETMEM((.STRO[STV_LEN]+5)/5,.STRO[STV_ADR],XDICT);
			    GST[GST_VAL] = 0
			    END;
			NEWV = .OPV;
			IF .NEWV NEQ 0
			THEN
			    BEGIN
			    STRO = PCMGMM( (.NEWV[STV_LEN]+5)/5, XDICT);
			    STRO[STV_LEN] = .NEWV[STV_LEN];
			    CH$MOVE(.NEWV[STV_LEN]+1,BYTPTR(.NEWV[STV_ADR]),
				    BYTPTR(.STRO[STV_ADR]));
			    GST[GST_VAL] = .STRO;
			    PCEFST(.NEWV)
			    END
			END
		    END;
    [STE_CLS_FML]:  BEGIN
		    LOCAL
			OPN: OPRAND,	! Operand descriptor
			SAVEFP,	! Save for current FP
			SAVEGS;	! ... CURGST
		    OPN[OPN_WRD] = .PCSTAK[.FP+.STE[STE_LOC],FRM_WRD];
		    IF .OPN[OPN_CLS] EQL OPN_CLS_TMP
		    THEN
			ERROR('Cannot store into value-only parameter');
		    SAVEFP = .FP;
		    SAVEGS = .CURGST;
		    CURGST = .PCSTAK[.FP,FRM_PRC];
		    FP = .PCSTAK[.FP,FRM_PRV];
		    SETCTX();
		    PCESOP(.OPN[OPN_WRD],.OPV,.TYP);
		    FP = .SAVEFP;
		    CURGST = .SAVEGS;
		    SETCTX()
		    END;
    [STE_CLS_PRC,
     STE_CLS_FCN]:  ERROR('Attempt to store into procedure')
		    TES
		END;
[OPN_CLS_SYN]:	BEGIN
		! System variable
		IF .PSDEFN[.OPA,SYN_CLS] NEQ SYN_CLS_VAR
		THEN
		    ERROR('Cannot set system procedure');
		IF NOT .PSDEFN[.OPA,SYN_WRT]
		THEN
		    ERROR('Cannot set readonly system variable');
		IF .PSDEFN[.OPA,SYN_TYP] NEQ .TYP
		THEN
		    ERROR('Incorrect operand type');
		IF .PSDEFN[.OPA,SYN_RTV]
		THEN
		    (.PSDEFN[.OPA,SYN_ADR])(.OPV,-1)
		ELSE
		    .PSDEFN[.OPA,SYN_ADR] = .OPV
		END;
[OPN_CLS_CNS]:	ERROR('Cannot store into a constant');
[OPN_CLS_TMP]:	BEGIN
		! Temporary to be pushed onto stack
		IF .STKP EQL STAKLN
		THEN
		    ERROR('Stack full');
		STKP = .STKP + 1;
		PCSTAK[.STKP,FRM_WRD] = .OPV
		END
	TES
    END;
ROUTINE CALPRC: NOVALUE =	! Call another procedure

!++
! Functional description:
!	  Called by instruction dispatcher, with PC pointing after CAL
!	instruction.  Instruction has procedure designator in operand A,
!	constant displacement of actual parameter list in operand B,
!	result destination descriptor in operand C (if typed procedure).
!	This routine distinguishes between system and user procedures:
!	for user procedures it checks for stack overflow, compares the actual
!	and formal arguments for validity, pushes actual parameter descriptors
!	onto the stack after this procedure's variables, pushes fixed fields
!	of stack frame onto stack, updates stack and stack frame pointers,
!	sets up	executer pointers to reference the new procedure, and sets
!	the PC to the beginning of the procedure.  For system procedures it
!	simply invokes the service routine.
!	  The actual arguments placed on the stack are genuine operand
!	descriptors, just as any other descriptors in the context of the
!	CALLER's routine.  There is a complication, however: temporaries
!	are not described by the generic OPN_TMP descriptor alone, but
!	additionally by the stack location of the real data word; this
!	is feasible because the called routine can never store into a
!	temporary anyway.
!	  If the called procedure returns a value, it will be stored in
!	the destination provided in the CAL instruction when the RET
!	is executed.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	PC, INSTR, symbol table, global symbol table,
!	constants, context pointers
!
! Implicit outputs:
!	Stack, FP, SP, context pointers
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	GST: REF GST_BLK,	! Global symbol table entry
	IDX,			! Symbol table index
	ARGI,			! Actual argument pointers
	ARGJ,
	NSPTR,			! New stack pointer
	TMPIDX,			! Stack index for allocating temporaries
	CNT;			! Argument count
    IDX = .INSTR[COD_OPA];
    GST = PCIFGS(.CURSMT[.IDX,STE_NAM]+.CURCNS,.PCCURC[ECB_PSV]);
    IF .GST GEQ 0
    THEN
	IF .GST[GST_CLS] NEQ GST_CLS_PRC AND .GST[GST_CLS] NEQ GST_CLS_FCN
	THEN
	    GST = -1;
    IF .GST LSS 0
    THEN
	PCEERR(	UPLIT(%ASCIZ 'Undefined procedure: #1'),
		.CURSMT[.IDX,STE_NMA]+.CURCNS);
    IF .STKP + FRM_LOC + .GST[GST_SLN] GTR STAKLN
    THEN
	ERROR('Stack full');
    ARGI = .INSTR[COD_OPB];
    IF .ARGI EQL %O'777777' THEN CNT = 0 ELSE CNT = .CURCNS[.ARGI];
    IF .CNT NEQ .GST[GST_PCT] THEN ERROR('Argument count mismatch');
%( The check for type mismatch is missing. Nobody references ARGJ at all )%
    ARGJ = .GST[GST_TXT] + .GST[GST_COD];
    ARGI = .ARGI + .CURCNS + .CNT;
    NSPTR = .STKP + .CNT + 1;
    TMPIDX = .STKP;
    ! This is a DECR because any temporaries MUST BE PUSHED IN THIS ORDER
    DECR I FROM .CNT-1 DO
	BEGIN
	LOCAL
	    OPN: OPRAND;	! Operand descriptor
	NSPTR = .NSPTR - 1;
	OPN[OPN_WRD] = ..ARGI;
	IF .OPN[OPN_CLS] EQL OPN_CLS_TMP
	THEN
	    BEGIN
	    OPN[OPN_ADR] = .TMPIDX;
	    TMPIDX = .TMPIDX - 1
	    END;
	ARGI = .ARGI - 1;
	PCSTAK[.NSPTR,FRM_WRD] = .OPN[OPN_WRD]
	END;
    NSPTR = .STKP + .CNT + 1;
    PCSTAK[.NSPTR,FRM_RET] = .PC;
    PCSTAK[.NSPTR,FRM_PRV] = .FP;
    PCSTAK[.NSPTR,FRM_STK] = .NSPTR - 1 - .CNT;
    PCSTAK[.NSPTR,FRM_PRC] = .CURGST;
    FP = .NSPTR;
    STKP = .NSPTR + FRM_LOC + .GST[GST_SLN];
    CURGST = .GST;
    SETCTX();
    DECR I FROM .GST[GST_SLN]-1 DO
	BEGIN
	PCSTAK[.NSPTR+FRM_LOC,FRM_WRD] = 0;
	NSPTR = .NSPTR + 1
	END;
    PC = 0
    END;
ROUTINE RETPRC: NOVALUE =	! Return from procedure

!++
! Functional description:
!	Unwinds stack frame to reference calling procedure, resets
!	context to caller, and continues.  If caller expected a value,
!	returned value is deposited.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	FP, stack frame
!
! Implicit outputs:
!	Stack frame pointer, PC, CURGST
!
! Routine value:
!	None
!
! Side effects:
!	Frees string variables in the called routine's stack frame
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	FPTR,			! Copy of frame pointer in a register
	LSP: REF BLOCK[1] FIELD(FRM_FLD),	! Local stack pointer
	OPN: OPRAND,		! Operand descriptor
	CNT,			! Argument count
	CLS,			! Class of returning routine
	VAL;			! Returned value
    CLS = .CURGST[GST_CLS];
    IF .CLS EQL GST_CLS_FCN
    THEN
	IF .CURGST[GST_TYP] EQL GST_TYP_INT
	THEN
	    VAL = PCEGOP(.INSTR[COD_OPA],STE_TYP_INT)
	ELSE
	    BEGIN
	    VAL = PCEGOP(.INSTR[COD_OPA],STE_TYP_STR);
	    IF .INSTR[COD_OPA] NEQ OPN_TMP_STR THEN VAL = PCECST(.VAL)
	    END;
    CLNVAR();
    FPTR = .FP;
    CNT = .CURGST[GST_PCT];
    PC = .PCSTAK[.FPTR,FRM_RET];
    CURGST = .PCSTAK[.FPTR,FRM_PRC];
    STKP = .PCSTAK[.FPTR,FRM_STK];
    FP = .PCSTAK[.FPTR,FRM_PRV];
    SETCTX();
    LSP = PCSTAK[.STKP,FRM_WRD];
    DECR I FROM .CNT-1 DO
	BEGIN
	LSP = .LSP + 1;
	OPN[OPN_WRD] = .LSP[FRM_WRD];
	IF .OPN[OPN_CLS] EQL OPN_CLS_TMP
	THEN
	    BEGIN
	    IF .OPN[OPN_STR]
	    THEN
		BEGIN
		OPN[OPN_WRD] = .OPN[OPN_ADR];
		PCEFST(.PCSTAK[.OPN[OPN_WRD],FRM_WRD])
		END;
	    IF .STKP EQL PCEOWN
	    THEN
		ERROR('PCL internal error - stack underflow');
	    STKP = .STKP - 1
	    END
	END;
    IF .CLS EQL GST_CLS_FCN
    THEN
	BEGIN
	OPN[OPN_WRD] = .CURCOD[.PC-2,COD_OPC];
	PCESOP(.OPN[OPN_WRD], .VAL, STE_TYP_STR)
	END
    END;
ROUTINE DOCASE: NOVALUE =	! Indexed jump

!++
! Functional description:
!	Using integer A is index, jump to A'th code index in table B,
!	which is C(B) words long, biasing each index by constant indexed
!	by C.  If A is outside the range, jump to the C(B)-1'th code index
!	unless C(B)-1 EQL -1 (ie, no OUTRANGE was specified), in which case
!	we abort.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	Instruction, user's operands
!
! Implicit outputs:
!	PC
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	IDX,			! Jump index
	TBL;			! Jump table location
    IDX = PCEGOP(.INSTR[COD_OPA],STE_TYP_INT);
    TBL = .INSTR[COD_OPB];
    IDX = .IDX - .CURCNS[.INSTR[COD_OPC]];
    IF .IDX LSS 0 OR .IDX GEQ .CURCNS[.TBL] ! Case out of range?
    THEN
	BEGIN
	IF .CURCNS[.TBL-1] NEQ -1	    ! Yes, OUTRANGE, specified?
	THEN
	    PC = .CURCNS[.TBL-1]	    ! Yes, go to OUTRANGE statement
	ELSE
	    ERROR('Index outside range')    ! Nope, die
	END
    ELSE
        PC = .CURCNS[.TBL+.IDX+1]	    ! In range, do normal stuff
    END;
ROUTINE CLNVAR: NOVALUE =	! Clean up local string variables

!++
! Functional description:
!	Called just before exit from a command or procedure, to
!	free all strings contained in local string variables.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	Current symbol table
!
! Implicit outputs:
!	String pool
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

%( This should take an argument to work its way up the stack frames )%
DECR I FROM .CURSML DO
    IF .CURSMT[.I,STE_VLD] EQL STE_VLD_NUM AND
       .CURSMT[.I,STE_CLS] EQL STE_CLS_VAR AND
       .CURSMT[.I,STE_TYP] EQL STE_TYP_STR
    THEN
	IF .PCSTAK[.FP+.CURSMT[.I,STE_LOC],FRM_WRD] NEQ 0
	THEN
	    BEGIN
	    EXTERNAL REGISTER Z;
	    PCEFST(.PCSTAK[.FP+.CURSMT[.I,STE_LOC],FRM_WRD])
	    END;
ROUTINE DOSBSS: NOVALUE =	! Extract substring

!++
! Functional description:
!	Performs SBS instruction: Extracts substring of string C, stores
!	substring in A.  B points to two constant words, containing
!	integer descriptors: First character (starts with 1) and length.
!	A length-designator of -1 means to extract to the end of the string.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	Instruction, operands
!
! Implicit outputs:
!	Instruction operand
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	OPAV: STR_VAL,		! Stringvalues
	OPCV: STR_VAL,
	STRT,			! Character offset
	LEN;			! Character count

    ! Take care to get the operands in this order; they might be on the stack
    LEN = .CURCNS[.INSTR[COD_OPB]+1];
    IF .LEN GEQ 0 THEN LEN = PCEGOP(.LEN,STE_TYP_INT);
    STRT = PCEGOP(.CURCNS[.INSTR[COD_OPB]],STE_TYP_INT);
    OPCV = PCEGOP(.INSTR[COD_OPC],STE_TYP_STR);
    IF .STRT LEQ 0 THEN ERROR('Substring start less than one');
    IF .LEN EQL -1 THEN LEN = .OPCV[STV_LEN]-.STRT+1;
    IF .STRT+.LEN-1 GTR .OPCV[STV_LEN] THEN LEN = .OPCV[STV_LEN]-.STRT+1;
    IF .LEN LSS 1
    THEN
	PCESOP(.INSTR[COD_OPA], 0, STE_TYP_STR)
    ELSE
	BEGIN
	OPAV = PCEAST(.LEN);
	CH$COPY(.LEN, CH$PTR(.OPCV[STV_ADR],.STRT-1),
		0, .LEN+1, BYTPTR(.OPAV[STV_ADR]));
	PCESOP(.INSTR[COD_OPA], .OPAV, STE_TYP_STR)
	END;
    IF .INSTR[COD_OPC] EQL OPN_TMP_STR THEN PCEFST(.OPCV)
    END;
ROUTINE DOCMND =		! DoCommand Statement

!++
! Functional description:
!	Copies string to be performed from A operand to
!	Exec's Command Buffer, after pointer CMPTR as
!	reported by EXECPM; appends newline.  Returns
!	number of characters in string inserted.  If B
!	operand field is zero, sets flag to indicate
!	Original mode.  If C is not -1, sets up Exec
!	to store Exec output into that string variable.
!	If string contains more than one line, generates
!	string block containing remaining lines.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	Instruction being executed
!
! Implicit outputs:
!	Exec Command Buffer
!
! Routine value:
!	Number of characters copied
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	OPND: STR_VAL,		! Operand descriptor
	PTRI,			! String pointers
	PTRO,
	ICNT,			! Characters inserted
	CHR;			! Character
    IF .PCCURC[ECB_PAR] NEQ 0
    THEN
	BEGIN
	IF PCIPRS(CFM_FLDDB,0) LSS 0 THEN PCMPER(0);
	PCCURC[ECB_PAR] = 0
	END;
    PCLDCO = 0;
    IF .INSTR[COD_OPB] EQL 0
    THEN
	IF .PCCURC[ECB_PSV] THEN PCLDCO = 1 ELSE PCLDCO = -1;
    IF (PCCURC[ECB_DTO] = .INSTR[COD_OPC]) NEQ %O'777777' THEN PCIPEO();
    OPND = PCEGOP(.INSTR[COD_OPA],STE_TYP_STR);
    PTRI = BYTPTR(.OPND[STV_ADR]);
    PTRO = .CMPTR;
    ICNT = 0;
    IF .OPND[STV_LEN] NEQ 0 THEN
    WHILE 1 DO
	BEGIN
	CHR = CH$RCHAR_A(PTRI);
	IF .CHR EQL $CHNUL THEN EXITLOOP;
	IF .CHR EQL $CHCRT
	THEN
	    BEGIN
	    LOCAL
		BLK: REF STB_BLK,	! String block
		SCNT,		! Characters skipped
		LEN;
	    SCNT = .ICNT + 1;
	    IF (CHR = CH$RCHAR(.PTRI)) EQL $CHLFD
	    THEN
		BEGIN
		CHR = CH$RCHAR_A(PTRI);
		SCNT = .SCNT + 1
		END;
	    IF .CHR EQL $CHNUL THEN EXITLOOP;
	    LEN = (.OPND[STV_LEN] - .SCNT + 9)/5;
	    BLK = PCMGMM(.LEN, XDICT);
	    BLK[STB_CNT] = .OPND[STV_LEN] - .SCNT;
	    BLK[STB_LEN] = .LEN;
	    PCCURC[ECB_DCB] = .BLK;
	    CH$MOVE(.BLK[STB_CNT], .PTRI, BYTPTR(BLK[STB_BUF]));
	    EXITLOOP
	    END
	ELSE
	    BEGIN
	    CH$WCHAR_A(.CHR,PTRO);
	    ICNT = .ICNT + 1
	    END
	END;
    IF .INSTR[COD_OPA] EQL OPN_TMP_STR THEN PCEFST(.OPND);
    CH$WCHAR_A($CHCRT,PTRO);
    CH$WCHAR_A($CHLFD,PTRO);
    CH$WCHAR_A($CHNUL,PTRO);
    .ICNT + 2
    END;
ROUTINE PUTDCL =		! Send additional DoCommand line

!++
! Functional description:
!	Pass additional DoCommand lines to Exec from string block
!	saved in ECB.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	Execution Context Block
!
! Implicit outputs:
!	Command string, Execution Context Block
!
! Routine value:
!	Number of characters inserted
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	BLK: REF STB_BLK,	! String block
	PTRI,			! String pointers
	PTRO,
	ICNT,			! Characters inserted
	RCNT,			! Characters remaining in string
	CHR;

    BLK = .PCCURC[ECB_DCB];
    PCCURC[ECB_DCB] = 0;
    ICNT = 0;
    PTRI = BYTPTR(BLK[STB_BUF]);
    PTRO = .CMPTR;
    RCNT = .BLK[STB_CNT];
    IF .RCNT GTR 0 THEN
    WHILE (RCNT=.RCNT-1) GEQ 0 DO
	BEGIN
	CHR = CH$RCHAR_A(PTRI);
	IF .CHR EQL $CHCRT
	THEN
	    BEGIN
	    LOCAL
		NBLK : REF STB_BLK,	! New string block
		LEN;
	    IF (CHR = CH$RCHAR(.PTRI)) EQL $CHLFD
	    THEN
		BEGIN
		CHR = CH$RCHAR_A(PTRI);
		CHR = CH$RCHAR(.PTRI);
		RCNT = .RCNT - 1
		END;
	    IF .RCNT LSS 0 THEN EXITLOOP;
	    LEN = (.RCNT + 9)/5;
	    NBLK = PCMGMM(.LEN, XDICT);
	    NBLK[STB_CNT] = .RCNT;
	    NBLK[STB_LEN] = .LEN;
	    PCCURC[ECB_DCB] = .NBLK;
	    CH$MOVE(.RCNT, .PTRI, BYTPTR(NBLK[STB_BUF]));
	    EXITLOOP
	    END
	ELSE
	    BEGIN
	    CH$WCHAR_A(.CHR,PTRO);
	    ICNT = .ICNT + 1
	    END
	END;
    RETMEM( .BLK[STB_LEN], .BLK, XDICT);
    CH$WCHAR_A($CHCRT,PTRO);
    CH$WCHAR_A($CHLFD,PTRO);
    .ICNT + 2
    END;
ROUTINE DOCARG(FFDB): NOVALUE =	! Get command arguments

!++
! Functional description:
!	Perform simple-format command parameter parsing.
!	Starting at first FLDDB, copy and execute each FLDDB,
!	storing the results of each successful one and aborting
!	to any error exit for each unsuccessful one.  After
!	the last FLDDB, require a .CMCFM.
!
! Formal parameters:
!	Constant index of first FLDDB, or -1 if only CONFIRM wanted
!
! Implicit inputs:
!	FLDDB list
!
! Implicit outputs:
!	User's variables
!
! Routine value:
!	None
!
! Side effects:
!	May change PC to enter error handler
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	PFDB: REF VECTOR,	! Proto-FLDDB pointer
	RFDB: REF VECTOR,	! Read-FLDDB pointer
	OPTFLG,			! Options
	HLFTMP: HLF_WRD;
    BIND
	TXT_FLDDB = UPLIT(%O'017000000000',0,0,0);

    PFDB = .FFDB;
    IF .PFDB GEQ 0
    THEN
    DO
	BEGIN
	RFDB = COPFDB(.PFDB);
	PFDB = .PFDB + .CURCNS;
	POINTR((RFDB[$CMFNP]),CM_LST) = 0;
	OPTFLG = (IF .POINTR((RFDB[$CMFNP]),CM_NIN) EQL 0 THEN 2 ELSE 0);
	! This stores results in system variables
	IF PCIPRS(.RFDB, .OPTFLG) LSS 0
	THEN
	    BEGIN
	    ! Take failure jump if provided, otherwise give standard error
	    RELFDB(.RFDB);
	    HLFTMP = .PFDB[$CMBRK];
	    IF .HLFTMP[HLF_RGT] EQL %O'777777'
	    THEN
		! Give this some text if there is ever any demand
		PCMPER(0)
	    ELSE
		BEGIN
		PC = .HLFTMP[HLF_RGT];
		PCIPRS(TXT_FLDDB, 0);
		RETURN
		END
	    END;
	RELFDB(.RFDB);
	HLFTMP = .PFDB[$CMBRK];
	IF .HLFTMP[HLF_LFT] NEQ %O'777777'
	THEN
	    CASE .POINTR((PFDB[$CMFNP]),CM_FNC) FROM $CMKEY TO $CMFLS OF
		SET
[$CMKEY,
 $CMNUM,
 $CMSWI]:	PCESOP(.HLFTMP[HLF_LFT], .PCVVAL, STE_TYP_INT);
[$CMIFI,
 $CMOFI,
 $CMFIL,
 $CMFLS]:	PCESOP(.HLFTMP[HLF_LFT], PCECST(DIVFNM()), STE_TYP_STR);
[$CMFLD,
 $CMDIR,
 $CMUSR,
 $CMDEV,
 $CMTXT,
 $CMTAD,
 $CMQST,
 $CMNOD]:	PCESOP(.HLFTMP[HLF_LFT], PCECST(.PCVATM), STE_TYP_STR);
[INRANGE]:	;
		TES
	END
	    UNTIL (PFDB = .POINTR((PFDB[$CMFNP]),CM_LST)) EQL 0;
    IF PCIPRS(CFM_FLDDB, 0) LSS 0 THEN PCMPER(0);
    PCCURC[ECB_PAR] = 0
    END;
ROUTINE DPARSE: NOVALUE =	! Parse instruction

!++
! Functional description:
!	Execute PRS instruction.  Field A contains location of
!	first field descriptor block in the chain; it is position
!	independent so I must allocate temporary space for each
!	block and rebuild everything.  Then I pass the copied list
!	to the Interface to do a COMND%.  The Interface will return
!	the address of the successful FLDDB, so I can jump
!	accordingly.  If nothing succeeded, I jump to operand C,
!	or issue a standard error message if C is -1.
!	If a reparse happened, I jump back to the user's last
!	Prompt instruction.
!	After releasing the temporary space, I am done.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	Instruction stream, field descriptor blocks
!
! Implicit outputs:
!	None
!
! Routine value:
!	None
!
! Side effects:
!	Causes a Jump to the selected processing
!	routine, and causes appropriate system variables to be set.
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	IFDB,			! Proto-FLDDB pointer
	OFDB,			! Real-FLDDB pointer
	TFDB,			! First real FLDDB
	SUCC,			! Success address
	OPTFLG;			! Options for the parse

    IF .PCCURC[ECB_PAR] EQL 0 THEN ERROR('No command parse in progress');
    IFDB = .INSTR[COD_OPA];
    OFDB = COPFDB(.IFDB);
    TFDB = .OFDB;
    OPTFLG = (IF .POINTR((.OFDB+$CMFNP),CM_NIN) EQL 0 THEN 2 ELSE 0);
    IF .PCCURC[ECB_SCM] THEN OPTFLG = .OPTFLG + 1;
    WHILE .POINTR((CURCNS[.IFDB+$CMFNP]),CM_LST) NEQ 0 DO
	BEGIN
	IFDB = .POINTR((CURCNS[.IFDB+$CMFNP]),CM_LST);
	POINTR((.OFDB+$CMFNP),CM_LST) = COPFDB(.IFDB);
	OFDB = .POINTR((.OFDB+$CMFNP),CM_LST)
	END;
    POINTR((.OFDB+$CMFNP),CM_LST) = 0;
    SUCC = PCIPRS(.TFDB, .OPTFLG);
    IFDB = .TFDB;
    IF .SUCC GTR 0
    THEN
	BEGIN
	PC = .(.SUCC+$CMBRK);
	IF .POINTR((.SUCC+$CMFNP),CM_FNC) EQL $CMCFM THEN PCCURC[ECB_PAR] = 0
	END;
    WHILE .IFDB NEQ 0 DO
	BEGIN
	OFDB = .IFDB;
	IFDB = .POINTR((.IFDB+$CMFNP),CM_LST);
	RELFDB(.OFDB)
	END;
    IF .SUCC LEQ 0
    THEN
	IF .SUCC EQL -2
	THEN
	    PC = .LSTPMT
	ELSE
	IF .INSTR[COD_OPC] EQL %O'777777'
	THEN
	    PCMPER(0)
	ELSE
	    PC = .INSTR[COD_OPC]
    END;
ROUTINE COPFDB(IFDB) =	! Make real FLDDB from prototype

!++
! Functional description:
!	  Given a proto-FLDDB, get a temporary block and make a real
!	FLDDB in it from the proto-FLDDB.  If the field type requires
!	only the basic five words, fine; if not, copy and relocate all
!	the additional information (help string, keyword table, etc.).
!	Returns the real address of this real FLDDB, which must be
!	completely ready for a COMND%.
!	  This routine is necessary because routines are stored in
!	position-independent format.  This position independence
!	applies to the pointers in FLDDB's, so all pointers to
!	strings and TBLUK% tables must be relocated.
!
! Formal parameters:
!	Index into constants of prototype FLDDB
!
! Implicit inputs:
!	None
!
! Implicit outputs:
!	None
!
! Routine value:
!	Real address of real FLDDB
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	OPV: STR_VAL,		! String temporary
	PFDB: REF VECTOR,	! Prototype FLDDB
	RFDB: REF VECTOR;	! Real FLDDB
    PFDB = .IFDB + .CURCNS;
    RFDB = GETBUF(5);
    RFDB[$CMFNP] = .PFDB[$CMFNP];    
    RFDB[$CMBRK] = .PFDB[$CMBRK];
    CASE .POINTR((RFDB[$CMFNP]),CM_FNC) FROM $CMKEY TO $CMFLS OF
	SET
[$CMKEY]:   RFDB[$CMDAT] = COPKWT(.PFDB);
[$CMNUM]:   RFDB[$CMDAT] = .PFDB[$CMDAT];
[$CMNOI]:   BEGIN
	    OPV = PCEGOP(.PFDB[$CMDAT],STE_TYP_STR);
	    RFDB[$CMDAT] = BYTPTR(.OPV[STV_ADR])
	    END;
[$CMSWI]:   RFDB[$CMDAT] = COPKWT(.PFDB);
[$CMFIL,
 $CMFLS]:   COPFDF(.PFDB[$CMDAT]);
[$CMTAD]:   RFDB[$CMDAT] = .PFDB[$CMDAT];
[$CMTOK]:   BEGIN
	    OPV = PCEGOP(.PFDB[$CMDAT],STE_TYP_STR);
	    RFDB[$CMDAT] = BYTPTR(.OPV[STV_ADR])
	    END;
[INRANGE]:  ;
	TES;
    IF .POINTR((RFDB[$CMFNP]),CM_HPP)
    THEN
	BEGIN
	OPV = PCEGOP(.PFDB[$CMHLP],STE_TYP_STR);
	RFDB[$CMHLP] = BYTPTR(.OPV[STV_ADR])
	END;
    IF .POINTR((RFDB[$CMFNP]),CM_DPP)
    THEN
	BEGIN
	OPV = PCEGOP(.PFDB[$CMDEF],STE_TYP_STR);
	RFDB[$CMDEF] = BYTPTR(.OPV[STV_ADR])
	END;
    .RFDB
    END;
ROUTINE COPKWT(PFDB) =	! Copy keyword table

!++
! Functional description:
!	Copies keyword table for Parse.
!
! Formal parameters:
!	Address of prototype FLDDB
!
! Implicit inputs:
!	None
!
! Implicit outputs:
!	None
!
! Routine value:
!	Real address of real keyword table
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    MAP
	PFDB: REF VECTOR;	! Prototype FLDDB
    LOCAL
	CNT: HLF_WRD,		! Keyword count
	HLFTMP: HLF_WRD,	! Temporary
	RTBL: REF VECTOR,	! Pointer to real keyword table
	PTBL: REF VECTOR;	! Pointer to prototype keyword table
    PTBL = .PFDB[$CMDAT] + .CURCNS;
    CNT = .PTBL[0];
    CNT = .CNT[HLF_RGT];
    RTBL = GETBUF(.CNT+1);
    RTBL[0] = .PTBL[0];
    PTBL = .PTBL+1;
    DECR I FROM .CNT-1 DO
	BEGIN
	HLFTMP = .PTBL[.I];
	HLFTMP[HLF_LFT] = .HLFTMP[HLF_LFT] + .CURCNS;
	RTBL[.I+1] = .HLFTMP
	END;
    .RTBL
    END;
ROUTINE COPFDF(DAT): NOVALUE =	! Copy FILE defaults

!++
! Functional description:
!	Set up the GTJFN block for a .CMFIL or .CMFLS parse.  If the user
!	supplies a list of defaults, fill in the appropriate fields; otherwise
!	clear the GTJFN block.
!
! Formal parameters:
!	Constant index of default list from prototype
!
! Implicit inputs:
!	None
!
! Implicit outputs:
!	GTJFN block
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	STR: STR_VAL;		! User's string

    DECR I FROM $GJACT-1 DO CJFNBK[.I] = 0;
    CJFNBK[$GJF2] = 0;
    IF .DAT EQL 0 THEN RETURN;
    CJFNBK[$GJGEN] = .CURCNS[.DAT];
    CJFNBK[$GJF2] = .CURCNS[.DAT+1];
    DECR I FROM $GJEXT TO $GJDEV DO
	IF .CURCNS[.DAT+.I] NEQ -1
	THEN
	    BEGIN
	    STR = PCEGOP(.CURCNS[.DAT+.I],STE_TYP_STR);
	    CJFNBK[.I] = BYTPTR(.STR[STV_ADR])
	    END
    END;
ROUTINE RELFDB(OFDB): NOVALUE =	! Free storage for real FLDDB

!++
! Functional description:
!	Frees temporary block used for real FLDDB, including copies
!	of Help and Default strings, and keyword table
!
! Formal parameters:
!	Real address of FLDDB
!
! Implicit inputs:
!	None
!
! Implicit outputs:
!	None
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    MAP
	OFDB: REF VECTOR;
    IF (.POINTR((OFDB[$CMFNP]),CM_FNC) EQL $CMKEY) OR
	(.POINTR((OFDB[$CMFNP]),CM_FNC) EQL $CMSWI)
    THEN
	BEGIN
	LOCAL
	    PTR,
	    CNT: HLF_WRD;
	PTR = .OFDB[$CMDAT];
	CNT = ..PTR;
	RETMEM( .CNT[HLF_RGT]+1, .PTR, DICT)
	END;
    RETMEM(4,.OFDB,DICT);
    END;
ROUTINE DPRMPT: NOVALUE =	! Prompt instruction

!++
! Functional description:
!	Execute PMT/PMN instruction.  Begin new command-parse line
!	with the prompt given in string A.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	Instruction stream
!
! Implicit outputs:
!	None
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL STR: STR_VAL;
    LSTPMT = .PC;
    PCCURC[ECB_SCM] = 1;
    PCCURC[ECB_PAR] = 1;
    PCCURC[ECB_ECO] = (IF .INSTR[COD_OPR] EQL OPR_PMT THEN 0 ELSE 1);
    STR = PCEGOP(.INSTR[COD_OPA],STE_TYP_STR);
    PCIPRS(0,.PCCURC[ECB_ECO],BYTPTR(.STR[STV_ADR]));
    END;
ROUTINE GETEOP: NOVALUE =	! Get Exec output

!++
! Functional description:
!	Get accumulated Exec typeout saved through PCL's PTY,
!	and store it in the user variable designated in the last
!	DoCommand instruction.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	Designator saved in ECB, PCPEOP
!
! Implicit outputs:
!	None
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	PTR: REF STB_BLK,	! String block
	DESIG,			! Designator of result
	OPV: STR_VAL;		! Stringvalue being created
    PCIPSO();
    ! Perhaps this should use EXCH
    PTR = .PCPEOP;
    PCPEOP = 0;
    DESIG = .PCCURC[ECB_DTO];
    PCCURC[ECB_DTO] = %O'777777';
    IF .PTR EQL 0
    THEN
	OPV = 0
    ELSE
    IF .PTR LSS 0
    THEN
	ERROR('Exec ran out of space storing typeout')
    ELSE
	BEGIN
	OPV = PCEAST(.PTR[STB_CNT]);
	IF .OPV NEQ 0
	THEN
	    CH$COPY(.PTR[STB_CNT], BYTPTR(PTR[STB_BUF]),
		    0, .OPV[STV_LEN]+1, BYTPTR(.OPV[STV_ADR]));
	RETMEM(.PTR[STB_LEN], .PTR, XDICT)
	END;
    PCESOP(.DESIG, .OPV, STE_TYP_STR)
    END;
ROUTINE DOTINP(FLG): NOVALUE =	! Typein instruction

!++
! Functional description:
!	Executes TIN or TIX instruction: Takes string operand A and copies
!	the string into the PTY controlling the user program.  PCL
!	execution waits until the program requires input.
!
! Formal parameters:
!	Flag: 0=TIN, 1=TIX
!
! Implicit inputs:
!	Instruction, operand
!
! Implicit outputs:
!	None
!
! Routine value:
!	None
!
! Side effects:
!	Waits for controlled program to need attention
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	OPND: STR_VAL,		! Operand descriptor
	SV: STR_VAL,		! Another string
	PTRI,			! String pointers
	PTRO,
	CHR,
	CNT;
    OPND = PCEGOP(.INSTR[COD_OPA],STE_TYP_STR);
    SV = PCEAST(.OPND[STV_LEN]+(IF .FLG EQL 0 THEN 1 ELSE 0));
    PTRI = BYTPTR(.OPND[STV_ADR]);
    PTRO = BYTPTR(.SV[STV_ADR]);
    CNT = .SV[STV_LEN];
    DECR I FROM .OPND[STV_LEN]-1 DO
	IF (CHR = CH$RCHAR_A(PTRI)) NEQ $CHLFD
	THEN
	    CH$WCHAR_A(.CHR,PTRO)
	ELSE
	    CNT = .CNT - 1;
    IF .FLG EQL 0 THEN CH$WCHAR_A($CHCRT,PTRO);
    CH$WCHAR_A($CHNUL,PTRO);
    IF .INSTR[COD_OPA] EQL OPN_TMP_STR THEN PCEFST(.OPND);
    PCITIN(BYTPTR(.SV[STV_ADR]), .CNT);
    PCEFST(.SV)
    END;
ROUTINE DOGTYO: NOVALUE =	! Gettypout instruction

!++
! Functional description:
!	Obtains all output from user program accumulated since start
!	(or since last call to this routine) and stores in operand A
!	if not -1.

!
! Formal parameters:
!	None
!
! Implicit inputs:
!	Accumulated output string block
!
! Implicit outputs:
!	User's string variable
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	PTR: REF STB_BLK,	! String block
	OPV: STR_VAL;		! Stringvalue being created
    BUILTIN MACHOP;
    REGISTER R1=1;
    PCIPSO();
    R1 = 0;
    ! I wish there were still an EXCH primitive
    MACHOP(%O'250',R1,PCPOTP);
    PTR = .R1;
    IF .PTR EQL 0
    THEN
	OPV = 0
    ELSE
    IF .PTR LSS 0
    THEN
	ERROR('Exec ran out of space storing typeout')
    ELSE
	BEGIN
	IF .INSTR[COD_OPA] NEQ %O'777777'
	THEN
	    BEGIN
	    OPV = PCEAST(.PTR[STB_CNT]);
	    CH$COPY(.PTR[STB_CNT], BYTPTR(PTR[STB_BUF]),
		    0, .OPV[STV_LEN]+1, BYTPTR(.OPV[STV_ADR]))
	    END;
	RETMEM(.PTR[STB_LEN], .PTR, XDICT)
	END;
    IF .INSTR[COD_OPA] NEQ %O'777777'
    THEN
	PCESOP(.INSTR[COD_OPA], .OPV, STE_TYP_STR)
    END;
ROUTINE DODPLY(FLG,TYP): NOVALUE =	! Display instruction

!++
! Functional description:
!	Display string in operand A on real terminal.
!
! Formal parameters:
!	0 for normal display, 1 for binary, -1 for normal without CRLF
!	GST_TYP_INT or GST_TYP_STR (type of value being displayed)
!
! Implicit inputs:
!	Instruction, operand
!
! Implicit outputs:
!	None
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	OPNS: STR_VAL,		! Operand (if a string)
	OPNI;			! Operand (if an integer)
    IF .TYP EQL GST_TYP_STR
    THEN
	BEGIN
	OPNS = PCEGOP(.INSTR[COD_OPA],STE_TYP_STR);
        PCIDPY(.OPNS[STV_ADR], .OPNS[STV_LEN], .FLG, .TYP);
        IF .INSTR[COD_OPA] EQL OPN_TMP_STR THEN PCEFST(.OPNS)
	END
    ELSE			! Integer
	BEGIN
	OPNI = PCEGOP(.INSTR[COD_OPA],STE_TYP_INT);
        PCIDPY(.OPNI, 0, .FLG, .TYP);
	END
    END;
ROUTINE CLIPRC: NOVALUE =	! Call internal routine

!++
! Functional description:
!	  After slightly validating the operands, this routine invokes
!	the requested system procedure, passing it the user's
!	argument list, and storing the value if the procedure returns one.
!
! Formal parameters:
!	None
!
! Implicit inputs:
!	PC, instruction word, symbol table, definition table
!
! Implicit outputs:
!	None
!
! Routine value:
!	None
!
! Side effects:
!	None
!
!--

%( Needs optimization of PSDEFN reference )%

    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	ARG,
	CNT,
	RTN: OPRAND,
	IDX,
	VAL;
    ARG = .INSTR[COD_OPB];
    IF .ARG EQL %O'777777' THEN CNT = 0 ELSE CNT = .CURCNS[.ARG];
    ARG = .ARG + .CURCNS + 1;
    RTN[OPN_WRD] = .INSTR[COD_OPA];
    IDX = .RTN[OPN_ADR];
    IF .IDX GEQ PSDEFL THEN ERROR('Bad system procedure index');
    IF .PSDEFN[.IDX,SYN_CLS] EQL SYN_CLS_VAR THEN ERROR('Not a procedure');
    VAL = EXEC(.PSDEFN[.IDX,SYN_ADR],.ARG,.CNT);
    IF .PSDEFN[.IDX,SYN_CLS] GEQ SYN_CLS_FCN
    THEN
	PCESOP(.INSTR[COD_OPC], .VAL, .PSDEFN[.IDX,SYN_TYP])
    END;
GLOBAL ROUTINE PCEXCT(XCTPTR) =	! Main executer loop

!++
! Functional description:
!	This routine makes up the outer loop of the executer.
!	It is called with the address of the Execution Context Block to
!	be executed.  After establishing the context defined there,
!	it starts it running (or continues an execution interrupted by
!	a DoCommand statement) by entering the fetch-execute cycle until
!	it is terminated by a Return from the outermost procedure, or
!	by a DoCommand statement.  The return value indicates which case
!	holds.  It may be that execution was terminated by a DoCommand
!	statement which generated more than one line; in that case, the
!	next line is passed to the Exec and control returns immediately.
!
! Formal parameters:
!	Byte pointer to Command Buffer to be filled
!
! Implicit inputs:
!	Everything that matters
!
! Implicit outputs:
!	Everything that matters
!
! Routine value:
!	-1 or -2 if completed by Exit, number of characters inserted
!	into Command Buffer if Perform, -3 to exit to the program.
!
! Side effects:
!	Uncountable and unpredictable
!
!--


    BEGIN
    EXTERNAL REGISTER Z;
    LOCAL
	OPR,			! Current instruction code
	OPAV: STR_VAL,		! Temporaries for operands
	OPBV: STR_VAL,
	OPCV: STR_VAL,
	HALTCD,			! Halt code
	ECB: REF ECB_BLK;	! Temporary for current Execution Context Block
    LABEL
	HALTEX;			! Stop execution
    ECB = .PCCURC;
    CMPTR = .XCTPTR;
    IF .ECB[ECB_DCB] NEQ 0 THEN RETURN PUTDCL();
    CURGST = .ECB[ECB_PRC];
    SETCTX();
    PC = .ECB[ECB_PC];
    STKP = .ECB[ECB_SP];
    FP = .ECB[ECB_FP];
    IF .FP EQL 0
    THEN
	BEGIN
	LOCAL
	    GST: REF GST_BLK,	! Global symbol table entry
	    PTR;		! Temporary
	PTR = .ECB[ECB_STK];
	FP = .PTR;
	PTR = .PTR + PCSTAK + FRM_LOC;
	GST = .CURGST;
	DECR I FROM .GST[GST_SLN]-1 DO
	    BEGIN
	    .PTR = 0;
	    PTR = .PTR + 1
	    END;
	IF .GST[GST_CMA] GEQ -1
	THEN
	    DOCARG(.GST[GST_CMA]);
	END
    ELSE
    IF .ECB[ECB_DTO] NEQ %O'777777' THEN GETEOP();

    HALTCD =
HALTEX:(WHILE .PC GEQ 0 DO
	BEGIN
	IF .PC GTR .CURCDL THEN ERROR('PC out of bounds');
	INSTR = .CURCOD[.PC,COD_CNS];
	INSTR+1 = .CURCOD[.PC+1,COD_CNS];
	IF .INSTR[COD_VLD] NEQ COD_VLD_NUM
	THEN
	    ERROR('Jump to non-instruction');
	OPR = .INSTR[COD_OPR];
	IF .OPR LSS 0 OR .OPR GTR OPR_LST THEN ERROR('Illegal operation code');
	PC = .PC+1;
	IF .OPR LSS OPR_11W THEN PC = .PC+1;
	IF .OPR GEQ OPR_ADD AND .OPR LEQ OPR_DIV THEN
	    BEGIN
	    ! Must fetch C before B because if they are temporaries
	    ! B will have been generated (and pushed) before C
	    OPCV = PCEGOP(.INSTR[COD_OPC],STE_TYP_INT);
	    OPBV = PCEGOP(.INSTR[COD_OPB],STE_TYP_INT);
	    OPAV = (CASE .OPR FROM OPR_ADD TO OPR_DIV OF
		SET
[OPR_ADD]:	.OPBV + .OPCV;
[OPR_SUB]:	.OPBV - .OPCV;
[OPR_MUL]:	.OPBV * .OPCV;
[OPR_DIV]:	.OPBV / .OPCV;
		TES);
	    PCESOP(.INSTR[COD_OPA],.OPAV,STE_TYP_INT)
	    END ELSE
	IF .OPR EQL OPR_CNS
	THEN
	    BEGIN
	    OPCV = PCEGOP(.INSTR[COD_OPC],STE_TYP_STR);
	    OPBV = PCEGOP(.INSTR[COD_OPB],STE_TYP_STR);
	    OPAV = PCEAST(.OPBV[STV_LEN] + .OPCV[STV_LEN]);
	    CH$COPY(.OPBV[STV_LEN], BYTPTR(.OPBV[STV_ADR]),
		    .OPCV[STV_LEN], BYTPTR(.OPCV[STV_ADR]),
		    0, .OPBV[STV_LEN]+.OPCV[STV_LEN]+1,BYTPTR(.OPAV[STV_ADR]));
	    IF .INSTR[COD_OPB] EQL OPN_TMP_STR THEN PCEFST(.OPBV);
	    IF .INSTR[COD_OPC] EQL OPN_TMP_STR THEN PCEFST(.OPCV);
	    PCESOP(.INSTR[COD_OPA],.OPAV,STE_TYP_STR)
	    END
	ELSE
	IF .OPR EQL OPR_STO
	THEN
	    PCESOP(.INSTR[COD_OPA],
		    PCEGOP(.INSTR[COD_OPC],STE_TYP_INT),STE_TYP_INT)
	ELSE
	IF .OPR EQL OPR_STS
	THEN
	    BEGIN
	    OPCV = PCEGOP(.INSTR[COD_OPC],STE_TYP_STR);
	    IF .INSTR[COD_OPC] NEQ OPN_TMP_STR THEN OPCV = PCECST(.OPCV);
	    PCESOP ( .INSTR[COD_OPA], .OPCV, STE_TYP_STR)
	    END
	ELSE
	IF .OPR GEQ OPR_BLE AND .OPR LEQ OPR_BGT THEN
	    BEGIN
	    OPAV = .INSTR[COD_OPA];
	    OPCV = PCEGOP(.INSTR[COD_OPC],STE_TYP_INT);
	    OPBV = PCEGOP(.INSTR[COD_OPB],STE_TYP_INT);
	    CASE .OPR FROM OPR_BLE TO OPR_BGT OF
		SET
[OPR_BLE]:	IF .OPBV LEQ .OPCV THEN PC = .OPAV;
[OPR_BLT]:	IF .OPBV LSS .OPCV THEN PC = .OPAV;
[OPR_BEQ]:	IF .OPBV EQL .OPCV THEN PC = .OPAV;
[OPR_BNE]:	IF .OPBV NEQ .OPCV THEN PC = .OPAV;
[OPR_BGE]:	IF .OPBV GEQ .OPCV THEN PC = .OPAV;
[OPR_BGT]:	IF .OPBV GTR .OPCV THEN PC = .OPAV;
		TES
	    END ELSE
	IF .OPR GEQ OPR_CLE AND .OPR LEQ OPR_CGT THEN
	    BEGIN
	    LOCAL
		OPBL,
		OPCL,
		OPBP,
		OPCP;
	    OPCV = PCEGOP(.INSTR[COD_OPC],STE_TYP_STR);
	    OPCL = .OPCV[STV_LEN];
	    OPCP = BYTPTR(.OPCV[STV_ADR]);
	    OPBV = PCEGOP(.INSTR[COD_OPB],STE_TYP_STR);
	    OPBL = .OPBV[STV_LEN];
	    OPBP = BYTPTR(.OPBV[STV_ADR]);
	    IF (CASE .OPR FROM OPR_CLE TO OPR_CGT OF
		SET
[OPR_CLE]:	CH$LEQ(.OPBL,.OPBP,.OPCL,.OPCP);
[OPR_CLT]:	CH$LSS(.OPBL,.OPBP,.OPCL,.OPCP);
[OPR_CEQ]:	CH$EQL(.OPBL,.OPBP,.OPCL,.OPCP);
[OPR_CNE]:	CH$NEQ(.OPBL,.OPBP,.OPCL,.OPCP);
[OPR_CGE]:	CH$GEQ(.OPBL,.OPBP,.OPCL,.OPCP);
[OPR_CGT]:	CH$GTR(.OPBL,.OPBP,.OPCL,.OPCP);
		TES) THEN PC = .INSTR[COD_OPA];
	    IF .INSTR[COD_OPB] EQL OPN_TMP_STR THEN PCEFST(.OPBV);
	    IF .INSTR[COD_OPC] EQL OPN_TMP_STR THEN PCEFST(.OPCV)
	    END
	ELSE
	CASE .OPR FROM OPR_CAL TO OPR_DIN OF
	    SET
[OPR_CAL]:	BEGIN
		LOCAL
		    OPN: OPRAND;
		OPN[OPN_WRD]=.INSTR[COD_OPA];
		IF .OPN[OPN_CLS] EQL OPN_CLS_SYN
		THEN
		    CLIPRC()
		ELSE
		    CALPRC()
		END;
[OPR_SBS]:	DOSBSS();
[OPR_DCM]:	LEAVE HALTEX WITH DOCMND();
[OPR_PRS]:	DPARSE();
[OPR_JMP]:	PC = .INSTR[COD_OPA];
[OPR_RET]:	IF .FP EQL .ECB[ECB_STK]
		THEN
		    LEAVE HALTEX WITH -1
		ELSE
		    RETPRC();
[OPR_CAS]:	DOCASE();
[OPR_IVP,
 OPR_IVO]:	BEGIN
		OPAV = PCEGOP(.INSTR[COD_OPA],STE_TYP_STR);
		PCIIVK(.OPAV,(IF .OPR EQL OPR_IVP THEN 0 ELSE 1));
		IF .INSTR[COD_OPA] EQL OPN_TMP_STR THEN PCEFST(.OPAV)
		END;
[OPR_TIN]:	DOTINP(0);
[OPR_TIX]:	DOTINP(1);
[OPR_GTO]:	DOGTYO();
[OPR_KIL]:	PCIKIF();
[OPR_DPY]:	DODPLY(0,GST_TYP_STR);
[OPR_DPB]:	DODPLY(1,GST_TYP_STR);
[OPR_DPN]:	DODPLY(-1,GST_TYP_STR);
[OPR_DIY]:	DODPLY(0,GST_TYP_INT);
[OPR_DIB]:	DODPLY(1,GST_TYP_INT);
[OPR_DIN]:	DODPLY(-1,GST_TYP_INT);
[OPR_XIT]:	LEAVE HALTEX WITH -.INSTR[COD_OPA]-1;
[OPR_ABT]:	BEGIN
		OPAV = PCEGOP(.INSTR[COD_OPA],STE_TYP_STR);
		IF .OPAV NEQ 0
		THEN
		    BEGIN
		    LOCAL
			PTRO,
			CHR;
		    OPAV = BYTPTR(.OPAV[STV_ADR]);
		    PTRO = BYTPTR(.CSBUFP[STV_ADR]+1);
		    DO (CHR=CH$RCHAR_A(OPAV); CH$WCHAR_A(.CHR,PTRO))
		      WHILE .CHR NEQ $CHNUL;
		    OPAV = .CSBUFP[STV_ADR]+1
		    END;
		PCICLP(1);
		CLNVAR();
		PCMXER(.OPAV)
		END;
[OPR_NOP]:	;
[OPR_PSH]:	BEGIN
		OPAV = .PCSTAK[.STKP,FRM_WRD];
		IF .INSTR[COD_OPA] EQL OPN_TMP_STR
		THEN
		    OPAV = PCECST(.OPAV);
		IF .STKP EQL STAKLN
	        THEN
		    ERROR('Stack full');
		STKP = .STKP + 1;
		PCSTAK[.STKP,FRM_WRD] = .OPAV
		END;
[OPR_POP]:	BEGIN
		OPAV = .PCSTAK[.STKP,FRM_WRD];
		STKP = .STKP - 1;
		IF .INSTR[COD_OPA] EQL OPN_TMP_STR THEN PCEFST(.OPAV)
		END;
[OPR_PMT,OPR_PMN]:
		DPRMPT()
	    TES
	END);
!+
! Execution is finished, at least for now.  The termination codes are:
!    positive: DoCommand
!    -1: Exit after cleanup
!    -2: Exit but don't kill the program fork
!    -3: Exit to the program
! If the termination code is -2 or -3 then we make the invoked program
! be the current fork (by setting FORK to its fork handle).
!-
    IF .PCCURC[ECB_PAR] NEQ 0
    THEN
	BEGIN
	IF PCIPRS(CFM_FLDDB,0) LSS 0 THEN PCMPER(0);
	PCCURC[ECB_PAR] = 0
	END;
    IF .HALTCD LSS 0
    THEN
	BEGIN
        IF .HALTCD EQL -2 OR .HALTCD EQL -3
        THEN
	    BEGIN
	    FORK = .ECB[ECB_CFK];
	    PCFORK = -2;
	    PCRNFK = -2;
	    CLRINV(.FORK);		! Fork is no longer INVOKE'd
	    END;
	PCICLP((IF .HALTCD EQL -1 THEN -1 ELSE 0));
	CLNVAR();
	STKP = .ECB[ECB_STK] - 1
	END
    ELSE
	BEGIN
	ECB[ECB_PRC] = .CURGST;
	ECB[ECB_PC] = .PC;
	ECB[ECB_FP] = .FP;
	ECB[ECB_SP] = .STKP
	END;
    .HALTCD
    END;
END
ELUDOM