*DECK,    ERPRO 
          IDENT  ERPRO
          TITLE              ERPRO - PASS 1 ERROR PROCESSOR 
*CALL     SSTCALL 
 B=ERPRO  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
  
          EXT    DIGMASK,TRANSIT,NODE2,MASKS,CD,COL 
          EXT    WB.FMT,DATA. 
          EXT    N.ERROR,N.FERR 
          EXT    LDPS2,SCANNER,RSELECT,NASAFLG
          EXT    LWAWORK
  
 TYPE     EQU    24B               CURRENT STMT TYPE
 SELIST   EQU    32B
 CLABEL   EQU    23B
 SCNT     EQU    46B
  
 E.ETOF   EQU    110               ERROR TABLE OVERFLOW 
 E.TMIE   EQU    206               TOO MANY INFORMATIVE ERRORS
          EJECT 
*** 
*         PASS 1 ERROR PROCESSOR
* 
*         ACCUMULATES INFORMATION IN THE ERROR TABLE FOR PRINTING DURING
*         PASS 2
* 
*         ENTRY CONDITIONS: 
*                B7 = RETURN ADDRESS
*                B6 = ERROR NUMBER
* 
*         IF B6 > 0 , THEN X4 OR X3 HOLD AN 8 CHARACTER MESSAGE 
* 
*         IF X4 = 0 THEN X3 HOLDS A BCD MESSAGE 
*          ELSE X4 HOLDS AN E LIST ITEM TO BE ADDED TO THE ERROR MESSAGE
* 
          SPACE  3
*** 
*         THE FORMAT OF AN ERROR TABLE ENTRY IS:  
* 
*         2/SEVERITY CODE,10/ERROR ORDINAL,48/MESSAGE 
*         60/10H LINE NUMBER
* 
*         THE ERROR CODES ARE:  
*                0 - FATAL TO EXECUTION 
*                1 - FATAL TO COMPILATION 
*                2 - ASA
*                3 - INFORMATIVE
          SPACE  3
          ENTRY  ASAER,ERPROI,FATALER,ERPRO,INFORM
          ENTRY  IMFLG       EXAMINED IN PS1CTL FOR FC TYPE ERRORS
  
          USE    /TABLES/ 
 O.ERTAB  BSS    1                 FWA OF ERROR TABLE 
          USE    *
  
 IMFLG    BSSZ   1
 FCFLAG   BSSZ   1                 .NZ. IF FC ERROR HAS OCCURED 
          TITLE              ERROR EXITS
*** 
*         ASAER  ACCUMULATE NON ASA USAGE DIAGNOSTICS 
* 
 ASAER    SX0    2
          EQ     INFORM 
          SPACE  3
*** 
*         ERPROI - ACCUMULATE INFORMATIVE ERRORS
* 
 ERPROI   SX0    3
  
 INFORM   SA1    N.ERROR
          SX2    X1-ERRMAX+12 
          NG     X2,ERPRO.1        IF ROOM FOR 12 ERRORS
  
          SB6    -E.TMIE
          SX0    3
          SX7    027B 
          LX7    51                JP  B7 INSTRUCTION 
          SA7    INFORM 
          EQ     ERPRO.1
          SPACE  3
*** 
*         FATALER - PROCESS FATAL ERROR ( TO COMPILATION )
* 
 FATALER  MX6    59 
          SA1    FCFLAG 
          BX0    -X6               X0 = 1 
          SA6    IMFLG
          NZ    X1,ERPROL          IF PREVIOUS FC ERROR, DO NOT ISSUE 
                                   REDUNDANT DIAGNOSTIC 
          SA6    A1                SET TO FC ERROR HAS OCCURED
          EQ     ERPRO1 
          SPACE  3
*** 
*         ERPRO - ACCUMULATE ERRORS FOR PASS 2
* 
 ERPRO    MX6    59 
          SA6    =XFEFLAG     SET FATAL ERROR FLAG FOR SCANNER
          SX0    B0           X0 = SEVERITY CODE
  
 ERPRO1   SA1    N.FERR 
          SX6    X1+1 
          SA6    A1                INCREMENT COUNT OF FATAL ERRORS
  
 ERPRO.1  SB5    1
          SA1    N.ERROR           ERROR COUNT
          SX2    X1-ERRMAX
          PL     X2,ERTOV          IF THE TABLE IS FULL 
  
 LASTER   SX6    X1+B5             INCREMENT ERROR COUNT
          SA6    A1 
  
          PL     B6,ERPRO2         IF X4 OR X3 HAS A MESSAGE
          MX5    0
          SB6    -B6
          EQ     ERPRO4 
  
 ERPRO2   BX5    X3 
          ZR     X4,ERPRO4   IF X3 CONTAINS *DETAILS* ENTRY 
          BX5    X1          (X5) = SAVED (X1)
          LX1    X4 
          RJ     CED         CONVERT E-LIST TO DISPLAY CODE 
          LX6    -12
          BX1    X5          RESTORE (X1) 
          LX5    X6 
  
*         FORM THE ERROR TABLE ENTRY
  
 ERPRO4   LX0    10 
          SX0    X0+B6             SEVERITY CODE AND ORDINAL
          SA2    SCNT        LINE NUMBER IN DPC 
          MX3    12 
          BX5    -X3*X5      REMOVE POSSIBLE GARBAGE FROM BITS 59_48
          LX0    48 
          BX6    X0+X5             FIRST WORD 
          LX1    1                 2*N.ERRORS 
          BX7    X2 
          SA6    O.ERTAB+X1 
          SA1    IMFLG
          SA7    A6+1 
          NZ     X1,ERPROK   IF FATAL-TO-COMPILATION ERROR
 ERPROE   JP     B7          EXIT 
  
*         FC ERROR - IGNORE THE REST OF THE PROGRAM 
  
 ERPROK   MX7    0
          SA7    A1          CLEAR CURRENT-FC-ERROR FLAG
          SA7    =XS.SCR     RESET MANAGED SCRATCH TABLE SIZE TO ZERO 
          SA5    =XO.SCR
          ZR     X5,ERPROL   IF SCRATCH TABLE NOT INITIALIZED (PHASE 1) 
          BX6    X5 
          SA6    =XFWAWORK   EXPAND AVAILABLE WORKING STORAGE 
 ERPROL   SA3    TYPE 
          SB7    X3                TYPE TO B7 
  
          SB4    B7-13
          SB3    B7-37
          ZR     B4,ERPROF         IF END CARD
          ZR     B3,ERPROF         IF ASSUMED EOF 
          RJ     SCANNER           SCAN NEXT STMT 
  
 ERPROP   EQ     ERPROL            LOOP ( USED AS A PLUG )
  
 ERPROF   SX6    B0 
          MX7    1
          SA6    =XL.UDV       CLEAR UDV TABLE
          SA7    =XP2NOGO    SET *SUPPRESS OBJECT CODE GENERATION*
          SA1    =XPROGNAM
          NZ     X1,=XLDPS2  IF PROGRAM NAME FOUND, LOAD PASS 2 
          EQ     =XPROGC     GENERATE *PROGRAM START.*
 ERTOV    SPACE  4,8
*         ERROR TABLE OVERFLOW
  
 ERTOV    SA2    ERPROE            PLUG FOR THE ENTRY POINT 
          SA3    IMFLG
+         ZR     X3,*+1            IF NOT AN FC ERROR 
          SA2    ERPROP 
  
          BX7    X2 
          SA7    ERPRO.1           PLUG THE ENTRY POINT 
          SA7    IMFLG             SET FLAG 
          SB6    -E.ETOF
          SB7    ERPROL            RETURN ADDRESS 
          SX0    1
          EQ     LASTER 
 CED      TITLE  CONVERT E-LIST TO DISPLAY CODE 
**        CED - CONVERT E-LIST TO DISPLAY CODE. 
* 
* 
*         ENTRY  (X1) = E-LIST ENTRY
* 
*         EXIT   (X6) = CONVERTED ENTRY, 10L FORMAT.  (IF A CONSTANT, 
*                       FIRST OR LEFTMOST TEN DIGITS ONLY.) 
* 
*         USES   X - 2, 6, 7
*                A - 2
*                B - 2
* 
*         CALLS  NONE 
  
  
          QUAL   CED
  
 CED      SUBR               ** ENTRY/EXIT ** 
          UX6,B2 X1          (B2) = E-LIST TYPE CODE
          SX7    B2-1 
          ZR     X7,CED3     IF A NAME
          SA2    ELOPTBL-2+B2      (X2) = PREFETCH DPC FOR E-LIST OPR 
          NZ     B2,CED4     IF NOT A CONSTANT
  
*         PROCESS CONSTANT. 
  
          SB2    X1-1 
          MI     B2,CED2     IF A LOGICAL CONSTANT
          SA2    X1 
          BX6    X2          RETURN (X6) = FIRST TEN CHARS OF CONSTANT
          EQ     EXIT.
  
 CED2     SA2    LCONTBL+1+X1      (X2) = DPC FOR LOGICAL CONSTANT
          EQ     CED4 
  
*         PROCESS NAME. 
  
 CED3     MX7    -6 
          BX2    X6 
          AX6    30 
          BX7    -X7*X6      (X7) = 3RD CHAR OF NAME
          SX6    X7-1R$ 
          SX7    1R &1R$
          NZ     X6,CED4     IF NO TRAILING $ (NOT REGISTER NAME) 
          LX7    30 
          BX2    X2-X7       CHANGE $ TO BLANK
  
*         EXTRACT 8R CHARACTERS, LEFT JUSTIFY, BLANK FILL AND EXIT. 
  
 CED4     LX2    12 
          SX6    2R 
          MX7    8*6
          BX2    X7*X2
          IX6    X2+X6
          EQ     EXIT.
 EDT      SPACE  4,8
**        EDT - E-LIST TO DISPLAY CODE CONVERSION TABLE.
* 
*  TAG    EDT    DPC
* 
* 
*         ENTRY  *DPC* = DISPLAY CODE, MAX 8 CHARACTERS 
  
  
          PURGMAC   EDT 
  
          MACRO  EDT,T,D
 T        VFD    12/0,48/8H_D 
 EDT      ENDM
  
  
  
**        E-LIST LOGICAL CONSTANT CONVERSION TABLE. 
  
 LCONTBL  BSS    0
 TRUE     EDT    .TRUE. 
 FALSE    EDT    .FALSE.
  
  
  
**        E-LIST OPERATOR CONVERSION TABLE. 
  
 ELOPTBL  BSS    0
          LOC    2
  
 RP       EDT    )
 COMMA    EDT    (,)
 EOS      EDT    END-STMT 
 EQU      EDT    =
 LP       EDT    ()(
 OR       EDT    .OR
 AND      EDT    .AND.
 NOT      EDT    .NOT.
 LE       EDT    .LE. 
 LT       EDT    .LT. 
 GE       EDT    .GE. 
 GT       EDT    .GT. 
 NE       EDT    .NE. 
 EQ       EDT    .EQ. 
 MINUS    EDT    -
 PLUS     EDT    +
 STAR     EDT    *
 SLASH    EDT    /
 DSTAR    EDT    ** 
  
          LOC    *O 
  
  
  
          QUAL   *
 CED      =      /CED/CED 
          ENTRY  CED
 TEM      TITLE  TRACE ERROR MESSAGE ORIGINATOR 
**        TEM - TRACE ERROR MESSAGE ORIGINATOR. 
* 
*                INTERCEPTS *ERPRO* CALL AND LISTS THE ERROR MESSAGE
*         NUMBER, WITH ORIGINATOR-S DECK NAME AND DECK-RELATIVE ADDRESS,
*         INTERSPERSED WITH SOURCE PROGRAM LISTING.  ACTIVATED ONLY IN
*         A TEST MODE COMPILER, WHEN SNAP=M SELECTED. 
* 
* 
*         ENTRY  (B4) = *ERPRO* ENTRY ADDRESS.
*                (B6) = ERROR MESSAGE NUMBER, OR ITS COMPLEMENT.
* 
*         EXIT   TO (B4) - DESIRED *ERPRO* SUBROUTINE.
* 
*         USES   X - 1, 6    (OTHER REGISTERS ARE SAVED AND RESTORED) 
*                A - 1, 6 
*                B - NONE 
* 
*         CALLS  CDD, FRA, LISTL
  
  
 .T       IFNE   TEST,0 
          QUAL   TEM
  
 TEM      SUBR               ** ENTRY/EXIT ** 
          SA1    =XCO.SNAP   CHECK CONTROL CARD SNAP= OPTION
          LX1    1RM
          MI     X1,TEM2     IF SNAP=M SELECTED 
          JP     B4          CONTINUE WITHOUT TRACEBACK ... 
  
*         BEGIN TRACEBACK PROCESSING. 
  
 TEM2     SX6    B6          (X6) = ERROR MESSAGE NUMBER
          SX1    B6 
          AX6    59-0 
          BX6    X1-X6       (X6) = ABS (ERROR MESSAGE NUMBER)
          SA6    TEMA 
          CALL   SAVE=       SAVE ALL REGISTERS 
          SA2    EXIT.
          SB1    1
          AX2    30 
          SX1    X2-1        (X1) = ADDRESS OF ORIGIN OF CALL 
          SB7    TEM3        (B7) = RETURN ADDRESS
          EQ     =XFRA=      FIND RELATIVE ADDRESS
  
 TEM3     SA6    TEMB 
          SA7    A6+1 
          SA1    TEMA        (X1) = ABS (ERROR MESSAGE NUMBER)
          CALL   CDD         CONVERT BINARY TO DECIMAL DISPLAY CODE 
          BX6    X4 
          SA6    TEMA 
          LISTL  TEMSG,TEMSGL 
          CALL   RESET=      RESTORE ALL REGISTERS
          JP     B4          CONTINUE ... 
  
  
  
 TEMSG    DATA   H.          .
          DATA   H.     *** ERR MSG NR. 
 TEMA     DATA   H.NNN.                  ABS (ERROR MESSAGE NUMBER )
          DATA   H.POSTED BY. 
 TEMB     DATA   C.000000 IN XXXXXXX. 
 TEMSGL   =      *-TEMSG
          SPACE  4
          QUAL   *
 TEM      =      /TEM/TEM 
          ENTRY  TEM
          SPACE  4
 .T       ENDIF 
          TITLE    ERPRO
          TITLE  MACRO DEFINITIONS
LOOK     MACRO     XN                   TO LOOK AT NEXT CHAR IN STRING
         A_XN      X1,B2                WITHOUT UPDATING POINTERS 
         B_XN      -X0*XN               MASK RTMOST CHAR INTO XN
         ENDM 
STEPIN   MACRO                          TO MOVE POINTERS TO NEXT CHARACT
         LOCAL     NEXT                 ER IN STRING -PACKED 10 CHAR PER
         SB2       B2-6                 WORD.  DECREMENT SHIFT COUNT
         PL        B2,NEXT              COUNT LEGAL-JUMP OUT
         SA1       A1-1                 NO. POINT TO NEXT WORD
         SB2       54                   RESET TO MAX SHIFT COUNT
NEXT     BSS       0                    AND RETURN. 
         ENDM 
STEPBK   MACRO                          TO MOVE POINTERS BACK 
         LOCAL  BACK                    ONE CHARACTER 
         SB2    B2-54                   CHECK SHIFT COUNT 
         MI     B2,BACK                 IF SHIFT COUNT NOT OUT OF RANGE 
         SA1    A1+1                    POINT TO PREVIOUS WORD
         SB2    -60                     SET TO ZERO SHIFT COUNT 
BACK     SB2    B2+60                   SET TO ZERO OR INCREMENT
*                                       SHIFT COUNT 
         ENDM 
GETCH    MACRO     XN                   TO FETCH NEXT CHARACTER IN
         LOCAL     LBL                  STRING   CHARACTERS PACKED
         A_XN      X1,B2                10 PER WORD.  SHIFT TO RT JSTFY 
         B_XN      -X0*XN               MASK OUT ALL BUT RTMOST CHAR
         GT        B2,B0,LBL            MORE CHARS IN WORD  GO TO LBL 
         SA1       A1-1                 WORD EMPTY. POINT TO NEXT WORD
         SB2       60                   RESET SHIFT COUNT 
LBL      SB2       B2-6                 DECREMENT SHIFT CT FOR NEXT CHAR
         ENDM 
PUTCH    MACRO     XN,XM                TO STORE AWAY CHARACTER STRING
         LOCAL     LBL,M                PACKED 10 CHARACTERS PER WORD.
M        MICRO     2,1, XM
         BX6       XN                   OUTPUT STORAGE IS ONE CHARACTER 
         SA"M"     SAVECHAR             BEHIND, HOLDING MOST RECENT CHAR
         L_XM      XM,B7                IN LOC SAVECHAR.
         BX7       X7+XM                SHIFT OUTPUT WORD TO APPEND CHAR
         SB7       B7-6                 UPDATE SHIFT COUNT
         SA6       A"M"                 STORE NEW SAVECHAR
         PL        B7,LBL               WORD NOT FULL. GO TO LBL
         SA7       A7-1                 STORE FULL WORD + UPDATE POINTER
          SA"M"  =XFWAWORK
          SB7    XM 
          S_XM   A7-B7
          SB7    54 
          MX7    0
          PL     XM,LBL 
          SX3    45 
          EQ     FERROR 
LBL      BSS       0                    AND RETURN. 
         ENDM 
          TITLE    FORMAT SCANNING PROCESSOR
 E.DDSN   EQU    8                 DOUBLY DEFINED STMT LABEL
 E.CLU    EQU    18                LABEL PREVIOUSLY USED AS STMT NUMBER 
  
 MINMAX   EQU    137
 PMAX     EQU    615
 LEVMAX   EQU    9           MAX LEVEL OF PARENS
 LASTERR  EQU    234
  
*** 
*         FORMAT PROCESSOR
* 
*         SYNTAX:  LABEL FORMAT(......) 
* 
 FORMAT   ENTRY.
          OUTUSE DATA.             GET IN THE RIGHT RB
          SA1    CLABEL 
          SB1    1                 NO LEADING ZEROS 
+         SB7    *+1
          EQ     =XLABCON          GO ENTER NAME IN SYMTAB
  
*         HERE IF FORMAT LABEL WAS NOT ALREADY IN *SYMTAB*. 
  
          EQ     FMT1A
  
*         HERE IF FORMAT LABEL ALREADY IN *SYMTAB*. 
  
          SA3    CLABEL 
          SB7    A1-1        SAVE THE SYM TAB ENTRY 
          SX6    B7          FORMAT ADDR INTO A TMP 
          SA6    SAVADR      STORAGE (WORD-B) 
          SX0    M.FNCHK
          LX3    -18
          LX0    P.FNCHK
          BX6    X0*X2       EXTRACT *DSN,RAS, AND DLT* BITS FROM WORD B
          SB7    FORMAT      (B7) = *ERPRO* RETURN ADDRESS
          ZR     X6,FMT1     IF FMT LAB NOT PREVIOUSLY REFD AS STMT LAB 
          POSTER SEV=FE,NR=E.CLU,FMT=DPC,TXT=X3,RETURN=B7 *LAB USE CONF*
  
 FMT1     MX0    2
          LX0    2+P.DFN
          BX6    X0*X2
          ZR     X6,FMT1A    IF FMT LAB NOT PREVIOUSLY DEFD AS FMT LAB
          POSTER SEV=FE,NR=E.DDSN,FMT=DPC,TXT=X3,RETURN=B7 *DBLY DEF LB*
  
*         HERE TO PROCESS *FORMAT* STATEMENT. 
  
 DFN      BIT    P.TYP-P.DFN
  
 FMT1A    SX0    T.LAB*DFN+1
          LX0    P.DFN
          BX6    X0+X2
          SA3    DATA.
          SA4    WB.FMT            RL AND RB FOR FORMAT LABEL 
          LX3    P.RA 
          IX5    X3+X4             +RA
          BX6    X6+X5             DEFINE THE ADDRESS 
          SA6    A2                UPDATE WORD 2 OF SYMTAB
  
          SX6    B1 
          SA6    TA1               SAVE B1
          SA1    =10H  FMT
          CALL   F1AMAC            OUTPUT FORMAT MACRO CALL 
  
          SA5    RSELECT
          ZR     X5,FMT2           IF R = 0 
          ADDREF TA1,DEF           DEFINTION OF THE FORMAT LABEL
  
 FMT2     BSS    0
          SPACE  3
*         INITIALIZE THE FORMAT PROCESSOR 
  
          SX5    -N.CELLS 
          MX6    0
          SX7    B5 
          SA6    O.CELLS           CLEAR FIRST CELL 
+         SA6    A6+B5             CLEAR CONTROL CELLS
          SX5    X5+B5
          NG     X5,* 
          SA7    NUMN              NUMN = 1 
  
          SB1    1                 B1 = 1 
         SB2       54                   INITIALIZE INPUT SHIFT COUNT
         SA4       SELIST               FETCH ADDR OF FIRST PACKED WORD 
         SA1       X4                   SET INPUT ADDR AND WORD 
          SA3    LWAWORK
          SA2    X3 
         BX7       X2                   TRANSFER
          SA7    A2 
         SB7       54                   INITIALIZE OUTPUT SHIFT COUNT 
         SB3       NODE2
         SA0       MASKS
         BX7       X7-X7
         MX0       60-6 
         GETCH     X2 
         BX6       X2 
         SA6       SAVECHAR 
          EQ     TRANSIT
          SPACE  3
          USE    /DAT.FMT/
 O.CELLS  BSS    0
PUSHDOWN BSSZ      LEVMAX+1 
NUMD     DATA      0
NUMN     DATA      1
NUMW     DATA      0
 SPESFLG  DATA   0           =3,-1,1,-3 FOR V,E,(I,O),(D,G) SPECIFICATIO
COLCNT   DATA      0
LEVEL    DATA      0
SAVECHAR DATA      0
         ENTRY     SAVECHR
SAVECHR  EQU       SAVECHAR 
RANB4    DATA      0
FLDX3    DATA      0
FLDB4    DATA      0
TEMPNW   DATA      0
WIDB4    DATA      0
WIDX3    DATA      0
 DECB4    EQU    FLDB4
 XB4      EQU    WIDB4
 TSAB4    EQU    WIDB4
 TCOB4    EQU    WIDB4
 SPESB4   EQU    WIDB4
 NULB4    EQU    RANB4
 HCOB4    EQU    WIDB4
 HSTB4    EQU    WIDB4
 SLAB4    EQU    WIDB4
 RECB4    EQU    FLDB4
 RECX3    EQU    FLDX3
 RITEB4   EQU    WIDB4
 FLAGPON  DATA   0           FLAG FOR SCALE FACTOR
 HDELIM   DATA   0           CONTAINS HOLL STRING DELIMITER 
 COLTEMP  DATA   0           TEMPORARY FOR COLUMN COUNT 
 XWORD    DATA   0           NONZERO IF MINUS SIGN
 MORECH   DATA   0
 STRING   DATA   0
FE       DATA      0
 N.CELLS  EQU    *-O.CELLS         END OF CELLS THAT ARE INITIALIZED
TA1      DATA      0
TB2      DATA      0
TX2      DATA      0
 TTA7     EQU    TX2
TB3      DATA      0
TB4      DATA      0
TX4      DATA      0
TB7      DATA      0
TA7      DATA      0
TX7      DATA      0
 MYFIRST  DATA   0
 MYLAST   DATA   0
          USE    *
 SAVADR   DATA   0           CONTAINS SYM TAB ENT OF FORMAT ADDR
          SPACE  3
TENMU    DATA      17170631463146314632B     BINARY_DISPLAY CONSTANT
          TITLE  LOCAL PROCESSORS CALLED BY TRANSITION DIAGRAM PROCESSOR
         TITLE     NUMBER 
         ENTRY     NUMBER 
NUMBER   SB6       X3                   SAVE INPUT PARAMETER
         BX3       X3-X3                CLEAR OUT TEMP SAVE AREA
         SA4       DIGMASK
          SX5    X2-1R= 
          ZR     X5,NUMB1    IF =, SPECIAL SYMBOL FOR A NUMBER
         EQ        ACCUM
MOVEIN   STEPIN                         POINT TO NEXT CHAR TO STORE 
         PUTCH     X2,X5                STORE CHAR IN OUTPUT STRING 
ACCUM    LX5       X3,B1                2*ACCUM 
         SX2       X2-1R0               REMOVE DISPLAY CODE FROM DIGIT
         LX3       3                    8*ACCUM 
         IX3       X5+X3                10*ACCUM
         IX3       X3+X2                ADD CURRENT DIGIT TO ACCUM
ADVCHAR  LOOK      X2                   FETCH NEXT CHAR 
         SB5       X2                   SET UP CONDITIONS 
         LX5       X4,B5                FOR DIGIT RECOGNITION 
         MI        X5,MOVEIN            YES,DIGIT. STORE AND CONTINUE 
         SX2       X2-1R                SUBTRACT DISPLAY CODE BLANK 
         NZ        X2,NONDIG            NOT BLANK. EXIT.
         STEPIN                         BLANK. MOVE UP INPUT POINTER. 
         EQ        ADVCHAR              GO,GET NEXT CHARACTER.
NONDIG   BX6       X3                   RETREIVE BINARY NUMBER
         SX3       B6                   RESTORE INPUT PARAMETER 
         SA6       B6+NUMN              STORE CONVERTED BINARY NUMBER.
         JP        B4        RETURN TO CALLING PROGRAM
 NUMB1    SA3    SAVADR      PICK UP WORD-B OF SYM TAB ENT OF FMT 
          SA3    X3 
          MX6    73B         SET UP MASK TO SET THE V OR = FLAG 
          BX3    -X6+X3      SET THE V OR = FLAG
          BX6    X3 
          SA6    A3          UPDATE WORD-B OF SYM TAB ENT OF FMT
          MX6    60 
          SA6    B6+NUMN     -0 FOR = SIGN ENCOUNTERED
          SX3    22          NON-ANSI SYMBOL
 NUMB2    LOOK   X2 
          SX2    X2-1R
          NZ     X2,UERROR   IF ALL TRAILING BLANKS ARE REMOVED 
          STEPIN
          EQ     NUMB2
          EQ     UERROR 
         TITLE     RANGE
         ENTRY     RANGE
RANGE    SB6       X3                   SAVE INPUT PARAMETER
         SX6       B4                   FETCH RETURN ADDRESS
         SA6       RANB4                STORE RETURN ADDRESS IN RANB4 
         SB4       RANREST              SET RETURN-IN-RANGE ADDRESS 
         NE        B6,B1,ZERTEST        WIDTH RANGE TEST, IF NO J ZERTES
         SA5       NUMW                 GET WIDTH VALUE 
         SX3       9
         SX6       X5-MINMAX-1          SUBTRACT INSIDE MAX 
          MI     X6,RANREST  IF WIDTH IS INSIDE MAX 
          AX5    17 
          ZR     X5,IERROR   IF WIDTH IS NOT MORE THAN 17 BITS
          SX3    46 
          EQ     FERROR 
RANREST  SA5       RANB4                RESTORE RETURN PARAMETER
         SB4       X5 
         SX3       B6 
         JP        B4        RETURN TO CALLING PROGRAM
ZERTEST  NE        B6,B0,PTEST          NONZERO TEST, IF NO,J PTEST 
         SA5       NUMN                 GET NUMBER VALUE
         NZ        X5,RANREST           IF NONZERO J TO RETURN CODE 
          MI     X5,RANREST  IF REPEAT COUNT INDICATED BY = 
          SX3    43 
          EQ     FERROR 
  
PTEST    SA4       FLAGPON              FETCH SCALE-ON FLAG 
         MX6       1                    TURN ON 
         SA6       A4                   NEW SCALE-ON FLAG 
         NZ        X4,PONERR            P-FLAG ALREADY ON  ERROR
RPTRTN   SA5       NUMN                 GET SCALE VALUE 
         SX6       B1                   RESTORE 
         SA6       NUMN                 NUMN TO ONE 
         SX6       X5-PMAX-1            SUBTRACT MAX FROM SCALE VALUE 
         PL        X6,PNUMERR           IF OUT OF RANGE, CALL ERROR 
         ZR        RANREST              J TO RETURN CODE
PONERR   SX3       11                   IF FLAG WAS 
         SB4       RPTRTN               ALREADY ON
         ZR        IERROR               PRODUCE AN INFORMATIVE ERROR
PNUMERR  SX3       10                   P-SCALE 
         SB4       RANREST              OUT OF RANGE
         ZR        IERROR 
         TITLE     FLDCHEK
         ENTRY     FLDCHEK
FLDCHEK  SX6       B4                   FETCH RETURN ADDRESS
         SA6       FLDB4                STORE RETURN ADDRESS IN FLDB4 
         BX6       X3                   FETCH INPUT PARAMETER 
         SA4       NUMN                 FETCH NUMN
         SA6       FLDX3                STORE INPUT PARAMETER IN FLDX3
         ZR        X3,FLDCALL           NUMN FIELD ALL TO CHECK FLDCALL 
         SA5       NUMW                 MULTIPLY
         PX6       X4                   NO
         PX5       X5                   INTEGERS
         DX4       X6*X5                NUMN*NUMW 
FLDCALL  SX3       B1                   SET PARAMETER TO 1
         SX6       X4                   GET VALUE TO BE CHECKED 
         SA6       NUMW                 STORE VALUE IN NUMW 
         SB4       FLDRTN               SET RETURN ADDRESS
         ZR        RANGE                GO TO RANGE-CHECKING ROUTINE
 FLDRTN   BSS    0
         SA3       COLCNT               FETCH CURRENT RECORD COUNT ADDR 
         SA5       NUMW                 AND NUMW ADDRESS
         IX6       X3+X5                ADD NUMW TO CURRENT RECORD COUNT
         SA4       LEVEL                GET CURRENT PARENTHESES LEVEL 
         SA4       X4+PUSHDOWN          GET ADDR OF PUSHDOWN WORD,LEVEL 
          MI     X5,FLDMI    IF BACKSPACING 
 FLDPL    SA6    A3          CURRENT RECORD COUNT 
         PL        X4,PDSET             NO SLASH LEAVE IN N1 POSN 
         LX5       18                   SHIFT P.D. WORD INTO PROP POS-N 
PDSET    IX6       X4+X5                ADD NEW CT TO PUSHDOWN(LEVEL) 
         SA6       A4                   STORE MODIFIED PUSH-WORD
WSET     SA5       FLDB4                RESTORE B4
         SB4       X5 
         SX6       B0                   ZERO OUT
         SA6       NUMW                 NUMW
         SA3       FLDX3                RESTORE X3
         JP        B4        RETURN TO CALLING PROGRAM
 FLDMI    BX2    X4 
          PL     X4,FLDMI1   IF NO SLASH
          LX2    -18
 FLDMI1   MX3    42 
          BX2    -X3*X2 
          IX2    X2+X5
          LX3    18 
          PL     X2,FLDPL    IF BACKSPACING + CNT IN PUSHDOWN 
          SB4    WSET        RETURN POINT 
          BX4    X4*X3       CNT IN PUSHDOWN CLEARED
          PL     X6,FLDMI2   IF BACKSPACING + RECORD CNT
          BX6    X6-X6
 FLDMI2   SA6    A3          CURRENT RECORD COUNT 
          MX3    1
          BX6    X3+X4       SLASH FLAG SET 
          SA6    A4          COUNT IN PUSHDOWN
          SX3    28          BACKSPACING TOO LARGE
          ZR     UERROR 
         TITLE     WIDTH
         ENTRY     WIDTH
WIDTH    SX6       B4                   FETCH RETURN PARAMETER
         SA6       WIDB4                STORE R P IN WIDB4
         BX6       X3                   FETCH INPUT PARAMETER 
         SA6       WIDX3                STORE I P IN WIDX3
         SB4       WNRTN                SET RETURN ADDRESS
         SX3       B1                   SET NUM PARAM EQ 1
         ZR        NUMBER               AND GO TO  NUMBER(1)
WNRTN    SA3       NUMW                 FETCH CONVERTED NUMW
          BX6    X3 
          SA6    TEMPNW 
          MI     X3,WIDREST  IF WIDTH WAS INDICATED BY A =
          NZ     X3,NWOK     IF WIDTH WAS > 0 
         SX3       4                    SET ERROR NO
         SB4       WIDREST              SET RETURN PT 
         ZR        IERROR               GO TO ERROR PROCESSOR 
NWOK     SB4       WRRTN                SET RETURN ADDRESS
         SX3       B1                   SET RANGE PARAM 
         ZR        RANGE                GO TO RANGE(1)
 WRRTN    BSS    0
         SB4       WFRTN                SET RETURN POINT
         SX3       B1                   SET FLDCHEK PARAM 
         ZR        FLDCHEK              GO TO FLDCHEK ROUTINE 
 WFRTN    SA4    SPESFLG
          PL     X4,WIDREST  IF NOT (D,E,G) SPECIFICATION 
         SA5       TEMPNW               FETCH NUMW FOR CHECH ON WIDTH 
         SX5       X5-6 
         PL        X5,WIDREST           IF RANGE OK  GO TO EXIT CODE
         SX3       5                    SET ERROR PARAMETER 
         SB4       WIDREST              SET RETURN POINT
         ZR        IERROR               GO TO ERROR ROUTINE 
WIDREST  SA4       WIDB4
         SA3       WIDX3
         SB4       X4 
         NZ        X3,WRTN              IS THIS DECIMAL-WIDTH CALL
         BX6       X6-X6                IF SO 
         SA6       FLAGPON              TURN ON SCALE-ON FLAG 
WRTN     JP        B4        RETURN TO CALLING PROGRAM
         TITLE     DECIM-FLAGW7D-ONECNT 
         ENTRY     DECIM
DECIM    SX6       B4                   FETCH RETURN PARAMETER
         SA6       DECB4                STORE IN DECB4
          SX6    X3 
          SA6    WIDX3       SAVE INPUT PARAMETER 
         SX3       -B1                  SET NUMD  PARAM 
         SB4       DNRET                SET DECIM RETURN PT 
         ZR        NUMBER               GO TO NUMBER ROUTINE
 DNRET    SA3    WIDX3
          SA4    TEMPNW 
          SA5    NUMD 
          MI     X4,DECREST  IF = SPECIFIED AS WIDTH, NO CHECKS MADE
          IX6    X4-X5       WIDTH - DECIMAL DIGITS 
          SA6    A4 
          ZR     X3,DECIM2   IF I,O,V SPEC. 
          PL     X3,DECIM1   IF E SPEC. 
          SX6    X6-2 
          SA3    SPESFLG
          ZR     X3,DECIM2   IF F SPEC. 
 DECIM1   SX6    X6-4 
 DECIM2   PL     X6,DECREST  IF WIDTH IS LARGE ENOUGH 
         SX3       13                   SET ERROR PARAM 
         SB4       DECREST              SET DECIM RETURN POINT
         ZR        IERROR               GO TO ERROR ROUTINE 
DECREST  SA4       DECB4                FETCH RETURN POINT
         SA3       NUMD 
         SB4       X4                   STORE R P IN B4 
         JP        B4        RETURN TO CALLING PROGRAM
          ENTRY  SPESSET
 SPESSET  BX6    X3 
          SA6    SPESFLG     SPECIFICATION FLAG SET 
          SX4    X2-1RO 
          ZR     X4,SPESS2   IF O SPEC
          SX5    X2-1RV 
          ZR     X5,SPESS1   IF V SPEC. 
          JP     B4 
 SPESS1   SA3    SAVADR      PICK UP WORD-B OF SYM TAB ENT OF FMT 
          SA3    X3 
          MX6    73B         SET UP MASK TO SET THE V OR = FLAG 
          BX3    -X6+X3      SET THE V OR = FLAG
          BX6    X3 
          SA6    A3          UPDATE WORD-B OF SYM TAB ENT OF FMT
 SPESS2   SX3    22          NON-ANSI SYMBOL
          EQ     UERROR 
         ENTRY     ONECNT 
ONECNT   SX6       B1                   ROUTINE INITIALIZES 
         SA6       NUMN                 NUMN=1
         BX6       X6-X6
         SA6       NUMW                 NUMW=0
         SA6       NUMD                 NUMD=0
          SA6    SPESFLG     CLEAR SPEC. FLAG 
          SA6    XWORD       CLEAR MINUS SIGN FLAG
         JP        B4        RETURN TO CALLING PROGRAM
          TITLE  XPROC-TSASI-TCODE
          ENTRY XPROC 
 XPROC    SX6    B4 
          SA6    XB4         SAVE RETURN POINT
          NZ     X3,XPROC1   IF THERE WAS A NUMBER IN X-FIELD 
          SX3    B1+B1       A BLANK IN X-FIELD 
          SB4    XPROC1 
          ZR     IERROR 
 XPROC1   SA5    XWORD
          SA4    NUMN 
          PL     X5,XPROC2   IF FORWARD SPACING 
          SX3    27 
          BX6    -X4
          SB4    XPROC2 
          BX4    X6 
          SA6    A4 
          ZR     UERROR 
 XPROC2   BX3    X3-X3
          SB4    XPROC3 
          NZ     X4,FLDCHEK  IF NUMBER TO SPACE WAS NOT 0 OR =
          MI     X4,XPROC3   IF = WAS SPACING INDICATOR 
          SX3    3
          ZR     IERROR 
 XPROC3   SA4    XB4
          SB4    X4 
          JP     B4 
          ENTRY  NEGSET 
 NEGSET   MX6    1
          SA6    XWORD       SETS FLAG FOR MINUS SIGN 
          JP     B4 
         ENTRY     TSASI
TSASI    SX6       B4                   ROUTINE SAVES RETURN POINT
         SA6       TSAB4                + CALLS DELCOM
         SB4       TSDRTN               TO SQUEEZE OUT
         ZR        DELCOM               REDUNDANT COMMAS
TSDRTN   SX3       24                   TSASI THEN CALLS
         SB4       TSURTN               UERROR - TO NOTE
         ZR        UERROR               TAB SETTING AS NON-USASI
TSURTN   SA4       TSAB4                RETURN PARAMETER
         SB4       X4                   IS RESTORED 
         JP        B4        RETURN TO CALLING PROGRAM
         ENTRY     TCODE
TCODE    SX6       B4                   ROUTINE SAVES RETURN POINT
         BX3       X3-X3                TO BINARY 
         SA6       TCOB4                THEN CONVERTS 
         SB4       TNRTN                DISPLAY CODE TAB SETTING
         ZR        NUMBER               VIA NUMBER ROUTINE
TNRTN    SA4       NUMN                 IF COLUMN SETTING 
          NZ     X4,TCODE1   IF TAB SET WAS NOT AT COLUMN 0 
          SX6    B1          DEFAULT TAB SET
          SA6    A4 
          MI     X4,TCODE1   IF = WAS TAB SET 
          SB4    TCODE1 
         SX3       14                   ERROR CODE
          EQ     IERROR 
 TCODE1   BSS    0
         SX3       B1                   OTHERWISE RECORD SIZE IS CHECKED
          SB4    TCIRTN 
         ZR        RECCHEK              FOR MAX + TAB RESET IN RECCHEK
TCIRTN   SA4       TCOB4                RETURN POINT
         SB4       X4                   IS RESTORED 
         JP        B4        RETURN TO CALLING PROGRAM
          TITLE  SPES-NULLP-DELCOM
          ENTRY  SPES 
 SPES     SX6    B4 
          SA6    SPESB4 
          MX5    60-2 
          SA4    SPESFLG
          BX6    -X5*X4 
          NZ     X6,SPES1    IF V,E,I,O SPEC. 
          SX3    31 
          EQ     FERROR 
 SPES1    SX4    X3          SAVE INPUT PARAMETER 
          SX3    26 
          SB4    SPES2
          ZR     UERROR 
 SPES2    SX3    X4          INPUT PARAMETER
          SA4    SPESB4 
          SB4    X4 
          SA4    DIGMASK     DIGIT MASK 
 SPES3    LOOK   X2 
          SB5    X2 
          LX5    X4,B5
          MI     X5,SPES4    IF A DIGIT 
          SX6    X2-1R= 
          ZR     X6,SPES4    IF A = SIGN
          SX2    X2-1R
          NZ     X2,SPES35   IF NOT A BLANK 
          STEPIN
          EQ     SPES3       STRIP BLANK
  
 SPES35   SX3    6
          EQ     IERROR 
 SPES4    STEPIN
          PUTCH  X2,X5
          EQ     DECIM
         ENTRY     NULLP
NULLP    SX6       B4                   ROUTINE HANDLES NULL SCALE FACTO
         SA6       NULB4                SAVES RETURN POINT
          SX3    15 
         SB4       NPIRTN               TO INFORM PROGRAMMER
         ZR        IERROR               OF OMISSION 
NPIRTN   SA4       FLAGPON              UPON RETURN,SCALE FLAG IS SET ON
         MX6       1                    AND FORMER SCALE
         SA6       A4                   IS CHECKED FOR STATUS 
          SX3    11 
         SB4       N2IRTN 
         NZ        X4,IERROR            AN INFORMATIVE ERROR IS PROD-D
N2IRTN   SA4       NULB4                RETURN POINT
         SB4       X4                   IS RESTORED 
         JP        B4        RETURN TO CALLING PROGRAM
         ENTRY     DELCOM 
DELCOM   SA4       SAVECHAR             FETCH LAST CHARACTER IN OUTPUT
         SX4       X4-1R,               STRING. IF IT WAS A COMMA,
         NZ        X4,DELEXIT           DELETE IT . IF NOT GO TO DELEXIT
         BX6       X2                   WAS COMMA. FETCH CURRENT CHAR 
         SA6       A4                   AND STORE OVER REDUNDANT COMMA. 
DELEXIT  JP        B4        RETURN TO CALLING PROGRAM
         TITLE     HCOUNTR-HSTRNGR
         ENTRY     HCOUNTR
HCOUNTR  SX6       B4                   ROUTINE SAVES RETURN POINT
         BX3       X3-X3                SET PARAMETERS
         SA6       HCOB4                THEN FETCHES
         SA4       NUMN                 HOLLERITH COUNT 
         ZR        X4,HCOFAT            ZERO COUNT CAUSES FATAL ERROR 
FETCH    GETCH     X2                   COUNT OK  GETCH 1ST H-CHAR
          NZ     X2,FETCH1
          SA3    A1 
          ZR     X3,HCEFAT
          BX3    X3-X3
 FETCH1   BSS    0
         PUTCH     X2,X5                CHAR OK  STORE IN OUTPUT STRING 
         SX4       X4-1                 SUBTRACT 1 FROM H-COUNT 
         NZ        X4,FETCH             COUNT EMPTY-IF NO FETCH NEXTCHAR
         SB4       HCFCOM 
         ZR        FLDCHEK              FOR VALID FLD LENGTH +INCR COLCT
HCOFAT   SX3       37                   0H COUNT INVALID
         ZR        FERROR               SCANNING CANNOT CONTINUE
HCEFAT   SX3       38                   END OF STATEMENT CHAR W NH INCOM
         SX6       B1 
         SA6       STRING 
         EQ        FERROR 
 HCFCOM  LOOK      X4 
         SX5       X4-1R, 
         ZR        X5,HCFRTN           IF NEXT CHARACTER NOT A COMMA
         SX6       X4-1R)              OR RIGHT PARENTHESIS 
         ZR        X6,HCFRTN
          SX5    X4-1R/ 
          SX6    X4-1R
          ZR     X5,HCFRTN   IF SEPARATOR IS A SLASH
          ZR     X6,HCFRTN   IF SEPARATOR IS A BLANK
         SX3       29                  LIST AS NON-ANSI 
         SB4       HCFRTN 
         EQ        UERROR 
HCFRTN   SA4       HCOB4                RESTORE 
         SB4       X4                   RETURN POINT
         JP        B4        RETURN TO CALLING PROGRAM
         ENTRY     HSTRNGR
HSTRNGR  SX6       B4                   ROUTINE SAVES RETURN POINT
         SA6       HSTB4                AND CHECKS ENTRY-TYPE 
         BX6       X2                   SAVE HOLLERITH STRING DELIMITER 
         SA6       HDELIM 
         NZ        X3,NONUH             IF HSTRNGR(0)-CALL
         SB4       NONUH                CALL DELCOM 
         ZR        DELCOM               TO DELETE REDUNDANT COMMAS
NONUH    SB4       BHSCAN               THEN PRODUCE
         SX3       25                   NON-USASI DIAGNOSTIC
         ZR        UERROR               IN UERROR 
BHSCAN   SB5       B0                   CLEAR OUT HOLLERITH COUNTER 
          MX6    0
         SA4       HDELIM               FETHC HOLLERITH DELIMITER 
          SA6    MORECH 
         SB4       X4                   AND SAVE IN B4
          SX6    1R,
          SX2    1RH
          SA6    SAVECHAR    REPLACE HOLL DELIMITER 
          PUTCH  X2,X5
          SX6    B7 
          SA6    TB7         B7, BYTE IN OUTPUT WORD SAVED
          SX6    A7-B1
          SA6    TA7         A7, ADDRESS OF OUTPUT STRING SAVED 
          SB7    B7-12
          PL     B7,CHSCAN   IF 4 BYTES ARE FREE IN OUTPUT WORD 
          SA7    X6          UPDATE OUTPUT WORD 
          MX7    0
          SB7    B7+60       UPDATE OUTPUT BYTE 
          EQ     CHSCAN 
 CHSC0    SA4    MORECH 
          ZR     X4,CHSC05   IF NO PREVIOUS 99
          SB6    X2 
          EQ     B6,B4,CHSC01 IF LAST CHARACTER LOOKED AT IS A DELIM
          PUTCH  X2,X5
          STEPBK
          EQ     CHSC04 
  
 CHSC01   STEPBK
          LE     B5,B0,CHSC03 IF POINTERS MOVED BACK TO END OF
*                            PREVIOUS 99
          SB5    B5-B1
          EQ     CHSC01 
  
 CHSC03   PUTCH  X2,X5
 CHSC04   SX6    2R99 
          EQ     CHSC2A      PROCESS 99 
  
 CHSC05   PUTCH  X2,X5
          SX4    B5-99
          ZR     X4,CHSC1B
CHSCAN   GETCH     X2                   HOLLERITH-CHAR-SCAN LOOP/GET CH 
          NZ     X2,CHSC1 
          SA3    A1 
          ZR     X3,HSTFAT   IF E-O-S 
 CHSC1    BSS    0
         SB5       B5+B1                NOT E-O-S,INCR H-COUNT
         SB6       X2                   MOVE H-CHAR FOR E-O-STRING TEST 
          NE     B6,B4,CHSC0 IF NOT YET HOLL DELIMITER
          SB6    B6-1R* 
          NZ     B6,CHSC1D   IF DELIMITER NOT AN *
          SB6    B5-1 
          NZ     B6,CHSC1D   IF COUNT GREATER THEN ONE
          SA4    MORECH 
          NZ     X4,CHSC1D   IF PREVIOUS 99 
          SX3    37          ERROR NUMBER 
          EQ     HSTFA       FATAL ERROR - NO CHARACTERS IN ASTERISK
*                            DELIMITED HOLLERITH STRING.
  
 CHSC1D   SX4    B4-1R" 
          NZ     X4,CHSC1A   IF HOLL DELIMITER NOT "
          LOOK   X2 
          SB6    X2 
          EQ     B6,B4,CHSC1E IF "" IN HOLLERITH STRING 
          SB6    B5-1 
          NZ     B6,CHSC1A   IF COUNT GREATER THEN ONE
          SA4    MORECH 
          NZ     X4,CHSC1A   IF PREVIOUS 99 
          SX3    37          ERROR NUMBER 
          EQ     HSTFA       FATAL ERROR - NO CHARACTERS IN " DELIMITED 
*                            HOLLERITH STRING.
  
 CHSC1E   STEPIN
          EQ     CHSC0
 CHSC1B   MX6    10 
          SA6    MORECH 
          SX6    B5 
          SA6    NUMN 
          SB5    B0 
          EQ     CHSCAN      CONTINUE UNTIL ANOTHER CHARACTER IS TO 
*                            STORED - THEN PROCESS PREVIOUS 99
 CHSC1A   SA4    MORECH 
          MX6    0
          SA6    A4 
          ZR     X4,CHSC1C   IF NO PREVIOUS 99 CHARACTERS TO PROCESS
          EQ     CHSC04 
  
 CHSC1C   SX6    B5-B1
          SA6    NUMN 
          SX6    A7 
          SA6    TTA7 
          SA7    TX7
          SX6    A1 
          SA6    TA1
          SX7    B2 
          SA7    TB2
          SX6    B3 
          SX7    B4 
          SA6    TB3
          SA7    TB4
          SX1    B5-B1
          RJ     =XCDD
          SA2    TA1
          SA3    TB2
          SA1    X2 
          SB2    X3 
          SA4    TTA7 
          SA5    X4 
          BX7    X5 
          SA2    TB3
          SA7    X4 
          SB3    X2 
          SA3    TB4
          SB4    X3 
          SA5    TX7
          BX7    X5 
 CHSC2A   SA3    TB7
          SA2    TA7
          SB5    X3          SAVED B7 IN B5 
          SB5    B5-6 
          MX5    60-12
          BX4    -X5*X6 
          SA2    X2          SAVED A7 IN A2 
          LX3    B5,X4
          BX6    X2+X3       END OF SAVED OUTPUT WORD FILLED
          SA6    A2 
          SB4    A7-B1
          SX6    A2-B4
          NZ     X6,CHSC2B
          BX7    X7+X3
 CHSC2B   PL     B5,CHSC3    IF 4 BYTES WERE FREE IN OUTPUT WORD
          LX4    54 
          BX3    X5*X4
          SA2    A2-B1
          BX6    X2+X3
          SA6    A2          DIGITS SAVED ON NEXT OUTPUT WORD 
          SX5    A2-B4
          NZ     X5,CHSC3 
          BX7    X7+X3
 CHSC3    BX3    X3-X3
         SB4       HSREST               FLDCHEK(0) TO CHECK FOR VALID 
         ZR        FLDCHEK              FIELD LENGTH + INCR RECORD COUNT
 HSREST   SA3    MORECH 
          MX6    0
          SA6    A3 
          NZ     X3,BHSCAN
          SA4    HSTB4
         SB4       X4                   RETURN POINT
         JP        B4        RETURN TO CALLING PROGRAM
HSTFAT   SX3       39 
 HSTFA    SX6    B1 
         SA6       STRING 
         ZR        FERROR 
          TITLE     SLASH 
          ENTRY     SLASH 
SLASH     SX6       B4                  ROUTINE SAVES RETURN POINT
          SA6       SLAB4               IN LOC SLASH
          NZ        X3,SLDRTN           IF ENTRY IS SLASH(0)
          SB4       SLDRTN              CALL DELCOM 
          ZR        DELCOM              AND DELETE REDUNDANT COMMA
SLDRTN    SB4       SLFRTN              FOR ALL ENTRIES 
          SX3       B0                  CALL RECCHEK(0) FOR CHECK OF
          ZR        RECCHEK             VALID RECORD LENGTH 
SLFRTN    SA4       LEVEL               RETRIEVE PUSHDOWN WORD ENTRY
          SA4       X4+PUSHDOWN         FOR LEVEL 
          MX3       60-18               CREATE MASK 
          SA5       SLAB4               FETCH RETURN POINT
          SB4       X5                  TO RETURN REGISTER
          LX3       18                  POSITION MASK W NO NL 
          BX6       X3*X4               MASK OUT NL 
          MX3       1                   CREATE SLASH BIT
          BX6       X3+X6               TURN ON SLASH BIT 
          SA6       A4                  STORE MODIFIED PUSH-WORD
          IX6       X6-X6               ZERO OUT
          SA6       COLCNT              COLCNT
         JP        B4        RETURN TO CALLING PROGRAM
          TITLE     RECCHEK 
          ENTRY     RECCHEK 
RECCHEK   SX6       B4                  ROUTINE SAVES RETURN POINT
          SA6       RECB4               IN LOC RECB4
          BX6       X3
          SA6       RECX3               IN LOC RECX3
          SA4       COLCNT              FETCH CURRENT COLUMN COUNT
          SX5       X4-MINMAX-1         IF LESS THAN INSIDE MAX 
          MI        X5,RERRTN           GO TO RERRTN
          SB4       RERRTN              ELSE, SET RETURN FLAG 
          SX3       12
          AX5    17 
          ZR     X5,IERROR   IF REC LENGTH IS NOT MORE THAN 17 BITS 
          SX3       47
          ZR        FERROR              ELSE, PRODUCE A FATAL ERROR 
RERRTN    SA4       RECX3               FETCH INPUT PARAMETER 
          ZR        X4,REREST           IF (0) ENTRY -GO TO RESTORE CODE
          MI        X4,FINISH           (-1) ENTRY -GO TO EXIT CODE 
          SA4       NUMN                (1)-T-ENTRY 
         SX6       X4-1 
         SA6       A4 
          SX5       X4-MINMAX-1         IF TAB SETTING LT INSIDE MAX
          MI        X5,RTENTN           GO TO RTENTN
          SB4       RTERTN              ELSE SET RETURN POINT 
          SX3       17
          AX5    17 
          ZR     X5,IERROR   IF TAB SET IS NOT MORE THAN 17 BITS
          SX3       48
         ZR        FERROR               ELSE PRODUCE FATAL ERROR
RTERTN    SX6       B1                  ERROR RETURN POINT.COLCNT=1 
          ZR        RSTCCT              GO STORE PT 
RTENTN    SA4       NUMN                FETCH NUMN FOR COLCNT 
          BX6       X4
RSTCCT    SA6       COLCNT              RESET COLCNT
          SA4       LEVEL               FETCH PUSHDOWN(LEVEL)-WORD
          SA5       X4+PUSHDOWN         FOR INDICATOR TEST
          MX4       60-18               FORM MASK 
          LX4    18                POSITION MASK
          BX6    X4*X5             CLEAR NL FIELD 
          MX5    1
          BX6    X5+X6             OR IN COLCNT 
          SA6       A5                  STORE IN ADDR PUSHDOWN(LEVEL) 
REREST    SA4       RECB4               RESTORE 
          SB4       X4                  RETURN POINT
          SA3       RECX3               AND INPUT PARAMETER 
          JP        B4       RETURN TO CALLING PROGRAM
         TITLE     LEFTPAR
         ENTRY     LEFTPAR
LEFTPAR  SA4       LEVEL                PUSHDOWN WORD FOR LAST LEVEL
         SX5       X4-LEVMAX            SUBTRACT MAXLEVEL 
         PL        X5,LEVERR            IF INVALID LEVEL PROCESS ERROR
         SX6       X4+B1                INCREMENT TO CURRENT LEVEL
         SA6       A4                   VALID LEVEL,STORE IN COUNTER
         SA5       X6+PUSHDOWN          FETCH PUSHDOWN WORD 
         SA4       NUMN                 FETCH NUMN,TO SET=GP(LEVEL) 
          PL     X4,LEFT1    IF = WAS NOT REPT COUNT
          SX4    1
 LEFT1    BSS    0
         LX4       60-6-18              SHIFT NUMN INTO POSITION
         IX6       X5+X4                ADD NUMN TO P(WORD) 
         SA6       A5                   STORE IN PUSHDOWN(LEVEL)
         JP        B4        RETURN TO CALLING PROGRAM
LEVERR    SX3    42                ERROR-MAX PAREN LEVEL EXCEEDED 
         ZR        FERROR               FATAL ERROR 
         TITLE     RITEPAR
         ENTRY     RITEPAR
RITEPAR  SX6       B4                   ROUTINE SAVES RETURN POINT
         SA6       RITEB4               IN RITEB4 
         SB5       X3                   MOVES INPUT PARAM TO TEST REG 
         NE        B5,B0,LEVTEST        IF INPUT PARAM =0,
         SB4       LEVTEST              DELETE PREV COMMA 
         ZR        DELCOM               BY CALL TO DELCOM 
LEVTEST  SA4       LEVEL                FETCH LEVEL 
         SX3       -B1                  IF LEVEL=0, GO TO END PROCESSING
         ZR        X4,RECCHEK           IN RECCHEK
         SA5       X4+PUSHDOWN          LEVEL NE 0  FETCH PUSHDOWN WORD 
         LX5       24                   SHIFT WORD SO GP IS RTMOST 18-BI
         SX4       X5                   SAVE GP(LEVEL) FOR TESTS
          SX3    43 
          ZR     X4,FERROR   IF REPEAT COUNT IS ZERO
         LX5       60-24                SHIFT P-WORD BACK TO NORMAL POSN
         SB4       X4                   MOVE GP(LEVEL) TO TEST REGISTER 
         PL        X5,SLOFF             SL(LEVEL) OFF,GO TO SLOFF CODE
         EQ        B4,B1,LEVDECR        GP=1, GO TO LEVDECR CODE
         SA3       COLCNT               FETCH CURRENT COLCNT
         BX6       X3                   MOVE COLCNT TO OUTPUT REG 
         SX4       X5                   MOVE N1 FOR ADD TO COLCNT 
         SA6       COLTEMP              FOR STORAGE IN TEMP-SAVE
         IX6       X3+X4                ADD N1 +COLCNT
         BX3       X3-X3                SET CALLING PARAM + RETURN POINT
         SA6       COLCNT               STORE IN COLCNT 
         SB4       RIRERTN              FOR CALL TO RECCHEK(0) TO CHECK 
         ZR        RECCHEK              FOR VALID RECORD LENGTH 
RIRERTN  SA4       COLTEMP              FETCH OLD COLCNT
         BX6       X4                   AND RESTORE VALUE 
         SA6       COLCNT               IN COLCNT WORD
  
 LEVDECR  SA3       LEVEL 
          SX6       X3-1
          SA4       X3+PUSHDOWN          PD(LEVEL)
          SA5       A4-B1                PD(LEVEL-1)
          SA6       A3                   DECREMENT LEVEL
          MX3       42
          BX6       X6-X6 
          LX3       18
          SA6       A4                   CLEAR PD(LEVEL)
          BX6       X3*X5 
          AX5       60                   EXTEND SLASH(LEVEL-1) BIT
          NO
          BX3       -X3*X4
          BX4       -X5*X4               PD(LEVEL) IF SLASH(LEVEL-1) OFF
          IX5       X6+X3                NL(LEVEL) REPLACES NL(LEVEL-1) 
          MX3       1+18
          NO
          LX3       18
          BX4       X3*X4                KEEP SLASH(LEVEL) AND N1(LEVEL)
          EQ        RPEND 
  
SLOFF    PX4       X4                   PACK GP FOR INTEGER MULTIPLY
         SX3       X5                   ISOLATE N1(LEVEL) 
         PX3       X3                   PACK N1 FOR INTEGER MULTIPLY
         DX4       X4*X3                INT MPY GP(LEVEL)*N1(LEVEL) 
         SX4       X4                   STRIP OFF EXPONENT
         SA3       LEVEL                FETCH LEVEL 
         BX6       X6-X6                CREATE ZERO WORD
         SA6       X3+PUSHDOWN          ZERO OUT OLD LEVEL
         SX6       X3-1                 DECREASE LEVEL BY 1 
         SA6       LEVEL                AND STORE BACK IN LEVEL-WORD
         SA5       X6+PUSHDOWN          FETCH P-WORD FOR NEW LEVEL
          PL        X5,RPEND             IF SLASH(LEVEL-1) BIT OFF
          LX4       18                   MOVE TOTAL WIDTH TO NL FIELD 
  
 RPEND    IX6       X4+X5                UPDATE PD(LEVEL-1) 
          SA6       A5
          SA4       RITEB4               CALLER-S RETURN ADDRESS
          PL        X6,RPEND2            IF SLASH(LEVEL-1) BIT OFF
          LX6       60-18                NL(LEVEL-1) TO BITS 17-0 
  
 RPEND2   SX6       X6                   ISOLATE N1/NL FIELD
          SB4       X4
          SA6       COLCNT               UPDATE CURRENT RECORD LENGTH 
          JP        B4                   RETURN TO CALLER 
         TITLE     ERROR
         ENTRY     UERROR 
 UERROR   SA5    =XANSI 
          SB5    ASAER
          NZ     X5,ERROR    IF FLAG IS ON
         JP        B4                   FLAG OFF  RETURN TO CONT PROCESS
         ENTRY     IERROR 
IERROR   SB5       ERPROI               INFORMATIVE ERROR ENTRY 
         ZR        X2,FERROR
         ZR        ERROR
         ENTRY     FERROR 
 NORPAR   SX3    41 
          ZR     ERROR
FERROR   SB5       ERPRO                FATAL ERROR ENTRY 
         SX6       B1 
          BX4    X4-X4
         SA6       FE 
          SB4    FINISH      SCANNING STOPS FOR THIS FORMAT 
          NZ     X2,ERROR    NOT AT END OF STMT 
          SA2    COL
         SX6       X2-1 
         SA6       A2 
          SA5    STRING 
          ZR     X5,NORPAR   IF NO RIGHT PARENS 
         BX6       X6-X6
          SA6    A5 
ERROR    SX6       A7                   TEMP SAVE AREA: 
         SA6       TA7                                 X7  OUT WORD 
         SX6       B7 
         SA7       TX7
         SA6       TB7                                 B7  SHIFT OUT
         SX7       B4 
         SA7       TB4                                 B4  RETURN POINT 
         SX6       B3 
         SA6       TB3                                 B3  NODE ADDRESS 
         BX7       X2 
         SX6       B2 
         SA7       TX2                                 X2  CHARACTER
         SA6       TB2                                 B2 
         BX7       X4 
         SA7       TX4
         SX7       A1 
         SA7       TA1                                 X1  IN WORD
         SB6       X3+LASTERR           CALCULATE ERROR NUMBER
         SX2       A1                   COMPUTE CURRENT COLUMN POINTER N
         SA3       SELIST 
         IX5       X3-X2                FWAFORMAT-(A1)
         LX3       X5,B1                X5*2
         LX5       3                    X5*8
         SX4       6
         IX5       X5+X3                X5*10 
         SB3       60 
         SX3       B3-B2                60-(B2) 
         PX3       X3 
         PX4       X4 
         NX4       X4 
         FX4       X3/X4
         UX4       X4,B7
         LX4       X4,B7                60-(B2)/6 
         IX5       X5+X4                N=(FWA-(A1))*10+(60-(B2))/6=(X5)
         SA4       COL                  FETCH COL 
         SX1       X4-2                 COL - 2 
         IX1       X1+X5                COL-1+N 
         SX2       66                   COMPUTE WORD ERROR IS IN
         PX1       X1 
         PX2       X2 
         NX2       X2 
         FX2       X1/X2
         UX2       X2,B7
         LX2       X2,B7                WD=(COL-1+N)/66 = (X2)
         SA3       CD                   FETCH CD
         IX3       X3+X2                CDNO=(CD)+WD = (X3) 
         IX1       X4+X5                COL+N 
         SX0       66 
         PX0       X0 
         PX2       X2                   P(WD) 
         DX5       X0*X2                66*WD 
         SX5       X5 
         SX1       X1+5                 COLNO=COL+N+5 
         IX1       X1-X5                COLNO=COL+N+5-(66*WD) 
         PX1       X1 
         SX0       10 
         SA2       TENMU
         PX0       X0 
         BX5       X3 
         SB4       B1+B1
         IX6       X6-X6
         SB2       COLSTOR
CDLOOP   DX3       X1*X2                T1 IN X3 = N * TENMU (L)
         FX1       X1*X2                T2 IN X1 = N * TENMU (U)
         FX3       X0*X3                DIGIT = T1 * P(10)
         SX3       X3                   ELIMINATE EXPONENT
         BX6       X6+X3                APPEND DIGIT TO STRING
         LX6       54                   LEFT JUSTIFY DIGIT STRING 
         SB4       B4-B1                REDUCE  DIGIT COUNT 
         NZ        B4,CDLOOP
         JP        B2                   RETURN TO PROCESSING
COLSTOR  SX7       2R00                 SAVE L-JUSTIFIED COLUMN COUNT 
         LX7       60-12
         IX7       X7+X6
         LX7       48 
         SB4       4                    SET B4 FOR CARD COUNT 
         IX6       X6-X6                CLEAR TEMP COUNT-SAVE AREA
         PX1       X5                   FETCH BINARY CARD COUNT 
         SB2       CDSTOR               SET RETURN POINT
         ZR        CDLOOP               GO TO DC CONVERT LOOP 
CDSTOR   SA3       =6RCD0000            CREATE DISPLAY CODE FOR CD
         SB2       B0                   INITIAL SHIFT COUNT 
LZLOOP   BX1       X6                   SHIFT DIGITS INTO TEMP LOC
         LX1       X1,B2                LEFT JUSTIFY CURRENT DIGIT
         AX1       54                   RIGHT JUSTIFY AND ISOLATE 
         NZ        X1,OKNZ              NONZERO DIGIT. JUMP OUT OF LOOP.
         SB2       B2+6                 INCREMENT SHIFT COUNT 
         ZR        LZLOOP               CONTINUE LOOPING
OKNZ     LX6       X6,B2                REMOVE ZERO DIGITS FROM STRING
         SB4       B2+36                CALCULATE SHIFT COUNT 
         AX6       X6,B4                RIGHT JUSTIFY NON-ZERO DIGITS 
         ZR        B2,MERGE             FOUR DIGITS. GO TO MERGE CODE.
         SX4       1R -1R0              CREATE BLANK FILL CHARACTER 
         LX4       18                   SHIFT INTO MERGE POSITION 
BLOOP    IX3       X3+X4                MERGE BLANK INTO NUMBER 
         SB2       B2-6                 DECREMENT SHIFT COUNT 
         ZR        B2,MERGE             ALL DIGITS TREATED- MERGE 
         SX4       1R 
         AX3       6                    SHIFT FILL CHARS FOR NEXT ADDN
         LX4       5*6
         ZR        BLOOP                CONTINUE BLANK FILL LOOP
MERGE    IX6       X6+X3                MERGE CD+FILL+ CDNO 
         BX3       X6+X7                MERGE COLNO+CD+FILL+CDNO
         IX4       X4-X4                SET X4 FOR DISPLAY CODE MESSAGE 
         SB7       ERESTOR              SET RETURN POINT
         JP        B5                   GO TO APPROPRIATE ERROR ENTRY 
ERESTOR  SA0       MASKS
         SB1       1                                     B1=1 
         MX0       60-6                                  X0 
         SA2       TA1                                   A1 
         SA1       X2                                    X1 
         SA2       TX2                                   X2 
         SA3       TB2                                   B2 
         SB2       X3 
         SA3       TB3                                   B3 
         SB3       X3 
         SA4       TB4                                   B4 
         SA5       TB7                                   B7 
         SB4       X4 
         SB7       X5 
         SA4       TA7
         SA5       X4 
         BX7       X5                                    X7 
         SA7       X4                                    A7 
         SA4       TX4
         SA5       TX7
         BX7       X5 
         SX3       B6 
         JP        B4        RETURN TO CALLING PROGRAM
         TITLE     FORMAT PACKING PROCESSOR 
         ENTRY     FINISH 
FINISH   PL        X4,FORMOUT           IF ABNORMAL EXIT, DONT PROCESS
         MX0       6                    CREATE 1 CHARACTER MASK 
         AX0       X0,B2                EXTEND MASK TO NO.CHARS REMAIN. 
         LX0       6                    EXTEND SHIFT CT TO POSN MASK
         LX0       X0,B2                POSITION MASK OVER REMAIN CHARS.
         ZR        X1,PACKPAR 
         BX1       X0*X1                IN X1 CREATE ZEROES+REMAIN CHARS
         SA2       BLANK                FETCH BLANKS FOR MASKING CHARS
         BX3       -X0*X2               MASK BLANKS IN GOOD CHARS 
         IX1       X1+X3                ADD LEADING BLANKS TO LAST WORD 
LOOPZ    BX4       X1-X2                SUBTRACT WORD OF BLANKS 
         NZ        X4,GARBAG            EXTRANEOUS CHARS AT END OF FORMT
         SB2       54 
         SA1       A1-B1                NO, FETCH NEXT WORD 
         NZ        X1,LOOPZ             NOT ZERO-WORD. CONTINUE SEARCH
PACKPAR  SA5       FE                   FETCH FATAL-TO-EXECUTION FLAG 
         NZ        X5,FORMOUT           IF E FE DONT OUTPUT COMPASS IMAG
         SA2       BLANK
         SA3       SAVECHAR             FETCH LAST GOOD CHARACTER.
         LX3       X3,B7                POSN CHARACTER FOR OUTPUT WORD
         BX7       X7+X3                OR CHARACTER INTO OUTPUT WORD.
         ZR        B7,LASTOK            OUT-WORD FULL. GO,INSERT ZERO WD
         SB7       B7-6                 MODIFY OUT-WORD SHIFT FOR NXT CH
         MX0       6                    CREATE ONE CHARACTER MASK 
         AX0       X0,B7                EXTEND MASK TO NO.CHARS TO FILL 
         LX0       6                    EXTEND SHIFT TO POSN MASK 
         LX0       X0,B7
         BX3       X0*X2                CREATE BLANK FILL CHARACTERS
         BX7       X7+X3                OR FILL-CHARS INTO OUTPUT WORD. 
LASTOK   SA7       A7-B1                STORE LAST WORD OF FORMAT STRING
          SA4    LWAWORK
         SX6       A7                   SAVE LAST ADDRESS 
          SA6    A4 
         SA5       DATA.
         SX7       A7-B1
          SX6    X4-1 
         SX5       X5+B1                INCR -DATA.- LEN FOR FMT LABEL
          IX0    X6-X7
         SA7       MYLAST               OUTPUT FORMAT INVERTED LWA+1
         SA6       MYFIRST              OUTPUT FORMAT INVERTED FWA
         IX7       X5+X0
         SB0       0
         SA7       A5                   UPDATE LENGTH OF -DATA.- BLOCK
  
*         WRITE COMPRESSED FORMAT TO *COMPS* FILE AS ONE OR MORE *DIS*
*         PSEUDO-OP LINES.  EACH LINE CONTAINS, AT MOST, 6 WORDS OF THE 
*         FORMAT, AND IS PREFACED WITH THE *DIS* PSEUDO AND WORD COUNT. 
  
 FIN2     SA3    MYLAST      (X3) = OUTPUT FORMAT INVERTED LWA+1
          SA2    MYFIRST     (X2) = OUTPUT FORMAT INVERTED FWA
          SA5    =H*  DIS   0,* 
          SX0    6           MAX LINE LENGTH, EXCLUDING *DIS* PSEUDO
          IX3    X2-X3       (X3) = TOTAL REMAINING FORMAT LENGTH 
          ZR     X3,FORMOUT  IF NO MORE FORMAT TO WRITE 
          MX4    X3-X0       (X4) = (REMAINING FMT LEN,MAX LEN) 
          SB6    FBUF        (B6) = OUTPUT LINE FWA 
          SA1    X2          (X1) = FIRST WORD OF REMAINING FORMAT
          SB2    X4          (B2) = OUTPUT LINE LENGTH, EXCL *DIS* WORD 
          LX4    6
          IX7    X5+X4       ADD LENGTH TO *DIS* PSEUDO (DPC) 
          NO
          SA7    B6          *DIS* PSEUDO TO OUTPUT BUFFER
 FIN3     BX7    X1 
          SA1    A1-B1       (X1) = NEXT FORMAT WORD
          SB2    B2-B1
          SA7    A7+B1
          GT     B2,B0,FIN3  IF *DIS* LINE NOT COMPLETE 
          BX6    X6-X6
          SX7    A1 
          SA6    A7+B1       ZERO WORD LINE TERMINATOR TO BUFFER
          SB7    A6+B1       OUTPUT LINE LWA+1
          SA7    A2          UPDATE FWA 
          SB7    B7-B6       OUTPUT LINE LENGTH 
          WRITEC =XF.CMPS,B6,B7    *DIS* LINE TO *COMPS* FILE 
          EQ     FIN2        LOOP FOR MORE OUTPUT 
  
*         HERE IF EXTRANEOUS CHARACTERS AFTER CLOSING RIGHT PARENTHESIS.
  
 GARBAG   SX3    44          EXTRANEOUS INFO FOLLS 0-LEV-). 
         SX5       1R 
         MX0       54 
GETIT    GETCH     X2 
         BX4       X5-X2
         ZR        X4,GETIT 
         ZR        X2,PACKPAR 
         SB4       PACKPAR              SET RETURN POINT TO PACK SAVECH.
          ZR     FERROR      ANNOUNCE FATAL ERROR 
FORMOUT  SB5       1                    RESTORE UNIT-REGISTER 
         ZR        FORMAT               RETURN COMPLETED FORMAT TO CALLR
          SPACE  3
 BLANK    DATA   10H
 FBUF     BSSZ   8           FORMAT STATEMENT OUTPUT BUFFER 
          END 
