Retro1.org codex

CWRITE
* /---   FILE TYPE = E
* /---   BLOCK      CWRITE     00 000   81/07/13  01.08 
          IDENT  CWRITE 
          LCC    OVERLAY(1,1) 
* 
          TITLE  OVERLAYS FOR COMMAND READINS 
          TITLE  CWRITE 
* 
* 
          CST 
* 
* 
 CWRITE$  OVFILE
* 
 CWRTOV   OVRLAY
          QUAL
          SB1    FSWRITE     LOG -WRITE- TEXT 
          RJ     =XPUBTEXT
          SA1    OVARG1      GET OVERLAY ARGUMENT 
          SB1    X1 
          JP     B1+*+1 
* 
+         EQ     NWRITE 
+         EQ     NEXACTC
+         EQ     NWRTCIN
*+         EQ     DISIN 
* 
* 
* /---   BLOCK      TWRITIN    00 000   85/01/21  10.48 
* 
* 
*         NEW WRITE ROUTINES FOR CONDENSE 
* 
*         PROPERLY RECORDS X AND Y INCREMENTS 
*         FOR BACKSPACE, SUB, SUP, RAISE, LOWER 
*         CR,  ETC. 
* 
* 
*         SHARES THE CHARACTER DEFINITION TABLE WITH
*         FORMAT  (THIS IS THE ONLY TABLE WHICH DEFINES 
*         ALL OF THE OPERATIONS)
 
 
 
          EXT    ERRORC 
          EXT    PUTCODE,GETLINE
          EXT    WRITE0=
          EXT    WRITE1=
          EXT    WRITE2=
          EXT    WRITE3=
          EXT    WRITE4=
          EXT    WRITEC=
          EXT    ZAT=        GET AROUND LOADER PROBLEM
 AT=      EQU    ZAT=-1      GET AROUND LOADER PROBLEM
          EXT    LNGUNIT
          EXT    ERRTAGS,ERRNAME,ERRSTOR
          EXT    ERRXYTG,ERR2MNY,ERR2FEW
          EXT    ERRTERM,ERRUARG,ERRVTYP
          EXT    ERROUTR,ERRCNTD,ERRXORQ
          EXT    ERRBAL 
          EXT    CONV2
 
 
 
 
 UNUSED=  EQU    ERRORC      FOR UNDEFINED OPERATIONS 
 XTEXT    TITLE  GET EXTERNAL TEXTS 
* 
* 
          BSS    0
* 
 XLLL     SET    *L 
* 
*CALL      CHRDEF 
*CALL      CHARS2 
 ENTER    SPACE  3
***       GENERATE LOCAL SUBROUTINE ENTRY 
* 
          PURGMAC ENTER 
 
          MACRO  ENTER,NAME 
 ENT.     IFC    EQ,*NAME** 
 2        ERR    LABEL FIELD BLANK, MACRO CALL IGNORED
 ENT.     ELSE
 NAME     SPACE  0
          DATA   0L_NAME
 NAME     DATA   0
 EXITNAM= SET    NAME 
 ENT.     ENDIF 
          ENDM
 EXIT     SPACE  4
***       GENERATE EXIT CODE
 
          PURGMAC EXIT
 
          MACRO  EXIT,A,BB
 EXT1     IFC    EQ,*A**
 EXT1     IFC    EQ,*BB** 
          EQ     EXITNAM= 
 EXT1     ELSE
 EXT2     IFC    NE,*A**
          EQ     A
 EXT2     ELSE
          EQ     BB 
 EXT2     ENDIF 
 EXT1     ENDIF 
          ENDM
* 
          LOC    XLLL+400B
* 
* 
* /---   BLOCK      LOCAL MAC  00 000   85/01/21  10.46 
 PLNTCODE TITLE  LOCAL MACROS 
***       PLNTCODE - PLANT COMMANDS IN WRITCBUF 
* 
* 
 PLNTCODE MACRO 
          SA1    WRKPNT 
          SA2    INWC 
          IX7    X2-X1
          PL     X7,LNGUNIT 
          SX7    X1-1 
          SA7    A1 
          SA6    X1+WRITCBUF
          ENDM
 CHRACTN  SPACE  5
***       CHRACTN - ACTION FOR PLOTABLE CHARACTER 
* 
* 
 CHRACTN  MACRO 
          PACKCHR X5
          ENDM
 
 
 PACKCHR  SPACE  5
****      PACKCHR - PACKS AND STORES CHARACTERS 
* 
* 
 PACKCHR  MACRO  XN 
          LOCAL NN
          SB4    B4+B1       COUNT
          LX7    6
          BX7    XN+X7
          SB7    B7-B1
*                            SENSE ASSEMBLY FULL
          NZ     B7,NN
          SA7    A7+B1
          MX7    0
          SB7    10 
 NN       BSS    0
          ENDM
BKSPCHR   SPACE  5
***       BKSPCHR - REMOVE ONE CHARACTER FROM PACKED STRING 
* 
* 
 BKSPCHR  MACRO 
          LOCAL  NN 
*                            TEST ASSEMBLY EMPTY
          SX1    B7-10
          NZ     X1,NN
*                            BACK UP ASSEMBLY 
          SA1    A7-B1
          BX7    X1 
          SA7    A1 
          SA1    A1+B1
          BX7    X1 
          SB7    B0 
*                            BACK SPACE ASSEMBLY
 NN       MX1    -6 
          BX7    X1*X7
          LX7    -6 
          SB4    B4-B1
* /---   BLOCK      LOCAL MAC  00 000   78/03/20  11.50 
          SB7    B7+B1
          ENDM
 NEXTCHR  SPACE  5
***       NEXTCHR -  FETCHS NEXT CHAR AND SETS UP X2 WITH THE ACTION
* 
* 
 NEXTCHR  MACRO  EXIT 
          SA5    A5+B1
          ZR     X5,EXIT
*                            CHECK CHARACTER
          SB2    X5+B5
          ZR     B2,EXIT
          BX2    X0+X5
          SA2    X2+OUTABLE 
          ENDM
 TESTMEM  SPACE  5
***       MEMTEST - TEST FOR SPECIAL MEMORY 
* 
* 
 TESTMEM  MACRO  JUMP 
          SX1    B2-6 
          PL     X1,JUMP
          ENDM
 TSTX     SPACE  5
***       TSTX   DEFINE DO NOTHING MACROS 
*         UNCOVER 
* 
* 
 TSTX     MACRO 
          BSS    0
          ENDM
 
 
 UNCOVER  OPSYN  TSTX 
 RECOVER  SPACE  5
***       RECOVER - FOR PACKER
* 
* 
 RECOVER  MACRO 
          EQ     CHAR 
          ENDM
 AUTOBKSP SPACE  5
***       AUTOBKSP - AUTOMATIC BACKSPACE
* 
* 
 AUTOBKSP MACRO 
          PL    X0,CHAR      NO ACCESS
          DEACC 
          EQ     CHAR 
          ENDM
 RAISER   SPACE  4
***       RAISER - DO RAISER OPERATIONS 
* 
* 
 RAISER   MACRO 
          SX0    X0          CLEAR ACCESS FLAG
          EQ     CHAR 
          ENDM
 SPECIAL  SPACE  5
***       SPECIAL - DO SPECIAL CHARACTER OPERATIONS 
* 
* 
 SPECIAL  MACRO 
          LOCAL  LL,MM
          SX1    X2-RMGACTN  CHECK FOR RIGHT MARGIN 
          NZ     X1,LL
          SX5    1R1         CHANGE TO SIMPLE BACKWARD
          EQ     MM          AND PACK IT AWAY 
 LL       SX1    X2-ORIACTN  CHECK FOR ENTER ORIENTAL 
          NZ     X1,MM
          SA2    A2 
          LX2    18 
          UX2,B0 X2          HORIZ/VERT CHAR
          LX2    18 
          SX1    X2-1R-      MINUS SIGN = VERTICAL
          NZ     X1,MM
          SX5    1R%         SWITCH TO VERTICAL 
 MM       PACKCHR X5
          ENDM
 CRINC    SPACE  5
****      CRINC - PROCESS REGISTERS FOR CR*S
* 
* 
 CRINC    MACRO 
          MX3    0
          MX0    0
          YINC   -YCHRINC 
          ENDM
 WCR      SPACE  5
***       WCR - SPECIAL CR ACTION MACRO 
* 
* 
 WCR      MACRO 
          CRINC 
          SB3    -B1
          ENDM
 CR       SPACE  5
***       CR - PROCESS CR TO MARGIN 
* 
* 
 CR       MACRO 
          WCR 
          EQ     CHAR 
          ENDM
 ALCR     SPACE  5
***       ALCR - PROCESS CR TO BORDER 
* 
* 
 ALCR     MACRO 
          CRINC 
          SB3    B1 
          EQ     CHAR 
          ENDM
 BKSP     SPACE  5
***       BKSP - PROCESS BACKSPACE
* 
* 
 
 
          PURGMAC   BKSP
 
 
 BKSP     MACRO 
          XINC   -XCHRINC 
          EQ     CHAR 
* /---   BLOCK      LOCAL MAC  00 000   78/03/20  11.50 
          ENDM
 TSTCNT   SPACE  5
***       MACRO TO TEST FOR A CONTINUATION
* 
* 
*                NO CONTINUATION EXIT TO EXIT 
* 
* 
 TSTCNT   MACRO  EXIT 
          SA1    NEXTCOM     GET NEXT COMMAND 
* /---   BLOCK      LOCAL MAC  00 000   78/03/14  23.54 
          SA2    K8S
          BX1    X1-X2       TEST CONTINUATION
          NZ     X1,EXIT
          ENDM
 PLNTELMT SPACE  5
***       MACRO TO PLANT ELEMENT IN TABLE 
* 
* 
 
 PLNTELMT MACRO 
*         COMBINE COMMAND TYPE AND PARAMETERS 
          BX6    X6+X7
*                            TEST FOR UNIT TOO LONG 
          SA1    INWC 
          SA2    WRKPNT 
          IX7    X1-X2
          PL     X7,LNGUNIT 
*                            INCREMENT POINTER AND PLANT ITEM 
          SX7    X1+B1
          SA7    A1 
          SA6    X1+WRITCBUF
          ENDM
 EMBED0   SPACE  5
***       DO EMBEDDING OPERATION
* 
* 
 EMBED0   MACRO 
          SX0    X0 
          EQ     PACKER 
          ENDM
ACOMMA    SPACE  4
***       ACOMMA - DO UNIVERSAL DELIMINATOR OPS 
* 
          PURGMAC ACOMMA
* 
 ACOMMA   MACRO 
          SA1    CSET=
          BX0    X1 
          SX1    B5-77B      CHECK ACTIVE 
          ZR     X1,PACKER   IF ACTIVE
          XINC   XCHRINC
          EQ     CHAR3       JUST CONTINUE
          ENDM
 EMBED1   SPACE  5
***       DO EMBEDDING OPERATION
* 
* 
 EMBED1   MACRO 
          XINC   XCHRINC
          EQ     CHAR3
          ENDM
 PLNTCR   SPACE  5
***       PLNTCR - DO END OF LINE CARRIAGE RETURN ACTION
* 
* 
 PLNTCR   MACRO 
          WCR 
          SX1    KCR
          PACKCHR X1
          RJ     WGETLINE 
          SA5    TAG-1
          ENDM
 PLNTWRD  SPACE  5
***       PLNTWRD - PLANT WORD IN FORWARD EXPANDING 
*                TABLE
* 
*         X6 - CONTAINS THE ITEM
* 
*                CHECKS FOR TABLE OVERLFOW
* 
* 
 
 
 PLNTWRD  MACRO  T
          LOCAL  NN 
*                            GET TABLE DESCRIPTOR 
          SA1    L.T
          UX2,B2 L.T
          SA6    X2+B2
          SB2    B2+1 
          PX7    X2,B2
          SA7    A2 
*                            CHECK FOR OVERFLOW ON NEXT ITEM
          NG     B2,NN
          RJ     LGETSPC
 NN       BSS    0
          ENDM
 PLNTCOD  SPACE  5
***       PLNTCOD - PLANT CODE IN BACKWARD EXPANDING
*                TABLE
* 
*         X6 - CONTAINS ITEM
* 
* 
 
 
 PLNTCOD  MACRO  T
          LOCAL  NN 
*                            GET TABLE DESCRIPTOR 
          SA2    O.T
          UX2,B2 X2 
*                            UPDATE TABLE PARAMETERS
          SB2    B2-1 
          SA6    X2,B2
          PX7    X2,B2
          SA7    A2 
*                            CHECK FOR TABLE UNDERFLOW ON NEXT ITEM 
* /---   BLOCK      LOCAL MAC  00 000   76/07/24  11.34 
          NZ     B2,NN
          RJ     OGETSPC
 NN       BSS    0
          ENDM
 FORWRD   SPACE  4
***       FORWRD - PROCESS FORWARD STRING 
* 
* 
 
          PURGMAC FORWRD
 
 FORWRD   MACRO 
          SB6    B0          MARK FORWARD 
          EQ     /FORWRD/CHAR 
          ENDM
 BACKWRD  SPACE  4
***       BACKWRD - PROCESS BACKWARD STRING 
* 
* 
 
          PURGMAC BACKWRD 
 
 BACKWRD  MACRO 
          SB6    1           MARK BACKWARD
          EQ     /BCKWRD/CHAR 
          ENDM
 RMARG    SPACE  4
***       PROCESS SET TO RIGHT MARGIN 
* 
* 
 
 
          PURGMAC RMARG 
 
 RMARG    MACRO 
*          SX3    512-XCHRINC 
          ENDM
 
* /---   BLOCK      WRITE      00 000   77/04/24  23.20 
 NWRITE   TITLE  NEW WRITEC COMMAND 
***       NEW WRITE COMMAND WHICH ALLOWS EMBEDDING
* 
* 
*                SPECIAL EMBEDDING CHARACTER IS ACCESS 0
* 
          LIST   M,G
* 
 NWRITE   BSS    0
          SA5    TAG-1       SET UP FOR PACKER
          SB5    7777B       SET TO IMPOSSIBLE CHARACTER
          SB1    1           SET UNIVERSAL CONSTANT 
          RJ     ECSINTL     DO PRESETS 
 WRT1     SB6    B0          CLEAR LEFT WRITING 
          RJ     PACKER 
          NZ     X5,WRT3     PROCESS ^0  ^1 
          TSTCNT WRT2        SENSE END OF STATEMENT 
          PLNTCR
          EQ     WRT1        AND CONTINUE WITH COMMAND
 
 WRT2     RJ     ECSFINAL    FINISH UP WRITE COMMAND
          SA7    COMNUM      SET UP COMMAND TYPE
          EQ     PUTCODE
 
 WRT3     SX1    X5-1R,      SENSE SPECIAL WRITEC TERMINATOR
          ZR     X1,WRT1     JUST CONTINUE
          SA1    A5+B1       TRY FOR MODE CHANGE
          SX1    X1-1RM 
          ZR     X1,WRT4     YES EMBED MODE IN STRING 
          RJ     EMBEDER     FINISH UP IN EMBED 
          SA7    COMNUM 
          EQ     PUTCODE
 
 WRT4     RJ     CPMODE 
          EQ     WRT1 
* /---   BLOCK      EXACTC     00 000   77/04/24  21.48 
 EXACTC   TITLE  NEW EXACTC COMMAND FOR LEFT WRITTING 
***       NEW EXACTC COMMAND.  PROPERLY HANDLES LEFT
*                WRITTING AND INCLUDES UNIVERSAL SEPARATOR
* 
 NEXACTC  BSS    0
          CALL   COMPILE     GET NGETVAR CODE 
          SB1    1           SET UNIVERSAL CONSTANT 
          BX6    X1          SAVE NGETVAR CODE
          LX6    -XCODEL     POSITION FOR COMMAND 
          SA6    =XBRVAR     SET UP FOR EXIT PROCESS
          MX7    0           CLEAR STORAGE POINTER
          SA7    WRKPNT      RELATIVE ELEMENT IDENT ADR 
          SA7    WORK        CLEAR FIRST LOCATION 
          SA7    CONV3       CLEAR NUMBER OF ITEMS
          SA1    INX         PRESENT INFO POINTER 
          SX6    INFO        SET UP A7 FOR PACKER 
          IX6    X1+X6       FIRST TEXT LOCATION
          SA6    ORGA7       PRESET FOR LENGTH CHECKS 
          SA1    X6-1        BACK UP ONE
          BX7    X1 
          SA7    A1          AND SET UP A7
          SA1    LASTKEY     GET EXPRESSION TERMINATIOR 
          BX1    -X1         SET UP TERMINATOR
          SB5    X1          IN B5
          SA2    WORDPT      GET FIRST TAG CHARACTER
          SA2    X2 
          SA5    A2-B1       SET UP A5 FOR PACKER 
          SB6    B0          CLEAR LEFT WRITING 
          ZR     X1,XCLN     ELEMENTS START ON NEXT LINE
          SX1    X1+1R,      SENSE SPECIAL EMBED
          NZ     X1,NEXC1 
          SA1    A5-B1       TRY FOR ACCESS 
          SX1    X1-ACCESS
          NZ     X1,NEXC1 
          SB5    77B
 NEXC1    ZR     X2,XCLN     START WITH NEXT LINE 
          EQ     XCLN1
 XCLN     SPACE  4
***       PROCESS EXACTC ITEMS
* 
*               ELEMENT TERMINATES ONLY AT SPECIAL CHARACTER
* 
* 
 XCLN     TSTCNT ERRCNTD     MUST BE CONTINUATION 
          CALL   WGETLINE 
          SA5    TAG-1       SET UP FOR PACKER
 XCLN1    RJ     EXCINTL     INITIALIZE BUFFERS 
 XCLN2    RJ     PACKER      PACK UP ELEMENT
          SX1    X5+B5       CHECK FOR TERMINATOR 
          ZR     X1,XCLN3    IF END OF ELEMENT
          ZR     X5,XCLN3    IF END OF LINE 
          SX1    X5-1R,      TRY FOR SPECIAL SEPARATOR
          NZ     X1,XCLN2    CONTINUE PACKING 
          SX1    B5-77B      CHECK IF ACTIVE
          NZ     X1,XCLN2    IF NOT ACTIVE
          RJ     BKSPCHR     REMOVE SEPARATOR 
          RJ     BKSPCHR
 
 XCLN3    RJ     EXCFINL     FINALIZE ENTRY 
          SA5    A5          CHECK FOR END OF LINE
          ZR     X5,XCLN4    IF END OF LINE 
          SA1    A5+B1       ELEMENT MAY END WITH SEPARATOR 
          NZ     X1,XCLN1    IF MORE ELEMENTS TO DO 
 
 XCLN4    TSTCNT EXFINAL     CHECK FOR CONTINUATION 
          CALL   WGETLINE    GET NEXT LINE
          SA5    TAG-1       INITIALIZE FOR PACKER
          EQ     XCLN1
* /---   BLOCK      EXACTC     00 000   76/08/13  04.32 
EXCFINL   SPACE  4
***       PROCESS EXIT FROM COMMAND 
* 
* 
 
 
 EXFINAL  SA1    CONV3       GET NUMBER OF ELEMENTS 
          ZR     X1,ERR2FEW  --- EXIT IF NO ITEMS 
          SX1    X1-1        0 TO N-1 
          AX1    1           NUMBER OF WORDS
          SB2    X1          COUNT OF WORDS 
          SX2    INFO 
          SX2    INFO-1      CALCULATE TABLE BIAS 
          SX6    A7          MARK TABLE ORIGIN
          IX6    X6-X2       RELATIVE LOCATION
          SA6    CONV2
          SA1    WORK-1      PRESET TO BEG OF ITEMS -1
 EXCFN1   SA1    A1+B1       FETCH ITEM 
          BX7    X1 
          SA7    A7+B1       PLANT IT 
          SB2    B2-B1       DECREMENT COUNT
          PL     B2,EXCFN1   LOOP 
 
 EXCFN2   SX6    INFO        GET RELATIVE OF LAST WORD USED 
          SX2    A7 
          IX6    X2-X6
          SA6    INX         UPDATE INFO POINTER
          SA4    COMNUM      GET COMMAND NUMBER 
          BX6    X4          FOR STANDARD PROCESS 
          EQ     =XCONUL4    ---  EXIT VIA CONDITNL BRANCH
* /---   BLOCK      NEW WRITEC 00 000   77/04/24  21.48 
 NWRTCIN  TITLE  PROCESS WRITEC COMMAND 
***       PROCESS WRITEC COMMAND
* 
*                SET UP TABLE AND DISTINGUISH COMMAND FORMAT
* 
* 
 NWRTCIN  BSS    0
          RJ     =XCOMPILE   GET NGETVAR CODE 
          SB1    1           SET UNIVERSAL CONSTANT 
          BX6    X1          SAVE NGETVAR CODE
          MX7    0           CLEAR STORAGE POINTER
          SA6    WCOMND 
          SA7    INWC 
          SX6    WRCBLTH-1   SET UP COMMAND POINTER 
          SA6    WRKPNT 
          SA1    LASTKEY     GET EXPRESSION TERMINATIOR 
          BX1    -X1         SET UP TERMINATOR
          SB5    X1          IN B5
          SA2    WORDPT      GET FIRST TAG CHARACTER
          SA2    X2 
          SA5    A2-B1       SET UP A5 FOR PACKER 
          SB6    B0          CLEAR LEFT WRITING 
          ZR     X1,WCLN     ELEMENTS START ON NEXT LINE
          SX1    X1+1R,      SENSE SPECIAL EMBED
          NZ     X1,NWRT1 
          SA1    A5-B1       TRY FOR ACCESS 
          SX1    X1-ACCESS
          NZ     X1,NWRT1 
          SB5    77B
 NWRT1    ZR     X2,WCLN     START WITH NEXT LINE 
          EQ     WCLN1
 WCLN     SPACE  5
***       PROCESS SPECIAL WRITEC
* 
*                ELEMENT TERMINATES ONLY AT SPECIAL CHARACTER 
* /---   BLOCK      NEW WRIT6C 00 000   76/07/25  09.16 
*                END OF LINE GENERATES CR 
* 
* 
 WCLN     TSTCNT ERRCNTD      MUST BE CONTINUATION
          RJ     WGETLINE 
          SA5    TAG-1       SET UP FOR PACKER
 WCLN1    RJ     ECSINTL     INITIALIZE REGS
 WCLN2    RJ     PACKER 
          SX1    X5+B5       CHECK FOR TERMINATOR 
          ZR     X1,WCLN3 
          NZ     X5,WCLN6    PROCESS ^0 
          TSTCNT WCLN3       NO CONTINUATION IS ALSO END
          PLNTCR
          EQ     WCLN2       CONTINUE WITH ELEMENT
 
 WCLN3    ZR     B4,WCLN5    SENSE NO CHAR
          RJ     ECSFINAL    FINISH UP ELEMENT
 WCLN3A   PLNTELMT           PLANT IT 
          SA5    A5          CHECK FOR END OF LINE
          ZR     X5,WCLN4    JUMP ON EOL
          SA1    A5+B1       LAST ITEM MIGHT END WITH COMMA OR SEMICOLON
          NZ     X1,WCLN1    JUMP IF NOT EOL
 WCLN4    TSTCNT WCFIN       CONTINUATION TEST
          RJ     WGETLINE 
          SA5    TAG-1
          EQ     WCLN1
 
 WCLN5    SX6    0           NULL WRITE OPERATION 
          SX7    WRITE0=
          EQ     WCLN3A      AND PLANT ELEMENT
 
 WCLN6    SX1    X5-1R,      SENSE SPECIAL WRITEC TERMINATOR
          ZR     X1,WCLN7    AND CONTINUE 
          SA1    A5+B1       TRY FOR MODE CHANGE
          SX1    X1-1RM 
          ZR     X1,WCLN8    YES EMBED MODE IN STRING 
          RJ     EMBEDER     FINISH UP IN EMBED 
          EQ     WCLN3A      AND PLANT ELEMENT
 
 WCLN7    SX1    B5-77B      CHECK SPECIAL TERMINATOR ACTIVE
          NZ     X1,WCLN2    IF NOT JUST CONTINUE 
          RJ     BKSPCHR
          RJ     BKSPCHR
          EQ     WCLN3       END ELEMENT
 
 WCLN8    RJ     CPMODE 
          EQ     WCLN2
 WCFIN    SPACE  5
***       PROCESS END ACTIONS 
* 
* 
*         FIX UP COMMAND WORD 
* 
* 
 WCFIN    SA1    WCOMND      GET NGETVAR CODE 
          SA2    INX         AND PRESENT STORAGE POINTER(INFO)
          SA3    INWC        AND PRESENT STORAGE POINTER(WRITCBUF)
          SA4    ATEMPEC     ADDRESS OF ECS BUFFER
          BX0    X4          ECS TEMP BUFFER
          SB2    X3          NUMBER OF ELEMENTS TO TRANSFER 
          SA0    WRITCBUF    TO INFO BUFFER 
          WE     B2          TRANSFER ELEMENTS
          RJ     =XECSPRTY
          SA0    X2+INFO
          SX6    X2+B2       BUMP INX 
          SA6    A2 
          RE     B2 
          RJ     ECSPRTY
          SX3    X3-1        RANGE IS O-(N-1) 
* /---   BLOCK      PROCESS EM 00 000   76/07/22  02.46 
          LX3    -24         POSITION RANGE 
          SB2    X2          STORAGE BIAS TO B2 
          PX3    B2,X3       PACK BIAS AND RANGE
          BX6    X1+X3       PACK NGETVAR CODE
          LX6    -XCODEL     FINAL POSITIONING
          SX7    WRITEC=
          SA7    COMNUM 
          EQ     PUTCODE     PLANT IT 
 EMBEDER  TITLE  PROCESS EMBEDDED COMMANDS
***       PROCESS EMBEDDED COMMANDS 
* 
* 
*         EXIT WITH DATA IN X6, AND COMMAND TYPE IN X7
* 
* 
 EMBEDER  ENTER 
          RJ     EINTL       DO INITIALIZATIONS 
 EMBD1    RJ     BKSPCHR     DUMP ^0
          RJ     BKSPCHR
          ZR     B4,EMBD2    IGNOR NULL WRITES
          RJ     ECSFINAL    FINISH UP WRITE
          BX6    X6+X7       COMBINE DATA AND COMMAND TYPE
          PLNTCODE
 EMBD2    SX6    A5+B1       SET UP FOR EMBEDDOR
          SA6    WORDPT 
          SX6    B5          SAVE TERMINATING CHAR
          SA6    WSAVEREG 
          SX6    B6 
          SA6    A6+B1
          CALL   EMBED
          SB1    1
          SA1    WSAVEREG 
          SB5    X1          RESTORE TERMINATOR 
          SA1    A1+B1
          SB6    X1 
          SA1    COMNUM      GET COMMAND TYPE 
          BX6    X1+X6       COMBINE WITH DATA
          PLNTCODE
          SA1    WORDPT      SET UP A5
          SA5    X1          GET LAST CHAR
          SX2    X5+B5       END OF ELEMENT TEST
          ZR     X2,EMBD7 
          ZR     X5,EMBD4    END OF LINE TEST 
          SA5    A5-B1       FOR PACKER 
          RJ     ECSINTL     INITIALIZE FOR ADDITIONAL WRITE
 EMBD3    RJ     PACKER      PROCESS WRITE
          SX1    X5+B5       END OF ELEMENT TEST
          ZR     X1,EMBD6 
          ZR     X5,EMBD5    END OF LINE TEST 
          SX1    X5-1R,      SENSE SPECIAL WRITEC TERMINATOR
          ZR     X1,EMBD8    BACKUP AND QUIT
          SA1    A5+B1       TRY FOR MODE CHANGE
          SX1    X1-1RM 
          ZR     X1,EMBD9    YES EMBED MODE IN STRING 
          EQ     EMBD1       PROCESS EMBEDDED ELEMENT 
* 
*                            POSSIBLE END OF ELEMENT
* 
 EMBD4    TSTCNT EMBD7
          RJ     ECSINTL     INITIAL FOR NEXT WRITE 
          SA1    COMNUM      CHECK FOR -AT- COMMAND 
          SX2    AT=
          IX2    X1-X2
          ZR     X2,EMBD4A   NO CR FOR AT 
          SX2    X2-1        CHECK FOR AT*
          ZR     X2,EMBD4A
          PLNTCR
          EQ     EMBD3
 
 EMBD4A   RJ     WGETLINE 
          SA5    TAG-1
          EQ     EMBD3       PROCESS NEXT WRITE SEGMENT 
* 
*                            POSSIBLE END OF WRITE
* /---   BLOCK      PROCESS MO 00 000   76/07/25  09.26 
* 
 EMBD5    TSTCNT EMBD6
          PLNTCR
          EQ     EMBD3       CONTINUE WITH WRITE
* 
* 
 EMBD6    ZR     B4,EMBD7    IGNOR NULL WRITES
          RJ     ECSFINAL    FINISH WRITE 
          BX6    X6+X7
          PLNTCODE
 EMBD7    RJ     EFINAL      FINISH UP EMBEDDED COMMANDS
          EXIT
 
 EMBD8    SX1    B5-77B      CHECK FOR SPECIAL ACTIVE 
          NZ     X1,EMBD3 
          RJ     BKSPCHR
          RJ     BKSPCHR
          EQ     EMBD6
 
 EMBD9    RJ     CPMODE 
          EQ     EMBD3       CONTINUE TO PACK 
 CPMODE   TITLE  PROCESS MODE CHANGE
***       PROCESS EMBEDED MODE CHANGES
*         CONVERT TO SPECIAL ACCESS KEYS
* 
* 
 
 
 CPMODE   ENTER              ENTRY/EXIT 
          RJ     BKSPCHR     REMOVE EMBED ACCESS
          RJ     BKSPCHR     REMOVE EMBED 0 
          SA1    A5+2        CHECK FORMAT 
          SX2    X1-1R, 
          NZ     X2,ERRTERM 
          SA1    A5+4 
          SX2    X1-ACCESS
          NZ     X2,ERRTERM 
          SA1    A5+5 
          SX2    X1-1R1      CHECK ENDING 
          NZ     X2,ERRTERM 
          SA1    A5+3        GET TYPE 
          SB2    1R2
          SX2    X1-1RE 
          ZR     X2,PMD1
          SB2    1R3
          SX2    X1-1RW 
          ZR     X2,PMD1
          SB2    1R4
          SX2    X1-1RR 
          NZ     X2,ERRNAME 
 PMD1     SX5    KUP         PLANT SHIFT CODE 
          PACKCHR X5
          SX5    B2 
          PACKCHR X5         PACK UP SPECIAL ACCESS 
          SA5    A5+5 
          EXIT
* /---   BLOCK      PACKER     00 000   76/08/09  03.48 
 PACKER   TITLE  PACK UP LINE INTO BUFFER 
*         ROUTINE TO PACK CHARACTER STRING INTO A BUFFER
* 
 PACKER   ENTER              EXIT/ENTRY 
 
 
          ZR     B6,/FORWRD/CHAR   IF NORMAL WRITING
          NG     B6,/BCKWRD/CHAR IF LEFT WRITING BUT NOT NEW
          SX5    KUP         SET UP FOR LEFT WRITING
          PACKCHR X5
          SX5    1R1
          PACKCHR X5
          EQ     /BCKWRD/CHAR  IF LEFT WRITING
 
          QUAL   FORWRD 
 
*          LIST   M,X,S 
          CHARACTR  PACKER   SPECIAL SCANNING MACRO 
 
 
          PURGMAC XINC
 
 XINC     MACRO  ARG
          LOCAL  L
 L        EQU    ARG
          SX3    X3-L 
          ENDM
 
          QUAL   BCKWRD 
 
          CHARACTR PACKER 
 
          QUAL
 
**        DEFINE RMARG AND ORIENTV ACTIONS
 
 RMGACTN  EQU    /BCKWRD/RMGACTN
 ORVACTN  EQU    /BCKWRD/ORIACTN
 
 
          LIST   *
* /---   BLOCK      PACKER     00 000   76/08/11  17.25 
 ECSINTL  SPACE  5
****      ECSINTL - INITIALIZE WORK BUFFER FOR ECS EXTRA
*                   STORAGE USED
* 
*         INITIALIZE ALSO VARIOUS REGS
* 
 
 
          PURGMAC XINC
 
 XINC     MACRO  ARG
          LOCAL  L
 L        EQU    ARG
          SX3    X3+L 
          ENDM
 
 ECSINTL  ENTER 
          SA2    WORK-1      PRESET A7/X7 
          BX7    X2 
          SA7    A2 
          MX7    0
          SB7    10 
          SB3    B0          CLEAR CR FALG
          SB4    B0          CLEAR CHARACTER COUNT
          MX0    0           CLEAR TO NORMAL FONT 
          MX3    0           CLEAR X
          MX4    0           CLEAR Y
          PX4    X4 
          EXIT
 ECSFINAL SPACE  5
* /---   BLOCK      ECSFINAL   00 000   77/03/31  14.54 
* 
****      ECSFINAL - WRITE INTO LAST OF ECS BUFFER THE
*                    INFO DATA, AND SET UP COMMAND WORD 
*                    WITH LENGTH AND BIAS IN X6 
*         LENGTH AS A PACKED EXPONENT 
*         BIAS   AS THE NEXT 16 BITS
*         XINC   AS THE NEXT 10 BITS
*         YINC   AS THE NEXT 10 BITS
* 
*         EXIT WITH COMMAND TYPE IN X7
* 
* 
 ECSFINAL ENTER 
* 
*PT       SAVING A5,B5,B6 PROBABLY NOT NEEDED (2/28/77) 
          SX6    A5          SAVE A5
          SA6    WSAVEREG 
          SX6    B5          AND B5 
          SA6    A6+1 
          SX6    B6          AND B6 
          SA6    A6+B1
* 
*                FIRST CLEAN UP X7
* 
          NZ     B4,ECSF1    SENSE NO CHARS 
          SX1    1R 
          PACKCHR X1         PACK SPACE 
          XINC   XCHRINC
 
 ECSF1    RJ     FIX.X7      POSITION X7
 
* 
*                            NOW PLANT IN ECS 
* 
 ECSF2    SA0    WORK        CM BUFFER
          SB2    A0-B1       LENGTH CAOC
          SB2    A7-B2       LENGTH TO B2 
* 
          SA2    ECSARGS     NUMBER OF ECS ARGS 
          SX1    B2 
          IX7    X1+X2       INCREMENT NUMBER OF ARGS 
          SX1    X7-ECSRESL 
          PL     X1,LNGUNIT  SEE IF TOO MANY ECS ARGS 
          SA7    A2          WRITE OUT NEW LENGTH 
          SA1    ECSRESB     ADDRESS OF ECS ARGS BUFFER 
          IX0    X1+X2       ADDRESS AT WHICH TO INSERT 
+         WE     B2          WRITE OUT
          RJ     ECSPRTY
* 
          SB1    1           RESET UNIVERSAL CON
          SA1    WSAVEREG    RESET A5/B5
          SA5    X1 
          SA1    A1+B1
          SB5    X1 
          SA1    A1+B1
          SB6    X1 
* 
*                            CONSTRUCT COMMAND WORD 
* 
          SX1    B4-3777B    CHECK IF TOO MANY CHARACTERS 
          PL     X1,ERRLNG
          BX6    X2          GET OFFSET INTO ECS ARGS 
          LX6    -12-16      POSITION FOR COMMAND WORD
          SB4    B4-1777B    OFFSET NUMBER OF CHARS 
          PX6    X6,B4       PACK NUMBER OF CHARS 
          MX0    -10         SET UP COMMAND WORD
          BX3    -X0*X3      TRUNCATE TO 9 BITS PLUS SIGN 
          UX4,B2 X4          RECOVER TEMP BIAS
          SX1    B2 
          IX4    X4-X1
          BX4    -X0*X4      YYY TRUNCATE 
          LX3    22 
          LX4    12          POSITION YYY 
          BX6    X3+X6       MERGE
          BX6    X4+X6
          SX1    B6          MARK DIRECTION 
          LX1    11 
          BX6    X1+X6
* 
*                            SET TYPE OF COMMAND
* 
          NZ     B3,ECSF3    SENSE CR 
* /---   BLOCK      PROCESS10  00 000   77/03/29  20.59 
* 
          SX7    WRITE1=     NO CR
          EXIT
 
 ECSF3    NG     B3,ECSF4    SENSE CR TO MARGIN 
          SX7    WRITE2=     SET UP CR TO BORDER
          EXIT
 
 ECSF4    SX7    WRITE3=
          EXIT
* 
 BKSPCHR  SPACE  5
***       ROUTINE TO BKSP A CHAR
* 
* 
 BKSPCHR  ENTER 
          BKSPCHR 
          EXIT
 EINTL    SPACE  5
***       INITIALIZE FOR EMBEDDING
* 
* 
 EINTL    ENTER 
          SX6    WRCBLTH-1   SET UP COMMAND POINTER 
          SA6    WRKPNT 
          EXIT
 EFINAL   SPACE  5
***       EFINAL - FINAL ACTIONS FOR EMBEDDING
* 
* 
 EFINAL   ENTER 
* 
*PT       PROBABLY DO NOT NEED THESE SAVES (2/28/77)
          SX6    A5          SAVE A5
          SA6    WSAVEREG 
          SX6    B5          AND B5 
          SA6    A6+1 
          SX6    B6 
          SA6    A6+B1
* 
*                            SET UP FOR ECS WRITE 
* 
          SA1    WRKPNT      CALC COMMAND LENGTH
          BX2    -X1
          SB4    X2+WRCBLTH-1  LENGTH 
          SA0    X1+WRITCBUF+1  ECS 
* 
          SA1    ECSRESB     START OF ECS ARGS
          SA2    ECSARGS     NUMBER OF ECS ARGS 
          IX0    X1+X2       ADDRESS TO INSERT MORE 
          SX1    B4 
          IX7    X2+X1       NEW NUMBER OF ECS ARGS 
          SA7    A2          UPDATE NEW LENGTH
          SX1    X7-ECSRESL 
          PL     X1,LNGUNIT  SEE IF TOO MANY ARGS 
+         WE     B4          WRITE OUT
          RJ     ECSPRTY
* 
          SB1    1           RESET UNIVERSAL CON
          SA1    WSAVEREG    RESET A5/B5
          SA5    X1 
          SA1    A1+B1
          SB5    X1 
          SA1    A1+B1
          SB6    X1 
* 
* 
*                            CALC COMMAND  BIAS 
* 
          BX6    X2          GET OFFSET IN ECS ARGS 
          LX6    -12-16 
          PX6    X6,B4       BIAS AND LENGTH
          SX7    WRITE4=     COMMAND TYPE 
          EXIT
* /---   BLOCK      WGETLINE   00 000   77/03/31  15.06 
 WGETLINE SPACE  5
****      WGETLINE
* 
*         EXIT WITH B6 = 0
* 
 WGETLINE ENTER 
          SX6    B3          SAVE B3,B4,B5,B7,A7,X0,X3,X4,X7
          SA6    WSAVEREG 
          SX6    B4 
          LX6    18 
          SX1    B7 
          BX6    X1+X6
          LX6    18 
          SX1    A7 
          BX6    X1+X6
          SA6    A6+B1
          SA7    A6+B1
          BX6    X0 
          SA6    A7+B1
          BX6    X3 
          SA6    A6+B1
          BX6    X4 
          SA6    A6+B1
          SX6    B5 
          SA6    A6+B1
* 
* * *     END TEST AT EVERY LINE TO STAY IN WORK BUFFER 
* 
          SX2    B4-3777B    CHECK IF TOO MANY
          PL     X2,ERRLNG
* 
* * * 
* 
          RJ     GETLINE
          SB1    1
          SA1    WSAVEREG    RESTORE REGS 
          SB3    X1 
          SA1    A1+B1
          SA2    X1 
          BX7    X2 
          SA7    X1 
          AX1    18 
          SB7    X1 
          AX1    18 
          SB4    X1 
          SA1    A1+B1
          BX7    X1 
          SA1    A1+B1
          BX0    X1 
          SA1    A1+B1
          BX3    X1 
          SA1    A1+B1
          BX4    X1 
          SA1    A1+B1
          SB5    X1 
 
 
          SB6    B0 
* 
          EXIT
* 
* 
 WRKPNT   DATA   0           COMMAND POINTER IN WRITCBUF
 INWC     DATA   0           STORAGE POINTER IN WRITCBUF
 WCOMND   DATA   0           TEMP STORAGE FOR WRITEC COMMAND
 WSAVEREG BSSZ   7
 CSET=    DATA   0           IN CONDENSE ALWAYS USE READ ONLY FONT
 
 
* /---   BLOCK      EXACTSUBS  00 000   76/08/13  03.05 
EXCSUBS   TITLE  VARIOUS SUBROUTINES FOR EXACTC 
***       INITIALIZE FOR AN ELEMENT 
* 
*                SETS UP FOR PACKER 
* 
* 
 
 
 EXCINTL  ENTER              EXIT/ENTRY 
          MX7    0           CLEAR CHARACTER ACCUM
          SB7    10          SET NUMBER OF CHARS REMAINING
          SB4    B0          NUMBER OF CHARS IN ELEMENT = 0 
          SB3    B0 
          MX0    0           SET TO NORMAL FONT 
 
*         THE FOLOWING ARE SET FOR X/Y OPERATIONS 
 
          MX3    0
          MX4    0
          PX4    X4 
 
          EXIT
 EXCFINL  SPACE  4
***       CLEAN UP ELEMENT AND BUMP COUNTERS
* 
* 
 
 
 EXCFINL  ENTER 
 
* 
          RJ     FIX.X7      GO FIXUP X7
 
* 
* 
*         NOW FORM THE ELEMENT IDENTIFIER 
* 
* 
 EXCF1    SA1    ORGA7
          SX6    INFO 
          IX6    X1-X6       RELATIVE ADDRESS IN *INFO* 
          LX6    30-12
          SX2    B4          TOTAL NUMBER OF CHARACTERS 
          LX2    30-12-12 
          BX6    X2+X6
          SA1    WRKPNT      CURRENT TABLE ADDRESS
          SA2    WORK+X1
          SA3    =XCONV3     CURRENT NUMBER OF ENTRIES
          BX6    X2+X6
          LX3    -1          TEST ODD/EVEN
          NG     X3,EXCF3    IF ODD 
          LX6    30          POSITION EVEN ENTRIES TO TOP 
          SA6    A2 
 EXCF2    LX3    1           RESTORE TRUE COUNT 
          SX6    X3+B1       AND BUMP IT
          SA6    A3 
          SX6    A7+B1       SAVE POSSIBLE ORG FOR NEXT ELMT
          SA6    ORGA7
 
          EXIT
 
 EXCF3    SA6    A2          PLANT COMPLETED WORD 
          SX6    X1+B1       BUMP NUMBER OF IDENTS
          SA6    A1 
          MX6    0           CLEAR NEXT WORD
          SA6    A2+B1
          EQ     EXCF2
 
 ORGA7    DATA   0           RELATIVE ORIGIN OF ELEMENT 
* /---   BLOCK      FIX.X7     00 000   77/11/12  04.41 
 FIX.X7   SPACE  4
***       COMMON ACTIONS TO POSITION X7 FOR EXACTC/WRITEC 
* 
* 
 
 
 FIX.X7   ENTER 
 
*         FIX UP X7 IF NECESSARY
* 
          SX1    B7-10       TEST NUMBER OF REMAINING CHARS IN WORD 
          ZR     X1,FIX.X7   IF NO CHARACTERS IN ACCUM
          SX1    B7          CALCULATE SHIFT COUNT
          LX1    1
          SX1    X1+B7       X3 
          LX1    1           X6 
          SB7    X1 
          LX7    B7,X7       POSITON LAST WORD
          SA7    A7+1        PLANT IT 
 
          EXIT
* 
*          TITLE  DISPLAY CODE OUTPUT COMMAND 
****       DISIN - PROCESS DISPLAY CODE OUTPUT
* 
* 
* DISIN    CALL   SYSTEST     LIMIT TO SYSTEM PROGRAMS
*          SX7    10          DEFAULT NUMBER OF CHARACTERS
*          CALL   SHOWAGO     USE SHOWA DRIVER
*          EQ     =XPUTCODE 
**
**
******
          PURGMAC SB1 
******
 ERRLNG   SB1    108         TOO MANY CHARS IN WRITE TAG
          EQ     =XERR
* 
 K8S      DATA   8L          SPACES 
* 
* 
          QUAL   CWRTOV 
          ENDOV 
* 
* /---   BLOCK      END        00 000   77/04/24  22.07 
* 
* 
          OVTABLE 
* 
* 
          END    CWRITE$