*DECK TSNAP 
          IDENT  TSNAP
          SST    A
  
          SECT   (TSNAP  TEST MODE SNAP PACKAGE)
  
          NOREF  A
  
 B=TSNAP  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
 #SNAP    IFNE   TEST,0 
  
          ENTRY  DAR
          ENTRY  DAR= 
          ENTRY  IDP= 
          ENTRY  IDPFLG 
          ENTRY  REG= 
          ENTRY  RSR= 
          ENTRY  SNP= 
          ENTRY  SVR= 
  
*         IN FTN
          EXT    F.OUT
  
*         IN TABLES 
          EXT    BASES,CHARMAP,FRA=,LASTCOL,MOVES,N.TABLE,ORIGINS 
          EXT    SIZES,TT=PAR,TT.PAR,TS=SYM,TS.SYM
  
*         IN PIG
          EXT    PIK=PS,PIK=XJP 
  
*         IN MAP
          EXT    WOD
  
*         IN ALLOC
          EXT    ADW,ADW2,ALC 
  
*         IN PAR
          EXT    PAR
  
*         IN GEN
          EXT    DUC.1ST,DUC.2ND,DUC.BTH
  
 DAZ=PS   =      PIK=PS 
 DAZ=XJP  =      PIK=XJP
 F.BDO    =      F.OUT       DEFINE BATCH DEBUG OUTPUT FILE TO BE SAME
*                              AS NORMAL OUTPUT FILE AS DEFINED BY
*                              *L=* CC PARAMETER
 SN=DMT   =      5           ORDINAL OF 1ST WORD OF *DUMPT* PARAMETER 
 PRBDO    SPACE  4,8
**        DEFINE BATCH DEBUG OUTPUT MACRO -- *PRBDO*. 
  
          PURGMAC PRBDO 
  
 PRBDO    OPSYN  PLINE
 FAA=     SPACE  4,8
**        FAA - FIND ABSOLUTE ADDRESS.
* 
* 
*         ENTRY  (X0) = MX0 7*CHAR
*                (X1) = 42/0LNAME, 18/0 
* 
*         EXIT   (X6) = .PL. IF ABS ADDR ASSOCIATED WITH *NAME* 
*                     = .MI. IF NO ADDR KNOWN FOR *NAME* (I.E. NO FIND) 
* 
*         USES   X - 2,3,6,7       (INCLUDES ALL CALLS) 
*                A - 2
*                B - 6,7
* 
*         CALLS  /DBG=IDP/SKT 
  
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
  
 FAA=     SUBR               ** ENTRY/EXIT ** 
          SB6    =XFWA1.0    (B6) = FWA OF (1,0) *RPV* TABLE
          RJ     /DBG=IDP/SKT  SEARCH *RPV* TABLE FOR *NAME*
          SX6    X2+
          NZ     X2,EXIT.    IF A FIND
          MX6    1           SET TO *NO FIND* 
          EQ     EXIT.
 #OS      ENDIF 
 UIO=     SPACE  4,8
**        UIO= - USER IDP OWNCODE.
* 
* 
*         ENTRY  (RA.ORG) =  12/LAST OVERLAY LOADED (0P0S FMT),48/OTHER 
*                (UIOA)   =  48/0,12/LAST OVERLAY LOADED ON PREVIOUS
*                              IDP CALL (0P0S FMT)
* 
*         EXIT   (X1)     =  .MI., I.E. HONOR BREAK 
* 
*                WARNING -- IF THE USER HAS NOT ALLOTTED ENOUGH SPACE 
*                  FOR THE USER *SET* NAME TABLE *IDPSET* TO CONTAIN
*                  ALL THE DEFAULT *SET* NMAES, THEN *ADZ* (CALLED BY 
*                  *IST*) WILL SENSE TABLE OVERFLOW AND XIT TO *IDP=ER*.
*                  THIS CONDITION SHOULD BE AVOIDED.
* 
*         USES   X - 0,1,2,3,6,7   (INCLUDES ALL CALLS) 
*                A - 1,2,6
*                B - 6,7
* 
*         CALLS  CLZ,IST
  
 #OS      IFNE   .OS,2
  
 UIO=     SUBR               ** ENTRY/EXIT ** 
          SA2    RA.ORG 
          SA3    UIOA 
          MX1    1           SET TO *HONOR BREAK* 
          AX2    48-0 
          IX7    X2-X3
          BX6    X2 
          ZR     X7,EXIT.    IF WE ARE STILL IN THE SAME OVERLAY
          SA6    A3 
          SB6    IDPBA
          RJ     CLZ         CLEAR IDP TABLE -- BREAK ADDRESSES 
          SB6    IDPSET 
          RJ     CLZ         CLEAR IDP TABLE -- SET NAMES 
          RJ     IST         (RE)INITIALIZE DEFAULT *SET* NAMES 
          MX1    1           SET TO *HONOR BREAK* 
          EQ     EXIT.
  
  
 UIOA     BSSZ   1           USED TO TELL WHETHER OR NOT A NEW OVERLAY
*                              HAS BEEN LOADED SINCE THE LAST *IDP* 
*                              CALL-- CONTAINS THE MOST RECENT OVERLAY
*                              LOADED NR FROM *RA.ORG* -- 48/0,12/0P0S
 #OS      ENDIF 
 URO=     SPACE  4,8
**        URO= - USER REG= OWNCODE. 
* 
*         ENTRY  NONE 
* 
*         EXIT   (X1) = .MI. IF SNAP TO BE HONORED, ELSE .PL. 
* 
*         USES   X - 1
*                A - 1
* 
*         CALLS  NONE 
  
  
 URO=     SUBR               ** ENTRY/EXIT ** 
          SA1    =XCO.SNAP
          LX1    1RG
          BX1    -X1
          EQ     EXIT.
  
  
 USO=     =      URO= 
 UFT=     SPACE  4,8
**        UFT= - USER FILE NAME TABLE.
  
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
  
 UFT=     BSS    0
          VFD    42/0LF.OUT,18/=XF.OUT
          VFD    42/0LOUTPUT,18/=XF.OUT 
          DATA   0           END OF TABLE MARK
 #OS      ENDIF 
 UKT=     SPACE  4,8
**        UKT= - USER KEYWORD TABLE.
  
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
  
 UKT=     BSS    0
          VFD    42/0LDUMPT,18/ST=DMT 
          DATA   0           END OF TABLE MARK
 #OS      ENDIF 
*CALL DBG=IDP 
 DBG=IDP  SPACE  4,8
  
          IFNE   .OS,2,1     IF NOT SCOPE 2 
 CLZ      =      /DBG=IDP/CLZ 
 DAR      =      /DBG=IDP/DAR 
 DAR=     =      /DBG=IDP/DAR 
 DCM      =      /DBG=IDP/DCM 
 FRK      =      /DBG=IDP/FRK 
 FWAPARM  =      /DBG=IDP/FWAPARM 
 HDR      =      /DBG=IDP/HDR 
 IDF.BDOP =      /DBG=IDP/IDF.BDOP
 IDF.SNLP =      /DBG=IDP/IDF.SNLP
 IDF.XECP =      /DBG=IDP/IDF.XECP
          IFNE   .OS,2,1     IF NOT SCOPE 2 
 IDPBA    =      /DBG=IDP/IDPBA 
 IDPFLG   =      /DBG=IDP/IDPFLG
          IFNE   .OS,2,1     IF NOT SCOPE 2 
 IDPSA5   =      /DBG=IDP/IDPSA5
          IFNE   .OS,2,1     IF NOT SCOPE 2 
 IDPSET   =      /DBG=IDP/IDPSET
          IFNE   .OS,2,1     IF NOT SCOPE 2 
 IST      =      /DBG=IDP/IST 
 L.BSL    =      /DBG=IDP/L.BSL 
          IFNE   .OS,2,1     IF NOT SCOPE 2 
 SKT      =      /DBG=IDP/SKT 
 SNAPLNE  =      /DBG=IDP/SNAPLNE 
 SOB      =      /DBG=IDP/SOB 
 ROL      =      /DBG=IDP/ROL 
          TITLE  TSFTN SNAPPING ROUTINES. 
 DAT      SPACE  4,8
**        DAT - DUMP A TABLE. 
* 
* 
*         ENTRY  (A1,X1) = ADDR + CNTS OF TABLE ORIGIN (TT.) WORD 
* 
*         EXIT   NONE 
* 
*         USES   ALL
* 
*         CALLS  COD,DCM,PRIDP
  
  
 DAT      SUBR               ** ENTRY/EXIT ** 
          SB5    A1+         (B5) = ADDR OF TABLE ORIGIN WORD 
          SA1    A1+N.TABLE  (X1) = LEN OF TABLE
          SA2    DATB 
          SB6    =XORIGINS
          SA3    A2+B1
          SB6    B5-B6
          SA4    B6+=XPTSN   (X4) = TABLE NAME (-H- FMT)
          SA5    A3+B1
          BX6    X2 
          SA6    SNAPLNE
          LX7    X3 
          SA7    A6+B1
          BX6    X4 
          LX7    X5 
          SA6    A7+B1
          SA7    A6+B1
          RJ     =XCOD       CONVERT BINARY TO OCTAL DPC (TBL LEN)
          SA6    A7+B1
          MX7    0
          SA7    A6+B1       MARK EOL 
          SB4    B5          (B4) = ADDR OF TABLE ORIGIN WORD 
          PRIDP  SNAPLNE,,1 
          SA2    B4          (X2) = ORIGIN (FWA) OF TABLE 
          MX3    0           (X3) = LWA (NULL)
          SA4    B4+N.TABLE  (X4) = LENGTH OF TABLE 
          RJ     DCM         DUMP CENTRAL MEMORY
          EQ     EXIT.
  
  
 DATB     DIS    2,      DUMP OF TABLE
*         DATA   10HTT.NAME 
          DATA   10H LENGTH = 
*         DATA   10H NNNNNNB
 DMT      SPACE  4,8
**        DMT - DUMP TABLES.
* 
* 
*                CALLED BY *DUMPT* MACRO. 
* 
*         ENTRY  LOWER HALF OF *RJ DMT=* WORD HAS FWA OF PARAMETER LIST-
* +       RJ     DMT= 
* -       VFD    30/FWA OF PARAMETER LIST 
* 
*         PARAMETER LIST EXISTS IN LOCAL BLOCK *USE DEBUG*, AS SET UP 
*         BY *DUMPT* MACRO.  (SEE *TSTEXT*) --
* 
*         VFD    60/LOWER LIMIT (LL)
*         VFD    60/UPPER LIMIT (UL)
*         VFD    60/INCREMENT (INC) 
*         VFD    60/10HSNAP NAME   (OR .ZR. IF NO NAME) 
*         VFD    60/0        (USED BY *FRK* TO KEEP SNAP COUNT) 
*         VFD    18/0,21/T2,21/T1 
*                 . 
*                 . 
*         VFD    18/0,21/TN,21/TM 
*         VFD    60/0        END OF TABLE MARK
* 
*                WHERE T1,T2,...,TM,TN ARE THE ADDRESS OF TABLE ORIGIN
*                  (TT.) WORDS (SEE *TABLE* MACRO IN *TABLES*). 
*                  T2 AND T1 SPECIFY THAT ALL THE TABLES T1 THRU T2,
*                  INCLUSIVE, ARE TO BE DUMPED.   (T1.LE.T2)
* 
*         EXIT   NONE 
* 
*         USES   NONE        (ALL REGISTERS ARE SAVED AND RESTORED) 
* 
*         CALLS  DAT,FRK,HDR,RSR,SOB,SVR
  
  
 DMT=     SUBR   =           ** ENTRY/EXIT ** 
          RJ     SVR         SAVE ALL REGISTERS 
          SX1    3           SET TO *EXECUTIVE IS /DMT=/* 
          RJ     SOB         SET OUTPUT BIT FLAGS 
          SA4    DMT= 
          LX4    30 
          SA5    X4-1        (A5,X5) = ADDR + CNTS OF CALLING *RJ*
          SX6    X5          (X6) = FWA OF PARAMETER LIST 
          SA6    FWAPARM
          RJ     FRK         CHECK FREQUENCY PARAMETERS 
          ZR     X5,DMT3     IF NO DUMP THIS TIME 
          RJ     HDR         OUTPUT HEADING 
          SX2    X5+SN=DMT-1 (X2+1) = ADDR OF 1ST TABLE PARAMETER WORD
          SA3    DMTA        INITIALIZE (A3) = ADDR TO STORE THE ADDR OF
*                              THE TABLE ORIGIN WORD FOR THE 1ST TABLE
*                              TO BE DUMPED 
          EQ     DMT2A
  
*         DUMP THE TABLES T1 THRU T2, WHERE T1 AND T2 ARE PICKED UP 
*         FROM A SINGLE *DUMPT* TABLE PARAMETER LIST ENTRY. 
  
 DMT2     SA1    X1          (A1,X1) = ADDR + CNTS OF TABLE ORIGIN WORD 
          RJ     DAT         DUMP A TABLE 
          SA2    FWAPARM     (X2) = ADDR OF CURRENT TABLE PARAMETER WORD
          SA3    DMTA        (X3) = ADDR OF TABLE ORIGIN (TT.) WORD FOR 
*                              TABLE JUST DUMPED
          SA1    X2          (X1) = 18/0,21/T2,21/T1
          SX6    X3+B1
          AX1    21 
          IX7    X1-X6       (X7) = T2-(TN+1)  *TN.GE.T1* 
          SA6    A3+
          PL     X7,DMT2     IF NOT FINISHED DUMPING T1 THRU T2 
  
*         PICK UP NEXT TM THRU TN DUMP RANGE FROM THE NEXT *DUMPT*
*         TABLE PARAMETER LIST ENTRY. 
  
 DMT2A    SX6    X2+B1
          SA1    X6          (A1,X1) = ADDR + CNTS OF NXT TABLE PARAM WD
          SA6    FWAPARM
          SX7    X1          (X7) = ADDR OF TABLE ORIGIN WORD FOR NEXT
*                              TABLE TO BE DUMPED 
          SA7    A3 
          NZ     X1,DMT2     IF NOT FINISHED DUMPING
  
 DMT3     RJ     RSR         RESTORE ALL REGISTERS
          EQ     EXIT.
  
  
 DMTA     BSSZ   1           SAVE CELL FOR THE ADDRESS OF THE TABLE 
*                              ORIGIN (TT.) WORD OF THE NEXT TABLE TO 
*                              BE DUMPED. 
 DXP=     SPACE  4,8
**        DXP= - DUMP EXCHANGE PACKAGE. 
* 
* 
*                BECAUSE SCOPE 2 REPRIEVE HAS NO RESET, THE SYSTEM DUMPS
*         ALL REGISTERS AS THEY WERE DURING REPRIEVE PROCESSING; AND
*         BECAUSE THIS IS NOT USEFUL, THIS ROUTINE DUMPS ALL REGISTERS
*         AS THEY WERE WHEN REPRIEVE WAS CALLED. IT ALSO DUMPS 100
*         WORDS EITHER SIDE OF WHAT THE -P- REGISTER WAS WHEN REPRIEVE
*         WAS CALLED. 
* 
*         ENTRY  (A1,X1) = A + C OF 1ST WORD OF EXCHANGE PACKAGE
* 
*         EXIT   NONE 
* 
*         USES   ALL BUT A0,A5,X5 
* 
*         CALLS  COD,DAR,DCM,PRIDP,TEX
  
 .OS      IFEQ   .OS,2       IF SCOPE 2 
  
 DXP=     SUBR   =           ** ENTRY/EXIT ** 
          RJ     TEX         TRANSFER EXCHANGE PACKAGE REGISTERS
  
*         DUMP P,RA,FL,EM,RE,FE, AND MA.
  
 DXP2     SA3    DXPB 
          SX6    X3-6 
          ZR     X6,DXP3     IF DONE
          SX6    X3+B1
          SA6    A3 
          SA2    DXPA+X3     (X2) = .......XX.   (.=BLANK(55B)) 
          SA1    HARDREG+X3  (X1) = SAVED CONTENTS OF HARDWARE REGISTER 
          BX6    X2 
          SA6    =XSNAPLNE
          RJ     =XCOD       CONVERT BINARY TO OCTAL DPC
          LX6    3*CHAR      (X6) = .NNNNNN...
          SA6    A6+B1
          MX7    0
          SA7    A6+B1       MARK EOL 
          PRIDP  SNAPLNE,3
          EQ     DXP2 
  
*         HERE TO DUMP ALL REGISTERS. 
  
 DXP3     RJ     DAR         DUMP ALL REGISTERS 
  
*         HERE TO DUMP 100B WORDS EITHER SIDE OF -P- REGISTER 
  
          SA1    HARDREG     (X1) = -P- REGISTER
          SX4    200B        (X4) = NR OF WORDS TO DUMP (LEN) 
          NZ     X1,DXP4     IF -P- REGISTER NONZERO
          SA1    B0          EXTRACT -P- FROM RA+0
          LX1    59-47+18 
  
 DXP4     MX0    -18
          BX1    -X0*X1 
          SX2    X1-100B     (X2) = FWA TO DUMP 
          RJ     DCM         DUMP CENTRAL MEMORY
          EQ     EXIT.
  
  
 DXPA     DATA   10H1       P  NNNNNN 
          DATA   10H       RA  NNNNNN 
          DATA   10H       FL  NNNNNN 
          DATA   10H       EM  NNNNNN 
          DATA   10H       RE  NNNNNN 
          DATA   10H       FE  NNNNNN 
          DATA   10H       MA  NNNNNN 
  
 DXPB     BSSZ   1
 .OS      ENDIF 
 PTA      SPACE  4,8
**        PTA -  PRINT TABLE ALLOCATION.
* 
*         ENTRY  (X1) = NAME OF CALLER. 
* 
*         USES   SAVES/RESTORES ALL REGISTERS.
  
  
 PTA      SUBR   =           ** ENTRY/EXIT ** 
          RJ     SVR         SAVE ALL REGISTERS 
  
          SA1    SVX+1
          BX6    X1 
          SA6    PTAB 
          PLINE  PTAA,,2
          RJ     PTO         PRINT TABLE ORIGINS
  
          RJ     RSR         RESTORE ALL REGISTERS
          EQ     PTAX        EXIT.. 
  
 PTAA     DIS    3,    ****  TABLE ALLOCATION AT
 PTAB     DIS    1, 
          CON    6L  **** 
 PTO      SPACE  4,8
**        PTO - PRINT TABLE ORIGINS.
* 
* 
*                PRINTS TABLE STATISTICS IN THE FOLLOWING FORMAT--
*     COL 1         1         1         1         (.=BLANK(55B))
*         ..........TABLE.......ORIGIN......SIZE.....SLOP...
*         ......NN..NAME........NNNNNN....NNNNNN...NNNNNN...
* 
*         ENTRY  NONE 
* 
*         EXIT   NONE 
* 
*         USES   ALL
* 
*         CALLS  COD,PLINE
  
  
 PTO      SUBR   =
          SA0    B0          (A0) = TABLE ORDINAL 
          MX7    0
          SA7    SNAPLNE+5   PRESET END OF LINE 
          PLINE  PTOA,5,1 
  
 PTO2     SX1    A0 
          RJ     =XCOD       CONVERT BINARY TO OCTAL DPC -- TABLE ORD 
          SA1    =XPTSN+A0   (X1) = TABLE NAME   (-H- FMT)
          LX6    2*CHAR      (X6) = ......NN..   (.=BLANK(55B)) 
          BX7    X1 
          SA6    SNAPLNE
          SA1    =XBASES+A0  (X1) = TABLE ORIGIN
          SA7    A6+B1
          =X5    X1+FUDGE    (X5) = ORIGIN + FUDGE
          RJ     =XCOD       CONVERT BINARY TO OCTAL DPC -- ORIGIN
          LX6    2*CHAR 
          SA6    A7+B1       (X6) = ..NNNNNN..   (.=BLANK(55B)) 
  
          SA3    A1+B1       (X3) = ORIGIN OF NEXT TABLE
          SA1    A0+=XSIZES  (X1) = TABLE LENGTH
          IX5    X5+X1
          IX5    X3-X5       (X5) = AMOUNT OF SLOP SPACE
          RJ     =XCOD       CONVERT BINARY TO OCTAL DPC -- LENGTH
          LX6    2*CHAR      (X6) = ..NNNNNN..   (.=BLANK(55B)) 
          SA6    A6+B1
  
          BX1    X5 
          RJ     =XCOD       CONVERT BINARY TO OCTAL DPC -- SLOP
          LX6    2*CHAR 
          SA6    A6+B1
          PLINE  SNAPLNE
          SB6    =XN.TABLE-1
          SA0    A0+B1
          SB7    A0 
          LT     B7,B6,PTO2  IF MORE TABLES TO GO 
          EQ     EXIT.
  
  
 PTOA     DIS    5,          TABLE      ORIGIN      SIZE     SLOP 
 PTS      SPACE  4,8
**        PTS -  PRINT TABLE STATISTICS.
  
  
 PTS9     RJ     RSR         RESTORE REGISTERS
  
 PTS      SUBR   =           ** ENTRY/EXIT ** 
          RJ     SVR         SAVE REGISTERS 
          SA3    MOVES
          SA2    CO.SNAP
          LX2    1RC
          SX6    X3+B1       COUNT TABLE CRASHES
          SA6    A3 
          PL     X2,PTS4     CRASH SNAP NOT DESIRED 
          SA1    =XCP.LSTF
          ZR     X1,PTS9     IF SHORT LIST
          PLINE  (=C=  **  TABLE CRASH -- RE-ALLOCATION REQUIRED.=),,1
          SA2    ALC
          AX2    30 
          SB7    ADW2 
          SB7    -B7
          SB7    X2+B7
          NZ     B7,PTS2     IF NOT CALLED FROM ADDWORD 
          PLINE  PTSB 
          SA2    ADW
          AX2    30 
 PTS2     SX1    X2 
          RJ     COD
          SA6    PTSC1
          PLINE  PTSC        PRINT CALL ADDRESS 
  
          SA1    SVB+2
          SA2    X1+PTSN
          SB5    X1 
          BX6    X2 
          SA6    PTSE1
          SA1    SVX+0
          RJ     COD         CONVERT INCREMENT
          SA6    PTSE2
          SA1    B5+=XSIZES 
          RJ     COD         CONVERT PREVIOUS SIZE
          SA6    PTSE3
          PLINE  PTSE 
  
          SA1    SVX+3
          RJ     COD         CONVERT NECESSARY STORAGE
          SA6    PTSF1
          SA1    =XW.TABS 
          RJ     COD
          SA6    PTSF2
          PLINE  PTSF 
 PTS4     SA2    CO.SNAP
          LX2    1RT
          PL     X2,PTS9     IF TABLE SNAP NOT SELECTED 
          RJ     PTO         PRINT TABLE ORIGINS
  
          EQ     PTS9        EXIT.. 
  
 PTSB     DIS    ,/          CALLED FROM *ADDWORD*./
  
 PTSC     DATA   H/          CALLED FROM /
 PTSC1    DATA   0,0
  
 PTSE     DIS    2,  TABLE NUMBER 
 PTSE1    DIS    1,(B2) 
          DIS    1, ADDING
 PTSE2    DIS    1,(X0) 
          DIS    1, TO PREV 
 PTSE3    DIS    1,(SIZES+B2) 
          DATA   0
  
 PTSF     DIS    2,  NOW USING
 PTSF1    DIS    1,(X3) 
          DIS    1, OUT OF
 PTSF2    DIS    1,(SIZCORE)
          DATA   0
 SBD      SPACE  4,8
**        SBD -  ENTRY POINT FOR STRING BUFFER DUMP.
  
  
 SBD      SUBR   =           ** ENTRY/EXIT ** 
          RJ     SVR         SAVE REGISTERS 
          SA1    CO.SNAP
          LX1    1RG         GENERAL SNAP FLAG
          MI     X1,SBD9     IF GENERAL SNAP NOT ON 
          SA4    SBD         (X4) = 30/EQ CALLING ADDRESS+1, 30/0 
          LX4    30 
          SA5    X4-1        (A5,X5) = ADDR + CNTS OF CALLING *RJ*
          SX6    X5          (X6) = FWA OF PARAMETER LIST 
          SA6    FWAPARM
          RJ     FRK         CHECK IF TIME TO SNAP
          ZR     X5,SBD9     IF SUPPRESSED THIS TIME
          RJ     HDR         OUTPUT HEADING 
          RJ     SBL         LIST THE STRING BUFFER 
  
 SBD9     RJ     RSR         RESTORE REGISTERS
          EQ     EXIT.
 SBL      SPACE  4,8
**        SBL -  STRING BUFFER LIST.
*         LISTS STRING BUFFER WITHOUT CHECKING ANY SWITCHES.
*         USES   ALL. 
  
  
 SBL      SUBR   =           ** ENTRY/EXIT ** 
          SA1    =XT.SB 
          SA3    LASTCOL
          BX6    0
          SA2    =1H
          SA5    X1+SB.HEAD 
          LX7    X2 
          SB4    X3-SB.HEAD 
          SA6    SNAPLNE+5   PRESET END OF LINE MARK
          SA7    SNAPLNE+3
  
 SBL4     SX1    A5 
          SB5    B4          SAVE (B4)
          RJ     COD         CONVERT ADDRESS TO DPC 
          LX6    9*CHAR-6*CHAR
          SB4    B5          RESTORE (B4) 
          =X2    2R  -2R= 
          SX3    X5 
          IX6    X6-X2
          BX1    X5-X3
          SA6    SNAPLNE
          RJ     SFN
          SA2    X5+CHARMAP 
          LX6    -2*6 
          SX3    X2 
          SA6    SNAPLNE+4
          BX1    X2-X3
          RJ     SFN         SPACE FILL CHARACTER MAPPING 
          LX6    -2*6 
          =A6    A6-1 
          BX1    X5 
          SB3    A5 
          RJ     WOD         CONVERT CONTENTS TO DPC
          =A7    A6-1 
          =A6    A7-1 
          =B4    B4-1 
          =A5    B3+1 
          PLINE  A6-1 
          PL     B4,SBL4     IF MORE TO GO
  
          PLINE  ,,1
          EQ     EXIT.
 SN.PAR   SPACE  4,8
**        SN.PAR - DUMP PARSED FILE (ONLY IF IN TEST MODE)
* 
*         ENTRY  (TT=PAR) = LENGTH OF PARSED FILE.
* 
*         EXIT   FORMATTED FILE DUMPED. 
* 
*         CALLS  PLINE, PIA, SVR, RSR, WOD
  
  
 SN.PAR   SUBR   =           ** ENTRY/EXIT ** 
          RJ     SVR         SAVE REGISTERS.
          SA1    TT=PAR 
          SA2    TT.PAR 
          BX6    0
          SA6    SN.PNO 
          SA5    X2 
          SB4    X1-1        LENGTH OF PARSED FILE. 
          SA0    B4 
          MI     B4,SN.PAR5  IF EMPTY TABLE 
          SA2    PAR
          MX0    -18
          AX2    30 
          BX1    -X0*X2 
          RJ     COD         CONVERT CALLING ADDRESS
          SA6    SN.CAL 
          SX1    A0+B1
          RJ     COD         CONVERT PARSE FILE LENGTH TO DPC 
          LX6    4*CHAR 
          SA6    SN.LEN 
          PLINE  SN.HDR,,1
  
**        LOOP ON PARSED FILE 
  
 SN.PAR1  RJ     SN.POP      PROCESS OPERATOR.
          PLINE  LINPAR 
          SB4    A0 
          MI     B4,SN.PAR5  IF FINISHED
          RJ     SN.PSYM     PROCESS 1ST SYMBOL.
          PLINE  LINPAR 
          SB4    A0 
          MI     B4,SN.PAR5  IF FINISHED
          RJ     SN.PSYM     PROCESS 2ND SYMBOL 
          PLINE  LINPAR 
          PLINE  ,,1         BLANK LINE BETWEEN TURPLES 
          SB4    A0 
          PL     B4,SN.PAR1  IF MORE TO GO. 
  
**        END OF LOOP 
  
 SN.PAR5  RJ     RSR         RESTORE REGISTERS. 
          EQ     EXIT.
 SN.PSYM  SPACE  4,8
**        SN.PSYM - DUMP SYMBOL FROM PARSED FILE. 
  
  
 SN.PSYM  SUBR               ENTRY/EXIT...
          SA1    SN.PNO 
          SX6    X1+B1
          SA6    A1          UPDATE ORDINAL 
          RJ     COD         CONVERT TO *DPC* 
          LX6    9*CHAR-6*CHAR
          SX1    2R  &2R= 
          BX6    X6-X1       (X6) = .NNNNNN.=.   (.=BLANK(55B)) 
          SA6    LINNO
          LX1    X5 
          BX0    X5 
          AX1    P.TAG
          IFBIT  X0,INTR,SN.SYM5        IF INTERMEDIATE 
          SB2    X1-C.SYM-1 
          MI     B2,SN.SYM10            IF NOT A VARIABLE.
          SA3    TS=SYM 
          SA2    TS.SYM 
          SB7    X3 
          GT     B2,B7,SN.SYM10        IF NOT A VARIABLE. 
          MX0    L.SYM
          SA3    X2+B2       LOAD SYMBOL
          BX6    X0*X3       SYMBOL ONLY
          EQ     SN.SYM40    CONTINUE 
  
**        HERE IF NOT INTERMEDIATE
  
 SN.SYM5  RJ     COD         CONVERT TO OCTAL DPC 
          SX1    2RI= 
          EQ     SN.SYM11 
  
**        HERE IF OTHER FORM OF TAG OR CONSTANT.
  
 SN.SYM10 RJ     COD         CONVERT TO OCTAL DPC 
          SX1    2RC= 
 SN.SYM11 MX0    4*CHAR 
          LX1    8*CHAR 
          BX0    -X0*X6 
          LX0    2*6
          BX6    X1+X0       ADD IN I=
          EQ     SN.SYM40    CONTINUE 
  
**        HERE WITH SYMBOL CONVERTED TO DPC.
*         (X6) = DPC FOR SYMBOL.
  
 SN.SYM40 SA6    LINPDP      STORE INTO LINE BUFFER.
          BX1    X5 
          SB3    A5 
          RJ     WOD         CONVERT TAG TO OCTAL (CLOBBERS A5) 
          SA6    LINPOC 
          SA7    A6+B1
          SA0    A0-B1
          SA5    B3+B1
          EQ     EXIT.
 SN.POP   SPACE  4,8
**        SN.POP - DUMP OPERATOR FROM PARSED FILE.
*         OUTPUT IS DIVIDED INTO SPECIFIED FIELDS THAT ARE SET-UP DURING
*         PARSING OF A STATEMENT. 
* 
*         ENTRY  (X5) = OPERATOR. 
* 
*         EXIT   (X5) = NEXT OPERAND
  
  
 SN.POP   SUBR               ENTRY/EXIT...
  
*         UPDATE ORDINAL AND SET DPC INTO LINE BUFFER.
  
          SA1    SN.PNO 
          =X6    X1+1 
          SA6    A1          UPDATE ORDINAL 
          RJ     COD         CONVERT TO *DPC* 
          LX6    9*CHAR-6*CHAR
          SX1    2R  &2R= 
          BX6    X6-X1       (X6) = .NNNNNN.=.   (.=BLANK(55B)) 
          SA6    LINNO
  
*         CONVERT OPERATORE PROCESSOR ADDRESS TO DPC
  
          BX1    X5 
          AX1    -18
          RJ     COD         CONVERT JUMP ADDRESS TO *DPC*
          SA6    LINJPAD     STORE IN LINE BUFFER.
  
*         CONVERT OPERATOR CODE TO DPC
  
          SA1    =7HST.NO.
          SB2    X5-LG.SYM
          BX6    X1 
          PL     B2,SN.POP5  IF NOT AN OPERATOR.
          SA2    X5+CHARMAP 
          MX0    L.CDPC 
          BX1    X0*X2
          RJ     SFN         PAD OUT WITH BLANKS. 
  
*         DETERMINE DOMINANT MODE OF OPERATOR 
  
 SN.POP5  LX6    -CHAR
          SA6    LINOPR      OPERATOR IN DPC
          BX0    X5 
          MX1    -L.DMOD
          AX0    P.DMOD 
          BX3    -X1*X0 
          SA2    X3+SN.DMOD 
          BX0    X5 
          BX6    X2 
          MX1    -L.MODC
          =A6    A6+1        OPERATOR DOMINANT MODE 
  
*         DETERMINE IF MODE CONVERSION ON OPERANDS
          AX0    P.MODC 
          BX3    -X1*X0 
          SA2    =1H
          ZR     X3,SN.POP6  IF NO MODE CONVERSION
          SA2    =10H MODE CONV 
 SN.POP6  BX6    X2 
          =A6    A6+1 
  
*         DETERMINE TYPE OF OPERANDS
  
          SA2    X5+CHARMAP 
          SB7    DUC.1ST
          SB7    -B7
          SB7    X2+B7
          SB2    SN.1ST 
          ZR     B7,SN.POP7 
          SB7    DUC.BTH
          SB7    -B7
          SB7    X2+B7
          SB2    SN.BOTH
          ZR     B7,SN.POP7 
          SB7    DUC.2ND
          SB7    -B7
          SB7    X2+B7
          SB2    SN.2ND 
          ZR     B7,SN.POP7 
          SB2    SN.NULL
 SN.POP7  SA3    B2 
          BX6    X3 
          =A6    A6+1 
  
*         CONVERT OPERATOR WORD TO DPC/OCTAL
  
          BX1    X5 
          SB3    A5 
          RJ     WOD
          SA6    LINPOC 
          SA7    A6+B1
  
*         UPDATE POINTERS.
  
          SA0    A0-B1
          =A5    B3+1 
          EQ     EXIT.
  
 SN.PNO   DATA   0           RELATIVE NUMBER ON LISTING OF DUMP.
  
**        LINE IMAGE FOR DUMPING CONTENTS OF A PARSED FILE ELEMENT. 
  
 LINPAR   BSS    0
 LINNO    DATA   0
 LINPOC   DATA   0           ENTRY 1ST HALF 
          DATA   0           ENTRY 2ND HALF 
          DATA   10H
 LINJPAD  BSS    0           JUMP ADDRESS OF OPERATOR.
 LINPDP   DATA   0
 LINOPR   DATA   0           OPERATOR DPC 
 LINDMOD  DATA   0           DOMINANT MODE
 LINMODC  DATA   0           MODE CONVERSION
 LINTYP   DATA   0           TYPE OF OPERANDS 
  
**        DOMINANT MODE *DPC* 
  
 SN.DMOD  DIS    1, CHAMELEON 
          DIS    1, LOGICAL 
          DIS    1, INTEGER 
          DIS    1, REAL
          DIS    1, DOUBLE
          DIS    1, COMPLEX 
  
**        TYPE OF OPERANDS
  
 SN.1ST   DATA   8L FIRST 
 SN.2ND   DATA   8L SECOND
 SN.BOTH  DATA   8L BOTH
 SN.NULL  DATA   8L NONE
  
**        HEADER LINE FOR EACH TIME PARSED OUTPUT IS REQUESTED. 
  
 SN.HDR   DATA   30H      (DUMP OF PARSED FILE.)
          DATA   20H CALLED FROM  ------
 SN.CAL   DATA   0
          DATA   40H      CURRENT LENGTH OF TT.PAR TABLE =
 SN.LEN   DATA   0
          DATA   2L 
 ST=      SPACE  4,8
**        ST= - STATEMENT PROCESSORS FOR USER *IDP* COMMANDS. 
* 
* 
*                THIS ROUTINE PROCESSES *TS* ONLY *IDP* COMMANDS--
* 
*         DUMPT  T1,T2,...,TN 
* 
*         ENTRY  (A5,X5) = A+C OF TOKEN THAT TERMINATED KEYWORD 
* 
*         EXIT TO *IDP=MN*
 ST=DMT   SPACE  4,8
**        HERE TO PROCESS *DUMPT T1,T2,...,TN*. 
  
 #OS      IFNE   .OS,2       IF NOT SCOPE 2 
  
 ST=DMT   SX6    A5 
          MX7    0
          SA6    IDPSA5      SAVE (A5) = NEXT TOKEN ADDR
          SB6    =XPTSN 
          SA7    B6+=XN.TABLE-1  SET *TT.END* NAME WORD TO END OF TABLE 
*                                  MARK 
  
 ST=DMT2  SA5    X6 
          MX0    7*CHAR 
          ZR     X5,IDP=MN   IF EOS ENCOUNTERED 
          SX6    X5-O.VAR 
          NZ     X6,ST=DMT3  IF NOT A NAME TOKEN
          BX1    X0*X5
          RJ     =XSFN       SPACE FILL NAME
          BX1    X6          (X1) = 10HTABLE NAME 
          SB6    =XPTSN      (B6) = FWA OF TABLE NAME WORDS (-H- FMT) 
          RJ     SKT         SEARCH TABLE FOR MATCH 
          ZR     X2,ST=DMT3  IF NO FIND 
          SA1    B7+ORIGINS  (A1,X1) = ADDR + CNTS OF TABLE ORIGIN WORD 
          RJ     DAT         DUMP A TABLE 
  
 ST=DMT3  SA1    IDPSA5 
          SX6    X1+B1
          SA6    A1 
          EQ     ST=DMT2
 #OS      ENDIF 
 TEX      SPACE  4,8
**        TEX - TRANSFER EXCHANGE PACKAGE REGISTERS.
* 
* 
*                THIS ROUTINE WILL TRANSFER THE CONTENTS OF THE 
*         REGISTERS IN THE SAVED EXCHANGE PACKAGE TO THE REGISTER SAVE
*         AREA (SVB,SVA,SVX -- AS SET UP BY *COMCSVR*). A SUBSEQUENT
*         CALL TO *RSR=* WOULD RESTORE ALL REGISTERS TO THEIR VALUES
*         AT THE TIME OF THE EXCHANGE.
* 
*         ENTRY  (A1,X1) = A + C OF 1ST WORD OF EXCHANGE PACKAGE
* 
*         EXIT   NONE 
* 
*         USES   X - 0,1,6,7
*                A - 1,6,7
*                B - 2,3,4,5,7
* 
*         CALLS  NONE 
  
  
 TEX      SUBR               ** ENTRY/EXIT ** 
          SA1    A1+16-1     (X1) = LAST WORD OF 16 WORD EXCHANGE PKG 
          SB2    =XSVB
          SB3    =XSVA
          SB4    =XSVX
          SB5    HARDREG
          SB7    7           (B7) = LOOP COUNT -N-
          MX0    -18
  
*         RESTORE -X- REGISTERS.
  
 TEX2     BX6    X1 
          SA6    B4+B7
          SB7    B7-B1       N-1
          SA1    A1-B1
          GE     B7,B0,TEX2  IF MORE -X- REGS TO GO 
  
*         RESTORE -B- AND -A- REGS, AND SAVE P,RA,FL,EM,RE,FE,MA. 
  
          SB7    7           (B7) = LOOP COUNT -N-
  
 TEX3     BX6    -X0*X1      (X6) = (B-N-)
          LX1    -18
          BX7    -X0*X1      (X7) = (A-N-)
          SA6    B2+B7
          SA7    B3+B7
          LX1    -18
          BX6    -X0*X1      (X6) = P,RA,FL,EM,RE,FE,OR MA
          SA6    B5+B7
          SB7    B7-B1       N-1
          SA1    A1-B1
          GE     B7,B0,TEX3  IF NOT DONE
          EQ     EXIT.
  
  
 HARDREG  BSSZ   8           SAVED HARDWARE REGISTERS 
*         BSSZ   1           SAVED P
*         BSSZ   1           SAVED RA 
*         BSSZ   1           SAVED FL 
*         BSSZ   1           SAVED EM 
*         BSSZ   1           SAVED RE 
*         BSSZ   1           SAVED FE 
*         BSSZ   1           SAVED MA 
*         BSSZ   1           DUMMY FOR CONSISTENCY
 CTEXT    SPACE  4,8
*         COMMON DECKS. 
  
  
*CALL COMCCDD 
*CALL COMCCOD 
*CALL COMCDXB 
*CALL COMCSFN 
*CALL COMCSVR 
 SVR=     SPACE  4,8
 RSR      =      RSR= 
          ENTRY  RSR
 SVR      =      SVR= 
          ENTRY  SVR
  
 #SVR     IF     -DEF,#SVR   IF LOCAL REGISTER SAVE AREA
          ECHO   4,R=(B,A,X)
 SV_R     =      /COMCSVR/SVREG+/COMCSVR/SV_R 
 SAV.R    =      SV_R 
          ENTRY  SV_R,SAV.R 
          ENTRY  SV=R 
 #SVR     ENDIF 
  
 #SNAP    ENDIF 
  
          LIST   D
          END 
