*           P-Code Interpreter Runtime Package

*           This module contains the following routines:

*           P$FJP       False jump
*           P$XJP       Indexed jump
*           P$CUP       Call user procedure
*           P$RET       Return from procedure
*           P$BOMB      Handle exceptional conditions
*           P$SPC       Store packed character
*           P$LPC       Load packed character

            SEG
            RLIT

            ENT         P$FJP,FJPECB
            ENT         P$XJP,XJPECB
            ENT         P$CUP,CUPECB
            ENT         P$RET,RETECB
            ENT         P$BOMB,BOMBECB
            ENT         P$SPC,SPCECB
            ENT         P$LPC,LPCECB

            EXT         CSTORE
            EXT         SP
            EXT         MP
            EXT         EP
            EXT         NP
CSTORE      COMM        STOREX

            DYNM        P(3),Q(3),ERRADR
F_ARG       EQU         P
ERROUT      EQU         -15

            EJCT
* p$fjp --- False jump instruction processor

P$FJP       ARGT                    Q
            FLX         SP
            LDL         STOREX,X    Get top of stack
            BLNE        RTN         Ignore if TRUE
            LDA         F_ARG,*     Pick up branch address
            STA         SB%+3       Modify return address

RTN         LDA         SP          Pop stack
            S1A
            STA         SP
            PRTN


            LINK
FJPECB      ECB         P$FJP,,F_ARG,1
            PROC
            EJCT
* p$xjp --- Indexed jump instruction processor

P$XJP       ARGT                    Q
            FLX         SP
            LDA         STOREX+1,X  Pick up index value
            ADD         F_ARG,*     Compute effective address
            STA         SB%+3       Modify return address

            LDA         SP          Pop stack
            S1A
            STA         SP
            PRTN

            LINK
XJPECB      ECB         P$XJP,,F_ARG,1
            PROC
            EJCT
* p$cup --- Call user procedure instruction processor

P$CUP       ARGT                    P
            LDA         P,*         P is number of locations for parameters
            ADD         =5-1        Plus 5 locations for mark information
            TCA
            ADD         SP
            STA         MP          Update Mark Pointer
            PRTN

            LINK
CUPECB      ECB         P$CUP,,P,1
            PROC
            EJCT
* p$ret --- Return instruction processor

P$RET       ARGT
            LDA         P,*         Get P field
            LEQ
            ARL         1           Set C-bit if P was zero
            LDA         MP
            SRC                     Skip if P was non-zero
            S1A
            STA         SP          Restore stack pointer
            FLX         MP
            LDA         STOREX+7,X  Get saved EP register
            STA         EP
            LDA         STOREX+5,X  Get saved mark pointer
            STA         MP
            PRTN


            LINK
RETECB      ECB         P$RET,,P,1
            PROC
            EJCT
* p$bomb --- Handle exceptional conditions (i.e. give up)

P$BOMB      ARGT                    Message
            CALL        PUTCH       Print a NEWLINE
            AP          ='212,S
            AP          =-15,SL

            CALL        REMARK      Print caller's message
            AP          F_ARG,*SL

            CALL        PRINT       Print register contents
            AP          =-15,S
            AP          FMT,S
            AP          MP,S
            AP          SP,S
            AP          EP,S
            AP          NP,SL

            CALL        P$WALK      Print procedure walkback
            CALL        SWT         Bomb out to SWT shell


            LINK
BOMBECB     ECB         P$BOMB,,F_ARG,1
FMT         BCI         "mp = *i, sp = *i, ep = *i, np = *i*n*n."
            PROC
            EJCT
* p$spc --- Store packed character

P$SPC       LDA         SP
            SUB         =3          Pop stack
            STA         SP
            A1A
            ALL         1
            TAX
            EAXB        STOREX,X    Point to new top of stack + 1
            LDL         XB%         Get store index of string
            LLL         2           Convert to byte index
            ADL         XB%+2       Add position within string
            LRL         1           Word index, set c-bit if odd byte
            TBA
            TAX
            LDA         STOREX,X    Get destination word
            SSC                     Skip if we're storing odd byte
            ICA                     Swap bytes
            CAR
            ERA         XB%+5       Insert new character
            SSC
            ICA                     Put bytes back in right order
            STA         STOREX,X
            PRTN
            LINK
SPCECB      ECB         P$SPC
            PROC
            EJCT
* p$lpc --- Load packed character

P$LPC       LDA         SP
            S1A                     Pop stack
            STA         SP
            ALL         1
            TAX
            EAXB        STOREX,X    Point to new top of stack
            LDL         XB%         Get store index of string
            LLL         2           Convert to byte index
            ADL         XB%+2       Add position within string
            LRL         1           Word index, set c-bit if odd byte
            TBA
            TAX
            LDA         STOREX,X
            SSC                     Skip if we're getting odd byte
            ICL                     Swap bytes, even byte is now on right
            CAL                     Zero left byte
            XCA                     Convert to long integer
            STL         XB%         Put character on stack
            PRTN

            LINK
LPCECB      ECB         P$LPC
            PROC

            END
* p$walk --- Walk back through the stack

            SEG
            RLIT

            SUBR  P$WALK
            EXT   PRINT

            DYNM  REGISTERS(28), LASTFRAME

START       E64V
            RSAV  REGISTERS

            PCL   PRINTP,*    PRINT HEADING
            AP    =-15,S
            AP    HEADING,SL

            EALB  SB%         POINT TO CURRENT FRAME

LOOP        LDL   LB%+4       CHECK SAVED STACK REGISTER
            BLEQ  EXITLOOP      IT'S ZERO, NO CALLER
            STL   LASTFRAME
            EAL   LB%
            ANA   ='7777      MASK OUT RING NUMBER
            CLS   LASTFRAME   CHECK NEXT FRAME SAME AS THIS ONE
            SKP                 NO
            JMP   EXITLOOP      YES

            PCL   PRINTP,*
            AP    =-15,S
            AP    LINEFMT,S
            AP    LB%+12,S    LINE NUMBER
            AP    LB%+2,S     SAVED PBH
            AP    LB%+3,S     SAVED PBL
            AP    LB%+4,S     SAVED SBH
            AP    LB%+5,S     SAVED SBL
            AP    LB%+6,S     SAVED LBH
            AP    LB%+7,SL    SAVED LBL

            EALB  LB%+4,*     POINT TO CALLER'S FRAME
            JMP   LOOP

EXITLOOP    RRST  REGISTERS   RESTORE GENERAL REGISTERS

            PRTN

PRINTP      IP    PRINT

HEADING     BCI   '  LINE        PB%             SB%             LB%     '
            BCI   '   ROUTINE*n*n.'

LINEFMT     BCI   ' *5i   *6,8i/*6,-8i   *6,8i/*6,-8i   *6,8i/*6,-8i*n.'

P$WALK      ECB   START
            END
* movs2s --- Move blocks of memory around quickly

            SUBR  MOVE2S

            SEG
            RLIT

            DYNM  FROM_PTR(3),TO_PTR(3),NUM_WRDS(3)

            LINK
MOVE2S      ECB   MOVE,,FROM_PTR,3
            PROC

MOVE        ARGT
            LDL   FROM_PTR,*
            STL   FROM_PTR
            LDL   TO_PTR,*
            STL   TO_PTR
            LDA   NUM_WRDS,*
            SNZ
            PRTN
            TAX
            EAXB  FROM_PTR,*X
            EALB  TO_PTR,*X
            TCA
            TAX
            SLN
            JMP   L1
            LDA   XB%,X
            STA   LB%,X
            BIX   *+3
            PRTN
            TXA
L1          SAS   15
            JMP   L2
            LDL   XB%,X
            STL   LB%,X
            IRX
            BIX   *+3
            PRTN
            TXA
L2          SAS   14
            JMP   L3
            DFLD  XB%,X
            DFST  LB%,X
            ADD   =4
            SNZ
            PRTN
            TAX
L3          SAS   13
            JMP   L4
            DFLD  XB%,X
            DFST  LB%,X
            DFLD  XB%+4,X
            DFST  LB%+4,X
            ADD   =8
            SNZ
            PRTN
            TAX
L4          DFLD  XB%,X
            DFST  LB%,X
            DFLD  XB%+4,X
            DFST  LB%+4,X
            DFLD  XB%+8,X
            DFST  LB%+8,X
            DFLD  XB%+12,X
            DFST  LB%+12,X
            ADD   =16
            BNE   L4-1
            PRTN
            END
