*DECK,PRUSNG
          IDENT  BASPRUS
          TITLE  BASPRUS
* 
*CALL COPYRITE
* 
          IPARAMS 
          COMMENT BASIC 3 - PRINT USING.
*CALL LIPARAM 
          ENTRY  BASOUSI,BATOUSI,BASOPRO,BATOPRO
          EXT    ASCII,BASOPRT,FINDEXP
          EXT    ER168
          EXT    CNVDGTS,OBUFLCL
          EXT    BASEGEN
          EXT    RNBLOCK,RNLIST,DBUGON
          EXT    SETDGTS,ROUNDIT
          EXT    BASOCON
          EXT    STRFMT 
          ENTRY  BASXSTR,BATXSTR
*CALL,LCORE 
*CALL,ERMNUM
* 
* 
* 
*         ERROR-MESSAGES
* 
 ERM109   DATA   C* INFINITE OPERAND *
 ERM111   DATA   C* INDEFINITE OPERAND *
 ERM127   DATA   C* BAD FORMAT FIELD *
 ERM128   DATA   C* NO FORMAT FIELD SPECIFIED * 
* 
* 
 ER109    BSS    0
          RTERROR ERMN109,ERM109,BASEGEN         *INFINITE OPERAND* 
* 
 ER111    BSS    0
          RTERROR ERMN111,ERM111,BASEGEN         *INDEFINITE OPERAND* 
* 
 ER127    BSS    0
          RTERROR ERMN127,ERM127,BASEGEN   *BAD FORMAT FIELD *
* 
 ER128    BSS    0
          RTERROR ERMN128,ERM128,BASEGEN   *NO FORMAT FIELD * 
* 
 DISZERO  EQU         33B 
 DISBLNK  EQU         55B 
 DISMINS  EQU         46B 
 DISPNT   EQU         57B 
 DISEXP   EQU         05B 
 DISBEE   EQU    2
 DISCEE   EQU    3
 DISDEE   EQU    4
 DISR     EQU    22B
 DISTAR   EQU    47B               ASTERISK 
 DISLPAR  EQU    51B               LEFT PAREN 
 DISRPAR  EQU    52B               RIGHT PAREN
 DISDOLR  EQU    53B               DOLLAR 
 DISCOMA  EQU    56B               COMMA
          IFEQ   CHARSET,OLDCSET
 DISPND   EQU    71B               POUND
          ELSE
 DISPND   EQU    60B               POUND
          ENDIF 
 DISGT    EQU    73B               GREATER THAN 
 ESCBEE   EQU    7602B             LOWERCASE B
 ESCCEE   EQU    7603B             LOWERCASE C
 ESCDEE   EQU    7604B             LOWERCASE D
 ESCR     EQU    7622B             LOWERCASE R
          IFEQ   CHARSET,NEWCSET
 ESCCIRC  EQU    7402B             ASCII CIRCUMFLEX 
 CIRCFLEX EQU    76B               NON-ASCII CIRCUMFLEX 
          ENDIF 
 DISPLUS  EQU       45B 
          TITLE  PRINT USING INITIALIZER (BASOUSI)
* 
* 
          DATA   10HBASOUSI 
 BASOUSI  DATA   0
* 
*         INITIALIZE PRINT USING
*         PRINT LEADING LITERAL, SET UP X5 = FORMAT POINTER 
* 
*         ENTRY A5 = ADDR OF FORMAT (IMAGE) 
*         EXIT  X5 = 1/EOL,1/NOFIELD,1/SEP,3/0,18/ADDR,18/ADDR,18/0 
*                    EOL=NOFIELD=1 IF FORMAT IS ALL LITERAL 
*                    SEP=0 INITIALLY
* 
          SX1    A5 
          ZR     X5,USI.A    X1 = FWA OF NULL STRING
          SX1    X5 
          PL     X5,USI.A    X1 = FWA OF VARIABLE STRING
          SX1    X5+B4       X1 = FWA OF CONSTANT STRING
 USI.A    BSS    0           SET UP INITIAL FORMAT POINTER WORD 
          BX6    X1                6/0,18/ADDR,18/WORD,18/CHAR
          LX6    18                WHERE WORD = ADDR AND CHAR = 0 
          BX6    X6+X1
          LX6    18 
          SA6    FPTR 
          NZ   B5,USI5             JUMP IF FILE ORD WAS NOT ZERO
          SB5    B4+1              ORD ZERO = KFILE 
 USI5     BSS    0
          SX7    B5                SAVE FET ADDR
          SA7    FETADDR
          SA1    STRFMT 
          ZR   X1,USI3             SKIP IF NOT STR$ CALL
          SX6    B0                INIT STR BUFFER PTR
          SA6    STRBUFP
* 
 USI3     RJ   LSCAN               SCAN FOR POSSIBLE LEAD LITERAL 
          SA1    WIDTH
          ZR   X1,USI1             SKIP IF NO LITERAL 
          SA1    STRFMT 
          ZR   X1,USI4             SKIP IF NOT STR$ CALL
          RJ   ADDTO               PACK FIELD INTO STR BUFFER 
          EQ   USI1 
 USI4     RJ   PRINTIT             PACK LITERAL AND PRINT 
* 
 USI1     SA5    FPTR              CHECK IF EOL BIT ON
          PL   X5,USI2             JUMP IF NOT ON 
          MX1    1                 FIRST LITERAL EXTENDS TO EOL, SET
          LX1    59                NO-FIELD FLAG
          BX5    X5+X1
* 
 USI2     SA1    FETADDR           RESTORE IN CASE NOT YET DONE 
          SB5    X1 
          EQ   BASOUSI             EXIT WITH FORMAT PTR IN X5 
* 
* 
          TITLE  PRINT USING PROCESSOR (BASOPRO)
* 
* 
          DATA   10HBASOPRO 
 BASOPRO  DATA   0
* 
*         PROCESS PRINT USING 
*         PRINT ITEM ACCORDING TO FORMAT FIELD
*         PRINT TRAILING LITERAL, UPDATE X5 = FORMAT PTR
* 
*         ENTRY X5 = FORMAT POINTER AS ABOVE
*               A4/X4 = STRING ADDR/NUMERIC ITEM
*               X3 = FLAGS - NEGATIVE FOR STRING ITEM, POS FOR NUM
*                          - ZERO FOR SEMICOLON SEPARATOR, ONE FOR COMMA
*         EXIT  X5 = UPDATED FORMAT POINTER 
*                    1/EOL,1/0,1/SEP,3/0,18/ADDR,18/WORD,18/CHAR
*               X3 = UNCHANGED (FOR MAT PRINT USING)
* 
* 
          BX1    X5                CHECK FOR NO-FIELD FLAG, BIT 58
          LX1    1
          NG   X1,ER128      *NO FORMAT FIELD SPECIFIED*
* 
          PL     X3,PRO.B    SKIP IF ITEM NOT A STRING
          SX7    A4          X7 = ADR OF NULL STR ITEM
          ZR     X4,PRO.A 
          SX7    X4          X7 =ADR OF VARIABLE STR ITEM 
          PL     X4,PRO.A 
          SX7    X4+B4       X7 = ADR OF CONST STR ITEM 
 PRO.A    SA7    ADDR        SAVE ADR OF STRING ITEM
 PRO.B    BSS    0
          BX6    X5                SAVE - FORMAT POINTER
          SA6    FPTR 
          BX6    X4                     - ITEM IF NUMERIC 
          SA6    VALUE
          BX6    X3                     - SEPARATOR/TYPE FLAGS
          SX7    B5                     - FET ADDR
          SA6    FLAGS
          SA7    FETADDR
* 
          PL   X5,SCAN             SKIP IF NOT AT END OF FORMAT 
*         REUSE THE IMAGE 
          BX1    X5                TERMINATE THE LINE IF REQD 
          LX1    2                 BIT 57 OF X5 IS PREVIOUS SEPARATOR 
          PL   X1,SCAN1            SKIP IF PREV SEP WAS SEMICOLON 
          MX5    0                 TERMINATE, PREV WAS COMMA
          MX4    59 
          RJ   BASOPRT
          SA5    FPTR              RESTORE X5 
 SCAN1    AX5    36                IMAGE ADDR 
          SA5    X5                IN A5
          MX5    0           ***** CLEAR X5 SO BASOUSI WON'T RE-
*                                  CALCULATE STR ADR FROM PTR WORD *****
          RJ   BASOUSI             PRINT POSSIBLE LEAD LITERAL
* 
 SCAN     SX6    B0                RESET PAREN SCAN MODE FLAG 
          SA6    PAREN
          RJ   FSCAN               SCAN FIELD AND UNPACK
* 
          SA1    FTYPE             FORMAT TYPE
          SB6    X1                B6 = 01234 FOR TYPE JIFES
          SA1    FLAGS             CONTAINS PRINT ITEM TYPE 
          NG   X1,STRING           JUMP IF STRING TO PRINT
          SB7    TYPES
          EQ   B6,B7,ER127   *BAD FORMAT FIELD* 
          RJ   FNUMBER             FORMAT NUMBER
          EQ   PRINT
 STRING   SB7    TYPES             S OR J FORMAT OK 
          EQ   B6,B7,STRING1
          SB7    TYPEJ
          NE   B6,B7,ER127   *BAD FORMAT FIELD* 
 STRING1  RJ   FSTRING             FORMAT STRING
* 
 PRINT    SA1    STRFMT            PRINT THE FORMATTED ITEM 
          ZR   X1,PRINT1           SKIP IF NOT STR$ CALL
          RJ   ADDTO               PACK FIELD ONTO END OF STRBUF
          EQ   LITERAL             GO SCAN FOR LITERAL
 PRINT1   RJ   PRINTIT             PACK FIELD AND PRINT 
* 
 LITERAL  RJ   LSCAN               SCAN POSSIBLE LITERAL AND UNPACK 
          SA1    STRFMT 
          ZR   X1,PRINT3           SKIP IF NOT STR$ CALL
          SA1    WIDTH
          ZR   X1,PRINT4           SKIP IF NO LITERAL 
          RJ   ADDTO               PACK FIELD ONTO END OF STRBUF
 PRINT4   SX6    B0                TURN OFF STR$ FLAG 
          SA6    STRFMT 
          EQ   EXIT1
 PRINT3   SA1    WIDTH
          ZR   X1,EXIT             EXIT IF NONE 
          RJ   PRINTIT             PACK LITERAL AND PRINT 
* 
 EXIT     SA5    FPTR              RECORD SEPARATOR IN BIT 57 OF X5 
          SA3    FLAGS
          MX1    1
          LX1    58 
          ZR   X3,EXIT2 
          BX5    X5+X1             SET BIT
          EQ   EXIT1
 EXIT2    BX5    -X1*X5            DROP BIT 
* 
 EXIT1    BSS    0                 EXIT WITH X3 AND X5 SET
          SA1    FETADDR           BE SURE FET ADDR IN B5 
          SB5    X1 
          EQ   BASOPRO
* 
* 
* 
* 
* 
 FNUMBER  DATA   0                 FORMAT NUMBER
          SA1    SETDGTS           SAVE SETDIGITS VALUE 
          BX6    X1 
          SA6    SAVSET 
          SA5    VALUE                 NUMBER TO BE FORMATTED 
          NX5    B7,X5             DETECT INFINITE OR UNDEFINED 
* 
          ID     X5,ER111    *INDEFINITE OPERAND* 
          OR     X5,ER109    *INFINITE OPERAND* 
          SX6    B0                RECORD SIGN OF NUMBER
          PL   X5,POSITIV          JUMP IF POSITIVE 
          BX5    -X5
          SX6    1
 POSITIV  SA6    SIGN              STORE 0/1 FOR POS/NEG
* 
          SB6    B6+B6             B6 = 0246 FOR TYPE = JIFE
          JP   B6+JMPTBL           PROCESS ACCORDING TO FORMAT TYPE 
 JMPTBL   RJ   IJFRMAT             J
          EQ   NUMPRNT
          RJ   IJFRMAT             I
          EQ   NUMPRNT
          RJ   FFORMAT             F
          EQ   NUMPRNT
          RJ   EFORMAT             E
* 
 NUMPRNT  SA1    SAVSET            RESTORE SETDIGITS
          BX6    X1 
          SA6    SETDGTS
          EQ   FNUMBER             DONE FORMATTING NUMBER 
* 
* 
* 
 FSTRING  DATA   0                 FORMAT STRING
          SA1    ADDR              POINT TO STRING
          SA1    X1                A1 = WORD ADDR 
          SB5    B6                SAVE TYPE
          SB6    B0                B6 = CHAR POSN 0-9 
          SX0    77B               CONSTANT 
* 
          SB7    TYPEJ
          EQ   B5,B7,STRING2       J FORMAT MEANS LEFT JUSTIFY
          SA2    FSIGN             CHECK JUSTIFICATION
          SX2    X2-DISGT 
          ZR   X2,STRING3          GO RIGHT JUSTIFY 
 STRING2  RJ   STRINGL             LEFT JUSTIFY 
          EQ   STRPRNT
 STRING3  RJ   STRINGR             RIGHT JUSTIFY
* 
 STRPRNT  SX6    FIELD             SET FIELD START ADDR 
          SA6    FLDSTRT
          EQ   FSTRING             DONE FORMATTING STRING 
* 
* 
* 
 STRINGL  DATA   0                 LEFT JUSTIFY STRING IN FIELD 
          SB7    FIELD             UNPACKED BUFFER POINTER
          SA5    WIDTH             FIELD WIDTH
          SX5    FIELD+X5          LAST CHAR ADDR PLUS ONE
* 
 GETCHRL  RJ   EXCHAR              GET NEXT CHAR TO X7
          SX2    X7-101B
          ZR   X2,DONEL            EXIT IF END OF STRING
          SA7    B7                STORE IN UNPACK BUFFER 
          SB7    B7+1 
          SB5    X5 
          LT   B7,B5,GETCHRL       GET ANOTHER IF ROOM
          EQ   STRINGL             FIELD FULL, TRUNCATE, DONE LJUSTIFY
* 
 DONEL    SB5    X5 
          EQ   B5,B7,STRINGL       FIELD FULL, DONE LEFT JUSTIFY
          SX6    DISBLNK           BLANK REST OF FIELD
 BLNKL    SA6    B7 
          SB7    B7+1 
          LT   B7,B5,BLNKL         LOOP 
          EQ   STRINGL             DONE LEFT JUSTIFYING 
* 
* 
* 
 STRINGR  DATA   0                 RIGHT JUSTIFY STRING IN FIELD
          SX5    B0                FIND STRING LENGTH, INIT COUNT 
* 
 STRNGR1  RJ   EXCHAR              READ CHAR
          SX3    X7-101B
          ZR   X3,STRNGR2          EXIT IF END
          SX5    X5+1              COUNT
          EQ   STRNGR1             LOOP 
* 
 STRNGR2  SA1    ADDR              REPOSITION TO START
          SA1    X1 
          SB6    B0 
          SB7    FIELD             DESTINATION ADDR 
          SA2    WIDTH             FIELD WIDTH
          IX2    X2-X5             MINUS STRING LENGTH
          NG   X2,TRUNCR           GO TRUNCATE LONG STRING ON LEFT
          ZR   X2,MOVSTR           EXACT FIT, GO MOVE 
* 
          SX6    DISBLNK           WIDE FIELD, BLANK ON LEFT, X2 = COUNT
 BLNKR    SA6    B7 
          SB7    B7+1 
          SX2    X2-1              COUNT
          NZ   X2,BLNKR            LOOP 
          EQ   MOVSTR              GO MOVE STRING 
* 
 TRUNCR   BX5    -X2               COUNT OF CHARS TO BE TRUNC ON LEFT 
 TRUNCR1  RJ   EXCHAR              SKIP A CHAR
          SX5    X5-1              COUNT
          NZ   X5,TRUNCR1          LOOP 
* 
 MOVSTR   SA2    WIDTH             MOVE CHARACTERS INTO FIELD 
          SX5    FIELD+X2          LAST CHAR ADDR PLUS ONE
 GETCHRR  SB5    X5 
          EQ   B5,B7,STRINGR       FIELD FULL, DONE RIGHT JUSTIFY 
          RJ   EXCHAR              GET CHAR IN X7 
          SA7    B7 
          SB7    B7+1 
          EQ   GETCHRR             LOOP 
* 
* 
* 
 IJFRMAT  DATA   0                 FORMAT IS INTEGER
          SA1    =XBASANSI
          ZR     X1,INTCHK
          SX1    171740B           SET UP FOR .5
          LX1    42 
          FX5    X5+X1             ADD .5 FOR ROUNDING
 INTCHK   BSS    0
          SA1    MAXINT            CHECK IF TOO LARGE 
          FX1    X5-X1
          PL   X1,INTBIG           JUMP IF GT 14 DIGITS 
          UX5    B6,X5             TRUNCATE TO INTEGER
          LX5    B6,X5
          ZR   X5,INTZER           JUMP IF INTEGER PART ZERO
          PX5    B0,X5
          NX5    B6,X5
* 
          RJ   FINDEXP             FIND EXPONENT AND MANTISSA 
          SX6    X6+1              X6 = NUMBER OF DIGITS (EXP+1)
          SA6    SETDGTS           SET FOR CONVDGTS RTN 
          SA6    INTDGTS           SAVE FOR INTEDIT RTN 
* 
          SX0    B0                FLAG FOR CNVDGTS 
          RJ   CNVDGTS             CONVERT TO DISPLAY CODE IN OBUFLCL 
          RJ   INTEDIT             EDIT DIGITS INTO FIELD 
          EQ   IJFRMAT             DONE FORMATTING INTEGER
* 
 INTBIG   RJ   NUMBIG              INTEGER IS GT 14 DIGITS
          EQ   IJFRMAT
* 
 INTZER   BSS    0                 INTEGER IS ZERO
          SX6    B0                ASSURE POSITIVE
          SA6    SIGN 
          SX6    1                 ONE DIGIT
          SA6    INTDGTS
          SX6    DISZERO           STORE IT IN OBUFLCL
          SA6    OBUFLCL+1
          RJ   INTEDIT             EDIT INTO FIELD
          EQ   IJFRMAT
* 
* 
* 
 FFORMAT  DATA   0                 FORMAT IS FIXED POINT
          SA1    MAXINT            CHECK IF TOO LARGE 
          FX1    X5-X1
          PL   X1,FIXBIG           JUMP IF GT 14 DIGITS (INTEGER PART)
          ZR   X5,FIXZER           JUMP IF TRUE ZERO
* 
*  SET UP THE PARAMETERS FOR BASROF TO ROUND TO THE CORRECT FRACTIONAL
*  POSITION.
* 
*      NOTE ===>  CHANGES TO BASROF MAY AFFECT OPERATION OF FFORMAT 
*   X5 = NUMBER TO ROUND
*   B6 = NUMBER OF ARGUMENTS SENT TO BASROF (I.E. 2)
*   X4 = NUMBER OF FRACTIONAL DIGITS TO ROUND TO (I.E. FRACPOS) 
* 
* 
* 
           SB6    1           B6 = NUMB OF ARGS SENT TO BASAROF; ASSUME 1 
           SA4    FRACPOS     X4 = NUMBER OF PLACES TO ROUND TO 
           ZR     X4,RNDFRAC  BR, ROUND TO NEAREST INTEGER
           SB6    2              ELSE, SEND 2 ARGS; THE NUMBER TO ROUND 
*                                AND THE NUMBER OF PLACES TO ROUND TO.
           PX4    X4          CHANGE TO FLOATING POINT FOR BASAROF
*                             VALUE TO ROUND IS IN X5 
 RNDFRAC   RJ     =XBASAROF   ROUND THE NUMBER
           ZR     X5,FIXZER   FIXED POINT REP. IS EFFECTIVELY ZERO
* 
          RJ   FINDEXP             FIND EXPONENT AND MANTISSA 
          SA6    EXPON             SAVE EXPONENT
          NG   X6,NEGEXP           JUMP IF NEGATIVE EXPONENT
* 
*         NUMBER IS OF FORM XX.XXX , THAT IS, IT HAS INTEGER PART 
 FFORMT1  BSS    0
          SA1    FRACPOS           NUM OF FRACTIONAL DIGIT POSNS
          SX6    X6+1              NUMBER OF INTEGER DIGITS 
          IX6    X6+X1             DESIRED NUMBER OF DIGITS IS SUM
          SX1    MAXDGTS           NOT GT MAX ACCURACY
          IX2    X1-X6
          PL   X2,FFORMT3 
          SX6    X1 
 FFORMT3  IX2    X1-X6              POSITION TO ROUND IN - MAX MINUS REQ
          SB5    X2                POINTER INTO ROUND TABLE 
          RJ   ROUNDIT             ROUND MANTISSA (SET B7 IF OVERFLOW)
          SA1    EXPON
          BX6    X1 
          ZR   B7,FFORMT4          SKIP IF NO OVERFLOW
          SX6    X6+1              INCREASE EXPONENT BY ONE 
          SA6    A1 
 FFORMT4  SX6    X6+1              NUMBER OF INTEGER DIGITS 
* 
          SA1    FRACPOS           FRACTIONAL POSNS 
          IX6    X6+X1             NUMBER OF DIGITS TO CONVERT
          SX1    MAXDGTS           NOT GT MAX ACCURACY
          IX2    X1-X6
          PL   X2,FFORMT5 
          SX6    X1 
 FFORMT5  SA6    SETDGTS
          SX6    B0                NO LEADING FRACTIONAL ZEROS FOR XX.XX
          SA6    FZEROS 
          EQ   FCONVT              GO CONVERT DIGITS
* 
 NEGEXP   BSS    0                 NEGATIVE EXPONENT (.00XX)
*         NUMBER MAY BE EFFECTIVELY ZERO IF NO DIGITS IN FIELD
          BX6    -X6               VALUE OF EXPONENT
          SA1    FRACPOS           FRAC FIELD WIDTH 
          SX2    MAXDGTS           NOT GT MAX ACCURACY
          IX3    X2-X1
          PL   X3,FFORMT7 
          SX1    X2 
 FFORMT7  SX1    X1+1              FIELD WIDTH PLUS ONE 
          IX2    X1-X6             SEE IF ANY DIGITS FALL IN FIELD
          NG   X2,FIXZER           JUMP IF EFFECTIVELY ZERO 
          NZ   X2,FFORMT6          SKIP IF SOME DIGITS IN FIELD 
* 
          SB5    MAXDGTS           HIGH ORDER DIGIT JUST OUTSIDE FIELD
          RJ   ROUNDIT             ROUND AND SET B7 IF OVERFLOW INTO FIE
          ZR   B7,FIXZER           EFFECTIVELY ZERO IF NO OVFL
          SA1    EXPON             INCREASE EXP BY ONE FOR OVFL 
          SX6    X1+1 
          SA6    A1 
          BX6    -X6               ABS VALUE OF EXP 
          SX6    X6-1              NUMBER OF LEAD ZEROS = EXP-1 
          SA6    FZEROS 
          SX6    1                 NUMBER OF SIGNIF DIGITS = 1
          SA6    SETDGTS
          EQ   FCONVT              GO CONVERT DIGITS
* 
 FFORMT6  BSS    0                 SOME DIGITS IN FIELD (.??? AND .0XX) 
          SX6    X6-1              EXP-1 = NUMBER OF LEAD ZEROS 
          IX2    X1-X6              POSN TO ROUND IN = (WIDTH+1)-LEADZER
          SX1    MAXDGTS+1
          IX2    X1-X2
          SB5    X2                POINTER INTO ROUND TABLE 
          RJ   ROUNDIT             ROUND, SET B7 IF OVFL
          SA1    EXPON
          BX6    X1 
          ZR   B7,FFORMT9          SKIP IF NO OVFL
          SX6    X6+1              INCREASE EXPONENT
          ZR     X6,FFORMT1  BRANCH IF ROUNDED TO 1.000 
          SA6    A1 
 FFORMT9  BX6    -X6               ABS VAL OF EXP 
* 
          SX6    X6-1              NUMBER OF LEAD ZEROS = EXP-1 
          PL   X6,FFRMT9A          JUMP IF POSITIVE 
          SX6    B0                NEVER ALLOW NEGATIVE 
 FFRMT9A  BSS    0
          SA6    FZEROS 
          SA1    FRACPOS           FRACTIONAL POSNS 
          SX2    MAXDGTS           NOT GT MAX ACCURACY
          IX3    X2-X1
          PL   X3,FFORMT10
          SX1    X2 
 FFORMT10 IX6    X1-X6             POSNS MINUS ZEROS = SIGNIF DIGITS
          SA6    SETDGTS
* 
 FCONVT   SX0    B0                FLAG FOR CNVDGTS RTN 
          RJ   CNVDGTS             CONVERT TO DISPLAY CODE IN OBUFLCL 
          SA1    EXPON
          SX6    X1+1              NUMBER OF INTEGER DIGITS 
          PL   X6,FCONVT1          NO LESS THAN ZERO
          SX6    B0 
 FCONVT1  SA6    INTDGTS
          RJ   INTEDIT             EDIT INTEGER DIGITS (IF ANY)  INTO FI
          SA1    OVFLOW 
          NZ   X1,FFORMAT          EXIT IF MONETARY OVERFLOW
* 
          SA1    FRACPOS
          ZR   X1,FFORMAT          EXIT IF NO FRACTION
          SA1    SETDGTS           TOTAL DIGITS CONVERTED 
          SA2    INTDGTS           INTEGER DIGITS 
          IX6    X1-X2             NUMBER OF FRACTIONAL DIGITS AVAILABLE
          SA6    FRCDGTS           SAVE FOR MOVFRAC RTN 
          RJ   MOVFRAC             MOVE FRACTIONAL DIGITS INTO FIELD
          EQ   FFORMAT             DONE FORMATTING FIXED POINT
* 
 FIXBIG   RJ   NUMBIG              FIXED POINT GT 14 DIGITS 
          EQ   FFORMAT
* 
 FIXZER   BSS    0                 FIXED PT EFFECTIVELY ZERO
          SX6    B0                ASSURE POSITIVE
          SA6    SIGN 
          SA1    FRACPOS
          NZ   X1,FIXZER1          JUMP IF SOME FRAC POSNS
          SX6    1                 PLACE ZERO IN UNITS POSN 
          SA6    INTDGTS
          SX6    DISZERO
          SA6    OBUFLCL+1
          RJ   INTEDIT
          EQ   FFORMAT
* 
 FIXZER1  SX6    B0                NO INTEGER DIGITS
          SA6    INTDGTS
          RJ   INTEDIT             EDIT INTEGER PART OF FIELD 
          SA1    FRACPOS           FRACTIONAL ZEROS TO BE SET 
          SX2    MAXDGTS           NOT GT MAX ACCURACY
          IX3    X2-X1
          PL   X3,FIXZER2 
          SX1    X2 
 FIXZER2  BX6    X1 
          SA6    FZEROS 
          SX6    B0                NO REAL FRACTIONAL DIGITS
          SA6    FRCDGTS
          RJ   MOVFRAC             MOVE FRAC ZEROS INTO FIELD 
          EQ   FFORMAT
* 
* 
* 
 NUMBIG   DATA   0                 INTEGER OR FIXED PT GT 14 DIGITS 
          SA1    MONEY
          ZR   X1,NUMBIG6          SKIP IF NOT MONETARY 
          RJ   ASTFILL             FILL FIELD WITH ASTERISKS
          EQ   NUMBIG 
* 
 NUMBIG6  BSS    0                 PRINT AS FORMAT *+?'''' (7 PLACES) 
          SA1    WIDTH             FIELD WIDTH
          SX2    7
          IX2    X2-X1
          PL   X2,NUMBIG2          JUMP IF LE 7 PLACES
* 
          SX6    DISBLNK           BLANK POSNS 8-N OF FIELD 
          SB6    FIELD+7           START ADDR 
          SB7    FIELD+X1          LAST CHAR ADDR PLUS ONE
 NUMBIG1  SA6    B6 
          SB6    B6+1 
          LT   B6,B7,NUMBIG1       LOOP 
* 
          SX6    FIELD             FIELD START ADDR 
          EQ   NUMBIG3
 NUMBIG2  BX2    -X2               FIELD TOO SMALL
          SX6    FIELD+X2          FIELD START (FIELD-N)
* 
 NUMBIG3  SA6    FLDSTRT
          SX7    DISTAR            STORE ASTERISK 
          SA7    X6 
          SX7    DISPLUS           STORE SIGN 
          SA1    SIGN 
          ZR   X1,NUMBIG4 
          SX7    DISMINS
 NUMBIG4  SA7    A7+1 
* 
          RJ   FINDEXP             FIND EXPONENT AND MANTISSA 
          SA6    EXPON             SAVE EXPONENT
          SB5    MAXDGTS-1         ROUND TO ONE DIGIT 
          RJ   ROUNDIT
          ZR   B7,NUMBIG5          SKIP IF NO OVERFLOW
          SA1    EXPON             INCR EXPON 
          SX6    X1+1 
          SA6    A1 
* 
 NUMBIG5  SX6    1                 NUMBER OF DIGITS TO CONVERT
          SA6    SETDGTS
          SX0    B0                FLAG FOR CNVDGTS 
          RJ   CNVDGTS             CONVERT TO DISPLAY IN OBUFLCL
          SA1    OBUFLCL+1         GET THE DIGIT
          BX6    X1                STORE IN FIELD 
          SA2    FLDSTRT
          SA6    X2+2 
* 
          SX6    X2+1              SET UP FOR EXPCONV RTN 
          SA6    UNITPOS           FAKE UNITS DIGIT ADDR
          SX7    B0                NO FRAC POSNS
          SA7    FRACPOS
          SX6    4                 4 UPARROWS 
          SA6    ARROWS 
          RJ   EXPCONV             CONVERT EXPONENT INTO FIELD
          EQ   NUMBIG              DONE FORMATTING GT 14 DIGITS 
* 
* 
* 
 EFORMAT  DATA   0                 FORMAT IS FLOATING POINT 
          ZR   X5,FLTZER           JUMP IF ZERO 
          RJ   FINDEXP             FIND EXPONENT AND MANTISSA 
          SA6    EXPON             SAVE EXPONENT
          SA1    INTPOS            GET TOTAL DIGIT POSNS
          SA2    FRACPOS
          IX6    X1+X2
          SX1    MAXDGTS           MAX POSSIBLE ACCURACY
          IX2    X1-X6
          PL   X2,SETDIG1          JUMP IF LE MAX 
          SX6    X1                LIMIT TO MAX 
 SETDIG1  SA6    SETDGTS           NUMBER OF DIGITS TO CONVERT
* 
          IX2    X1-X6             DETERMINE POSN TO ROUND IN 
          SB5    X2                POINTER INTO ROUND TABLE 
          RJ   ROUNDIT             ROUND MANTISSA (SET B7 IF OVERFLOW)
          ZR   B7,EFORMT1          SKIP IF NO OVFL
          SA1    EXPON             INCREASE EXPONENT BY ONE 
          SX6    X1+1 
          SA6    A1 
* 
 EFORMT1  SX0    B0                FLAG FOR CNVDGTS RTN 
          RJ   CNVDGTS             CONVERT TO DISPLAY CODE IN OBUFLCL 
          SA1    INTPOS            GET TOTAL DIGIT POSNS
          SA2    FRACPOS
          IX1    X1+X2
          SA2    SETDGTS           AVAILABLE DIGITS 
          IX3    X2-X1
          NG   X3,BIGFLD           JUMP IF MORE POSNS THAN DIGITS 
          SA1    INTPOS            DETERMINE NUM OF INTEGER DIGITS
          SA2    FSIGN             IF FORMAT HAS NO SIGN POSN AND NUMBER
          NZ   X2,EFORMT2          IS NEGATIVE, STEAL DIGIT POSN IF ANY 
          SA2    SIGN 
          ZR   X2,EFORMT2 
          SX1    X1-1              STEAL PLACE
          PL   X1,EFORMT2          BUT NO LESS THAN ZERO PLACES 
          SX1    B0 
* 
 EFORMT2  SX6    X1                NUMBER OF INTEGER DIGITS 
          SA6    INTDGTS
          RJ   INTEDIT             EDIT INTEGER DIGITS INTO FIELD 
          SA1    OVFLOW 
          NZ   X1,EFORMAT          EXIT IF MONETARY OVERFLOW
* 
          SA1    FRACPOS           NUM FRAC DIGITS FOR MOVFRAC RTN
          BX6    X1 
          SA6    FRCDGTS
          SX6    B0                NO LEAD FRAC ZEROS 
          SA6    FZEROS 
          RJ   MOVFRAC             MOVE FRAC DIGITS INTO FIELD
          EQ   CALCEXP             GO FORMAT EXPONENT 
* 
 BIGFLD   BSS    0                 MORE POSNS THAN DIGITS, RIGHT JUSTIFY
          SA1    FRACPOS           UP TO MAXDGTS POSNS AFTER POINT
          SX2    MAXDGTS
          IX3    X2-X1
          PL   X3,EFORMT3 
          SX1    X2 
 EFORMT3  BX6    X1                FRACTIONAL DIGITS FOR MOVFRAC RTN
          SA6    FRCDGTS
          SA1    SETDGTS           DIGITS AVAILABLE 
          IX6    X1-X6             INTEGER DIGITS 
          PL   X6,EFORMT4          NO LESS THAN ZERO
          SX6    B0 
 EFORMT4  SA6    INTDGTS           FOR INTEDIT RTN
          RJ   INTEDIT             EDIT INTEGER DIGITS INTO FIELD 
          SA1    OVFLOW 
          NZ   X1,EFORMAT          EXIT IF MONETARY OVERFLOW
* 
          SX6    B0                NO LEAD FRAC ZEROS 
          SA6    FZEROS 
          RJ   MOVFRAC             MOVE FRACTIONAL DIGITS INTO FIELD
* 
 CALCEXP  BSS    0                 CALCULATE AND FORMAT EXPONENT
          SA1    EXPON             ADJUST EXPONENT IF POINT NOT AFTER FI
          SA2    INTDGTS           DIGIT, EG XXX.XXX SUBTRACTS 2 FROM EX
          BX2    -X2
          SX2    X2+1 
          IX6    X1+X2
          SA6    A1 
          RJ   EXPCONV             CONVERT EXPONENT, MOVE INTO FIELD
          EQ   EFORMAT             DONE FORMATTING FLOATING POINT 
* 
 FLTZER   BSS    0                 FLOATING PT IS ZERO
          SA1    FRACPOS
          NZ   X1,FLTZER1          JUMP IF SOME FRAC POSNS
          SX6    1                 PLACE ZERO IN UNITS POSN 
          SA6    INTDGTS
          SX6    DISZERO
          SA6    OBUFLCL+1
          RJ   INTEDIT
          EQ   FLTZER3             GO SET EXPONENT
* 
 FLTZER1  SX6    B0                NO INTEGER DIGITS
          SA6    INTDGTS
          RJ   INTEDIT             EDIT INTEGER PART OF FIELD 
          SA1    FRACPOS           FRACTIONAL ZEROS TO BE SET 
          SX2    MAXDGTS           NOT GT MAX ACCURACY
          IX3    X2-X1
          PL   X3,FLTZER2 
          SX1    X2 
 FLTZER2  BX6    X1 
          SA6    FZEROS 
          SX6    B0                NO REAL FRACTIONAL DIGITS
          SA6    FRCDGTS
          RJ   MOVFRAC             MOVE FRAC ZEROS INTO FIELD 
* 
 FLTZER3  SX6    B0                ZERO EXPONENT
          SA6    EXPON
          RJ   EXPCONV             CONVERT EXPONENT, MOVE INTO FIELD
          EQ   EFORMAT
* 
* 
* 
 INTEDIT  DATA   0                 EDIT INTEGER DIGITS INTO FIELD 
*                                  FROM RIGHT TO LEFT 
          SA1    INTDGTS           X1 = NUMBER OF DIGITS
          SA2    UNITPOS
          SB6    X2+1              ADDR OF POSN TO RIGHT OF UNITS POSN
          SB7    FIELD             B7 = ADDR OF LEFT END OF FIELD 
          SX6    B0                RESET OVERFLOW FLAG
          SA6    OVFLOW 
          ZR   X1,PREFILL          SKIP IF NO DIGITS
* 
          SB6    B6-1              ADDR OF UNITS POSN 
          SA2    OBUFLCL+X1        FETCH UNITS DIGIT
 INTEDT3  BX6    X2 
          SA6    B6                STORE IT IN FIELD
          SX1    X1-1              DECREMENT COUNT
          ZR   X1,PREFILL          EXIT IF NO MORE DIGITS 
 INTEDT2  SB6    B6-1              NEXT FORMAT POSN TO THE LEFT 
          LT   B6,B7,INTEDT4       NO COMMA CHECK IF OVERFLOWING
          SA3    B6                FETCH FORMAT CHAR
          SX3    X3-DISCOMA 
          ZR   X3,INTEDT2          SKIP OVER COMMA
 INTEDT4  SA2    A2-1              FETCH NEXT DIGIT 
          EQ   INTEDT3             GO STORE IT
* 
 PREFILL  SA1    FSIGN             PREPARE TO FILL REST OF FIELD
          NZ   X1,INTEDT9          JUMP IF SIGN SPECIFIED 
          SA1    SIGN              NO SIGN, TREAT SIGN AS A DIGIT 
          ZR   X1,INTEDT9          JUMP IF NUMBER IS POSITIVE 
          SX6    DISMINS           STORE MINUS SIGN 
          SB6    B6-1 
          SA6    B6 
* 
 INTEDT9  SX6    B6                SAVE LAST CHAR POSN IN CASE NEEDED LA
          SA6    LASTCHR           FOR PLACING SIGN 
          LE     B6,B7,SETDOLR     SKIP IF FIELD FULL 
* 
          SA1    B6-1              FORMAT CHAR TO LEFT OF DIGITS
          SX2    X1-DISPND
          ZR   X2,BLNKPND          GO BLANK POUNDS
          SX2    X1-DISTAR
          ZR   X2,SKIPAST          GO LEAVE ASTERISKS 
          SX2    X1-DISCOMA 
          NZ   X2,SETDOLR          NOT COMMA, DONE FILLING
          SA1    B6-2              CHECK CHAR PRECEDING COMMA 
          SX2    X1-DISPND
          ZR   X2,BLNKPND          GO BLANK POUNDS
          SX2    X1-DISTAR
          NZ     X2,SETDOLR  BRANCH IF NOT STAR 
          SX6    X1          REPLACE THE COMMA WITH A STAR
          SB6    B6-1 
          SA6    B6 
          EQ     SKIPAST
* 
 BLNKPND  SX6    DISBLNK           BLANK ANY POUNDS AND COMMAS
 INTEDT7  SB6    B6-1 
          SA6    B6                BLANK FIRST ONE
          LE   B6,B7,SETDOLR       DONE IF FIELD EXHAUSTED
          SA1    B6-1              FETCH NEXT FORMAT CHAR TO THE LEFT 
          SX2    X1-DISPND
          ZR   X2,INTEDT7          BLANK IT IF POUND
          SX2    X1-DISCOMA 
          ZR   X2,INTEDT7          BLANK IT IF COMMA
          SX2    X1-DISTAR
          NZ   X2,SETDOLR          DONE FILLING IF NOT ASTERISK 
* 
 SKIPAST  SB6    B6-1              LEAVE ANY ASTERISKS AND COMMAS 
          SA1    B6                FETCH FORMAT CHAR
          SX2    X1-DISTAR
          ZR   X2,INTEDT8 
          SX2    X1-DISCOMA 
          NZ   X2,INTEDT10         DONE FILLING IF NOT COMMA OR ASTERISK
          SX6    DISTAR      REPLACE THE COMMA WITH A STAR
          SA6    A1 
 INTEDT8  LE     B6,B7,INTEDT11    DONE IF FIELD EXHAUSTED
          EQ   SKIPAST             LOOP FOR MORE FILL 
* 
 INTEDT10 SB6    B6+1              POINT TO LAST CHAR SKIPPED 
          SA1    B6                CHECK IF IT WAS COMMA
          SX1    X1-DISCOMA 
          NZ   X1,INTEDT11         NO 
          SB6    B6+1              LET DOLLAR OVERWRITE IT
 INTEDT11 SX6    B6                SAVE LAST CHAR POSN
          SA6    LASTCHR
* 
 SETDOLR  SA1    DOLLAR            STORE DOLLAR SIGN IF REQD
          ZR   X1,SETSIGN          JUMP IF NO DOLLAR NEEDED 
          SX6    DISDOLR
          SB6    B6-1 
          SA6    B6 
          SX6    B6                UPDATE LAST CHAR POSN
          SA6    LASTCHR
* 
 SETSIGN  BSS    0                 STORE SIGN IF REQD 
          SA1    FSIGN             X1 = FORMAT SIGN SPECIFICATION 
          ZR   X1,BLANKFL          EXIT IF NO SPEC, ALREADY DONE
          SA2    SIGN              X2 = NONZERO IF NUMBER NEGATIVE
          NG   X1,SETSGN3          SKIP IF LOWERCASE
          SX3    X1-DISDEE
          ZR   X3,TRAILSG          HANDLE TRAILING SIGN SEPARATELY
          SX3    X1-DISCEE
          ZR   X3,TRAILSG 
          EQ   SETSGN4
 SETSGN3  BX1    -X1               CONVERT TO 76XX
          SX3    X1-ESCCEE
          ZR   X3,TRAILSG 
          SX3    X1-ESCDEE
          ZR   X3,TRAILSG 
* 
 SETSGN4  BSS    0
          SX6    DISBLNK           SET UP SIGN CHAR AS IF 
          SX3    X1-DISPLUS        NUMBER WERE POSITIVE 
          NZ   X3,SETSGN1          JUMP IF NOT PLUS FORMAT
          SX6    DISPLUS
 SETSGN1  ZR   X2,SETSGN2          SKIP IF NUMBER NEGATIVE
          SX6    DISMINS           CHANGE CHAR FOR NEG NUM
          SX3    X1-DISLPAR        SET MINUS OR PAREN 
          NZ   X3,SETSGN2          JUMP IF NOT PAREN
          SX6    X1                USE PAREN
 SETSGN2  SA3    LASTCHR           READY TO STORE, LAST CHAR POSN 
          SB6    X3-1              NEXT POSN TO THE LEFT
          SA6    B6 
          SX3    X1-DISLPAR 
          NZ   X3,BLANKFL          EXIT IF NOT PAREN
* 
 TRAILSG  BSS    0                 HANDLE TRAILING SIGN FORMAT
          NZ   X2,BLANKFL          EXIT IF NUMBER NEGATIVE
          SA2    WIDTH             MUST BLANK TRAILING CHARS
          SX2    X2+FIELD-1        FOR POSITIVE NUMBER
          SX6    DISBLNK
          SA6    X2                BLANK LAST CHAR
          SX3    X1-DISLPAR 
          ZR   X3,BLANKFL          EXIT IF PAREN
          SA6    X2-1              BLANK SECOND LAST FOR DB OR CR 
* 
 BLANKFL  SX6    DISBLNK           BLANK FILL FIELD TO LEFT 
 BLANKF1  LE   B6,B7,SETSTAR       SKIP IF FIELD FULL 
          SB6    B6-1 
          SA6    B6                STORE BLANK
          EQ   BLANKF1             LOOP 
* 
 SETSTAR  GE   B6,B7,INTEXIT       SKIP IF NO OVERFLOW
          SA1    MONEY
          ZR   X1,SETSTR1          SKIP IF NOT MONETARY 
          RJ   ASTFILL             FILL FIELD WITH ASTERISKS
          MX6    1                 SET OVERFLOW FLAG
          SA6    OVFLOW 
          EQ   INTEDIT
 SETSTR1  SX6    DISTAR 
          SB6    B6-1 
          SA6    B6 
 INTEXIT  SX6    B6                SAVE ADDR OF FIELD START 
          SA6    FLDSTRT
          EQ   INTEDIT
* 
* 
* 
 MOVFRAC  DATA   0                 MOVE FRACTIONAL DIGITS INTO FIELD, BL
          SA1    UNITPOS
          SB6    X1+2              ADDR OF FIRST FRAC DIGIT POSN
          SA1    FZEROS 
          ZR   X1,MOVFRC           SKIP IF NO LEAD ZEROS NEEDED 
* 
          SX6    DISZERO
 MOVZERO  BSS    0                 MOVE LEAD FRACTIONAL ZEROS 
          SA6    B6                STORE ZERO 
          SB6    B6+1 
          SX1    X1-1              DECR COUNT 
          NZ   X1,MOVZERO          LOOP IF MORE 
* 
 MOVFRC   BSS    0                 MOVE FRACTIONAL DIGITS 
          SA1    FRCDGTS           NUMBER OF DIGITS TO MOVE 
          SA2    INTDGTS
          SA2    OBUFLCL+X2+1      FETCH FIRST FRAC DIGIT IF ANY
 MOVFRC1  ZR   X1,BLNKFRC          GO BLANK WHEN ALL DIGITS MOVED 
          BX6    X2                STORE DIGIT IN FIELD 
          SA6    B6 
          SB6    B6+1 
          SX1    X1-1              DECR COUNT 
          SA2    A2+1              FETCH NEXT DIGIT IF ANY
          EQ   MOVFRC1             LOOP 
* 
 BLNKFRC  BSS    0                 BLANK REST OF FRACTION FIELD 
          SA1    FRACPOS           SIZE OF FRAC FIELD 
          SA2    FRCDGTS           NUMBER OF DIGITS AVAILABLE 
          SA3    FZEROS            ADD LEAD ZEROS 
          IX2    X2+X3
          IX1    X1-X2             NUMBER OF BLANKS NEEDED
          SX6    DISBLNK
 BLNKFR1  ZR   X1,MOVFRAC          EXIT WHEN DONE 
          SA6    B6                STORE BLANK
          SB6    B6+1 
          SX1    X1-1              DECR COUNT 
          EQ   BLNKFR1             LOOP 
* 
* 
* 
 EXPCONV  DATA   0                 CONVERT EXPONENT, MOVE INTO FIELD
          SX6    1                 DETERMINE NUMBER OF DIGITS 
          SA1    EXPON
          PL   X1,EXPCON1 
          BX1    -X1               ABS VALUE
 EXPCON1  SX2    9
          IX2    X2-X1
          PL   X2,EXPCON2 
          SX6    X6+1              ALLOW FOR TENS DIGIT 
 EXPCON2  SX2    99 
          IX2    X2-X1
          PL   X2,EXPCON3 
          SX6    X6+1              ALLOW FOR HUNDREDS DIGIT 
 EXPCON3  SA6    EXPDGTS           NUM DIGITS 
* 
          SA2    EXPON
          PL   X2,EXPCON4          JUMP IF POSITIVE EXP 
          SX6    X6+1              ALLOW FOR MINUS SIGN 
 EXPCON4  SX6    X6+1              ALLOW FOR E, X6 = POSNS REQUIRED 
          SA2    UNITPOS           FIND ADDR OF EXP FIELD 
          SA3    FRACPOS
          IX2    X2+X3
          SB6    X2+2              ALLOW FOR PERIOD, POINT TO NEXT FREE 
          SA2    ARROWS            EXPONENT FIELD WIDTH 
          IX2    X2-X6             MINUS EXP SIZE 
          NG   X2,EXPERR           JUMP IF TOO LARGE
* 
          SX6    DISEXP            STORE E
          SA6    B6 
          SB6    B6+1 
          SA3    EXPON
          NG   X3,EXPSIGN          GO PLACE MINUS SIGN
          ZR   X2,EXPZERO          EXACT FIT, NO PLUS SIGN
          SX6    DISPLUS           PLACE PLUS SINCE ROOM EXISTS 
          SA6    B6 
          SB6    B6+1 
          SX2    X2-1              DECR PLACES LEFT 
          EQ   EXPZERO             GO PLACE LEAD ZEROS
 EXPSIGN  SX6    DISMINS           PLACE MINUS SIGN 
          SA6    B6 
          SB6    B6+1 
* 
 EXPZERO  BSS    0
          SX6    DISZERO           X2 = NUM LEAD ZEROS REQD 
 EXPCON5  ZR   X2,EXPDIGS          EXIT IF DONE 
          SA6    B6 
          SB6    B6+1 
          SX2    X2-1 
          EQ   EXPCON5             LOOP 
* 
 EXPERR   BSS    0                 EXPONENT TOO BIG FOR FIELD 
          SA3    MONEY
          ZR   X3,EXPERR1          SKIP IF NOT MONETARY 
          RJ   ASTFILL             FILL FIELD WITH ASTERISKS
          EQ   EXPCONV             DONE 
 EXPERR1  BX2    -X2               NUMBER OF EXTRA SPACES REQD
          SB5    X2+1              PLUS ONE FOR THE ASTERISK
          SA2    WIDTH
          SX6    X2+B5             UPDATE WIDTH 
          SA6    A2 
          SX6    DISEXP            STORE E AND ASTERISK 
          SA6    B6 
          SX6    DISTAR 
          SA6    B6+1 
          SB6    B6+2 
          SA2    EXPON             PLACE MINUS IF NEGATIVE
          PL   X2,EXPDIGS 
          SX6    DISMINS
          SA6    B6 
          SB6    B6+1 
* 
 EXPDIGS  BSS    0                 INSERT DIGITS INTO FIELD 
          SA2    EXPDGTS           X1 STILL CONTAINS VALUE OF EXP 
          SX3    X2-3 
          NG   X3,EXPCON6          SKIP HUNDREDS
          SX6    DISZERO-1
          SX3    100
 EXPCON7  SX6    X6+1 
          IX1    X1-X3
          PL   X1,EXPCON7          LOOP 
          IX1    X1+X3             TOO FAR,RESET
          SA6    B6                STORE DIGIT
          SB6    B6+1 
 EXPCON6  SX3    X2-2 
          NG   X3,EXPCON8          SKIP TENS
          SX6    DISZERO-1
          SX3    10 
 EXPCON9  SX6    X6+1 
          IX1    X1-X3
          PL   X1,EXPCON9          LOOP 
          IX1    X1+X3             RESET
          SA6    B6 
          SB6    B6+1 
 EXPCON8  SX6    X1+DISZERO        UNITS DIGIT
          SA6    B6 
          SB6    B6+1 
          EQ   EXPCONV
* 
* 
* 
 ASTFILL  DATA   0                 FILL FIELD WITH ASTERISKS
          SB6    FIELD-1           START ADDR - 1 
          SA1    WIDTH
          SB7    FIELD+X1-1        END ADDR 
          SX6    DISTAR 
 ASTFIL1  SB6    B6+1 
          SA6    B6 
          LT   B6,B7,ASTFIL1       LOOP 
          SX6    FIELD             FIELD START ADDR 
          SA6    FLDSTRT
          EQ   ASTFILL
* 
* 
* 
 FSCAN    DATA   0                 SCAN FORMAT AND UNPACK 
          SA2    PAREN
          NZ   X2,FSCAN3           SKIP IF PAREN CHECK MODE 
          SA1    FPTR              GET FORMAT POINTER WORD
          SB6    X1                B6 = CHARACTER POSN 0-9
          AX1    18                CURRENT WORD ADDR
          SA1    X1                X1 = CURRENT WORD OF FORMAT
          SB5    B6                POSITION TO CHARACTER
 FSCAN1   ZR   B5,FSCAN2
          LX1    6
          SB5    B5-1 
          EQ   FSCAN1 
 FSCAN2   SX0    77B               CONSTANT 
          SB7    FIELD             B7 = UNPACKED BUFFER POINTER 
* 
 FSCAN3   SX6    B0                SET INITIAL STATE
          SA6    STATE
          SA6    FSIGN             INIT FORMAT SIGN TYPE UNSIGNED 
          SA6    DOLLAR            NO DOLLARS YET 
          SA6    ASTERSK           NOR ASTERISKS
          SA6    PERIOD            NOR PERIOD 
          SA6    MONEY             NOT MONETARY FIELD 
          SA6    INTPOS            INIT INTEGER POSITIONS 
          SA6    FRACPOS           AND FRACTIONAL ONES
          SX6    TYPEJ             INIT FORMAT TYPE 
          SA6    FTYPE
* 
 GETCHR   RJ   EXCHAR              GET NEXT CHARACTER IN X7 
          PL   X7,GETCHR3          SKIP IF NOT ESCAPE CODE CHAR 
          BX2    -X7               CONVERT TO 74XX OR 76XX
          IFEQ   CHARSET,NEWCSET
          SX3    X2-ESCCIRC        CHECK IF CIRCUMFLEX
          NZ   X3,GETCHR4 
          SX7    CIRCFLEX          SUBSTITUTE NON-ASCII VALUE 
          EQ   GETCHR3
          ENDIF 
 GETCHR4  SX3    X2-ESCCEE
          ZR   X3,GETCHR5          FOUND LOWERCASE C
          SX3    X2-ESCDEE
          ZR   X3,GETCHR5          FOUND LOWERCASE D
          SX7    1                 ANYTHING ELSE WILL END SCAN
          EQ   GETCHR3             SUBSTITUTE UPPERCASE A TO END SCAN 
 GETCHR5  SX2    9                 SET CLASS 9 FOR TRAILING SIGN
          EQ   GETCHR6             JUMP INTO STATE CHANGE 
 GETCHR3  BSS    0
          SX3    X7                CLASSIFY THE CHARACTER 
          LX3    59                PLUS/MINUS FOR CHAR VALUE EVEN/ODD 
          SX2    X7 
          AX2    1                 CHAR VALUE/2 
          SA2    TABLE+X2          FETCH WORD CONTAINING 2 ENTRIES
          NG   X3,GETCHR1          USE ODD ENTRY
          AX2    30                SELECT EVEN ENTRY
 GETCHR1  AX2    24 
          BX2    X0*X2             X2 = CLASS 
 GETCHR6  BSS    0
          SA3    STATE             COMBINE CURRENT STATE AND CHAR CLASS 
          LX3    1                 TO GET NEW STATE AND ACTION ADDR 
          BX4    X3                2*STATE
          LX4    2                 8*STATE
          IX3    X3+X4             10*STATE 
          IX2    X2+X3             10*STATE+CLASS 
          SX3    X2                FETCH NEW STATE AND ACTION 
          LX3    59 
          AX2    1
          SA2    TABLE+X2          2 ENTRIES
          NG   X3,GETCHR2 
          AX2    30 
 GETCHR2  SB5    X2                ACTION ADDR
          AX2    18 
          BX6    X0*X2             NEW STATE
          SA6    STATE
          JP   B5                  GO DO ACTION 
* 
 FERROR   BSS    0                 ERROR EXIT FOR PAREN CHECK MODE
          SX6    B0                TURN PAREN FLAG OFF TO INDICATE ERROR
          SA6    PAREN
          EQ   FSCAN
 PUTSIGN  SA7    FSIGN             STORE SIGN CHAR
          SX2    X7-DISLPAR 
          NZ   X2,PUTSGN1 
          SA7    MONEY             PAREN SIGN MEANS MONETARY FIELD
 PUTSGN1  SX6    TYPEI             TYPE SIGNED INTEGER
          SA6    FTYPE
          EQ   PUTCHR 
 PUTJUST  SA7    FSIGN             STORE STRING JUSTIFICATION 
          SX6    TYPES             TYPE STRING
          SA6    FTYPE
          EQ   PUTCHR 
 SETDOL   SA7    DOLLAR            INDICATE DOLLARS EXIST 
          SA7    MONEY             INDICATE MONETARY FIELD
          EQ   PUTCHR              DO NOT COUNT FIRST DOLLAR AS INTEGER 
 SETAST   SA7    ASTERSK           INDICATE ASTERISKS EXIST 
          SA7    MONEY             INDICATE MONETARY FIELD
          EQ   INTINCR             AND GO COUNT AS AN INTEGER POSN
 DECPT    SA7    PERIOD            INDICATE PERIOD EXISTS 
          SX6    TYPEF             TYPE FIXED POINT 
          SA6    FTYPE
          SX6    B7-1              UNITS DIGIT PRECEDES POINT 
          SA6    UNITPOS
          EQ   PUTCHR 
 INTINCR  SA2    INTPOS            INCREMENT INTEGER POSNS
          SX6    X2+1 
          SA6    A2 
          EQ   PUTCHR 
 COMMA    SA7    B7                STORE COMMA
          SB7    B7+1 
          RJ   EXCHAR              CHECK NEXT CHARACTER 
          SX2    X7-DISPND
          NZ   X2,COMMA1
          SX6    2                 NEW STATE 2 FOR POUND
          SA6    STATE
          EQ   INTINCR             GO COUNT IT
 COMMA1   SX2    X7-DISDOLR 
          NZ   X2,COMMA2
          SA2    STATE             DOLLAR OK ONLY IN STATE 3
          SX2    X2-3 
          NZ   X2,COMMA4           REJECT COMMA DOLLAR
          EQ   INTINCR             ACCEPT, GO COUNT DOLLAR
 COMMA2   SX2    X7-DISTAR
          NZ   X2,COMMA4           REJECT IF NOT POUND, DOLLAR, OR ASTER
          SA2    STATE             ASTERISK OK ONLY IN STATE 3 OR 4 
          SX3    X2-3 
          ZR   X3,COMMA3
          SX3    X2-4 
          NZ   X3,COMMA4           REJECT COMMA ASTERISK
 COMMA3   SX6    4                 NEW STATE 4 FOR ASTERISK 
          SA6    STATE
          EQ   SETAST              GO COUNT ASTERISK
 COMMA4   SX6    B7-2              SAVE ADDR OF END OF INTEGER FIELD
          SA6    UNITPOS
          EQ   BACK1               GO BACK UP OVER COMMA
 INTDONE  SX6    B7-1              END INTEGER, SAVE ADDR OF UNITS POSN 
          SA6    UNITPOS
          EQ   DONE 
 FRCINCR  SA2    FRACPOS           INCR FRACTIONAL POSNS
          SX6    X2+1 
          SA6    A2 
          EQ   PUTCHR 
 FSTARRW  SX6    TYPEE             TYPE FLOATING POINT
          SA6    FTYPE
          SX6    1                 INIT ARROW COUNT 
          SA6    ARROWS 
          EQ   PUTCHR 
 EXPINCR  SA2    ARROWS            INCR ARROW COUNT 
          SX6    X2+1 
          SA6    A2 
          EQ   PUTCHR 
 EXPDONE  SA2    ARROWS            CHECK IF 2 OR MORE ARROWS
          SX2    X2-2 
          PL   X2,DONE             EXIT IF 2 OR MORE
          SX6    TYPEF             NOT REALLY FLOATING PT 
          SA6    FTYPE
          EQ   BACK1               GO BACK UP OVER THE ARROW
 EXPTRL   SA2    ARROWS            CHECK IF 2 OR MORE ARROWS
          SX2    X2-2 
          PL   X2,TRLSGN5          YES, PROCESS TRAILING SIGN 
          SX6    TYPEF             NOT REALLY FLOATING PT 
          SA6    FTYPE
          EQ   BACK1               GO BACK UP OVER ARROW AND SIGN 
 TRLSGN   BSS    0                 POSIBLE TRAILING SIGN ENCOUNTERED
          SA2    FTYPE             SAVE ADDR OF UNITS DIGIT POSN
          SX3    X2-TYPEJ          IF INTEGER FORMAT
          ZR   X3,TRLSGN4 
          SX3    X2-TYPEI 
          NZ   X3,TRLSGN5          JUMP IF NOT I OR J 
 TRLSGN4  SX6    B7-1 
          SA6    UNITPOS
 TRLSGN5  SA2    FSIGN
          ZR   X2,TRLSGN1          SKIP IF NO LEAD SIGN 
          SX3    X2-DISLPAR 
          NZ   X3,DONE             REJECT IF NOT LEAD LPAREN
          SX2    X7-DISRPAR        LEAD SIGN IS LPAREN
          NZ   X2,FERROR           THIS IS NOT MATCHING RPAREN
          SA7    B7                ACCEPT RPAREN
          SB7    B7+1 
          EQ   DONE2               GO WRAP UP 
 TRLSGN1  SX2    X7-DISRPAR        NO LEAD SIGN 
          ZR   X2,DONE             REJECT RPAREN IF NO LEAD LPAREN
          SA7    TRLCHAR           SAVE FIRST CHAR OF POSSIBLE DB CR
          SB7    B7+1 
          RJ   EXCHAR              GET NEXT CHAR IN X7
          SA2    TRLCHAR           X2 = FIRST CHAR, X7 = SECOND CHAR
          NG   X2,TRLSGN7          SKIP IF LOWERCASE
          SX3    X2-DISCEE
          ZR   X3,TRLSGN2          FOUND C
          EQ   TRLSGN6             NOT C IS D 
 TRLSGN7  BX3    -X2               CONVERT TO 76XX
          SX3    X3-ESCCEE
          NZ   X3,TRLSGN6          NOT C IS D 
 TRLSGN2  BSS    0                 FIRST CHAR IS C
          NG   X7,TRLSGN8          SKIP IF LOWERCASE
          SX3    X7-DISR
          ZR   X3,TRLSGN3          FOUND CR 
          EQ   BACK1
 TRLSGN8  BX3    -X7               CONVERT TO 76XX
          SX3    X3-ESCR
          ZR   X3,TRLSGN3          FOUND CR 
          EQ   BACK1
 TRLSGN6  BSS    0                 FIRST CHAR IS D
          NG   X7,TRLSGN9          SKIP IF LOWERCASE
          SX3    X7-DISBEE
          ZR   X3,TRLSGN3          FOUND DB 
          EQ   BACK1
 TRLSGN9  BX3    -X7               CONVERT TO 76XX
          SX3    X3-ESCBEE
          ZR   X3,TRLSGN3          FOUND DB 
          EQ   BACK1
 TRLSGN3  BX6    X2                ACCEPT DB OR CR
          SA6    FSIGN             SET SIGN D OR C
          SA6    MONEY             INDICATE MONETARY FIELD
          SA6    B7-1              STORE CHARACTER IN FIELD 
          SA7    B7                AND SECOND CHAR
          SB7    B7+1              POINT TO NEXT FREE SPACE 
          EQ   DONE2               GO WRAP UP 
 PUTCHR   SA7    B7                STORE CHARACTER IN UNPACK BUFFER 
          SB7    B7+1 
          EQ   GETCHR              GO GET NEXT CHAR 
* 
 BACK1    BSS    0                 BACK UP ONE BEFORE GOING TO DONE 
          SA2    ASCII
          ZR   X2,BACK12           SKIP IF NOT ASCII MODE 
          SA2    LASTASC           MAY HAVE TO BACK UP 12 BITS
          LX2    30                PROMOTE SECOND LAST CHAR FLAG TO LAST
          BX6    X2 
          SA6    A2                UPDATE LASTASC FLAG
          SX2    X2                EXTRACT LAST CHAR INDICATOR
          ZR   X2,BACK12           JUMP IF IT WAS NOT ESCAPE CODE CHAR
          ZR   B6,BACK13           BACK UP FIRST 6 BITS OF 12 
          SB6    B6-1 
          EQ   BACK12 
 BACK13   SA1    A1-1 
          SB6    9
 BACK12   SB7    B7-1              BACK UP 6 BITS HERE
          ZR   B6,BACK11
          SB6    B6-1 
          EQ   DONE 
 BACK11   SA1    A1-1 
          SB6    9
* 
 DONE     BSS    0                 BACK UP POINTER TO PREVIOUS CHARACTER
          SA2    ASCII
          ZR   X2,DONE3            SKIP IF NOT ASCII MODE 
          SA2    LASTASC           MAY HAVE TO BACK UP 12 BITS
          AX2    30                EXTRACT LAST CHAR INDICATOR
          ZR   X2,DONE3            JUMP IF IT WAS NOT ESCAPE CODE CHAR
          ZR   B6,DONE5            BACK UP FIRST 6 BITS OF 12 
          SB6    B6-1 
          EQ   DONE3
 DONE5    SA1    A1-1 
          SB6    9
 DONE3    BSS    0                 BACK UP 6 BITS HERE
          ZR   B6,DONE1            JUMP IF BACKUP INTO PREV WORD
          SB6    B6-1 
          EQ   DONE2
 DONE1    SA1    A1-1 
          SB6    9
* 
 DONE2    SA2    FSIGN             CHECK FOR MATCHING PARENS
          SX2    X2-DISLPAR 
          NZ   X2,DONE4            SKIP IF NOT LPAREN SIGN
          SA2    B7-1              LAST CHAR IN FIELD 
          SX2    X2-DISRPAR 
          NZ   X2,FERROR           ERROR IF NOT MATCHING RPAREN 
* 
 DONE4    SA2    PAREN             EXIT IF PAREN CHECK MODE 
          NZ   X2,FSCAN 
          SA2    FPTR              UPDATE FORMAT POINTER
          MX3    24                SAVE FLAGS AND ADDR
          BX6    X3*X2
          SX2    A1                WORD ADDR
          LX2    18 
          BX6    X6+X2
          SX2    B6                CHAR POSN
          BX6    X6+X2
          SA6    A2 
          SX7    B7-FIELD          CALCULATE FIELD WIDTH
          SA7    WIDTH
          EQ   FSCAN
* 
* 
* 
 EXCHAR   DATA   0                 EXTRACT NEXT FORMAT CHARACTER TO X7
* 
          SB7    B7-FIELD    CHECK FOR UNPACK FIELD OVERFLOW
          SB5    MAXFLD+1 
          GT     B7,B5,ER127 * BAD FORMAT/LITERAL FIELD * 
          SB7    B7+FIELD 
* 
          LX1    6                 EXTRACT CHAR 
          BX7    X0*X1
          NZ   X7,EXCHAR4          NONZERO CHARACTER
* 
          SB5    9                 CHECK FOR END OF LINE
          EQ   B5,B6,EXCHAR2       JUMP IF LAST CHAR IN WORD
          SX2    B6                CHECK IF REST OF WORD ZERO 
          LX2    1                 2*B6 
          SX3    X2 
          LX3    1                 4*B6 
          IX2    X2+X3             6*B6 
          BX2    -X2
          SX2    X2+54             54-6*B6
          SB5    X2-1              FORM MASK
          MX2    1
          AX2    X2,B5
          BX3    X2*X1             REST OF WORD 
          NZ   X3,EXCHAR1          JUMP IF NOT END OF LINE
          EQ   EXCHAR3             GO SET EOL 
 EXCHAR2  SA2    A1+1              CHECK NEXT WORD ZERO 
          NZ   X2,EXCHAR1          JUMP IF NOT EOL
 EXCHAR3  SX7    101B              END OF LINE ENCOUNTERED
* 
 EXCHAR4  BSS    0
          SA2    ASCII
          ZR   X2,EXCHAR1          SKIP IF NOT ASCII MODE 
          SA3    LASTASC     MOVE LAST CHAR ASCII FLAG TO 2ND-LAST POSN 
          AX3    30 
          SX2    X7-CMASK1         CHECK IF ESCAPE CODE 
          ZR   X2,EXCHAR5          YES
          SX2    X7-CMASK2
          NZ   X2,EXCHAR7          EXIT IF NOT
 EXCHAR5  LX7    6                 MOVE ESCAPE CODE OVER
          SB6    B6+1              INCR CHAR POSN 
          SB5    10 
          NE   B5,B6,EXCHAR6       SKIP IF MORE IN THIS WORD
          SA1    A1+1              FETCH NEXT WORD
          SB6    B0                RESET CHAR PTR 
 EXCHAR6  LX1    6                 GET NEXT CHAR - LOWER HALF OF
          BX2    X0*X1             12 BIT ESCAPE CODE CHARACTER 
          BX7    X7+X2             FORM 12 BIT CHAR 
          BX7    -X7               COMPLEMENT FOR EASY IDENTIFICATION 
          SX2    1                 INDICATE LAST CHAR IS ASCII
          LX2    30 
          BX3    X3+X2
 EXCHAR7  BX6    X3                UPDATE LAST CHAR FLAGS 
          SA6    A3 
 EXCHAR1  SB6    B6+1              INCR CHAR POSN 
          SB5    10 
          NE   B5,B6,EXCHAR        EXIT IF MORE CHARS IN WORD 
          SA1    A1+1              FETCH NEXT WORD
          SB6    B0                RESET CHAR POINTER 
          EQ   EXCHAR 
* 
* 
* 
 LSCAN    DATA   0                 SCAN POSSIBLE LITERAL AND UNPACK 
          SA1    FPTR              GET FORMAT POINTER WORD
          SB6    X1                B6 = CHARACTER POSN 0-9
          AX1    18                CURRENT WORD ADDR
          SA1    X1                X1 = CURRENT WORD
          SB5    B6                POSITION TO CHARACTER
 LSCAN1   ZR   B5,LSCAN2
          LX1    6
          SB5    B5-1 
          EQ   LSCAN1 
 LSCAN2   SX0    77B               CONSTANT 
          SB7    FIELD             B7 = UNPACKED BUFFER POINTER 
* 
 LGETCHR  RJ   EXCHAR              GET NEXT CHARACTER IN X7 
 LCLASS   BSS    0                 CHECK IF FIELD STARTS HERE 
          SX6    B0                RESET PAREN FLAG 
          SA6    PAREN
          NG   X7,LPUTCHR          JUMP IF ESCAPE CODE CHAR 
          SX3    X7                CLASSIFY THE CHARACTER 
          LX3    59                PLUS/MINUS FOR CHAR VALUE EVEN/ODD 
          SX2    X7 
          AX2    1                 CHAR VALUE/2 
          SA2    TABLE+X2          FETCH WORD CONTAINING 2 ENTRIES
          NG   X3,LCLASS1          USE ODD ENTRY
          AX2    30                SELECT EVEN ENTRY
 LCLASS1  AX2    24 
          BX2    X0*X2             X2 = CLASS 
          SB5    X2 
          SB5    X2 
          JP   B5+LJMPS            TAKE ACTION
 LJMPS    JP   LOTHER              OTHER INCL EOL 
          JP   LSIGN               SIGN - PLUS MINUS LPAREN 
          JP   ENDLIT              LESS GREATER 
          JP   ENDLIT              POUND
          JP   LDOLLAR             DOLLAR 
          JP   LASTRSK             ASTERISK 
          JP   LPERIOD             PERIOD 
          JP   LPUTCHR             COMMA
          JP   LPUTCHR             UPARROW
          JP   LPUTCHR             TRAILSIGN - C D RPAREN 
* 
 LOTHER   SX2    X7-101B           CHECK FOR EOS
          NZ   X2,LPUTCHR          JUMP IF NOT
          SA2    FPTR              SET EOS BIT
          MX6    1
          BX6    X6+X2
          SA6    A2 
          EQ   ENDLIT3             GO WRAP UP 
 LSIGN    SA7    B7                STORE SIGN 
          SB7    B7+1 
          SX6    B0                RESET BACKUP COUNT 
          SA6    BACKUP 
          SX2    X7-DISLPAR 
          NZ   X2,LSIGN1           SKIP IF NOT LPAREN 
          MX6    1                 SET SWITCH FOR LATER RPAREN CHECK
          SA6    PAREN
 LSIGN1   RJ   EXCHAR              CHECK NEXT CHAR
          SX2    X7-DISPND
          ZR   X2,LBACK1           SIGN-POUND, BACK UP
          SX2    X7-DISPNT
          NZ   X2,LSIGN2
          SX6    1                 SET BACKUP COUNT 
          EQ   LPEROD1             CALL PERIOD CHECK
 LSIGN2   SX2    X7-DISDOLR 
          NZ   X2,LSIGN3
          SX6    1                 SET BACKUP COUNT 
          EQ   LDOLLR1             CALL DOLLAR CHECK
 LSIGN3   SX2    X7-DISTAR
          NZ   X2,LCLASS           NOT POSSIBLE SIGN FIELD
          SX6    1                 SET BACKUP COUNT 
          EQ   LASTRK1             CALL ASTERISK CHECK
 LDOLLAR  SX6    B0                RESET BACKUP COUNT 
 LDOLLR1  SA6    BACKUP            ENTER HERE IF CALLED 
          SA7    B7                STORE DOLLAR 
          SB7    B7+1 
          RJ   EXCHAR              CHECK NEXT CHAR
          SX2    X7-DISPND
          ZR   X2,LBACK1           DOLLAR-POUND, BACK UP
          SX2    X7-DISDOLR 
          ZR   X2,LBACK1           DOLLAR-DOLLAR, BACK UP 
          SX2    X7-DISPNT
          NZ   X2,LDOLLR2 
          SA2    BACKUP            INCR BACKUP COUNT
          SX6    X2+1 
          EQ   LPEROD1             CALL PERIOD CHECK
 LDOLLR2  SX2    X7-DISTAR
          NZ   X2,LCLASS           NOT POSSIBLE DOLLAR FIELD
          SA2    BACKUP            INCREASE BACKUP COUNT
          SX6    X2+1 
          EQ   LASTRK1             CALL ASTERISK CHECK
 LASTRSK  SX6    B0                RESET BACKUP COUNT 
 LASTRK1  SA6    BACKUP            ENTER HERE IF CALLED 
          SA7    B7                STORE ASTERISK 
          SB7    B7+1 
          RJ   EXCHAR              CHECK NEXT CHAR
          SX2    X7-DISPND
          ZR   X2,LBACK1           AST-POUND
          SX2    X7-DISTAR
          ZR   X2,LBACK1           AST-AST
          SX2    X7-DISPNT
          NZ   X2,LASTRK2 
          SA2    BACKUP            INCREASE BACKUP COUNT
          SX6    X2+1 
          EQ   LPEROD1             CALL PERIOD CHECK
 LASTRK2  SX2    X7-DISCOMA 
          NZ   X2,LCLASS           NOT POSSIBLE ASTERISK FIELD
          SA7    B7                STORE COMMA
          SB7    B7+1 
          SA2    BACKUP            INCREASE BACKUP COUNT
          SX6    X2+1 
          SA6    A2 
          RJ   EXCHAR              CHECK NEXT CHAR
          SX2    X7-DISPND
          ZR   X2,LBACK1           AST COMMA POUND
          SX2    X7-DISTAR
          ZR   X2,LBACK1           AST COMMA AST
          EQ   LCLASS 
 LPERIOD  SX6    B0                RESET BACKUP COUNT 
 LPEROD1  SA6    BACKUP            ENTER HERE IF CALLED FROM ANOTHER CHA
          SA7    B7                STORE PERIOD 
          SB7    B7+1 
          RJ   EXCHAR              CHECK FOR FOLLOWING POUND
          SX2    X7-DISPND
          ZR   X2,LBACK1           PERIOD-POUND, BACK UP
          EQ   LCLASS              ACCEPT PERIOD, CLASSIFY OTHER
 LPUTCHR  SA7    B7                STORE CHARACTER IN UNPACK BUFFER 
          SB7    B7+1 
          EQ   LGETCHR             GO GET NEXT CHAR 
* 
 LBACK1   SB7    B7-1              BACK UP 1 BEFORE GOING TO ENDLIT 
          ZR   B6,LBACK11 
          SB6    B6-1 
          EQ   LBACK12
 LBACK11  SA1    A1-1 
          SB6    9
 LBACK12  SA2    BACKUP            CHECK IF MORE REQUIRED 
          ZR   X2,ENDLIT           EXIT IF DONE 
          SX6    X2-1 
          SA6    A2 
          EQ   LBACK1              REPEAT 
* 
 ENDLIT   BSS    0                 FINISHED LITERAL 
          ZR   B6,ENDLIT1          BACK UP OVER LAST CHAR 
          SB6    B6-1 
          EQ   ENDLIT2
 ENDLIT1  SA1    A1-1 
          SB6    9
* 
 ENDLIT2  SA2    PAREN
          ZR   X2,ENDLIT4          SKIP IF NO PAREN CHECK REQD
          SX6    A1                SAVE CURRENT POSN OF (XXX
          LX6    18 
          SX2    B6 
          BX6    X6+X2
          SA6    PARPOSN
          SA1    A1                BACK UP X1 SINCE LBACK1 DID NOT
          SB5    B6 
 ENDLIT6  ZR   B5,ENDLIT5 
          LX1    6
          SB5    B5-1 
          EQ   ENDLIT6
 ENDLIT5  SX7    B7                SAVE B7
          SA7    PARSAV7
          RJ   FSCAN               SETS PAREN TO ZERO IF NO RPAREN MATCH
          SA1    PARPOSN           RESTORE POSN TO (XXX 
          SB6    X1 
          AX1    18 
          SA1    X1 
          SA2    PARSAV7           RESTORE B7 
          SB7    X2 
          SA2    PAREN
          NZ   X2,ENDLIT4          PAREN IS PART OF FIELD (XXX) 
          RJ   EXCHAR              PAREN IS PART OF LITERAL, FIELD IS XX
          SB7    B7+1 
* 
 ENDLIT4  SA2    FPTR              UPDATE FORMAT POINTER
          NG   X2,ENDLIT3          SKIP IF AT END 
          MX3    24                SAVE FLAGS AND INIT ADDR 
          BX6    X3*X2
          SX2    A1                WORD ADDR
          LX2    18 
          BX6    X6+X2
          SX2    B6                CHAR POSN
          BX6    X6+X2
          SA6    A2 
 ENDLIT3  SA2    ASCII
          NZ     X2,NOTCOLN  BR, NOT ASCII DATA--TRAILING COLONS ARE OK 
          SA2    B7-1        CHECK IF LAST CHARACTER IS A TRAILING COLON
          NZ     X2,NOTCOLN  BR, LAST CHARACTER IS NOT A COLON
          SX6    55B         ELSE, APPEND A BLANK TO THE LITERAL STRING 
          SA6    B7 
          SB7    B7+1 
          MX6    1           SET THE BLANK-APPENDED-TO-TRAILING-COLON FLAG
          SA6    COLONFL
 NOTCOLN  SX7    B7-FIELD    CALCULATE LITERAL WIDTH
          SA7    WIDTH
          SX6    FIELD             START ADDR 
          SA6    FLDSTRT
          EQ   LSCAN
* 
* 
* 
 PRINTIT  DATA   0                 PACK FIELD, PRINT, CHECK MARGIN
          SA1    FETADDR           GET MARGIN IN CHARACTERS 
          SA2    X1+FETLINL 
          SX6    MAXFLD 
          ZR     X2,PRNTIT0  JUMP IF MARGIN IS INFINITE 
          SX7    X2                CHARACTERS 
          AX2    29                WORDS*2
          BX3    X2 
          LX3    2
          IX2    X2+X3             WORDS*10 
          IX7    X7+X2             TOTAL CHAR 
* 
          SA1    X1+FETCHAR        GET CHARS ALREADY IN LINE
          SX6    X1 
          AX1    29 
          BX2    X1 
          LX2    2
          IX1    X1+X2
          IX6    X6+X1             EXISTING CHARS IN LINE 
* 
          IX6    X7-X6             MARGIN-EXISTING = SPACE LEFT 
          SA6    SPACE
* 
 PRNTIT0  BSS    0
          SA1    FLDSTRT           FIELD START ADDR 
          SA2    WIDTH
          SX2    FIELD+X2          FIELD END ADDR PLUS ONE
          IX7    X2-X1             FIELD SIZE 
* 
          IX7    X6-X7             SPACE-SIZE 
          PL   X7,PRNTIT1          SKIP IF IT FITS ON LINE
* 
*         FILL CURRENT LINE TO MARGIN 
          ZR   X6,PRNTIT1          SKIP IF LINE FULL
          SB6    X1                FIELD START ADDR FOR PACKFLD RTN 
          SX6    X6-1 
          SB7    B6+X6             FIELD END ADDR = START+SPACE-1 
          RJ   PACKFLD             PACK 10 CHAR PER WORD
          SA1    FETADDR           PRINT AND END LINE 
          SB5    X1 
          MX4    59                END LINE CODE
          RJ     PRNTIT2
          SA1    FLDSTRT           UPDATE START ADDR
          SA2    SPACE
          IX6    X1+X2
          SA6    A1 
          BX1    X6 
* 
 PRNTIT1  BSS    0                 PRINT REST OF FIELD
          SB6    X1                FIELD START ADDR 
          SA2    WIDTH
          SB7    FIELD+X2-1        FIELD END ADDR 
          RJ   PACKFLD             PACK 10 CHAR PER WORD
          SA1    FETADDR           PRINT AS MANY LINES AS REQUIRED
          SB5    X1 
          SA4    COLONFL
          ZR     X4,SETTAB   BR, NO BLANK-APPENDED-TO-TRAILING-COLON IN STRING
          LX4    -3          SET BLANK-APPENDED-TO-TRAILING-COLON FLAG (BIT 57
          SA1    FLDSTRT          OF STRING POINTER WORD) 
          BX6    X1-X4       AND STORE IT  BACK IN FLDSTRT
          SA6    A1 
          MX6    0           RESET THE BLANK-APPENDED-TO-TRAILING-COLON FLAG
          SA6    COLONFL               IN PREPERATION FOR NEXT TIME 
 SETTAB   MX4    0           SEMICOLON TAB (NO SPACING) 
          MX4    0                 SEMICOLON TAB (NO SPACING) 
          RJ     PRNTIT2
          EQ   PRINTIT
* 
* 
 PRNTIT2  DATA   0           CREATE POINTER WORD AND CALL BASOPRT 
          SA1    FLDSTRT     X1 = FWA 
          LX3    18+18       X3 = LENGTH IN 6-BIT CHARS 
          BX6    X1+X3
          SA6    STRPTR      SAVE DUMMY STR PTR 
          SA5    A6          A5 = ADR OF PTR WORD 
          RJ     BASOPRT
          EQ     PRNTIT2
* 
* 
* 
 PACKFLD  DATA   0                 PACK FIELD AND ADD LINE TERMINATOR 
          MX3    0           X3 = COUNT OF 6-BIT CHARS
          SA1    B6-1              PRESET A6
          BX6    X1 
          SA6    A1 
* 
 PACKFL1  SX6    B0                START NEW PACKED WORD
          SB5    9                 COUNT 9 - 0
 PACKFL2  SA1    B6                FETCH CHARACTER
          PL   X1,PACKFL5          SKIP IF NOT ESCAPE CODE CHAR 
          SX3    X3+1        INCREMENT 6-BIT CHAR COUNT 
          BX1    -X1               CONVERT TO 74XX OR 76XX
          MX2    54 
          BX2    -X2*X1            SAVE THE XX
          AX1    6                 RIGHT JUSTIFY 74 OR 76 
          LX6    6
          BX6    X6+X1             ADD TO WORD
          SB5    B5-1 
          PL   B5,PACKFL6          STILL ROOM FOR XX
          SA6    A6+1              STORE THE FULL WORD
          SX6    B0                START A NEW WORD 
          SB5    9
 PACKFL6  BX1    X2                MOVE SAVED XX BACK TO X1 
 PACKFL5  BSS    0
          LX6    6
          BX6    X6+X1
          SX3    X3+1        INCREMENT 6-BIT CHAR COUNT 
          EQ   B6,B7,PACKFL3       EXIT IF LAST ONE 
          SB6    B6+1 
          SB5    B5-1 
          PL   B5,PACKFL2          LOOP IN WORD 
          SA6    A6+1              STORE FULL WORD
          EQ   PACKFL1             GO START NEW WORD
* 
 PACKFL3  ZR   B5,PACKFL4          FILL LAST WORD WITH ZEROS
          LX6    6
          SB5    B5-1 
          EQ   PACKFL3             LOOP 
* 
 PACKFL4  SA6    A6+1              STORE LAST WORD
          SX1    7777B             CHECK IF LINE TERMINATOR EXISTS
          BX1    X1*X6
          ZR   X1,PACKFLD          EXIT IF YES
          SX6    B0                STORE EXTRA WORD 
          SA6    A6+1 
          EQ   PACKFLD
* 
* 
* 
 ADDTO    DATA   0                 PACK FIELD ONTO END OF STRBUF
          SA1    FLDSTRT
          SB6    X1                B6 = FIELD START ADDR
          SA1    WIDTH
          SB7    FIELD+X1-1        B7 = FIELD END ADDR
          SA1    STRBUFP           AMOUNT ALREADY IN STRBUF 
          SX2    X1                X2 = NUM CHAR IN LAST WORD 
          AX1    18                X1 = NUM WORDS 
          SA3    XSTRPTR     X3 = FWA OF RESULT STRING
          SX3    X3-2 
          IX3    X3+X1       PREST X6 
          SA3    X3 
          BX6    X3 
          SA6    A3 
          SA3    A3+1              FETCH LAST WORD
          BX6    X3 
          ZR   X1,ADDTO5           JUMP IF EMPTY BUFFER 
          SX3    X2-10
          NZ   X3,ADDTO1           SKIP IF LAST WORD NOT FULL 
 ADDTO5   SA6    A6+1 
          EQ   ADDTO4              GO START NEW WORD
* 
 ADDTO1   BX3    X2                COMPLETE LAST WORD 
          BX4    X3 
          LX4    1
          IX3    X3+X4
          LX3    1                 6*NCHAR = BITS ALREADY IN LAST WORD
          SB5    X3 
          LX6    X6,B5             POSITION PARTIAL WORD
          SX1    X1-1              ADJUST WORD COUNT, LAST NOT STORED YE
          EQ   ADDTO3              GO FILL WORD 
* 
 ADDTO4   SX6    B0                START NEW WORD 
          SX2    B0                ZERO CHAR COUNT
 ADDTO3   SA3    B6                FETCH NEXT CHARACTER 
          PL   X3,ADDTO9           SKIP IF NOT ESCAPE CODE CHAR 
          BX3    -X3               CONVERT TO 74XX OR 76XX
          MX4    54 
          BX4    -X4*X3            SAVE THE XX
          AX3    6                 RIGHT JUSTIFY 74 OR 76 
          LX6    6
          BX6    X6+X3             ADD 74 OR 76 TO WORD 
          SX2    X2+1              COUNT CHAR 
          SX5    X2-10
          NZ   X5,ADDTO10          STILL ROOM FOR XX
          SA6    A6+1              STORE FULL WORD
          SX1    X1+1              COUNT WORD 
          SX6    B0                START NEW WORD 
          SX2    B0 
 ADDTO10  BX3    X4                MOVE SAVED XX TO X3
 ADDTO9   BSS    0
          LX6    6
          BX6    X6+X3
          SX2    X2+1              COUNT CHAR 
          EQ   B6,B7,ADDTO2        EXIT IF NO MORE CHARS TO ADD 
          SB6    B6+1 
          SX4    X2-10
          NZ   X4,ADDTO3           LOOP IN WORD 
          SA6    A6+1              STORE FULL WORD
          SX1    X1+1              COUNT WORDS
          SX6    X1-MAXSIZE 
          PL     X6,ER168    * STRING OVERFLOW
          EQ   ADDTO4              GO START NEW WORD
* 
 ADDTO2   SX3    X2-10             FILL LAST WORD WITH ZEROS
 ADDTO7   ZR   X3,ADDTO6           EXIT IF FULL 
          LX6    6
          SX3    X3+1 
          EQ   ADDTO7              LOOP 
* 
 ADDTO6   SA6    A6+1              STORE FINAL WORD 
          SX1    X1+1              COUNT IT 
          SX3    7777B             CHECK FOR LINE TERMINATOR
          BX3    X3*X6
          ZR   X3,ADDTO8           SKIP IF YES
          SX6    B0                STORE EXTRA WORD 
          SA6    A6+1 
* 
 ADDTO8   BX6    X1                SAVE WORD AND CHAR COUNT 
          LX6    18 
          BX6    X6+X2
          SA6    STRBUFP
          EQ   ADDTO
* 
* 
* 
* 
 TYPEJ    EQU    0                 UNSIGNED POUND SIGNS 
 TYPEI    EQU    1                 SIGNED POUND SIGNS 
 TYPEF    EQU    2                 FIXED POINT
 TYPEE    EQU    3                 FLOATING POINT 
 TYPES    EQU    4                 STRING ONLY
 MAXDGTS  EQU    14 
 FPTR     BSS    1                 FORMAT POINTER WORD FROM X5
 ADDR     BSS    1                 PRINT ITEM ADDRESS FROM A4 
 VALUE    BSS    1                     PRINT ITEM FROM X4 
 FLAGS    BSS    1                 SEPARATOR/ITEM TYPE FLAGS FROM X3
 FETADDR  BSS    1                 FET ADDR FROM B5 
 SAVSET   BSS    1                 SAVE SETDIGITS VALUE 
 SPACE    BSS    1                 SAVE SPACE LEFT ON LINE
 OVFLOW   BSS    1                 NONZERO IF MONETARY FIELD OVERFLOWS
* 
 SIGN     BSS    1                 0/1 FOR NUMBER POS/NEG 
 INTDGTS  BSS    1                 NUMBER OF DIGITS IN INTEGER PART 
 FRCDGTS  BSS    1                 NUMBER OF DIGITS IN FRACTIONAL PART
 EXPDGTS  BSS    1                 NUMBER OF DIGITS IN EXPONENT 
 EXPON    BSS    1                 EXPONENT (POWER OF TEN)
 FZEROS   BSS    1                 NUMBER OF FRACTIONAL LEAD ZEROS
 LASTCHR  BSS    1                 ADDR OF HIGH ORDER DIGIT 
 FLDSTRT  BSS    1                 ADDR OF START OF NUMERIC FIELD 
* 
 STATE    BSS    1                 STATE FOR FSCAN ROUTINE
 TRLCHAR  BSS    1                 SAVE FIRST CHAR OF POSSIBLE DB CR
 BACKUP   BSS    1                 BACKUP COUNT FOR LITERAL SCAN
 PAREN    BSS    1                 FLAG FOR MATCHING PAREN CHECK
 PARPOSN  BSS    1                 SAVE POSITION OF (XXX
 PARSAV7  BSS    1                 SAVE B7 FOR LITERAL SCAN CALLING FSCA
 LASTASC  DATA   0     INDICATES LAST 2 CHAR SCANNED ASCII OR NOT 
 COLONFL  BSSZ   1           BLANK-APPENDED-TO-TRAILING-COLON FLAG
*          30/LAST,30/SECONDLAST USED FOR BACKING UP
 TABLE    BSS    0                 COMBINATION CHARACTER CLASSIFICATION,
*                                  STATE, AND ACTION TABLE FOR FSCAN
*  EACH 30-BIT ENTRY IS 6/CLASS,6/STATE,18/ACTION 
* 
*                                   CHARACTER  INPUT SYMBOL 
*         STATE 0 - START 
          VFD    6/0,6/0,18/FERROR   COLON     OTHER
          VFD    6/0,6/1,18/PUTSIGN  A         SIGN 
          VFD    6/0,6/7,18/PUTJUST  B         JUSTIFY
          VFD    6/9,6/2,18/INTINCR  C         POUND
          VFD    6/9,6/3,18/SETDOL   D         DOLLAR 
          VFD    6/0,6/4,18/SETAST   E         ASTERISK 
          VFD    6/0,6/5,18/DECPT    F         PERIOD 
          VFD    6/0,6/0,18/FERROR   G         COMMA
          VFD    6/0,6/0,18/FERROR   H         UPARROW
          VFD    6/0,6/0,18/FERROR   I         TRAILSIGN
*         STATE 1 - AFTER SIGN
          VFD    6/0,6/0,18/FERROR   J         OTHER
          VFD    6/0,6/0,18/FERROR   K         SIGN 
          VFD    6/0,6/0,18/FERROR   L         JUSTIFY
          VFD    6/0,6/2,18/INTINCR  M         POUND
          VFD    6/0,6/3,18/SETDOL   N         DOLLAR 
          VFD    6/0,6/4,18/SETAST   O         ASTERISK 
          VFD    6/0,6/5,18/DECPT    P         PERIOD 
          VFD    6/0,6/0,18/FERROR   Q         COMMA
          VFD    6/0,6/0,18/FERROR   R         UPARROW
          VFD    6/0,6/0,18/FERROR   S         TRAILSIGN
*         STATE 2 - COLLECT INTEGER POUNDS
          VFD    6/0,6/0,18/INTDONE  T         OTHER
          VFD    6/0,6/0,18/INTDONE  U         SIGN 
          VFD    6/0,6/0,18/INTDONE  V         JUSTIFY
          VFD    6/0,6/2,18/INTINCR  W         POUND
          VFD    6/0,6/0,18/INTDONE  X         DOLLAR 
          VFD    6/0,6/0,18/INTDONE  Y         ASTERISK 
          VFD    6/0,6/5,18/DECPT    Z         PERIOD 
          VFD    6/0,6/2,18/COMMA    0         COMMA
          VFD    6/0,6/0,18/INTDONE  1         UPARROW
          VFD    6/0,6/0,18/TRLSGN   2         TRAILSIGN
*         STATE 3 - COLLECT INTEGER DOLLARS 
          VFD    6/0,6/0,18/INTDONE  3         OTHER
          VFD    6/0,6/0,18/INTDONE  4         SIGN 
          VFD    6/0,6/0,18/INTDONE  5         JUSTIFY
          VFD    6/0,6/2,18/INTINCR  6         POUND
          VFD    6/0,6/3,18/INTINCR  7         DOLLAR 
          VFD    6/0,6/4,18/SETAST   8         ASTERISK 
          VFD    6/0,6/5,18/DECPT    9         PERIOD 
          VFD    6/1,6/3,18/COMMA    PLUS      COMMA
          VFD    6/1,6/0,18/INTDONE  MINUS     UPARROW
          VFD    6/5,6/0,18/TRLSGN   ASTERISK  TRAILSIGN
*         STATE 4 - COLLECT INTEGER ASTERISKS 
          VFD    6/0,6/0,18/INTDONE  SLASH     OTHER
          VFD    6/1,6/0,18/INTDONE  LPAREN    SIGN 
          VFD    6/9,6/0,18/INTDONE  RPAREN    JUSTIFY
          VFD    6/4,6/2,18/INTINCR  DOLLAR    POUND
          VFD    6/0,6/0,18/INTDONE  EQUALS    DOLLAR 
          VFD    6/0,6/4,18/INTINCR  BLANK     ASTERISK 
          VFD    6/7,6/5,18/DECPT    COMMA     PERIOD 
          VFD    6/6,6/4,18/COMMA    PERIOD    COMMA
 IF1      IFEQ   CHARSET,OLDCSET
          VFD    6/0,6/0,18/INTDONE  QUOTE     UPARROW
          VFD    6/0,6/0,18/TRLSGN   LBRKT     TRAILSIGN
*         STATE 5 - COLLECT FRACTIONAL POUNDS 
          VFD    6/0,6/0,18/DONE     RBRKT     OTHER
          VFD    6/0,6/0,18/DONE     PERCENT   SIGN 
          VFD    6/0,6/0,18/DONE     APOST     JUSTIFY
          VFD    6/0,6/5,18/FRCINCR  AMPRSND   POUND
          VFD    6/0,6/0,18/DONE     CR        DOLLAR 
          VFD    6/0,6/0,18/DONE     LF        ASTERISK 
          VFD    6/8,6/0,18/DONE     UPARROW   PERIOD 
          VFD    6/3,6/0,18/DONE     POUND     COMMA
          VFD    6/2,6/6,18/FSTARRW  LESS      UPARROW
          VFD    6/2,6/0,18/TRLSGN   GREATER   TRAILSIGN
*         STATE 6 - COLLECT UPARROWS
          VFD    6/0,6/0,18/EXPDONE  UNUSED    OTHER
          VFD    6/0,6/0,18/EXPDONE  QUESTMK   SIGN 
          VFD    6/0,6/0,18/EXPDONE  UNUSED    JUSTIFY
 IF1      ELSE
          VFD    6/3,6/0,18/INTDONE  POUND     UPARROW
          VFD    6/0,6/0,18/TRLSGN   LBRKT     TRAILSIGN
*         STATE 5 - COLLECT FRACTIONAL POUNDS 
          VFD    6/0,6/0,18/DONE     RBRKT     OTHER
 IF2      IFEQ   IP.CSET,IP.C63 
          VFD    6/0,6/0,18/DONE     COLON     SIGN 
 IF2      ELSE
          VFD    6/0,6/0,18/DONE     PERCENT   SIGN 
 IF2      ENDIF 
          VFD    6/0,6/0,18/DONE     QUOTE     JUSTIFY
          VFD    6/0,6/5,18/FRCINCR  UNDERLINE  POUND 
          VFD    6/0,6/0,18/DONE     EXCLAM     DOLLAR
          VFD    6/0,6/0,18/DONE     AMPRSND  ASTERISK
          VFD    6/0,6/0,18/DONE     APOSTROPHE  PERIOD 
          VFD    6/0,6/0,18/DONE     QUESTMK  COMMA 
          VFD    6/2,6/6,18/FSTARRW  LESS       UPARROW 
          VFD    6/2,6/0,18/TRLSGN   GREATER   TRAILSIGN
*         STATE 6 - COLLECT UPARROWS
          VFD    6/0,6/0,18/EXPDONE  AT       OTHER 
          VFD    6/0,6/0,18/EXPDONE  BACKSLASH  SIGN
          VFD    6/8,6/0,18/EXPDONE  UPARROW(CIRCUMFLEX)  JUSTIFY 
 IF1      ENDIF 
          VFD    6/0,6/0,18/EXPDONE  SEMICLN   POUND
          VFD    6/0,6/0,18/EXPDONE  UNUSED    DOLLAR 
          VFD    6/0,6/0,18/EXPDONE  EOS       ASTERISK 
          VFD    6/0,6/0,18/EXPDONE            PERIOD 
          VFD    6/0,6/0,18/EXPDONE            COMMA
          VFD    6/0,6/6,18/EXPINCR            UPARROW
          VFD    6/0,6/0,18/EXPTRL             TRAILSIGN
*         STATE 7 - COLLECT STRING POUNDS 
          VFD    6/0,6/0,18/DONE               OTHER
          VFD    6/0,6/0,18/DONE               SIGN 
          VFD    6/0,6/0,18/DONE               JUSTIFY
          VFD    6/0,6/7,18/PUTCHR             POUND
          VFD    6/0,6/0,18/DONE               DOLLAR 
          VFD    6/0,6/0,18/DONE               ASTERISK 
          VFD    6/0,6/0,18/DONE               PERIOD 
          VFD    6/0,6/0,18/DONE               COMMA
          VFD    6/0,6/0,18/DONE               UPARROW
          VFD    6/0,6/0,18/DONE               TRAILSIGN
* 
 FTYPE    BSS    1                 FORMAT FIELD TYPE - JIFES 01234
 FSIGN    BSS    1                 FORMAT SIGN FIELD  0+-(CD
 INTPOS   BSS    1                 NUM DIGIT POSNS IN INTEGER PART
 FRACPOS  BSS    1                 NUM DIGIT POSNS IN FRACTIONAL PART 
 ARROWS   BSS    1                 NUMBER OF UPARROWS 
 DOLLAR   BSS    1                 NONZERO IF DOLLARS IN FORMAT 
 ASTERSK  BSS    1                 NONZERO IF ASTERISKS IN FORMAT 
 PERIOD   BSS    1                 NONZERO IF PERIOD IN FORMAT
 WIDTH    BSS    1                 TOTAL FIELD WIDTH
 UNITPOS  BSS    1                 ADDR OF UNITS DIGIT POSN IN FIELD
 MONEY    BSS    1                 NONZERO IF MONETARY FIELD
* 
          BSS    20                OVERFLOW AREA FOR FIELD BELOW
 MAXFLD   EQU    150         MAXIMUM FIELD/LITERAL WIDTH
 FIELD    BSS    MAXFLD      UNPACKED FORMAT FIELD
* 
 MAXINT   DATA   1.0E14 
 STRPTR   BSSZ   1           POINTER FOR PRINT USING RESULT STRINGS 
 STRBUFP  BSS    1                 AMOUNT IN ABOVE BUFFER 24/0,18/WORDS 
*                                  18/CHARS IN LAST WORD
 MAXSIZE  EQU    131070/10+1
 CMASK1   EQU    74B
 CMASK2   EQU    76B
* 
* 
 BATOUSI  BSS    0                 BASOUSI NEEDS SOME BASOPRO ROUTINES
 BATOPRO  BSS    0
* 
* 
          TITLE  STR FUNCTION (BASXSTR) 
*         THIS ROUTINE WAS PUT IN HERE BECAUSE IT REQUIRES
*           PRINT USING . 
* 
*                STR RETURNS (IN B7) THE ADDRESS OF THE NUMERIC STRING
*                PRODUCED BY CONVERTING THE VALUE (IN X5) ON ENTRY. 
* 
* 
          DATA   10HBASXSTR 
 BASXSTR  BSS    0
          JP     0
          SX1    XSTRPTR     X1 = ADR OF RESULT POINTER WORD
          SX2    30          X2 = CHARS REQUIRED FOR RESULT 
          ZR     X4,XSTR.A   JUMP IF FORMAT NOT SPECIFIED 
          SA2    A4          X2 = FORMAT POINTER WORD 
          LX2    59-53+18    POISITION LENGTH FIELD OF POINTER WORD 
          SX2    X2+20       X2 = CHARS REQ FOR RESULT
 XSTR.A   RJ     =XBASGSTR   GO GET STRING SPACE
          ZR     X4,STR1     JUMP IF UNFORMATTED CALL 
          BX7    X5                     ITEM
          SA5    A4                FORMAT ADDR IN A5 FOR BASOUSI
          SA7    VALU 
          SX7    1                 INDICATE STR$ CALLING PRINT USING
          SA7    STRFMT 
          RJ   BASOUSI             PRINT LEAD LITERAL, SET UP X5
          SA4    VALU 
          MX3    0                 FLAGS NUMERIC ITEM FOR BASOPRO 
          RJ     BASOPRO     FORMAT ITEM AND LITERAL
          SA1    STRBUFP     X1 = WORDS / CHARS IN RESULT 
          BX2    X1 
          AX2    18          X2 = WORDS INCLUDING PART WORD 
          SX2    X2-1        X2 = FULL WORDS
          LX2    1           X2 = WORDS * 2 
          BX3    X2 
          LX3    2           X3 = WORDS * 8 
          IX2    X2+X3       X2 = WORDS * 10
          SX1    X1 
          IX2    X2+X1       X2 = WORDS * 10 + LEFT OVER CHARS
          EQ     STR2 
 STR1     BSS    0
* 
          RJ     BASOCON           CALL BINARY-TO-BCD CONVERSION
          SA5    X5          A5 = FWA OF STRING 
* 
* 
          SA1    XSTRPTR
          SB7    X1          B7 = FWA OF NEW RESULT STRING
          MX2    0           X2 = COUNT OF 6-BIT CHARS
*         STRIP LEADING AND TRAILING BLANK
          SX6    B5 
          SA6    SVB5        SAVEB5 
          MX0    -6          (X0) = CHARACTER MASK
          BX6    X6-X6       CLEAR ASSEMBLY 
          SB5    60          ASSEMBLY SHIFT COUNT 
          MX4    1           CHARACTER COUNTER
          SB6    B0          ASSEMBLY INDEX 
          EQ     ST2         ENTER LOOP 
 ST1      BSS    0
          LX6    6
          SB5    B5-6 
          BX6    X6+X7
          SX2    X2+1        INCREMENT COUNT OF 6-BIT CHARS 
          ZR     B5,ST5 
 ST2      BSS    0
          LX5    6           NEXT CHARACTER 
          BX7    -X0*X5 
          LX4    6
          PL     X4,ST3 
          SA5    A5+1 
 ST3      BSS    0
          SX3    X7-1R
          ZR     X3,ST2      CHARACTER IS BLANK 
          ZR     X7,ST4      CHARACTER IS 00 (EOL)
          EQ     ST1
 ST4      BSS    0
          LX6    X6,B5       LEFT JUSTIFY ASSEMBLY
 ST5      BSS    0
          SA6    B7+B6       STORE IT 
          SB5    60 
          SX6    B0 
          SB6    B6+1 
          SA6    A6+1        CLEAR LAST + 1 
          ZR     X7,ST6 
          EQ     ST2
 ST6      BSS    0
          SA1    SVB5 
          SB5    X1          RESTORE B5 
 STR2     BSS    0
* 
*   TRUNCATE RESULT STRING TO CHARS USED, SET UP B7 
*   AND EXIT
          SX1    XSTRPTR     XI = ADR OF RESULT POINTER WORD
          SB7    X1 
          RJ     =XBASTSTR   TRUNCATE STR TO X2 CHARS 
          SX7    B7-B2             OFFSET OF RESULT REL. TO STR VBL AREA
          SA7    STRBFAD           RECORD ADDRESS OF WORK STRING
          SB7    STRBFAD           GET B7 TO POINT TO THE ADDRESS LOCN
* 
          EQ     BASXSTR
* 
* 
* 
 STRBFAD  BSSZ   1           POINTER ADR-B2 STORED HERE 
 XSTRPTR  BSSZ   1           POINTER WORD FOR RESULT
  
 VALU     BSSZ   1
 SVB5     BSSZ   1
 BATXSTR  BSS    0
* 
          END 
