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