*M*      TEL      TERMINAL EXECUTIVE LANGUAGE
         SYSTEM   SIG7FDP
UTSPROC  SET      0
S69PROC  SET      1
BITS     SET      1                 ENABLE DEFAULT LITERALS
         SYSTEM   UTS
         SYSTEM   BPM
         M:PT     1                 PROTECT TYPE 1 FOR SYS BPM FPT'S
************************************************************************
*P*      NAME:    TEL                                                  *
*P*                                                                    *
*P*      PURPOSE:      TEL IS THE DEFAULT COMMAND PROCESSOR FOR TIME-  *
*P*               SHARING AND THUS SERVES AS THE TERMINAL USER'S       *
*P*               INTERFACE TO CP-V'S SERVICES. IT IS FUNCTIONALLY     *
*P*               EQUIVALENT TO 'CCI' IN BATCH MODE.  SOME OF THE      *
*P*               MAJOR FUNCTIONS PERFORMED BY TEL ARE:                *
*P*               1.  CALL USER PROGRAMS AND SYSTEM PROCESSORS         *
*P*               2.  ASSOCIATE DELTA, OR OTHER DEBUGGERS              *
*P*               3.  MANIPULATE THE  ASSIGN/MERGE RECORD (VIA THE     *
*P*                   SET COMMAND) TO ESTABLISH DEVICE & FILE          *
*P*                   ASSIGNMENTS                                      *
*P*               4.  PERFORM PARTIAL CHECKPOINT/RESTORE (SAVE/GET)    *
*P*               5.  CHANGE TERMINAL DEFAULTS, SUCH AS TIMING         *
*P*                   ALGORITHMS AND PAGINATION                        *
*P*               6.  'SUPERCLOSE' SYMBIONT FILES (PRINT COMMAND)      *
*P*               7.  DISPLAY SYSTEM PARAMETERS & BATCH JOB STATUS     *
*P*               8.  SEND MESSAGES TO THE CP-V OPERATOR'S CONSOLE     *
*P*                                                                    *
*P*      DESCRIPTION:                                                  *
*P*                    TEL LIVES IN THE SPECIAL SHARED PROCESSOR       *
*P*               AREA (ABOVE X'1C000') AND MAY REMAIN                 *
*P*               ASSOCIATED WITH THE USER ALONG WITH HIS PROBLEM      *
*P*               PROGRAM.  TEL IS INVOKED INITIALLY BY AN             *
*P*               INTERPRETIVE EXIT FROM THE LOGON PROCESSOR.          *
*P*               THEREAFTER, TEL REGAINS CONTROL WHEN A PROBLEM       *
*P*               PROGRAM OR SYSTEM PROCESSOR ABORTS OR EXITS, AND     *
*P*               WHEN THE TERMINAL USER TYPES 'CONTROL-Y' OR          *
*P*               'ESC-ESC'.  ALL EXITS ARE INTERPRETIVE EXCEPT ABORT  *
*P*               CASES, WHICH CAUSE THE USER AREA TO BE CLEANED       *
*P*               UP BY STEP, FOLLOWED BY RE-ASSOCIATION OF TEL.       *
*P*               FINAL EXIT FROM TEL IS MADE TO LOGON, WHERE THE      *
*P*               ACCOUNTING RECORD IS WRITTEN AND THE USER IS LOGGED  *
*P*               OFF.                                                 *
*P*                    TEL IS LOADED WITH MONSTK AND COPIES OF THE     *
*P*               PASS2-GENERATED DEVICE AND OPLABEL TABLES (USED BY   *
*P*               SET COMMAND).    IT MUST ALSO HAVE SPECIAL JIT       *
*P*               ACCESS AND THE MAXIMUM MEMORY FLAGS SET.             *
*P*                                                                    *
*P*      REFERENCE:                                                    *
*P*               TEL IS  DESCRIBED IN THE CP-V TIME-SHARING           *
*P*               REFERENCE MANUAL, 900907.                            *
************************************************************************
         SPACE    3
************************************************************************
DBUG     SET      0                 NORMAL MODE
************************************************************************
         PAGE
*        **********
*        *  DEFS  *
*        **********
         DEF      AMBUF             SBUF2 USED TO READ A/M RECORD
         DEF      BINDECBCD         CONVERTS BINARY TO DEC. EBCDIC
         DEF      CLEANSTACK        RESETS TELSTACK & PROMPTS
         DEF      CMNERR1           PROCESS TEL ERRORS
         DEF      CPXEND            ENTRY AT TERMINAL READ
         DEF      DECBIN            EBCDIC TO BINARY CONV.
         DEF      FID               GET N.A.P OF FILES
         DEF      FLOP              OPENS M:TEL TO A FILE
         DEF      FREEBUF1          RELEASES TEL'S CONTEXT PAGE
         DEF      GETFIELD          SCAN INTO D1
         DEF      HEX2EBC           CONVERTS BINARY TO HEX EBCDIC
         DEF      INBREAK1          ABORTS TEL
         DEF      NFND              CONVERTS LMN NAME TO TEXTC
         DEF      ONERR             PRINTS ERROR MSG
         DEF      PATCH             PATCH AREA
         DEF      NTJBST            ISSUE ERROR 030100
         DEF      PROMPT            TYPES BANG & READS UC
         DEF      PROMPTF           ENTRY FOR COMMAND FILES
         DEF      SCAN              SCANS COMMAND LINE FOR FIELDS
         DEF      SCAN#             ENTRY TO SCAN WITH # AS DELIMITER
         DEF      SETSTP            EXU LIST
         DEF      SYNTAX            TYPES 'EH?'
         DEF      SYN1              CLEANUP AFTER INTERNAL ERROR MSG
         DEF      SYSERR            CLEANUP AFTER SYSTEM ERROR
         DEF      TEL               MAIN ENTRY POINT
         DEF      BLANKBUF          CLEAN J:CCBUF IN TERR
*
*DATA   DEFS
*
         DEF      CPXUSR            BIT IN JIT, WORD 0, MEANS
*,*                                 EXECUTING FROM COMMAND FILE.
         DEF      EXLYBIT           EXECUTE ONLY BIT IN J:ASSIGN
         DEF      FEXTIMG           TEMP FILE EXT BITS IN SBUF1
         DEF      FLOPBUF           OPEN FPT IN CONTEXT PAGE
         DEF      FPFPT             FREE PAGE FPT
         DEF      F0F9
         DEF      GPFPT             GET PAGE FPT
         DEF      MSTRMODE          FPT FOR M:MASTER BEFORE SUA
         DEF      ON                TEXT
         DEF      OPENBIT           FCD BIT IN DCB WORD 0
         DEF      OPENME            OPEN PRIME PLIST FOR UC
         DEF      OVER              TEXT
         DEF      RETN              TEXT CARRIAGE RETURN
         DEF      SETBUF            PLIST BUILD AREA IN SBUF1
         DEF      SETBUFE           END OF SETBUF
         DEF      SETBUFSZ          SIZE OF SETBUF
         DEF      SZCELL            TEMP IN SBUF1
         DEF      EXPNDSZ           TEMP IN SBUF1
         DEF      TELBUF            COMMAND BUFFER IN CONTEXT PAGE
         DEF      TELSTACK          SPD IN SBUF1
         DEF      DCBTAB2           2ND DCBTAB IN SBUF1
         DEF      M:TEL             TEL'S SPECIAL DCB IN SBUF1
         DEF      M:TELSIZ          LENGTH OF M:TEL
         DEF      TM:SI             TEXT M:SI
         DEF      VERB1             LIST OF 4 BYTE COMMANDS
         DEF      VERB2             DBLWD OF BLANKS, DBLWD CMD LIST
         DEF      VERSCELL          MONITOR ROOT CELL (ABS)
         DEF      WRITE             FPT TO WRITE UC
         DEF      DCBBUF
*
*  J:TELBUF BIT DEFS
*
         DEF      JSTEP
         DEF      BRKBIT
         DEF      PHSFLG
         DEF      SINOREL
         DEF      SISET
         DEF      ONBIT
         DEF      OVERBIT
         DEF      DELTABIT
         DEF      FDPBIT
         DEF      %ROMFLG
         DEF      COMFLG
         DEF      LOFLG
         DEF      DONTBIT
         DEF      CCBUFBIT
         DEF      STRTBIT
         DEF      FIPROC
         DEF      MSGEBIT
         DEF      IQUIT
         DEF      UDELTFLG
         DEF      UNKLMN
         DEF      EXTNDBIT
         PAGE
*        **********
*        *  REFS  *
*        **********
         REF      M:UC              JIT DCB
         REF      M:XX              JIT DCB
         REF      SBUF1VPA          SPECIAL BUFFER 1
         REF      SBUF2VPA          SPECIAL BUFFER 2
         REF      J:TELFLGS         JIT FLAGS UNIQUE TO TEL
         REF      J:ABC             ABORT CODE
         REF      ERO               JIT DISPLACEMENT OF ERROR SUBCODE
         REF      J:RNST            JOB STATUS BITS
         REF      JB:CCARS          SAVED ARS FROM M:UC COMMAND READ
         REF      TSTACK            REMOVE ABORT ENVIRONMENT
         REF      J:JAC             CHECK FOR JOB STEP
         REF      JB:PCDCB          DCB PAGE COUNT FOR JOB STEP CHK
         REF      J:AMR             DISC ADDRESS OF A/M RECORD
         REF      J:OPT             USER ACCESSIBLE ASSIGNMENTS
         REF      J:ABUF            VIRTUAL CORE ADDRESS OF A/M RECORD
         REF      READAM            READS A/M RECORD
         REF      WRITEAM           WRITES A/M RECORD
         REF      ASSIGN            EDITS A/M RECORD
         REF      DCBSCAN
         REF,1    JB:FRS            FINAL RUN STATUS
         REF      J:EXTENT          EXIT CONTROL ADDRESS & FLAGS
         REF      FILENT            BUILDS SIMPLE FILE PLIST
         REF      PLIST             SKELETON PLIST FOR A/M ENTRIES
         REF      MODE              WORD 3 IN SKELETON PLIST
         REF      PPAS              PASSWORD VLP IN PLIST
         REF      PACC              ACCOUNT VLP IN PLIST
         REF      NAME              FILE NAME VLP IN PLIST
         REF      J:ACCN            ACCOUNT FIELD IN JIT
         REF      J:UNAME           USER LOG0N NAME IN JIT
         REF      SV:LSIZ           SIZE OF LOGICAL NAME TABLE (SYSGEN)
         REF      SH:LNM            LOGICAL NAME TABLE (SYSGEN)
         REF      J:JIT             START OF JIT
         REF,1    JB:LPP            LINES PER PAGE
         REF,2    JH:PC             TERMINAL PAGE COUNT
         REF,1    JB:PCW            TERMINAL PAGE WIDTH
         REF,1    JB:PROMPT         SET PROMPT FOR TEL, PROMPT COMMAND
         REF,1    JB:DPROMPT        SET DEFAULT PROMPT CHARACTER
         REF,1    JB:LBPH           SET, DISPLAY LINES BEFORE PAGE HEADING
         REF,1    JB:LAPH           SET, DISPLAY LINES AFTER PAGE HEADING
         REF      SET               HANDLES SET COMMAND
         REF      RESET             HANDLES RESET COMMAND
         REF      SETFLE            BUILDS SHORT FILE PLIST
         REF      SETNUMB           BUILDS DEVICE VOLUME PLIST
         REF      J:CCBUF           CONTROL COMMAND BUFFER
         REF      J:UTIME           USER ACCOUNTING CELLS
         REF      J:PTIME           PROCESSOR ACCOUNTING CELLS
         REF      J:INTER           TERM. INTERACT. ACCTING CELL
         REF      J:CALCNT          COUNT OF CALS
         REF      J:LMN             *TEMP* RUNNING PRGM NAME
         REF      J:EXLY            EXECUTE ONLY FLAG WORD (J:ASSIGN)
         REF      :LOGSZ            SIZE OF :USER RECORD
         REF      J:START           *TEMP* RUNNING PRGM START ADDR
         REF      T%ERR             PRINTS TEL'S ERROR MSGS
         REF      OX                COMMAND FILE HANDLER
         REF      CPXREAD           READS COMMANDS FROM A FILE
         REF      CPXBREAK          CPX CLEANUP FOR CONTROL-Y
         REF      ECHO              TOGGLES ECHO BIT IN J:OPT
         REF      JSBUF1VP          PAGE NUMBER OF SBUF1
         REF      FPMC              FREE PAGE MAP CONSTANT
         REF      JX:CMAP           PHYSICAL PAGE MAP
         REF      J:ASSIGN          LIMIT EXCEEDED BITS
         REF      PRDCRM            PERM RAD SPACE REMAINING
         REF      PRDPRM            PERM DISK SPACE REMAINING
         REF      J:CPPO            FILE EXTENSION BITS
         REF      CIC               COUNT OF CARDS READ
         REF      COCMESS           ADMINISTRATIVE MSG IN MONITOR
         REF      CPO               COUNT OF CARDS PUNCHED
         REF      CUPO              COUNT OF USER PAGES OUT
         REF      CDPO              COUNT OF DIAGNOSTIC PAGES OUT
         REF      SS                JIT DISPL. TO PSEUDO SENSE SWITCHES
         REF      SAVE              SAVE COMMAND ROUTINE
         REF      GET               GET COMMAND ROUTINE
         REF      BLDMTEL           CREATES M:TEL IN SBUF1
         REF      KILLMTEL          RELEASES M:TEL IN SBUF1
         REF      FMTELCL           FORCES M:TEL CLOSED
         REF,1    JB:PRIV           USER'S PRIVILEGE
         REF      COCLN             LINE NUMBER IN M:UC DCB
         REF      DCACCESS          # OF DC I/O OPERATIONS
         REF      DPACCESS          # OF DP I/O OPERATIONS
         REF      TPACCESS          # OF TAPE OPERATIONS
         REF      S:COUP            COUPLING FEATURE CONTROL CELL.
         SREF     LB:UN             VALIDATE WHERE CMND
         REF      T%ERRTXT          READS ERRMSG INTO TELSTACK
         REF      T%WRTERR          WRITES ERRMSG & CLEARS TELSTACK
         REF      S:SYMDB           BATCH DEVICE AND FEATURE BITS
         REF      S:SYMDO           ONLINE DEVICE AND FEATURE BITS
         REF      SH:SYMT           DEVICE AND FEATURE NAME TABLE
         REF      SV:FTYM           DEVICE AND FEATURE TABLE LENGTH
         REF      SB:RBMX           BATCH RESOURCE LIMIT TABLE
         REF      SB:RODF           ONLINE RESOURCE LIMIT TABLE
         REF      SH:RNM            RESOURCE NAME TABLE
         REF      SV:RSIZ           RESOURCE TABLE LENGTH
         REF      SL:BMX            BATCH SERVICE LIMIT TABLE
         REF      SL:ODF            ONLINE SERVICE LIMIT TABLE
         REF      SL:NAME           SERVICE NAME TABLE
         REF      SV:LIM            SERVICE TABLE LENGTH
         SREF     SCRAM             PASSWORD SCRAMBLER
         SREF     TTP               IF DEFINED, TP IS GEN'ED
*        ************************
*        *  REFS FROM LITERALS  *
*        ************************
         REF      XA                LITERAL CONSTANT
         REF      XFFFD             LITERAL CONSTANT
*        ********************
*        * REFS FROM AMRDEF *
*        ********************
         REF      AM:ORG            POINTER TO AVAILABLE A/M SPACE
         REF      AM:STDOP          INTER-JOB-STEP IMAGE OF J:OPT
         PAGE
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
         SPACE    3
TEL      CSECT    1
MUCRSET  EQU      -X'28131'         =X'FFFD7ECF', MASK TO RSET M:UC
CPXUSR   EQU      Y08               COMMAND FILE USER
AMBUF    EQU      SBUF2VPA          WINDOW PAGE TO READ A/M RECORD
VERSCELL EQU      X'2B'             MONITOR TYPE CELL
ARS      EQU      M:UC+4
MAXMSG   EQU      140               MAXIMUM ERRMSG RECORD LENGTH
*  NOTE  ABOVE SYMBOL MUST MATCH DEFINITION IN OTHER TEL MODULES
*        OR TERRIFIC MAYHEM WILL RESULT ( BUT IT SHOULD NEVER NEED
*        TO BE CHANGED ANYWAY).
         PAGE
************************************************************************
*
*        THE FOLLOWING DEFINES THE LAYOUT OF TEL'S DATA PAGE
*  AND SHOULD BE CHANGED WITH CARE
*
SETBUF   EQU      SBUF1VPA          WINDOW PAGE, SP. BUFFER 1
SETBUFSZ EQU      255
SETBUFE  EQU      SETBUF+SETBUFSZ
TELSTACK EQU      SETBUFE+1         SPD MUST BE ON DWD BOUNDARY
NLSAVE   EQU      TELSTACK+2        TEMP FOR 1ST WORD IN TELBUF
FEXTIMG  EQU      NLSAVE+1          IMAGE OF FILE EXT BITS AT A/M READ
SZCELL   EQU      FEXTIMG+1
EXPNDSZ  EQU      SZCELL+1
TELBUF   EQU      EXPNDSZ+1
SCNPTRSV EQU      TELBUF+20
FLOPBUF  EQU      SCNPTRSV+1        PLIST BUILD AREA
DCBTAB2  EQU      FLOPBUF+18
DCBBUF   EQU      DCBTAB2+6
LINKSAVE EQU      DCBBUF+8
M:TEL    EQU      LINKSAVE+1
M:TELSIZ EQU      42                MINIMUM DCB SIZE
STACK0   EQU      M:TEL+M:TELSIZ    TELSTACK STARTS HERE
TSTAKSZ  EQU      SBUF1VPA+511-STACK0     SIZE OF TELSTACK
************************************************************************
         SPACE    3
LOGSIZE  EQU      :LOGSZ
FORSEC   EQU      1                 SET TO 1 FOR ELAP TIME IN SEC
         PAGE
*
* PROC TO CHANGE STACK POINTER THE AMOUNT SPECIFIED BY THE 1ST ARGUMENT
* USING THE REGISTER SPECIFIED BY THE 2ND ARGUMENT.
*
BUMP     CNAME
         PROC
LF       LI,AF(2) AF(1)
         MSP,AF(2)  TELSTACK
         PEND
*
* PUSH OR PULL N WORDS SPECIFIED BY 1ST ARGUMENT INTO REGS STARTING
* AT 2ND ARGUMENT.
*
PUSH     CNAME    X'9',X'B'
PULL     CNAME    X'8',X'A'
         PROC
         DO       NUM(AF)=1
LF       GEN,1,7,4,3,17  0,NAME(1),AF(1),0,TELSTACK
         ELSE
         DO       AF(1)=1
LF       GEN,1,7,4,3,17  0,NAME(1),AF(2),0,TELSTACK
         ELSE
         DO       AF(1)=16
LF       LCI      0
         ELSE
LF       LCI      AF(1)
         FIN
         GEN,1,7,4,3,17  0,NAME(2),AF(2),0,TELSTACK
         FIN
         FIN
         PEND
         PAGE
*
*  THESE PROCS ARE USED TO GENERATE THE VARIOUS TABLES USED TO
*  IDENTIFY AND EXECUTE  VALID TEL COMMANDS
*
         OPEN     I,J,K,S,OPCDS
I,J      SET      0
DBIT1    SET      0
DBIT2    SET      0
CMND     CNAME    0
DCMND    CNAME    1
         PROC
OPCDS    SET      X'680',X'126'
S        SET      S:NUMC(AF(1))
         DO       S<=4
         USECT    VERB1
         ELSE
         USECT    VERB2
         FIN
LF(1)    TEXT     AF(1)
         DO       S<=4
         USECT    VECTOR1
         ELSE
         USECT    VECTOR2
         FIN
LF(2)    GEN,12,20   OPCDS(SCOR(AF(2),B,LD6)),AF(3)
         ERROR,7,SCOR(AF(2),B,LD6)=0 'UNKNOWN OPCD IN AF 2'
         DO       S<=4
I        SET      I+1
K        SET      1+(I**-5)
DBIT1(K) SET      DBIT1(K)|NAME**((I&X'1F')-1)
         ELSE
J        SET      J+1
K        SET      1+(J**-5)
DBIT2(K) SET      DBIT2(K)|NAME**((J&X'1F')-1)
         FIN
         PEND
         CLOSE    I,J,K,S,OPCDS
         TITLE    'TEL-TERMINAL EXECUTIVE LANGUAGE'
*                 **************************
*                 * BIT USAGE OF J:TELFLGS *
*                 **************************
*
JSTEP    EQU      1                 AT JOB STEP
BRKBIT   EQU      2                 BREAK RECIEVED
PHSFLG   EQU      4                 0=BUILD GO DCB; 1=BUILD LO DCB
SINOREL  EQU      8                 DO NOT RELEASE SI ENTRIES FROM A/M
SISET    EQU      X'10'             SI HAS BEEN ASSIGNED
ONBIT    EQU      X'20'             'ON' HAS BEEN SPECIFIED
OVERBIT  EQU      X'40'             'OVER' HAS BEEN SPECIFIED
DELTABIT EQU      X'80'             'UNDER DELTA' HAS BEEN SPECIFIED
FDPBIT   EQU      X'100'            'UNDER FDP' HAS BEEN SPECIFIED
%ROMFLG  EQU      X'200'            DEFAULT FOR % ROM IN PROGRESS
COMFLG   EQU      X'400'            UNIQUE 'COMMENT' CMD INDICATOR
LOFLG    EQU      X'800'            UNIQUE 'LIST' CMD INDICATOR
DONTBIT  EQU      X'1000'           'DONT' IN EFFECT
CCBUFBIT EQU      X'2000'           REPROCESS CURRENT BUFFER IMAGE
STRTBIT  EQU      X'4000'           LMN WAS DETECTED IN START PROCESS
FIPROC   EQU      X'8000'           N.A.P HAS BEEN PROC DURING PARSE
         EQU      X'10000'          UNUSED
MSGEBIT  EQU      X'20000'          END OF VALID MSG FLAG
IQUIT    EQU      Y0004             IMPLIED QUIT FLAG
UDELTFLG EQU      Y0008             UNDER DELTA IMPLIED FOR NEXT COMMAND
UNKLMN   EQU      Y001              UNRECOGNIZED LOAD MODULE
EXTNDBIT EQU      Y002              USER REQUESTED EXTENDED MEMORY MODE
         EQU      X'400000'         PROCESSING SNGLE USR ABRT (INITRCVR SET)
PIDGFLG  EQU      Y008              DEFERRED MSG PENDING
ERRORFLG EQU      Y01               ERROR DEV TAPE FLAG
TPFLG    EQU      Y1                REQUEST LOGOFF TO TP
INFMFLG  EQU      Y2                INFORM USER OF COUPLING ATTEMPT BY  ANOTHER
ABRTFLG  EQU      Y4                ABORTED PROGRAM STILL HERE
         PAGE
*           -------------------------------------
* J:TELFLGS |        |        |     1 1| 1 1 1 1|
*  (1ST HW) | 0 1 2 3| 4 5 6 7| 8 9 0 1| 2 3 4 5|
*           -------------------------------------
*             | | | |  | | | |  | | | |  | | | >UNUSED
*             | | | |  | | | |  | | | |  | | >MSGEBIT-END OF VALID MSG
*             | | | |  | | | |  | | | |  | >IQUIT-IMPLIED QUIT FLAG
*             | | | |  | | | |  | | | |  >UDELTFLG-U DELTA ON NXT CMD
*             | | | |  | | | |  | | | >UNKLMN-UNRECOGNIZED LMN CALLED
*             | | | |  | | | |  | | >EXTNDBIT-EXTENDED MEMORY MODE
*             | | | |  | | | |  | >  PROCESSING SINGLE USER ABORT
*             | | | |  | | | |  >PIDGFLG-DEFERRED MESG TO BE PRINTED
*                            >ERRORFLG--ERROR TAPE DEV ON CONTROL Y
*             | | | |  | | >UNUSED
*             | | | |  | >UNUSED
*             | | | |  >UNUSED
*             | | | >TPFLG-USER REQUESTED TP SWITCH
*             ` `INFMFLG-INFORM USER OF COUPLING ATTEMPT
*             | >ABRTFLG-ABORTED PROGRAM STILL HERE
*             >SETERR - ERROR MESS. IN CCBUF FOR CCI TO PRINT
*
*
*           -------------------------------------
* J:TELFLGS | 1 1 1 1| 2 2 2 2| 2 2 2 2| 2 2 3 3|
*  (2ND HW) | 6 7 8 9| 0 1 2 3| 4 5 6 7| 8 9 0 1|
*           -------------------------------------
*             | | | |  | | | |  | | | |  | | | >JSTEP-AT JOB STEP
*             | | | |  | | | |  | | | |  | | >BRKBIT-CONTROL Y RECVD
*             | | | |  | | | |  | | | |  | >PHSFLG-BLD GO(0),BLD LO(1)
*             | | | |  | | | |  | | | |  >SINOREL-DON'T RLS SI FRM A/M
*             | | | |  | | | |  | | | >SISET-M:SI HAS BEEN ASSIGNED
*             | | | |  | | | |  | | >ONBIT- 'ON' HAS BEEN SPECIFIED
*             | | | |  | | | |  | >OVERBIT- 'OVER' HAS BEEN SPECIFIED
*             | | | |  | | | |  >DELTABIT-ASSOCIATE DELTA
*             | | | |  | | | >FDPBIT-ASSOCIATE FDP DEBUGGER
*             | | | |  | | >%ROMFLG-BUILD % DEFAULT FOR M:GO
*             | | | |  | >COMFLG-PROCESSING 'COMMENT' COMMAND
*             | | | |  >LOFLG-PROCESSING 'LIST' COMMAND
*             | | | >DONTBIT-USER SAID DONT SOMETHING
*             | | >CCBUFBIT-REPROCESS CURRENT CMD IN CCBUF
*             | >STRTBIT-LMN WAS DETECTED ON START COMMAND
*             >FIPROC-N.A.P HAS BEEN PROCESSED DURING PARSE
*
*        **********************
*        * BIT USAGE OF J:OPT *
*        **********************
*
*        ----------------------------------
* J:OPT  |        |       |    1 1|1 1 1 1|
*(1ST HW)| 0 1 2 3|4 5 6 7|8 9 0 1|2 3 4 5|
*        ----------------------------------
*          |                             >DEBUG (FORTRAN COMPILE)
*          >ECHO COMMAND FILE
*
*        ----------------------------------
* J:OPT  | 1 1 1 1|2 2 2 2|2 2 2 2|2 2 3 3|
*(2ND HW)| 6 7 8 9|0 1 2 3|4 5 6 7|8 9 0 1|
*        ----------------------------------
*                  | | | | | | | | | | | >LIST - M:LO ASSIGNMENT
*                  | | | | | | | | | | >
*                  | | | | | | | | | >
*                  | | | | | | | | >
*                  | | | | | | | >  M:SI ASSIGNMENT
*                  | | | | | | >
*                  | | | | | >
*                  | | | | >OUTPUT - M:GO ASSIGNMENT
*                  | | | >COMMENT - M:DO ASSIGNMENT
*                  | | >
*                  | >
*                  >
         PAGE
************************************************************************
*S*      SCREECH CODE:     60-00                                       *
*S*      REPORTED BY:   TEL                                            *
*S*      MESSAGE: TEL ISSUED SINGLE USER ABORT ON YOU                  *
*S*      TYPE:    SINGLE USER ABORT                                    *
*S*      REGISTERS:     R15 HAS SUBCODE.
*S*      REMARKS: USER ALREADY HAS SBUF1 AT ENTRY TO TEL.
*S*               THIS SCREECH INDICATES A PROBLEM IN MEMORY MGMT OF   *
*S*               PHYSICAL POOL PAGES.                                 *
************************************************************************
         BAL,R4   CHKBUF1           DO WE HAVE SBUF1 ALREADY?
         B        GETSB1            NO, EVERYTHING'S O.K.
* WE'VE GOT SBUF1. BOY, ARE WE IN TROUBLE...
         CAL1,6   MSTRMODE          GET MSTRMODE
         SUA      X'60',0
***
GETSB1   EQU      %
         LI,SR2   SBUF1VPA          TEL'S CONTEXT PAGE
         CAL1,8   GPFPT             GET IT (& ASSUME WE GOT IT)
         LI,D1    STACK0            START OF STACK
         LW,D2    STKINIT           INITIAL STACK SIZE
         STD,D1   TELSTACK          INIT. STACK PTR DBLWD
*
         BAL,R0   BLDMTEL           INITIALIZE M:TEL 'DCB'
*
         DO       DBUG=0            ***NORMAL MODE***
         LW,D2    J:AMR             CHK IF A/M RECORD EXISTS
         BEZ      ERRABN1           IF NOT, LOG USER OFF
         FIN
         LC       J:JIT
         BCS,8    BRKTST            ONLINE
         STW,SR4  LINKSAVE
         LI,R7    79                SET UP JB:CCARS WITH COMMAND LENGTH
         LB,R0    J:CCBUF,R7
         CI,R0    X'40'
         BNE      SETCCARS
         BDR,R7   %-3
SETCCARS AI,R7    1
         STB,R7   JB:CCARS
BRKTST   LW,D2    J:TELFLGS
         CI,D2    BRKBIT
         BANZ     BREAKER           BREAK SET
         LB,R7    J:ABC             TEST STATUS OF LAST MAJOR COMMAND
         BNEZ     SYSERR
         LB,R7    J:RNST            TEST FOR RUN STATUS FLAGS SET
         BNEZ     SYSERR
SETUP    LI,R7    JSTEP
         STS,R7   J:TELFLGS         SET JOB STEP FLAG
BUFINT   RES      0                 CHECK FOR VALID INFO
*
*  MOVE J:CCBUF TO TELBUF IN CASE USER WANTS TO DO AN ESC-D (RE-READ)
*
         LW,R7    =80**24+WA(TELBUF)+WA(TELBUF)+WA(TELBUF)+WA(TELBUF)
         MBS,R7  BA(J:CCBUF)-WA(TELBUF)-WA(TELBUF)-WA(TELBUF)-WA(TELBUF)
         LI,R7    CCBUFBIT          IS CURRENT BUFFER VALID?
         LS,R7    J:TELFLGS
         BEZ      PROMPT            NO
         LB,R1    JB:CCARS          GET SAVED ARS
         LI,D4    0                 CLEAR IMPLIED DELTA % OUIT FLAGS
         LI,R7    DELTABIT          DID USER SAY 'U' BEFORE
         LS,R7    J:TELFLGS         WE ASKED 'QUIT?'?
         BEZ      ITSOK             NO
         LW,D4    UDELTFLG          YES
         B        ITSOK
         PAGE
*
* TEL MUST ISSUE A PROMPT(!) BY GIVING COC A SINGLE CHARACTER WRITE.
*
PROMPT   EQU      %
         LC       J:JIT
         BCS,8    PROMPT1           ONLINE
         LW,SR4   LINKSAVE
         BAL,D4   FREEBUF1
         B        *SR4              RETURN TO CCI
PROMPT1  CAL1,8   COCSTATC
         LC       SR3               WE HAVE, IF THE 40 BIT OF MODE4
         BCR,4    PROMPT0           IS SET AND TIE NE OUR LINE #.
************************************************************************
*E*      ERROR:   GRP 3, 0E-00                                         *
*E*      DESCRIPTION:     SOMETIME SINCE WE LAST PROMPTED, SOMEONE     *
*E*               UNSUCCESSFULLY TRIED TO COUPLE TO THIS USER (BIT 1   *
*E*               OF MODE4 = 1).  THE MODE4 BIT IS RESET AND WE LET THE*
*E*               USER KNOW WHICH LINE NUMBER IT WAS SO HE CAN DECIDE  *
*E*               TO ALLOW COUPLING. BY DEFAULT, THE USER IS NOT       *
*E*               INFORMED UNLESS HE SO DESIRES BY HAVING PREVIOUSLY   *
*E*               EXECUTED THE INFORM COMMAND.                         *
************************************************************************
         STB,SR3  R5                SAVE LINE NUMBER IN R5
         LI,R4    X'40'             RESET MODE4, BIT 1
         CAL1,8   MCTCPL            DO M:CT TO RESET MODE4
         LC       J:TELFLGS         OUTPUT MESSAGE IF INFORM FLAG SET
         BCR,2    PROMPT0
         LI,D1    X'030E00'         ERRMSG KEY
         BAL,SR4  T%ERRTXT          READ MESSAGE TEXT
         LB,SR2   R5                RETRIEVE LINE NUMBER
         BAL,SR4  HEX2EBC           MAKE THAT CHARACTERS
         LI,R3    5                 INSERT LINE NUMBER
         STW,D2   *R1,R3            IN MESSAGE TEXT
         BAL,R0   T%WRTERR          AND WRITE MSG.
PROMPT0  EQU      %
         LCI      7                 SAVE M:UC DATA
         LM,SR1   M:UC
         PSM,SR1  TELSTACK          PUSH 1ST 7 WORDS OF M:UC
         LI,SR2   MUCRSET           RSET MOD,DRC & VFC BITS
         LS,SR2   M:UC              BEFORE READING RESPONSE
         STW,SR2  M:UC
         LI,SR2   0                 INITIALIZE ERR AND ABA
         STW,SR2  M:UC+3
         STW,SR2  M:UC+4
PIDGMSG  EQU      %
         LW,R7    PIDGFLG           IS THERE A
         CW,R7    J:TELFLGS         DEFERRED MSG?
         BAZ      NOEGG             NO, GO ON....
         LI,SR3   COCMESS           YES, MAP ONTO
         BAL,SR1  MAPPER            MONITOR
         MTB,0    *SR2              CHECK COUNT OF DEFERRED MSG
         BEZ      NOMSG             THERE IS NO MSG - IT'S GONE...
         LI,R1    RETN              TYPE CARRIAGE
         LI,R2    1                 RETURN BEFORE
         CAL1,1   WRITE             MESSAGE.
         LI,R1    X'10'             TO SET
         STS,R1   M:UC              UBTD TO 1.
         LW,R1    SR2               BUFFER ADDRESS
         LB,R2    *SR2              MSG BYTE COUNT
         CAL1,1   WRITE             WRITE THE DEFERRED MSG
NOMSG    EQU      %
         BAL,SR4  UNMAPPER          FIX USER'S MAP
         LI,SR2   MUCRSET           CLEAN M:UC
         LS,SR2   M:UC              BEFORE WRITE
         STW,SR2  M:UC
NOEGG    EQU      %
*
*  IF THE USER IS IN CPX MODE, GO READ FROM THE COMMAND FILE
*
         LW,SR4   CPXUSR            ARE WE IN
         CW,SR4   J:JIT             COMMAND FILE MODE?
         BANZ     CPXREAD           YES, GET NEXT COMMAND FROM FILE.
CPXEND   EQU      %
         LI,R1    RETN
         LI,R2    1                 L/1; SIZE FOR WRITE
         CAL1,1   WRITE             WRITE CARRIAGE RETURN (NO BANG)
         LI,R2    BA(JB:PROMPT)     L/ADR OF PROMPT CHAR IN JIT
         LB,SR2   0,R2              L/USER PROMPT CHARACTER
         LI,R1    X'5A'             L/BANG
         STB,R1   0,R2              S/BANG AS PROMPT CHARACTER
PROMPTA  CAL1,1   READ              READ RESPONSE INTO TELBUF
         LW,R1    ARS               TEST TERMINATING CHARACTER FOR AN
         SLS,R1   -17               ESCAPE.
         CI,R1    0                 REISSUE READ IF ARS=0
         BE       PROMPTA
         STB,SR2  0,R2              S/USER PROMPT CHARACTER
PROMPTF  EQU      %
         PULL     7,SR1             RESTORE M:UC DATA
         STW,SR1  M:UC              RESTORE WORD ZERO
         LW,SR1   SR2               RESTORE WORD ONE,
         LI,SR2   -X'100'           EXCEPT FOR BYTE 3
         STS,SR1  M:UC+1
         LCI      5
         STM,SR3  M:UC+2            REST OF SAVED M:UC DATA
*
         LW,D4    J:TELFLGS         CHECK IF IMPLIED QUIT
         CW,D4    IQUIT             OCCURRED ON PREVIOUS COMMAND
         BAZ      PRMPT50           B IF NO
         SW,D4    IQUIT             RESET IMPLIED QUIT FLAG
         STW,D4   J:TELFLGS         AND IN CURRENT FLAGS
         CI,R1    1                 1 CHAR RESPONSE TO "QUIT?"
         BNE      PRMPT50           B IF NO
         LB,D1    TELBUF            GET FIRST CHARACTER
         CI,D1    X'0D'             WAS IT A CARRIAGE RETURN
         BE       PRMPT20           B TO DO IMPLIED QUIT
         CI,D1    X'15'             WAS IT LINE FEED
         BNE      PRMPT50           B TO NORMAL PROCESSING
PRMPT20  EQU      %
         LW,R2    NLSAVE            GET 1ST WORD OF PREVIOUS COMMAND
         STW,R2   TELBUF            RESTORE 1ST WORD
         LB,R1    JB:CCARS          GET PREVIOUS ARS
         LW,D4    IQUIT             SET IMPLIED QUIT
         B        ITSOK10
*
PRMPT50  EQU      %
         LW,R2    R1
         AI,R2    -1
         LB,D1    TELBUF,R2         GET LINE TERMINATOR
         LC       J:TELFLGS         IF WE HAVE ABORTED PROGRAM
         BCS,4    %+3               IMPLIED QUIT ALWAYS
         CI,D1    X'15'             IST IT LINE FEED
         BNE      %+2               B IF NO
         LW,D4    IQUIT             SET IMPLIED QUIT FLAG.
         LW,D1    CPXUSR            JB:CCARS ALREADY
         CW,D1    J:JIT             SET IF IN
         BANZ     %+2               CPX MODE.
         STB,R1   JB:CCARS          SAVE ORIGINAL ARS-1
ITSOK    LW,D1    J:TELFLGS         RESET TEL WORKING FLAGS
         AND,D1   FLAGS
         STW,D1   J:TELFLGS
         CW,D4    UDELTFLG          CHECK IF PREVIOUS COMMAND WAS
         BAZ      ITSOK10           "UNDER DELTA", B IF NO
         LI,R7    DELTABIT          YES, SET UNDER DELTA FLAG
         STS,R7   J:TELFLGS         FOR THE CURRENT COMMAND
ITSOK10  EQU      %
*
* PICK-UP FIRST FIELD OF INPUT STATEMENT AND DECODE COMMAND VERB.
*
         LI,R2    1                 SKIP BANG IN COLUMN 1
         LC       J:JIT
         BCR,8    NEXTTIME          IF BATCH
         LW,SR3   CPXUSR            OR IF CPXMODE
         CW,SR3   J:JIT
         BANZ     NEXTTIME
         LI,R2    0                 OTHERWISE DONT SKIP
NEXTTIME  RES     0                                                  RL2
         BAL,SR3  GETFIELD                                           RL2
         CI,R7    0                 INSURE DATA IS PRESENT
         BE       PROMPT            GO AGAIN IF NO COMMAND GIVEN
         CI,R6    '.'               DID A PERIOD TERMINATE THE FIELD--
         BNE      SCANCVT           NO, NOT A LOAD MODULE
         CI,R7    1                 DID FIELD CONTAIN MORE THAN I CHAR.
         BG       LMNCMD            YES, MUST BE A LMN.
         LB,SR4   D1                IMPLIES A LMN OR PCL COMMAND.
         CI,SR4   'L'               L  .ACCNT ENTERED AS COMMAND.
         BNE      LMNCMD            IF NOT A L COMMAND, MUST BE A LMN.
*
* SCAN COMMAND VERB TABLE(S)
*
SCANCVT  EQU      %
         PUSH     2,D1              SAVE COMMAND AS USER TYPED IT
         LI,SR1   -1                FLAG UPPER CASE
         LI,R4    0                 INITIALIZE FLAG TO WORD SEARCH
         CI,R7    4                 VERIFY WORD SEARCH
         BLE      %+2               O.K.
         AI,R4    1                 DO DOUBLEWORD SEARCH
         CI,R7    8                 MORE THAN 8 CHARS MEANS
         BG       DOUBLE1           NOT A TEL COMMAND
VECTAB1  LW,R5    SCNVBSIZ,R4       GET LIST SIZE
VECTAB2  EXU      SCNVERB,R4        EXECUTE PROPER COMPARE INST
         BE       VECT              A MATCH!!
         BDR,R5   VECTAB2           SCAN ENTIRE LIST
         AI,SR1   1                 INCR FLAG FOR LOWER CASE SEARCH
         BGZ      DOUBLE1           LOWER CASE SRCH DONE, UNKNOWN CMD
* NOW SEE IF THE COMMAND IS RECOGNIZABLE WHEN CONVERTED TO UPPER CASE
         OR,D1    VERB2             CONVERT LOWER CASE
         OR,D2    VERB2             TO UPPER CASE.
         B        VECTAB1           GO SCAN THE LIST AGAIN
*
* PROCESS A COMPLEX LMN AS COMMAND.
*
LMNCMD   EQU      %
         CW,D4    IQUIT             CHECK FOR IMPLIED QUIT
         BANZ     LMNCMD10          B IF YES
         LI,R5    JSTEP
         LS,R5    J:TELFLGS         ARE WE AT JOB STEP?
         BEZ      BKOPT0            NO - ASK IF QUIT?
LMNCMD10 EQU      %
         BAL,SR4  FID               BREAK COMPLEX FID
         PUSH     2,SR2             SAVE ACCOUNT
         PUSH     2,R7              SAVE PASSWORD
         BAL,SR3  NFND              THIS WILL LEAVE LMN IN R6,R7,SR1
         PULL     2,SR3             RESTORE PASSWORD
         PULL     2,D2              AND ACCOUNT
         LW,R5    UNKLMN            SET FLAG TO INDICATE UNKNOWN LMN
         STS,R5   J:TELFLGS
         LI,D1    PARSER            SET TO SCAN REMAINING MSG
         B        GROUP2B
*
DOUBLE1  EQU      %
         PULL     2,D1              RESTORE USER'S TYPED COMMAND
         CW,D4    IQUIT             CHECK FOR IMPLIED QUIT
         BANZ     DBL10             B IF YES
         LI,R5    JSTEP
         LS,R5    J:TELFLGS         ARE WE AT JOB STEP?
         BEZ      BKOPT0            NO - ASK IF QUIT?
DBL10    EQU      %
         BAL,SR3  NFND              NO FIND-PROCESS AS UNKNOWN LMN
SPCASP   EQU      %
         LI,D1    PARSER            SET TO SCAN REMAINING INPUT WITH
*                                   UNKNOWN LMN. IF NO SCAN IS DESIRED,
*                                   CHANGE TO LI,D1 0.
         LW,R5    UNKLMN            SET FLAG TO INDICATE UNKNOWN LMN
         STS,R5   J:TELFLGS
         B        GROUP2A
*
VECT     PULL     2,D1              RESTORE USER'S TYPED COMMAND
* BEFORE EXECUTING THE COMMAND, SEE IF USER SAID DONT ILLEGALLY
         PUSH     R1
         LI,R1    DONTBIT           WAS COMMAND PRECEDED
         CW,R1    J:TELFLGS         BY DONT?
         BAZ      NODONT            NO, DON'T BOTHER CHECKING LEGALITY
         PUSH     R5                YES, CHECK PROPER DONT BIT LIST
         LI,R1    X'1F'             MASK FOR BIT POSITION
         AND,R1   R5                INDEX FOR SHIFT INST.
         LI,SR1   0
         LW,SR2   Y8                BIT TO SHIFT
         SLD,SR1  0,R1              SHIFT FOR COMPARE
         SLS,R5   -5                WORD INDEX FOR DONT BIT LIST
         EXU      DCMPRS,R4         EXECUTE PROPER COMPARE
         BANZ     DONTOK            DONT IS LEGAL (BIT SET)
         B        GIVEBIRD          DONT IS ILLEGAL
DONTOK   PULL     R5
NODONT   PULL     R1
         EXU      VECTORS,R4        EXECUTE PROPER VECTOR
VECTB10  EQU      %
         LI,D1    0                 LMN NAME LOADED IN R6,R7 AND NO
*                                   FURTHER SCAN NECESSARY
*
* THE GROUP2 COMMANDS ARE THOSE REQUIREING THE LOAD OF AN ASSOCIATED
* PROGRAM. THE LOAD IS EXECUTED IMMEDIATLY IF NO FURTHER SCAN IS
* REQUIRED BUT DEFERRED TO THE END IF SCANNING IS DONE.
*
GROUP2   LW,SR1   VERB1
GROUP2A  LW,D2    SYS               SET SYSTEM ACCOUNT AND JIT FOR
         LW,D3    VERB1             THE PROGRAM LOADER.
         LI,SR3   0                 CLEAR PASSWORD
         LI,SR4   0
GROUP2B  EQU      %
*
* TEST FOR WITHIN JOB STEP. ABORT PREVIOUS MAJOR OPERATION IF NOT.
*
         LI,R5    JSTEP             ARE WE AT
         LS,R5    J:TELFLGS         JOB STEP?
         BEZ      INBREAK           JUMP IF GROUP2 COMMAND AND BREAK
         CI,D1    0                 IS FURTHER SCAN IMPLIED
         BNE      PARSE             YES
GROUP2C  EQU      %
*
* TEST FOR SI RELEASE AND ASSIGN/MERGE WRITE LOGIC
*
         PUSH     16,R1             SAVE REGS
         BAL,SR4  READAM            NO-READ IT IN
         LW,R4    J:ABUF            NOW PICKUP ADDRESS
         LI,R1    SINOREL           CAN SI BE RELEASED?
         LS,R1    J:TELFLGS         IF SET DO NOT RELEASE SI FROM A/M
         BEZ      GRPEXT            AS THIS IS A NEW ENTRY
         LI,R1    -(SINOREL+1)      MASK TO
         AND,R1   J:TELFLGS         RESET SI RELEASE FLAG
         STW,R1   J:TELFLGS
         B        GRPEXT1
GRPEXT   LD,R6    TM:SI             RELEASE SI ENTRIES
         BAL,SR4  ASSIGN+2
GRPEXT1  LD,R6    TM:GO             IS THERE A GO IN A/M
         BAL,SR4  ASSIGN+1
         CI,R5    0
         BNE      GRPEXT2           YES
         LI,R1    %ROMFLG           NO - CREATE % DEFAULT
         STS,R1   J:TELFLGS         SET RETURN FLAG
         B        %ROM              THIS WILL RETURN %+1
GRPEXT2  BAL,SR4  WRITEAM           WRITE ASSIGN/MERGE
         LI,R5    DONTBIT           IS THE 'DONT' FLAG SET
         AND,R5   J:TELFLGS
         BNE      GIVEBIRD          IF SO, GIVE 'EM THE BIRD.
         LI,R5    X'10'             ALWAYS PROVICE SI OPTION
         OR,R5    AM:STDOP,R4       AND ASSIGNED OPTIONS FOR THIS STEP
         STW,R5   J:OPT
         BAL,R0   TELCCBUF          PLACE COMMAND IN J:CCBUF FOR USER
         LI,R1    -(BRKBIT+JSTEP+1) RESET BREAK & JSTEP FLAGS
         AND,R1   J:TELFLGS
         STW,R1   J:TELFLGS
         SLS,R4   17                RESET ARS YO ITS ORIGINAL VALUE
         LI,R5    -X'20000'         X'FFFE0000'
         STS,R4   ARS               (M:UC)
         PULL     16,R1             RESTORE REGS
         CD,R0    FDP               IF THE COMMAND WAS EITHER
         BE       NODEL             FDP OR DELTA, SKIP THE
         CD,R0    DELTA             SMALL SECTION OF CODE
         BE       NODEL
         LI,R0    FDPBIT            FDP FLAG BIT
         AND,R0   J:TELFLGS
         BEZ      NOFDP             BR. IF FDP BIT NOT SET
YESFDP   EQU      %                 SET UP DEBUGGER ASSOCIATION
         LD,R0    FDP1              DEBUGGER ASSO.
         B        XEXIT             SKIP DELTA ASSOCIATION
*
NOFDP    LI,R0    DELTABIT
         AND,R0   J:TELFLGS
         BEZ      NODEL             BR. IF DELTA BIT NOT SET
         LD,0     DELTA             YES
NODEL    RES      0
*                                   *  RELEASE DATA
XEXIT    RES      0
         DO       DBUG=0            ***NORMAL MODE***
         LI,R3    MUCRSET           RSET MOD,DRC & VFC BITS
         LS,R3    M:UC              BEFORE EXITING
         STW,R3   M:UC
         FIN
         LI,R3    0                                                  RL2
         CD,R6    LOGOFF            RESET RUN STATUS FOR ALL EXITS
         BE       YEXIT             EXCEPT LOGOFF
         LI,R4    JB:FRS
         STB,R3   0,R4
YEXIT    EQU      %
         BAL,D4   FREEBUF1          RELEASE OUR BUFFER
*
         LI,SR2   0                 INDICATE NON-COMMAND FILE EXIT
         CAL1,9   1                 INTERPRETIVE EXIT -- NAME IN R6
         PAGE
* THE FOLLOWING IS EXECUTED WHEN A MAJOR COMMAND(ONE REQUIRERING THE
* LOAD AND EXECUTION OF AN OUTSIDE PROCESSOR) IS RECEIVED OUTSIDE OF A
* JOB STEP. THIS IMPLIES THE ABORTION OF THE PREVIOUS JOB STEP AND
* REPLACING IT WITH THE CURRENT ONE.
*
INBREAK  EQU      %
         CW,R6    DELTA             IS THIS A REQUEST FOR DELTA
         BE       GROUP2C
         LI,R5    CCBUFBIT          SET IMAGE BUFFER CONTROL TO RETAIN
         STS,R5   J:TELFLGS         CURRENT MESSAGE AND RE-PROCESS
         BAL,0    TELCCBUF
         LI,R5    X'1FFFF'
         CW,R5    J:EXTENT          EX CON SPECIFIED?
         BANZ     QUIT              YES, FORCE EXIT
INBREAK1 EQU      %
         LI,5     0
         STB,R5   J:ABC             ABORTED PREVIOUS PROCESS
XABORT   RES      0
         BAL,D4   FREEBUF1          RELEASE OUR BUFFER
         CAL1,9   3                 ABORT
         PAGE
*
* QUIT COMMAND COMES HERE.
*
QUIT     LI,R5    JSTEP             WE MUST BE IN A BREAK CONDITION
         LS,R5    J:TELFLGS
         BNEZ     SYN1
*  INTERPRET AS A 'GO' COMMAND IF EXIT CONTROL HAS
* BEEN ESTABLISHED AND NOT IN PROGRESS
*
         LI,R5    X'1FFFF'
         CW,R5    J:EXTENT
         BAZ      INBREAK1
         LB,R5    J:EXTENT
         CI,R5    X'20'
         BANZ     INBREAK1          IF IN PROGRESS, NO FAKE
         LI,R7    2                 FAKE IT,SET BIT 6
         OR,R5    R7
         STB,R5   J:EXTENT
         B        CONTINX
         TITLE    'PARSE COMPILE AND ASSEMBLE COMMANDS'
*
* THE FOLLOWING LOGIC PRESERVES THE INTEGRITY OF THE REGISTERS THAT WILL
* BE USED WHEN WE FINALLY EXIT AND LOAD THE DESIRED LMN. IT ALSO
* PROVIDES A COMMON EXIT FROM THE PARSING LOGIC.
*
PARSE    PUSH     15,R1             SAVE LOAD PARAMETERS
         CI,R1    0                 IS THERE MORE MESSAGE TO SCAN
         BNE      *D1               YES-ENTER CORRECT PROCESS
ENTPRG   EQU      %                 NO-PROVIDE COMMON EXIT
         PULL     15,R1
         B        GROUP2C
* THIS SECTION OF CODE IS DEDICATED TO THE BREAKDOWN OF THE INPUT STREAM
* AS IT PERTAINS TO THE COMPILE AND ASSEMBLE COMMAND VERBS. THERE IS A
* GREAT VARIETY OF FORM ASSOCIATED WITH THIS INPUT STREAM AND,
* CONSEQUENTLY, A GOOD DEAL OF LOGIC IS PROVIDED, NOT ALL OF WHICH NEED
* BE EXECUTED FOR A PARTICULAR BUFFER IMAGE. ENTRY TO THIS CODE MAY BE
* MADE ONLY IF AT LEAST ONE FIELD FOLLOWS THE COMMAND VERB.
*
PARSER   EQU      %
         BAL,SR4  READAM            GET ASSIGN/MERGE TABLE
         LW,R4    J:ABUF            AM BUFFER ADDRESS
TOPPARSE EQU      %
         STW,R2   SCNPTRSV          SAVE INP PTR FOR SYNTAX CHECKING
         BAL,SR3  GETFIELD
         BAL,0    STOPS,5
         CI,R7    0                 DIS WE GET SOME DATA
         BE       TESTEOM           NO
*
* AT THIS POINT, A DETERMINATION MUST BE MADE TO DETECT CERTAIN,
* RECOGNIZABLE ELEMENTS SUCH AS %, ME, OVER, OR ON. IF NONE OF THESE,
* THE FIELD IS ASSUMED TO BE A SIMPLE FID.
*
         CW,D1    DOLL              A % IS EXPLICILY ILLEGAL AS A FID
         BE       CHKULM            SYNTAX ERROR
         CW,D1    ME
         BE       DOME
         CW,D1    ON
         BE       DOON
         CW,D1    OVER
         BE       DOOVER
A1       EQU      %
         BAL,R5   GETACPAS
TESTSI   LI,R5    SISET             IS THIS THE FIRST SI ENTRY?
         LS,R5    J:TELFLGS
         BEZ      TESTSI2           YES
TESTSI1  LW,R2    SCNPTRSV          MULT SI NOT ALLOWED, SYNTAX ERROR
         AI,R2    -1
         B        CHKULM
*
* THIS FID MUST NOW BE SET IN THE ASSIGN/MERGE TABLES REPLACING ALL
* PREVIOUS M:SI ASSIGNMENTS.
*
TESTSI2  PUSH     R7
         LD,R6    TM:SI
         LW,R4    J:ABUF            CLEAR ASSIGN/MERGE AND FIND A
         BAL,SR4  ASSIGN            PLACE FOR THIS ENTRY(RETURNED IN R5)
         PULL R7
MGSI     BAL,SR4  FILENT            ENTER SI PLIST
         LI,R3    1                 BUT MAKE IT AN IN MODE FILE
         STW,R3   MODE-PLIST+3,R5
TESTEOM  LI,R5    %ROMFLG           ARE WE PROCESSING FOR DEFAULT GO?
         LS,R5    J:TELFLGS
         BNEZ     GRPEXT2           YES
         LI,R5    ONBIT+OVERBIT     HOW ABOUT AN OVER/ON CONDITION?
         LS,R5    J:TELFLGS
         BNEZ     %+3
         LI,R5    TOPPARSE
         B        %+2
         LI,R5    OPRSE
         CI,R1    0                 ANY MORE MESSAGE
         BLE      ENTPRG            NO
         LI,R3    MSGEBIT
         LS,R3    J:TELFLGS         TEST FOR TRAILING GARBAGE
         BNEZ     CHKULM            SYNTAX ERROR
         B        *R5
*
*
* PROCESS INVOKED WHEN 'ME' IS ENCOUNTERED AS A FID
*
DOME     LI,R5    SISET             HAS THERE BEEN AN SI YET?
         LS,R5    J:TELFLGS
         BEZ      DOME2             NO-GO CREATE ONE
         B        TESTSI1           YES, MULTIPLE SI NOT ALLOWED
DOME1    LCI      4                 CREATE ME OP LABL PLIST
         LM,D1    OPENME
         STM,D1   3,R5
         B        MGSI+3
DOME2    LW,R4    J:ABUF
         LD,R6    TM:SI
         BAL,SR4  ASSIGN
         LW,D1    AM:ORG,R4         OLD AVAIL HEAD
         AI,D1    7                 SIZE THIS ENTRY
         STW,D1   AM:ORG,R4         UPDATE HEAD
         B        DOME1
         TITLE    'PARSE OVER/ON PORTION OF COMMAND VERB'
DOON     LI,R3    ONBIT             SET 'ON' FLAG
         B        DOOVER1
DOOVER   CI,R7    4                 DOUBLECHECK OVER IMPLICATION
         BG       A1                ITS AN SI FID
         LI,R3    OVERBIT           SET 'OVER' FLAG
DOOVER1  EQU      %
         STS,R3   J:TELFLGS
         CI,R6    C','              DID ADVERB END WITH A COMMA
         BE       EXTDGO            ASSUME IMPLIED SPECIFICATION IF YES
OPRSE    BAL,SR3  GETFIELD
         CI,R7    0                 INSURE WE GOT DATA
         BE       CHKULM            SYNTAX ERROR
         BAL,0    STOPS,R5
         LI,R5    PHSFLG            PHASING FLAG FOR GO OR LO
         CW,R5    J:TELFLGS
         BANZ     DOLO              SET = PROCESS FOR LO
         STS,R5   J:TELFLGS         OTHERWISE, FLIP TO DO LO NEXT
         CW,D1    DOLL              TEST FOR % ROM SPECIFICATION
         BE       %ROM
         CW,D1    ME                ME IS NOT ALLOWABLE FOR OUTPUT
         BNE      ROMDEV
         LW,R1    J:TELFLGS         IS IT
         CW,R1    UNKLMN            UNRECORNIZED LMN?
         BANZ     ENTPRG            IGNORE ERROR AND EXECUTE LMN
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=04                        *
*E*      DESCRIPTION:                                                  *
*E*               USER SPECIFIED ON OR OVER ME WHICH IS ILLEGAL        *
*E*               AS ROM NAME.                                         *
************************************************************************
         LI,D1    X'030104'         ERROR CODE & SUBCODE
         B        CMNERR1           TELL USER & PROMPT
*
ROM%BLT  EQU      %
         LW,D4    J:TELFLGS         IS THIS AN UNRECNIZED LMN?
         CW,D4    UNKLMN
         BANZ     ROM%BLT5
         CW,D1    LP                LP IS NON-ALLOWED IN THIS POSITION
         BE       CHKULM            SYNTAX ERROR
ROM%BLT5 EQU      %
         LI,D4    FIPROC            WAS FID ALREADY...
         CW,D4    J:TELFLGS         ...PROCESSED?
         BANZ     ROM%BLT1          YES
         LCI      2                 CREATE COMPLETE FID FROM INPUT DATA
         LM,SR2   J:ACCN            PUT LOG-ON ACCOUNT IN SR2,SR3
         LI,R7    0                 NO PASSWORD IS ASSUMED IN R7, SR1
         LI,SR1   0
ROM%BLT1 LW,R4    J:ABUF
         LI,R5    ONBIT             WAS 'ON' SPECIFIED?
         LS,R5    J:TELFLGS
         BEZ      ROMGO             NO
         LI,R5    %ROMFLG           IS BUILD % DEFAULT
         LS,R5    J:TELFLGS            SPECIFIED
         BNEZ     ROMGO             YES
         BAL,SR4  FLOP              CHECK IF FILE ALREADY EXISTS
         CI,R0    0
         BE       ONERR             FILE EXISTS, ON ILLEGAL
ROMGO    EQU      %
         PUSH     R7
         LD,R6    TM:GO             RELEASE ANY PREVIOUS GO ENTRIES AS
         BAL,SR4  ASSIGN            THIS IS A NEW SPECIFICATION.
         PULL     R7
         BAL,SR4  FILENT            FILL FILE DATA INTO ASSIGN ENTRY
ROMGO1   LI,R5    -2                RESET FILE
         AND,R5   FEXTIMG           EXTENSION FOR
         STW,R5   FEXTIMG           M:GO.
         LI,R5    X'80'
         B        LOFINS
         PAGE
*
* CHKS FOR LDEV,CP OR NO. IF FOUND BUILDS
* DEVICE PLIST FOR M:GO. OTHERWISE RETURNS TO
* ROM%BLT AND PROCESSES FOR FID.
*
*
ROMDEV   EQU      %
         CI,R7    2                 CHK SIZE OF FIELD
         BNE      ROM%BLT           DOESN'T QUALIFY
         LW,R5    D1
         SAS,R5   -16
         LI,R7    SV:LSIZ
         CH,R5    SH:LNM,R7         IS IT STRM ID?
         BE       ROMDEV1
         BDR,R7   %-2
         AND,R5   M16
         CI,R5    'CP'              CARD PUNCH?
         BE       ROMDEV1
         CI,R5    'NO'
         BNE      ROM%BLT           GO PROCESS FOR FID
ROMDEV1  LI,R5    OVERBIT           CHECK OVER FLAG &
         LS,R5    J:TELFLGS            DON'T ALLOW
         BNEZ     CHKULM                FOR DEVICES.
         LW,R4    J:ABUF            GET ADR OF A/M REC
         LD,R6    TM:GO
         BAL,SR4  ASSIGN            REL PREV ENTRIES
         LW,R7    AM:ORG,R4         OLD FREE HEAD
         AI,R7    7                 SIZE THIS ENTRY
         STW,R7   AM:ORG,R4         NEW FREE HEAD
         LCI      4
         LM,R7    OPENME            DEV PLIST
         STW,D1   SR3               STORE DEV IN PLIST
         SLS,SR3  -16
         LCI      4
         STM,R7   3,R5              PLACE PLIST IN A/M REC.
         B        ROMGO1
         PAGE
*
* CREATE A %ROM FILE ENTRY IN THE ASSIGN/MERGE AND RELEASE ANY PREVIOUS
* ENTRIES FOR THE GO DCB. ANY PREVIOUS %ROM FILES WILL ALSO BE RELEASED.
*
%ROM     EQU      %
         LI,5     C'G'
         BAL,SR4  NAME%
         STW,5    D1
         LW,D2    VERB1
         LW,D3    VERB1
         LCI      2
         LM,SR2   J:ACCN
         LI,7     0
         LI,SR1   0
         B        ROM%BLT1
*
* PERFORM NECESSARY FUNCTIONS WHEN A FIELD HAS BEEN IMPLIED.
*
EXTDGO   RES      0
         LI,R5    PHSFLG            INSURE PHASE FLAG IS SET
         STS,R5   J:TELFLGS
         LI,R5    X'80'
         B        LOFINS
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=12                        *
*E*      DESCRIPTION:                                                  *
*E*               USER SAID 'ON'   A FILE WHICH ALREADY EXISTS.        *
*E*               FILE NAME IS INSERTED BEFORE TYPING THE ERROR        *
*E*               MESSAGE.                                             *
************************************************************************
ONERR    EQU      %
         LCI      3                 SAVE FILE
         STM,D1   R5                   NAME IN R5-R7
         LI,D1    X'030112'         ERROR CODE & SUBCODE
         BAL,SR4  T%ERRTXT          GET  MSG
         LCI      3                 STORE FILE NAME
         STM,R5   2,R1                 IN MESSAGE
         LI,R0    SYN1              SIMULATE BAL
         B        T%WRTERR          WRITE MSG & RETURN BUFFER
*
*
* PROCESS FOR LIST SPECIFICATION.
*
DOLO     EQU      %
         CI,R7    2                 POSSIBLE STRM OR DEV?
         BNE      DOLO1             NO
         LW,R5    D1
         SAS,R5   -16
         LI,R7    SV:LSIZ
         CH,R5    SH:LNM,R7
         BE       LOME              FOUND DEV STREAM
         BDR,R7   %-2
         CW,D1    ME                TEST FOR VARIATIONS
         BE       LOME
         CW,D1    LP
         BE       LOME
         CW,D1    NO
         BE       LOME
DOLO1    CW,D1    DOLL              A % IS ILLEGAL IN THIS POSITION
         BE       CHKULM            SYNTAX ERROR
         LI,D4    FIPROC            WAS A COMPLEX FID..
         CW,D4    J:TELFLGS         ...ALREADY PROCESSED?
         BANZ     LOBLT             YES
         LCI      2                 CREATE A COMPLETE FID
         LM,SR2   J:ACCN            USING LOG-ON ACCOUNT
         LI,R7    0                 NO PASSWORD IS THE ASSUMPTION
         LI,SR1   0
LOBLT    LI,R5    ONBIT             WAS 'ON' SPECIFIED
         LS,R5    J:TELFLGS
         BEZ      LOMGO             NO
         BAL,SR4  FLOP              CHECK FOR UNIQUE FILE
         CI,R0    0
         BE       ONERR             FILE EXISTS, ON ILLEGAL
LOMGO    LI,R5    COMFLG            TEST FOR COMMENT COMMAND
         LS,R5    J:TELFLGS
         BNEZ     DOBLT
         LW,R4    J:ABUF
         PUSH     R7
         LD,R6    TM:LO             ANY PREVIOUS ENTRIES ARE RELEASED AS
         BAL,SR4  ASSIGN            THIS IS A NEW SPECIFICATION.
         PULL     R7
         BAL,SR4  FILENT            ENTER THE FILE DATA
LOSETUP  EQU      %
         LI,R5    -5                RESET FILE
         AND,R5   FEXTIMG           EXTENSION FOR
         STW,R5   FEXTIMG           M:LO.
         LI,R5    MSGEBIT           SET END OF MSG FLAG
         STS,R5   J:TELFLGS
         LI,R5    1                 SET LO SPEC IN OPTIONS
LOFINS   EQU      %
         STS,R5   AM:STDOP,R4
         LI,R5    LOFLG             HAVE WE BEEN PROCESSING A LIST CMD
         LS,R5    J:TELFLGS
         BEZ      TESTEOM           NO
         CI,R1    0                 INSURE NO TRAILING JAZZ
         BG       CHKULM
         BAL,SR4  WRITEAM           WRITE A/M
         B        PROMPT            YES-GO FOR NEXT MESSAGE
DOBLT    EQU      %
         LW,R4    J:ABUF
         PUSH     R7
         LD,R6    TM:DO             MAKE ENTRY FOR DO DCB
         BAL,SR4  ASSIGN
         PULL     R7
         BAL,SR4  FILENT
LAS      LI,R5    X'FFFEF'          RESET FILE
         AND,R5   FEXTIMG           EXTENSION FOR
         STW,R5   FEXTIMG           M:DO.
         LI,R5    X'100'            SET DO IN OPTIONS
         B        LOFINS
*
* CREATE ME OR LP OPLABEL AND MERGE INTO DCB.
*
LOME     LI,R5    COMFLG            DETERMINE IF LO OR DO
         LS,R5    J:TELFLGS
         BNEZ     LOME3
         LW,R4    J:ABUF            CREATE NEW LO ASSIGN ENTRY
         LD,R6    TM:LO
         BAL,SR4  ASSIGN            ADDRESS RETURNED IN R5
         LW,R7    AM:ORG,R4         OLD FREE HEAD
         AI,R7    7                 SIZE THIS ENTRY
         STW,R7   AM:ORG,R4         NEW HEAD
         LCI      4
         LM,R7    OPENME
         CW,D1    ME
         BE       %+3
         STW,D1   SR3
         SLS,SR3  -16
         LCI      4
         STM,R7   3,R5
         B        LOSETUP           GO SET BITS FOR LO
LOME3    LW,R4    J:ABUF
         LD,R6    TM:DO             CREATE NEW DO ASSIGN ENTRY AS WAS
         BAL,SR4  ASSIGN            DONE FOR LO
         LW,R7    AM:ORG,R4         OLD FREE HEAD
         AI,R7    7                 SIZE THIS ENTRY
         STW,R7   AM:ORG,R4         NEW FREE HEAD
         LCI      4
         LM,R7    OPENME
         CW,D1    ME
         BE       %+3
         STW,D1   SR3
         SLS,SR3  -16
         LCI      4
         STM,R7   3,R5
         B        LAS               COMPLETE THE PROCESS
*
* DETERMINES IF UNRECOGNIZED LOAD MODULE (NOT FORTRAN OR META). IF SET,
*TERMINATE SCAN,IGNORE ERROR AND EXECUTE LOAD MODULE.
*
CHKULM   EQU      %
         PUSH     R1
         LW,R1    J:TELFLGS         IS THIS AN UNRECNIZED LMN?
         CW,R1    UNKLMN
         BAZ      SYNTAX            NO, PUT OUT SYNTAX ERROR MSGE.
         PULL     R1                YES, EXIT AND EXECUTE LMN
         B        ENTPRG
         PAGE
*
* UNDER DELTA SHORT (&ONLY) FORM COMMAND VERB
*
UDELT    EQU      %
         CI,R1    1                 IF U IS SPECIFIED, "UNDER DELTA"
         BG       SYNTAX            IS IMPLIED FOR THE NEXT COMMAND.
         LW,D2    UDELTFLG
         STS,D2   J:TELFLGS         SET UNDER DELTA FOR NEXT COMMAND
         B        PROMPT            FLAG
         TITLE    'DEBUG COMMAND VERB'
DEBUG    EQU      %                 FIELD AFTER DEBUG?
         CI,R7    5                 YES - SYNTAX ERROR
         BG       SYNTAX
         BAL,SR4  READAM            (NOP IF A/M IN CORE)
         LW,R4    J:ABUF
         LI,R3    DONTBIT           DONT PREFIX ?
         LS,R3    J:TELFLGS         YES - BR.
         BNEZ     DEBUG1
         LI,D2    X'10000'          SET DEBUG MODE ON
         STS,D2   AM:STDOP,R4
         B        DEBUG2
DEBUG1   EQU      %                 RESET DEBUG MODE OFF
         LI,R3    X'EFFFF'
         AND,R3   AM:STDOP,R4
         STW,R3   AM:STDOP,R4
DEBUG2   BAL,SR4  WRITEAM
         B        PROMPT
         TITLE    'OUTPUT COMMAND VERB'
OUTPUT   LI,R4    0                 SET COMMAND INDEX
         B        LISTCOM
*
*                 COMMENT COMMAND VERB
*
COMMENT  LI,R3    COMFLG+PHSFLG     FLIP PHASE TO LO & SET CMD UNIQUE
         STS,R3   J:TELFLGS
         LI,R4    2                 SET COMMAND INDEX FOR COMMENT
         B        LISTCOM
*
* THIS LOGIC HANDLES THE ADVERB DONT BY SETTING A SPECIAL FLAG AND
* CONTINUING THE COMMAND INTERPRETATION. THE FLAG IS CHECKED ONLY IN
* THE COMMAND PROCESS WHERE IT HAS MEANING.
*
DONT     EQU      %
         LI,R3    DONTBIT
         STS,R3   J:TELFLGS         SET DONT FLAG IN TELFLGS
************************************************************************
*E*      ERROR:   GROUP 3, CODE = 01-16                                *
*E*      DESCRIPTION:     THE USER SAID 'DONT'  WITHOUT SPECIFIYING    *
*E*               THE VERB OR WITH AN ILLEGAL COMMAND, SO WE GIVE      *
*E*               'EM THE BIRD (SIC).                                  *
************************************************************************
         CI,R1    0                 ANY UN-SCANNED CHARACTERS
         BG       NEXTTIME
GIVEBIRD LI,D1    X'030116'         ERROR CODE & SUBCODE
         B        CMNERR1           TELL USER...
*
OPTAB    DATA,2   X'80',X'01'
         DATA,2   X'100',X'0'
NOPTAB   DATA     X'FFFFFF7F'
         DATA     X'FFFFFFFE'
         DATA     X'FFFFFEFF'
         TITLE    'LIST COMMAND VERB'
LIST     LI,R3    PHSFLG            FLIP THE PHASE TO LO
         STS,R3   J:TELFLGS
         LI,R4    1                 SET COMMAND INDEX FOR LIST
*
* THE FOLLOWING IS COMMON CODE USED BY THE LIST, OUTPUT AND COMMENT
* COMMAND VERBS. R4 MUST CONTAIN AN INDEX UNIQUE TO THE COMMAND.
*
LISTCOM  CI,R1    0                 TEST FOR FOLLOWING MODIFIER
         BE       LIST1             NO DATA-IMPLIES FUNCTION CHANGE
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=00                        *
*E*      DESCRIPTION:                                                  *
*E*               USER ISSUED LIST, COMMENT OR OUTPUT COMMAND          *
*E*               WITH IMPLIED ASSIGNMENT CHANGE, E.G. LIST ON         *
*E*               DC/ABC, WHEN NOT AT JOB STEP.  THIS IS ILLEGAL AND   *
*E*               WE TYPE A MESSAGE AND PROMPT.                        *
************************************************************************
         LI,R3    JSTEP             PRE-ASSIGN CAN ONLY BE DONE
         LS,R3    J:TELFLGS         AT JOB STEP
         BEZ      NTJBST            COMMAND ILLEGAL UNLESS JOB STEP TIME
*
         LW,D1    VERB1
         LI,R3    D1
         BAL,SR3  SCAN              OBTAIN MODIFIER
         LI,R3    LOFLG             SET LIST CMD FLAG
         STS,R3   J:TELFLGS
         BAL,SR4  READAM            NO-READ IT IN
         LW,R4    J:ABUF            AM BUFFER ADDRESS
         CW,D1    ON                IS MODIFIER ON
         BE       DOON              YES-ENTER COMMON CODE
         CW,D1    OVER              HOW ABOUT OVER
         BNE      SYNTAX            NO-ERROR
         CI,R7    4                 MUST BE FOUR CHARACTERS
         BE       DOOVER
         B        SYNTAX            NEITHER ONE IS AN ERROR
LIST1    LI,R3    JSTEP             ARE WE AT JOB STEP OR BREAK
         LI,R5    J:OPT
         LS,R3 J:TELFLGS
         BNEZ     LIST4             JOB STEP
LIST2    LI,R3    DONTBIT
         LS,R3    J:TELFLGS         TEST FOR DONT ADVERB
         BNEZ     LIST3             IT HAS BEEN GIVEN
         LH,R3    OPTAB,R4
         STS,R3   *R5
         B        LIST5
LIST3    LW,R3    NOPTAB,R4         TURN OFF OPTION
         AND,R3   *R5
         STW,R3   *R5
LIST5    BAL,SR4  WRITEAM
         B        PROMPT
LIST4    BAL,SR4  READAM            NOP IF ALREADY IN
         LW,R5    J:ABUF
         AI,R5    AM:STDOP
         B        LIST2
         TITLE    'START COMMAND'
START    CI,R1    1                 IS THERE MORE MSG
         BLE      START4
         BAL,SR3  GETFIELD          GET NEXT FIELD
         CD,D1    UNDER             CHK IF FORM OF 'START UNDER LMN'
         BE       START8
         CI,R6    '.'               CHECK COMPLEX FID
         BNE      START5-2
         BAL,SR4  FID               BRAEK FID
START1A  PUSH     2,SR2
         PUSH     2,R7
         BAL,SR3  NFND              MAKE NAME TEXTC
         PULL     2,SR3
         PULL     2,D2
START2   LI,D1    0
         LI,R5    STRTBIT           SET BIT FOR SYSERR IN CASE FETCH
         STS,R5   J:TELFLGS         DOESN'T FIND IT.
         CI,R1    1                 TEST FURTHER MESSAGE
         BLE      GROUP2B           NO MORE
         PUSH     9,R6              SAVE LOAD DATA
         LD,D1    VERB2
         BAL,SR3  SCAN              NEXT FILD CAN ONLY BE 'UNDER'
         CI,R7    1                 CHECK FOR SINGLE CHAR "UNDER DELTA"
         BNE START70                REQUEST. B IF NO
         CI,R1    1                 NO MORE ALLOWED
         BG       SYNTAX
         LI,SR3   'U'               WAS IT 'U' FOR "UNDER DELTA"
         CB,SR3   D1
         BE       START75           B IF YES
START70  EQU      %
         CD,D1    UNDER
         BNE      SYNTAX
START7   RES      0
         LD,D1    VERB2
         BAL,SR3  SCAN
         CI,R1    1
         BG       SYNTAX
         CD,D1    DELTA1            IS IT DELTA OR FDP
         BNE      START3
START75  EQU      %
         LI,R3    DELTABIT          SET DELTA FLAG
         STS,R3   J:TELFLGS
         PULL     9,R6
         B        START2
START3   CD,D1    FDP1
         BNE      SYNTAX
         LI,R3    FDPBIT
         STS,R3   J:TELFLGS
         PULL     9,R6
         B        START2
START4   RES      0
         BAL,R0   START9
         B        START2
         CW,D1    DOLL              CHECK FOR % FILE
         BE       START6
START5   LCI      2
         LM,SR2   J:ACCN
         LI,R7    0
         LI,SR1   0
         B        START1A
START6   LI,R6    X'30000'          BYTE COUNT FOR IDL
         LI,R7    X'FFFF'           MASK TO GET SYSID
         LS,R6    J:JIT             GET SYSID
         SLS,R6   8                 POSITION
         AI,R6    'L'               R6 = TEXTC IDL
         LCI      2
         LM,D2    J:ACCN
         B        START2
START8   RES      0
         CI,R1    1                 MORE INFO MUST  FOLLOW
         BLE      STARTERR
         BAL,R0   START9
         LI,R5    STRTBIT
         STS,R5   J:TELFLGS
         PUSH     9,R6
         B        START7
*
*
START9   RES      0
         LCI      3
         LM,R6    J:LMN             INSURE A LMN  EXISTS
         CI,R6    0
         BE       STARTERR
         LCI      2
         LM,D2    J:ACCN
         LI,SR3   0                 PASS. FOR LINK LM ALWAYS=0
         LI,SR4   0
         B        *R0
         TITLE    'CONTINUE COMMAND VERB'
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=14                        *
*E*      DESCRIPTION:                                                  *
*E*               USER SAID CONTINUE (GO) WHILE AT JOB STEP.           *
*E*               THERE IS NO PROGRAM TO GO BACK TO.                   *
************************************************************************
CONTINUE LI,R3    JSTEP             ARE WE AT A JOB STEP?
         LS,R3    J:TELFLGS
         BEZ      CONTINX           NOT AT STEP, O.K.....
         LI,D1    X'030114'         ERROR CODE & SUBCODE
         B        CMNERR1           TELL USER
*
CONTINX  RES      0
         LW,9     J:ABUF
         BEZ      %+2
         CAL1,8   FPFPT             RELEASE AM BUFFER PAGE
         LI,R6    0                 SET UP RETURN EXIT
         STW,6    J:ABUF            CLEAR ABUF FLAG
         LI,R7    0
         DO1      DBUG=1            DEBUG MODE
         B        TEL               TEMP             *****
         B        XEXIT
         TITLE    'FDP  VERB  SETUP'
*
FDPSET   RES      0
         LD,R6    FDP
         LD,R0    FDP
         LI,D1    0
         B        GROUP2
         TITLE    'DELTA  VERB  SETUP'
*
DELTASET RES      0
         LD,R6    DELTA
         LD,R0    DELTA
         LI,D1    0
         B        GROUP2
         TITLE    'TP COMMAND VERB'
************************************************************************
*F*      NAME:    TP                                                   *
*F*      PURPOSE:      THE TP COMMAND IS A SPECIAL FORM OF 'OFF'       *
*F*               WHICH TELLS THE SYSTEM TO LOG THIS USER OFF          *
*F*               TIMESHARING AND MAKE THE LINE AVAILABLE AS A TP      *
*F*               LINE.                                                *
*F*      DESCRIPTION:     THE FOLLOWING TESTS ARE MADE BEFORE PROCESSIN*
*F*               THE COMMAND:                                         *
*F*                    1. THE SYSTEM MUST BE SYSGENED FOR TP           *
*F*                    2. TPG (THE TP GHOST) MUST BE ACTIVE            *
*F*               IF THESE CONDITIONS ARE SATISFIED, WE WILL PERFORM   *
*F*               THE SPECIAL LOGOFF.  OTHERWISE, AN ERROR MESSAGE     *
*F*               IS GENERATED AND THE USER REMAINS IN TEL             *
************************************************************************
TP       EQU      %
************************************************************************
*E*      ERROR:   GRP 03,  0C-01                                       *
*E*      DESCRIPTION:    THE USER ISSUED THE TP COMMAND AND THE        *
*E*               SYSTEM IS NOT SYSGENED FOR TP.                       *
************************************************************************
         LI,D1    TTP               SREF, WILL BE ZERO
         BNEZ     %+3               IF OPTION NOT GEN'ED.
         LI,D1    X'030C01'         ERROR CODE
         B        CMNERR1
*
************************************************************************
*E*      ERROR:   GRP 03, 0C-02                                        *
*E*      DESCRIPTION:     M:GETID RETURNED CC1 SET, INDICATING TPG     *
*E*               IS NOT ACTIVE.                                       *
************************************************************************
         CAL1,7   GETID             TPG IS ACTIVE IF
         BCR,8    %+3               CC1 IS NOT SET.
         LI,D1    X'030C02'         ERROR CODE
         B        CMNERR1
*
         LW,D4    TPFLG             SET TP FLAG FOR
         STS,D4   J:TELFLGS         STEP.
************************************************************************
*E*      ERROR:   GRP 03, 0C-03                                        *
*E*      DESCRIPTION:     THIS IS AN INFORMATION-ONLY MESSAGE TO       *
*E*               LET THE USER KNOW HE HAS PASSED THE TESTS FOR TP     *
*E*               IT WILL BE FOLLOWED BY THE STANDARD ACCOUNTING       *
*E*               LINE NORMALLY SEEN AT LOGOFF.                        *
************************************************************************
         LI,D1    X'030C03'         ERRMSG KEY
         BAL,R0   T%ERR             PRINT MESSAGE
*
         LI,D1    0                 TO STOP SCAN.
         LD,R6    LOGOFF            SET UP FOR EXIT
         B        GROUP2            TO LOGOFF.
         TITLE    'PASSWORD COMMAND VERB'
************************************************************************
*F*      NAME:    PASSWORD                                             *
*F*      PURPOSE:     THE PASSWORD COMMAND IS USED BY THE TERMINAL     *
*F*               USER TO CHANGE HIS LOGON PASSWORD.  SECURITY IS      *
*F*               ADDITIONALLY ENFORCED BY REQUIRING THE OLD PASSWORD  *
*F*               TO BE SUPPLIED BEFORE THE NEW ONE IS ENTERED.        *
*F*      DESCRIPTION:     THE :USERS RECORD IS READ IN AND THE FIRST   *
*F*               FIELD SUPPLIED BY THE USER IS COMPARED WITH THE      *
*F*               CURRENT PASSWORD. IF IT MATCHES, THE SECOND FIELD    *
*F*               IS STORED AND THE :USERS RECORD IS WRITTEN OUT.  IF  *
*F*               THE PASSWORD SCRAMBLER IS INCLUDED IN THE SYSTEM IT  *
*F*               IS INVOKED.                                          *
************************************************************************
PASSWORD EQU      %
         STW,R1   SETBUF            SAVE REGS FOR SCAN
         STW,R2   SETBUF+1
         LI,R2    4                 FOR OPEN INOUT
         BAL,R0   RD:USERS          READ USER RECORD INTO TELSTACK
         PUSH     R3                SAVE BUFFER ADDRESS
         LW,R1    SETBUF            RESTORE SCAN'S REGS
         LW,R2    SETBUF+1
         BAL,SR3  GETFIELD          SCAN FOR OLD PASSWORD
************************************************************************
*E*      ERROR:   GROUP 03, CODE=05, SUBCODE=07                        *
*E*      DESCRIPTION:    THE FIRST FIELD OF THE PASSWORD COMMAND DIDN'T*
*E*               END WITH A COMMA.  THIS PROBABLY MEANS THAT THE USER *
*E*               IS NOT AWARE OF THE NEW (WITH D00) FORMAT OF THE     *
*E*               PASSWORD COMMAND.  HE MUST SUPPLY OLD,NEW PASSWORD   *
************************************************************************
         CI,R6    ','               WILL NEW PASSWORD FOLLOW?
         BE       %+4               YES...
         LI,D1    X'030507'         NO, ERROR CODE & SUBCODE
         PULL     R3                RESTORE BUFFER POINTER
         B        PASSCLUP          GO TELL USER & CLEANUP
         BAL,SR4  SCRAMBLE          NO, SCRAMBLE OLD FOR COMPARE
         PULL     R3                RESTORE BUFFER ADDRESS
************************************************************************
*E*      ERROR:   GROUP 03, CODE=05, SUBCODE=05                        *
*E*      DESCRIPTION:     THE 'OLD' PASSWORD SUPPLIED BY THE           *
*E*               USER DOESN'T MATCH THE CURRENT :USERS RECORD.        *
************************************************************************
         CW,D1    6,R3              DOES FIRST WORD MATCH?
         BNE      %+3               NO,ERROR
         CW,D2    7,R3              HOW ABOUT SECOND WORD?
         BE       %+3               MATCHES O.K.
         LI,D1    X'030505'         ERROR CODE & SUBCODE
         B        PASSCLUP          NO MATCHEE, NO CHANGEE
*
*  NOW SCAN FOR NEW PASSWORD
         PUSH     R3                SAVE BUFFER PTR
         BAL,SR3  GETFIELD          SCAN FOR NEW PASSWORD
************************************************************************
*E*      ERROR:   GROUP 03, CODE=05, SUBCODE=06                        *
*E*      DESCRIPTION:     THE PASSWORD IS GREATER THAN 8 CHARACTERS    *
************************************************************************
         CI,R7    8                 LEGAL SIZE?
         BLE      %+4               YES
         PULL     R3                TO EVEN UP STACK
         LI,D1    X'030506'         NO, ERROR CODE & SUBCODE
         B        PASSCLUP          CLEAN UP & TELL USER
*
         BAL,SR4  SCRAMBLE          SCRAMBLE NEW PASSWORD
         PULL     R3
WR:USERS STW,D1   6,R3              STORE NEW PASSWORD
         STW,D2   7,R3
         LCI      2                 REPLACE WORDS 0 & 1
         LM,R1    WUSR                OF READ FPT FOR WRITE
         STM,R1   LOGSIZE,R3           WITH DEFAULT KEY.
         LI,SR3   0                 CLEAR SR3 BEFORE WRITE
         CAL1,1   LOGSIZE,R3        WRITE :USERS RECORD BACK
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=05, SUBCODE=03                        *
*E*      DESCRIPTION:                                                  *
*E*               WRITE ERROR OF SOME SORT OCCURRED WHILE              *
*E*               TRYING TO WRITE :USERS RECORD BACK. ABORT,           *
*E*               PRESUMING CURRENT RECORD UNALTERED.                  *
************************************************************************
         CI,SR3   0
         BE       %+3               NO ERRORS ON WRITE
         LI,D1    X'030503'         ERROR CODE & SUBCODE
         B        R:UERR            RSET STACK & GO TO CMNERR1
*
************************************************************************
*E*      ERROR:   GROUP 03, CODE=05, SUBCODE=04                        *
*E*      DESCRIPTION:     THIS IS NOT AN ERROR CONDITION.  IT IS AN    *
*E*               INFORMATION-ONLY MESSAGE TO INDICATE SUCCESSFUL      *
*E*               COMPLETION OF PASSWORD CHANGE.                       *
************************************************************************
         LI,D1    X'030504'         ERRMSG KEY
*
*  THIS IS COMMON POINT TO CLEAN UP W/ ERROR MSG
PASSCLUP EQU      %
         BAL,R4   FMTELCL           CLOSE M:TEL
         LCI      2                 BLANK OUT PASSWORD WHEREVER IT
         LM,D2    VERB2             APPEARS IN CORE
         STM,D2   6,R3
         BUMP     -(LOGSIZE+RWUSRSZ),R5     CLEAN STACK
         LB,R2    JB:CCARS          LENGTH OF CMND
         AI,R2    -1
         LI,R1    TELBUF
         BAL,R4   BLANKBUF          BLANK COMMAND BUFFER
         LI,R0    PROMPT            RETURN FOR T%ERR
         B        T%ERR
OPERR    B        *SR1              ERROR RETURN VECTOR
         PAGE
************************************************************************
*D*      NAME:    SCRAMBLE                                             *
*D*      CALL:    BAL,SR3   SCRAMBLE                                   *
*D*      REGISTERS:     R3,R4,R6,R7,SR4 ARE CLOBBERED                  *
*D*      INPUT:   TEXT PASSWORD IN D1-D2                               *
*D*      DATA:    VERB2 - DWD OF BLANKS                                *
*D*      OUTPUT:  ENCODED PASSWORD IN D1-D2                            *
*D*      INTERFACE:     SCRAM - SREF'ED PASSWORD SCRAMBLER             *
*D*      DESCRIPTION:     IF INPUT IS NULL (BLANKS), RETURN            *
*D*               ZEROES.  OTHERWISE, CHECK FOR SCRAM INCLUDED. IF     *
*D*               PRESENT, SCRAMBLE PASSWORD.  OTHERWISE, EXIT.        *
************************************************************************
SCRAMBLE EQU      %
         PUSH     SR4               SAVE LINK
         PUSH     R2
         CD,D1    VERB2             IS INPUT NULL?
         BNE      %+4               NO
         LI,D1    0                 YES,
         LI,D2    0                   RETURN
         B        SCRAMBLX              ZEROES
         LI,R6    SCRAM             IS SCRAM INCLUDED?
         BEZ      SCRAMBLX          NO, RETURN
         BAL,SR4  SCRAM
         LD,D1    R6                ENCODED PASSWORD TO D1-D2
SCRAMBLX PULL     R2
         PULL     SR4
         B        *SR4              RETURN
         TITLE    'SHOW COMMAND'
* THE SHOW COMMAND READS THE :USERS ENTRY FOR THIS USER
* AND MOVES IT TO A COMMON PAGE FOR THE SHOW PROCESSOR
* AFTER MOVING THE RECORD TO THE COMMON PAGE IT CALLS
* SHOW VIA AN INTERP EXIT. THE 'PASSWORD' CODE HAS BEEN
* GREATLY UTILIZED FOR THE READING OF THE :USERS FILE.
*
*
SHOW     EQU      %
         LI,R3    JSTEP             ARE WE GOING TO CLOBBER
         LS,R3    J:TELFLGS            THE USER'S PRGM W/ SHOW?
         BNEZ     %+3               NO, OK TO CALL SHOW
         CW,D4    IQUIT             YES, DID WE ASK QUIT?
         BNE      BKOPT0            NO, ASK IT...
         LI,R2    1                 SET READ MODE TO 'IN'
         BAL,R0   RD:USERS          READ IN :USERS RECORD
         BAL,R4   FMTELCL           CLOSE M:TEL
         LI,R4    0
         STW,R4   6,R3              ZERO PASSWORD
         STW,R4   7,R3                 FOR SECURITY
         CAL1,8   GCOMNPG           GET A COMMON PAGE
         BCS,8    SHOWXX            CANT GET PAGE
         LI,R4    LOGSIZE+1         SET UP COUNTER
         AI,R3    -1
         AI,SR2   -1
         LW,R2    *R3,R4            GET WORD FROM STACK
         STW,R2   *SR2,R4           & MOVE TO COMMON PAGE
         BDR,R4   %-2
         BUMP     -(LOGSIZE+RWUSRSZ),R5   CLEAN STACK
         LW,R1    SR2               GET COMMON PAGE ADDRESS
         AI,R1    1
         SLS,R1   2                 MAKE BYTE ADDRESS
         LD,R2    ADRTAB0           SH:RNM IN TEL DATA
         AW,R3    R1                ADD COMMON PAGE BYTE ADDRESS
         MBS,R2   0
         LI,R2    S:SYMDB           LOWEST ADDRESS
         LI,R3    S:SYMDO           HIGHEST ADDRESS
         BAL,SR4  CVM               MAP ON TO LOW CORE
         LI,SR1   ADRTAB1           TABLE OF TABLE MOVE (MBS) INFO
         LI,R7    2                 TWO ENTRIES IN ADRTAB1
         BAL,SR4  MOVTBLS           MOVE SYMDO - SYMDB TO COMMON PAGE
         LI,R2    SH:SYMT           LOWEST ADDRESS
         LI,R3    SL:ODF+SV:LIM     HIGHEST ADDRESS
         BAL,SR4  CVM               MAP ON TO LOW CORE
         LI,SR1   ADRTAB2           TABLE TWO OF MBS INFO
         LI,R7    6                 SIX ENTRIES IN ADRTAB2
         BAL,SR4  MOVTBLS           MOVE TABLES TO COMMON PAGE
         LI,R2    1                 SET FLAG SAYING DFLTS IN PAGE
CVMDONE  SLS,R1   -2                CONVERT TO WORD ADDRESS
         STW,R2   500,R1            SET FLAG
         B        SHOW1
************************************************************************
*        CVM - MAP ON TO DEFAULT TABLES IN LOW CORE
*           ENTER : R2 - LOWEST ADDRESS AND
*                   R3 - HIGHEST ADDRESS OF REQUESTED TABLES
*           EXIT :  R5 - WORD ADDRESS OF LOWEST REAL PAGE
*                   R6 - WORD ADDRESS OF LOWEST VIRTUAL PAGE
*                   SR3 - NUMBER OF PAGES
*                   SR2 - WORD ADDRESS OF HIGHEST VIR. PAGE +X'200'
**************************************************************************
CVM      LI,D1    X'1FE00'          MASK FOR PAGE ADDRESS
         AND,R2   D1                GET THE ADDRESSES OF THE PAGES
         AND,R3   D1                CONTAINING HIGH AND LOW ADDRESSES
         SW,R3    R2                CALCULATE THE
         SLS,R3   -9                NUMBER OF PAGES
         AI,R3    1                 TO MAP ON TO
         LI,SR2   X'1FC00'
         LW,R6    SR2               SET UP R6 - VIRTUAL PAGE BASE
         LW,R5    R2                R5 - REAL PAGE BASE
         LW,SR3   R3                R10 - NUMBER OF PAGES
         CAL1,8   CVMCAL            DO THE MAP
         BCS,8    NOCVM             NO GO - NO DFLTS IN COMMON PAGE
         AI,R2    X'200'            INCREMENT PAGES
         AI,SR2   X'200'            UTIL WE GOT
         BDR,R3   %-4               WHAT WE NEED
         B        *SR4              RETURN
NOCVM    LI,R2    0                 SET FLAG - NO DEFAULTS IN COM. PG.
         B        CVMDONE           GET OUT
CVMCAL   GEN,8,24 X'87',R2
         DATA     X'80000009'
**********************************************************************
*        MOVTBLS - MOVE DEFAULT TABLES TO COMMON PAGE - RELEASE CVM PAGES
*           ENTER : SR1 - ADDRESS OF MBS INFO. DOUBLEWORD TABLE
*                   R7 - NUMBER OF TABLE ENTRIES
*                   R5 - ADDRESS OF LOWEST REAL PAGE
*                   R6 - ADDESS OF LOWEST VIRTUAL PAGE
*                   SR2 - ADDRESS OF HIGHEST VIRTUAL PAGE + X'200'
**********************************************************************
MOVTBLS  LD,R2    *SR1,R7           GET ADDRESS - BYTE COUNT - DISP.
         SW,R2    R5                SUBTRACT ADDRESS OF LOW REAL PAGE
         AW,R2    R6                ADD ADDRESS OF LOW VIRTUAL PAGE
         AW,R3    R1                ADD COM. PG. BYTE ADR. TO DISP.
         SLS,R2   2                 CONVERT TO BYTE ADDRESS
         MBS,R2   0                 MOVE THE TABLE
         BDR,R7   MOVTBLS           MOVE THE NEXT ONE
         AI,SR2   -X'200'           GET ADD OF HIGHEST PAGE
         CAL1,8   FREVPGS           AND RELEASE IT
         BDR,SR3  %-2               AND ANY LOWER ONES
         B        *SR4              RETURN
FREVPGS  DATA     X'85000009'
*
* SH:RNM IS IN TEL DATA - NO CVM NEEDED
         BOUND    8
ADRTAB0  EQU      %
         DATA     BA(SH:RNM)
         GEN,8,24 (SV:RSIZ+1+SV:RSIZ+1),428*4
*
*ADRTAB1 AND ADRTAB2 - THESE ARE DOUBLEWORD TABLES CONTAINING THE
*INFORMATION NEEDED TO MOVE THE DEFAULT TABLES TO THE COMMON PAGE
*THE FORMAT IS:
*          WORD 0 - ADDRESS OF THE TABLE IN LOW CORE
*          WORD 1 - BYTE 0 - TABLE LENGTH IN BYTES
*                 - BYTE 3 - BYTE DISPLACEMENT OF TABLE IN COMMON PAGE
*
* NOTE: THESE TABLES SPLIT THE NEEDED TABLES INTO TWO GROUPS BASED ON
* THEIR ADDRESSES IN LOW CORE. THE CURRENT ASSUMPTION IS THAT S:SYMDO
* AND S:SYMDB ARE NOT LOCATED NEAR THE OTHER TABLES WHICH ARE ALL
* RELATIVELY CLOSE IN ADDRESS. A SECOND ASSUMPTION IS THAT S:SYMDO
* HAS A HIGHER ADDRESS THAN S:SYMDB AND THAT OF THE OTHER GROUP
* SH:SYMT HAS THE LOWEST AND SL:ODF THE HIGHEST ADDRESS.
ADRTAB1  EQU      %-2
         DATA     S:SYMDB
         GEN,8,24 4,410*4
         DATA     S:SYMDO
         GEN,8,24 4,411*4
ADRTAB2  EQU      %-2
         DATA     SB:RBMX
         GEN,8,24 (SV:RSIZ+1),420*4
         DATA     SB:RODF
         GEN,8,24 (SV:RSIZ+1),424*4
         DATA     SL:BMX
         GEN,8,24 SV:LIM+SV:LIM+SV:LIM+SV:LIM+4,440*4
         DATA     SL:ODF
         GEN,8,24 SV:LIM+SV:LIM+SV:LIM+SV:LIM+4,460*4
         DATA     SH:SYMT
         GEN,8,24 SV:FTYM+1+SV:FTYM+1,412*4
         DATA     SL:NAME
         GEN,8,24 SV:LIM+SV:LIM+SV:LIM+SV:LIM+4,480*4
SHOW1    EQU      %
         LI,D1    0                 DONT SCAN CMMAND
         LD,R6    XSHOW             CMMAND TO R6&R7
         B        GROUP2            GO LOAD AND LINK
         PAGE
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=03, SUBCODE=00                        *
*E*      DESCRIPTION:                                                  *
*E*               WE COULDN'T GET A COMMON PAGE TO PASS THE :USERS     *
*E*               RECORD TO SHOW.  NOTE - TELSTACK IS CLEANED BEFORE   *
*E*               ERROR MESSAGE.                                       *
************************************************************************
SHOWXX   BUMP     -(LOGSIZE+RWUSRSZ),R5 CLEAN STACK
         LI,D1    X'030300'         ERROR CODE & SUBCODE
         B        CMNERR1
         TITLE    'WHERE COMMAND VERB'
*        THE WHERE COMMAND IS USED TO SEE IF A SPECIFIED USER
*        IS LOGGED ON TO THE SYSTEM. THIS IS DONE BY CHECKING
*        THE FILE :LOGD.:SYS BUILT BY LOGON, WHICH CONTAINS A RECORD
*        FOR EACH ONLINE USER. THIS FILE IS READ NONE, WRITE
*        NONE, SO WE MUST GO TO X'C0' PRIV. LEVEL TO READ IT.
*
WHERE    EQU      %
         LW,D1    S:COUP            SEE IF FEATURE ENABLED
         CI,D1    2                 THE 2 BIT IN S:COUP
         BAZ      GIVEMEH           MUST BE SET.
         CI,R1    1                 WE MUST HAVE AN ARGUMENT
         BLE      GIVEMEH           OR WE COMPLAIN.
         BAL,R4   FMTELCL           MAKE SURE M:TEL CLOSED.
         LW,R3    TELSTACK          A WORK AREA
         AI,R3    20                OVER HERE A WAYS...
         LW,D1    ='    '           PRESET THIS BUFFER AREA
         STW,D1   0,R3              TO BLANKS.
         STW,D1   1,R3              WE ADDED 20 BECAUSE OTHER
         STW,D1   2,R3              ROUTINES, SUCH AS SCAN,
         STW,D1   3,R3              USE THE STACK TOO.
         STW,D1   4,R3
         LI,D1    0
         PUSH     R3                REMEMBER THAT.
         BAL,SR3  SCAN
         CI,R6    ','               BETTER END ON A COMMA
         BNE      SYNTAX            OR I WONT LIKE YOU.
         CI,R7    8
         BG       SYNTAX            TOO LONG
         CI,R7    0
         BLE      SYNTAX            TOO SHORT
         LW,R3    *TELSTACK         TOP OF STACK
         AI,R3    2                 NOW DO 3 WORD NAME
         BAL,SR3  SCAN
WHSC     CI,R7    12
         BG       SYNTAX
         CI,R7    0
         BLE      SYNTAX            GUESS IT LOOKS GOOD.
WHERE1   LB,15    JB:PRIV           THIS IS THE USERS PRIV LEVEL
         LI,1     X'C0'             THIS IS WHAT I NEED
         STB,1    JB:PRIV           .....POKE.....
         PULL     13                OUR ARG AREA
         LI,14    0                 HIT COUNTER
WHERE2   CAL1,1   WHOPEN            OPEN ME THIS FILE
         STB,D4   JB:PRIV           RESET USER PRIV LEVEL.
MAPAGE   EQU      X'1FC00'          ADR OF 1ST CVM'D PAGE
         M:CVM    LB:UN,MAPAGE
         M:CVM    LB:UN+512,MAPAGE+512
         LCI      5                 FAR OUT, ITS OPEN...
         LM,0     *13               GET THE 5 WD NAME+ACCT
         CI,13    1                 IS BUFFER ON DOUBLEWORD???
         BANZ     %+2               I DONT WANT IT ON ONE.
         AI,13    -1                IT IS NOW........
         LI,5     '*'               LOGGED ON INDICATOR
         LI,6     3                 BYTE INDEX FOR COMPARE
WHERE3   CAL1,1   WHREAD            READ ME A RECORD.
         CB,5     *13,6             IS IT LOGGED ON????
         BNE      WHERE3            NOPE.
         AI,13    1                 MOVE TO DOUBLEWORD.
         CD,0     *13               CHECK FIRST 2 WORDS.
         BNE      WHERE3-3          WHY DIDNT SOMEBODY PUT IN
         AI,13    2                 A COMPARE MULTIPLE WITH
         CD,2     *13               ALL THE OTHER MULTIPLE WORD
         BE       %+3               INSTRUCTIONS.....
         AI,13    -3                DIDNT HIT ON WDS 3+4
         B        WHERE3            DEC PTR AND SPLIT.
         AI,13    2
         CW,4     *13               LAST WORD FOR A MATCH.
         BE       %+3               WE GOT ONE.
         AI,13    -5
         B        WHERE3
         PUSH     3,R1              SAVE THIS STUFF
         AI,13    -6                I KNOW, I ONLY ADDED 5
         LW,3     =' ON '           BIT I'M GOING TO POKE THIS
         STW,3    *13               IN BEFORE THE LINE NUMBER.
         LI,R1    4                 L/4; BTD INTO TEXT TO CONVERT
         LI,R2    0                 L/0; ACCUMULATOR
WHERE3F  ;
         LB,R3    *13,R1            L/CHAR OF EBCDIC HEX
         CI,R3    '0'               C/CHAR W/0
         BGE      %+2               BGE; IT'S 0 -> 9
         AI,R3    -'A'+'0'+10       ITS A -> F
         AI,R3    -'0'              MAKE BINARY DIGIT
         SLS,R2   4                 SHIFT ACCUM LEFT 4 BITS
         AW,R2    R3                ADD DIGIT TO ACCUM
         AI,R1    1                 INC BTD
         CI,R1    5                 C/BTD W/5; HI BTD
         BLE      WHERE3F           BLE; PROCESS NEXT CHAR
         LI,R1    LB:UN             L/ADR OF LINE# TO USER# TABLE
         AND,R1   =X'1FF'           &/ADR W/.1FF; G/PAGE DISP
         AI,R1    MAPAGE            + WA OF MAPPED PAGE
         INT,R3   *M:TEL+10         L/RIGHT HALF OF KEY
         CB,R3    *R1,R2            C/SAVED USER# W/CURRENT USER#
         BNE      WHERE3H           BNE; NOT VALID REC
         LW,1     13                BUFFER ADDRESS.
         LI,2     6                 AND LENGTH
         CAL1,1   WRITE             FOUND ONE FOR YOU.
WHERE3H  ;
         AI,13    1
         AI,14    1                 REMEMBER THAT WE FOUND ONE.
         PULL     3,R1
         B        WHERE3            GO LOOK FOR MORE.
WHERE4   ;
         M:FVP    MAPAGE            FREE MAPPED PAGE
         M:FVP    MAPAGE+512        FREE MAPPED PAGE
         BAL,R4   FMTELCL           CLOSE M:TEL
         CI,14    0                 FIND ANYBODY....
         BNE      PROMPT            YUP. GOOD FOR YOU.
         LI,R1    NONE              SORRY, NOBODY NAMED JOE
         LI,R2    4                 AROUND NOW.....
         CAL1,1   WRITE             TRY AGAIN LATER......
         B        PROMPT
*
*        READ A RECORD
*
WHREAD   GEN,8,24 X'10',M:TEL
         DATA     X'F0000010'       P1-P4, WAIT.
         DATA     WHERR,WHERR       ERR AND ABN
         DATA     X'8000000D'       BUF= *13
         DATA     44                RECL=44 BYTES
*
*        OPEN THE :LOGD FILE
*
WHOPEN   GEN,8,24 X'14',M:TEL
         DATA     X'FF400009'
         DATA     WHERR1,WHERR1     ERR AND ABN
         DATA     X'8000000D'       BUF= *13
         DATA     44                RECL=44 BYTES
         DATA     10                TRIES=10
         DATA     1                 ORG=CONSEC (ITS REALLY KEYED)
         DATA     1                 SEQUEN
         DATA     X'301'            MODE=IN, SHARE
         DATA     2
         GEN,8,8,8,8 1,0,2,2
         TEXTC    ':LOGD'           NAME= :LOGD
         GEN,8,8,8,8 2,1,2,2
         TEXT     ':SYS    '        ACCT= :SYS
*
*        ERROR HANDLER FOR WHERE FILE OPERATIONS.
*
WHERR    LB,7     10                LOOK AT MAJOR CODE
         CI,7     6                 END OF FILE HIT??
         BE       WHERE4            YES. GO CLEAN UP.
         CI,14    0                 HAVE WE BEEN HERE BEFORE?
         BL       WHERE4            YUP, SCRAM...
         LI,1     WHM
         LI,2     18
         CAL1,1   WRITE             ERROR- COP OUT.
         LI,14    1                 NO, WE DIDNT...
         B        WHERE4
WHM      TEXT     'BUSY OR FILE ERROR'
*
*        AND FOR OPEN PROBLEMS
*
WHERR1   LI,R1    GASP
         LI,R2    25
         STB,D4   JB:PRIV           RESET PRIV LEVEL
         LI,D3    1                 SET FLAG SO WE DONT PRINT 'NONE'
         CAL1,1   WRITE             COMPLAIN
         B        WHERE4            AND CUT OUT...
GASP     TEXT     'CANNOT ACCESS :LOGD FILE'
         TITLE    'TABS COMMAND VERB'
TABS     EQU      %
         CI,R6    X'E2'             TABS INQUEIRY ??
         BE       TABS1             YES, BRANCH
         CI,R6    ' '               CHECK FOR SPACK
         BNE      SYNTAX
         LW,R4    TELSTACK
         AI,R4    1
         BUMP     7,R5
         LCI      7
         LM,SR1   TABPL
         STM,SR1  0,R4
         AI,R4    2
         LI,R0    0                 CLEAR A COUNT FOR TAB VALUES
TABSA    LI,R3    D1
         LW,D1    VERB1
         BAL,SR3  SCAN              GET THE TAB VALUE
         CI,R7    0                 INSURE DATA
         BE       SYNTAX
         CI,R7    3                 ALLOW UP TO 3 CHARACTERS
         BG       SYNTAX
         AI,R0    1                 BUMP THE COUNT
         BAL,SR4  DECBIN            CONVERT THE VALUE TO BINARY
         STW,R0   R3
         STB,R7   *R4,R3            STORE THE VALUE IN PLIST
         CI,R0    16                TEST FOR LIMIT
         BG       SYNTAX
         CI,R6    ','               ANY MORE
         BE       TABSA             YUP
         CI,R1    1                 TEST FOR TRAILING GARBAGE
         BG       SYNTAX
         STB,R0   *R4               NOPE-STORE COUNT
         AI,R4    -2
         CAL1,1   *R4               ISSUE M:DEVICE CAL
         BUMP     -7,R5
         B        PROMPT
*                                   OUTPUT CURRENT TABS
TABS1    EQU      %
         LI,R3    M:UC+19           PT TO END OF TABS
         LI,R7    -16               INDEX BACK
         LB,SR3   *R3,R7            ANY TAB ENTRIES?
         BNEZ     TABS2             YES
         LI,R1    NONE              NO
         LI,R2    4                 BYTE COUNT
         CAL1,1   WRITE             OUTPUT NONE MSSG
         B        PROMPT            PROMPT
*
TABS2    EQU      %                 DISPLAY TABS ROUTINE
         LW,R6    TELSTACK
         AI,R6    1                    SPACE
         BUMP     16,R5                  FOR OUTPUT
         LI,R0    ','               COMMA BETWEEN ENTRIES
         LI,R2    0                 INITIAL BYTE COUNT
TABS4    LB,D1    *R3,R7            GET TAB ENTRY
         BEZ      TABS3             NO ENTRY, GIVEUP
         BAL,SR4  BINDECBCD         CONVERT TO DECIMAL
         LI,R4    0
TABS5    LB,R5    D2,R4
         CI,R5    '0'               IS DATA A ZERO?
         BNE      TABS6
         AI,R4    1
         B        TABS5
TABS6    STB,R5   *R6,R2
         AI,R2    1
         AI,R4    1
         CI,R4    4
         BE       TABS7
         LB,R5    D2,R4
         B        TABS6
*
*
TABS7    STB,R0   *R6,R2
         AI,R2    1
         BIR,R7   TABS4
TABS3    EQU      %
         AI,R2    -1
         LI,R0    ' '               BLANK
         STB,R0   *R6,R2
         LW,R1    R6                BUFFER ADDR TO R1
         CAL1,1   WRITE             OUTPUT TO TERMINAL
         BUMP     -16,R5            EVEN UP
         B        PROMPT            PROMPT
         TITLE    'PAGE COMMAND VERB'
*
* PAGE ROUTINE
* THE PAGE FUNCTION ALLOWS THE ON-LINE USER TO RESET THE
* CURRENT PAGE NO. OUTOUT IN THE HEADER BY THE COC ROUTINE
*
*
PAGE     EQU      %
         CI,R1    0
         BE       SYNTAX            NO INPUT FOLLOWS
         CI,R6    ' '
         BNE      SYNTAX
         BAL,SR3  GETFIELD          GET NUMBER
         BAL,SR4  DECBIN            CONVERT TO BIN
         LH,SR3   R7                SEE IF # TO BIG
         BNEZ     SYNTAX            YES, TEL HIM
         LI,R6    JH:PC
         STH,R7   0,R6              PUT VALUE IN JIT
         B        PROMPT
         TITLE    'PLATEN COMMAND VERB'
PLATEN   EQU      %
         CI,R6    'N'               IS IT A PLATEN ONLY ?
         BE       PLATEN1
         CI,R6    ','               ONLY LENGTH PRESENT?
         BE       COMMA+2           IF YES GO PROCESS IT
         LW,D1    VERB1
         LI,R3    D1
         BAL,SR3  SCAN
         CI,R7    0                 WAS DATA PRESENT
         BE       COMMA             NO; GO CHECK FOR COMMA
         CI,R7    3
         BG       SYNTAX            HE GETS ONLY 3 CHARACTERS
         BAL,SR4  DECBIN
         CI,R7    140
         BG       SYNTAX            WIDTH MAGNITUDE TEST
         LI,R5    JB:PCW
         STB,R7   0,R5              STORE WIDTH
COMMA    EQU      %
         CI,R6    ','               IS A LENGHT FIELD PRESENT
         BNE      DONE              NO;
         LI,R3    D1                YES; GET LENGHT
         LW,D1    VERB1
         BAL,SR3  SCAN
         CI,R7    0                 INSURE DATA
         BE       SYNTAX
         CI,R7    3                 ARE MORE THAN 3 CHARACTERS PRESENT
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255               CHECK LENGTH MAGNITUDE
         BG       SYNTAX
         LI,R5    BA(JB:LPP)        L/BA OF LINES/PAGE
         STB,R7   0,R5              S/LINES/PAGE
         CI,R6    ','               C/TERMINATING CHAR W/COMMA
         BNE      DONE              BNE; NO MORE FIELDS
         LI,R3    D1                L/ADR OF DESTINATION FIELD FOR SCANNER
         LW,D1    VERB1             L/BLANKS
         BAL,SR3  SCAN              GET NEXT FIELD
         CI,R7    0                 C/SIZE W/0
         BE       SYNTAX            B/0; ILLEGAL
         CI,R7    3                 C/SIZE W/3
         BG       SYNTAX            BG; ILLEGAL
         BAL,SR4  DECBIN            CONVERT TEXT TO INTEGER
         CI,R7    255               C/VALUE W/MAX LEGAL
         BG       SYNTAX            BG; ILLEGAL
         LI,R5    BA(JB:LBPH)       L/ADR OF LINES-BEFORE-PAGE-HEADING
         STB,R7   0,R5              S/LINES BEFORE PAGE HEADING
         CI,R6    ','               C/TERMINATING CHAR W/COMMA
         BNE      DONE              BNE; NO MORE FIELDS
         LI,R3    D1                L/ADR OF DESTINATION FIELD FOR SCANNER
         LW,D1    VERB1             L/BLANKS
         BAL,SR3  SCAN              GET NEXT FIELD
         CI,R7    0                 C/SIZE W/0
         BE       SYNTAX            B/0; ILLEGAL
         CI,R7    3                 C/SIZE W/3
         BG       SYNTAX            BG; ILLEGAL
         BAL,SR4  DECBIN            CONVERT TEXT TO INTEGER
         CI,R7    255               C/VALUE W/MAX LEGAL
         BG       SYNTAX            BG; ILLEGAL
         LI,R5    BA(JB:LAPH)       L/ADR OF LINES-AFTER-PAGE-HEADING
         STB,R7   0,R5              S/LINES AFTER PAGE HEADING
DONE     EQU      %
         LI,R5    BA(JB:PCW)        L/ADR OF LINES/PAGF
         LB,R5    0,R5              L/LINES/PAGE
         BNEZ     %+2               BNEZ; OK TO DIVIDE
         LI,R5    1                 L/1; DON'T DO DIVIDE ON 0
         LI,R3    121               L/APPROX MAX SIZE OF HEADING
         DW,R3    R5                (MAX SIZE) / (CHARS/LINE) = MAX # LINES
         LI,R5    BA(JB:LBPH)       L/ADR OF LINES BEFORE PAGE HEADING
         LI,R6    BA(JB:LAPH)       L/ADR OF LINES AFTER PAGE HEADING
         LI,R7    BA(JB:LPP)        L/# OF LINES/PAGE
         LB,R4    0,R5              L/LINES BEFORE PAGE HEADING
         AW,R3    R4                + LINES BEFORE PAGE HEADING
         LB,R4    0,R6              L/LINES AFTER PAGE HEADING
         AW,R3    R4                + LINES AFTER PAGE HEADINGS
         CB,R3    0,R7              C/APPROX MAX PAGE SIZE W/PAGINATION POINT
         BL       DONE5             B/OK
         LI,R3    0                 L/0; RESET PAGINATION
         STB,R3   0,R7              RESET PAGINATION
         B        SYNTAX            B; ILLEGAL, GIVE ERROR MSG
DONE5    ;
         CI,R1    1                 TEST FOR TRAILING JAZZ
         BG       SYNTAX
         B        PROMPT
*
* PLATEN1: INFORMS USER OF CURRENT PLATEN SETTINGS
*
PLATEN1  EQU      %
         LW,R7    TELSTACK          L/TOP-OF-STACK ADR
         AI,R7    1                 POINT TO 1ST UNUSED WORD
         BUMP     8,R1              ALLOCATE 8 WORDS IN THE STACK
         LI,R6    #PLATS*32-32      L/BYTE INDEX TO ITEM TEXT ENTRY
         LI,R3    #PLATS            L/# OF PLATEN DISPLAY ITEMS
PLATEN2  LD,R4    R6                L/ITEM BYTE INDEX, STACK BUF WA
         SLS,R5   2                 STACK ADR X 4; G/BA
         AW,R5    =32*24            + BC OF 32 FOR MBS
         MBS,R4   BA(TXPLAT)        MOVE TEXT INTO STACK
         LW,R5    ADRPLAT-1,R6      L/ADR OF VALUE TO DISPLAY
         LB,D1    0,R5              L/VALUE TO DISPLAY
         BAL,SR4  BINDECBCD         CONVERT IT
         LI,R0    ' '
         LI,R1    -4                COUNT
PLATEN3  LB,R5    D3,R1             PICK UP THE CONVERTED BYTE
         CI,R5    '0'
         BNE      PLATEN4
         STB,R0   D3,R1             CHANGE LEADING ZERO TO BLANK
         BIR,R1   PLATEN3           CHECK NEXT DIGIT
         AI,D2    C'0'-C' '         TO PRINT ZERO
PLATEN4  STW,D2   0,R7              S/TEXT INTEGER INTO 1ST BUF WD IN STACK
         LW,R1    R7                L/BUFFER ADR
         LI,R2    32                L/SIZE FOR WRITE
         CAL1,1   WRITE             M:WRITE M:UC,(BUF,*R1),(SIZE,*R2)
         AI,R6    -32               DEC BYTE INDEX TO ITEM TEXT ENTRY
         BDR,R3   PLATEN2           BDR/GET NEXT ITEM
         BUMP     -8,R1             RESET STACK
*
         B        PROMPT            PROMPT
*
*
GETFIELD LD,D1    VERB2
         LW,D3    VERB2
         LI,R3    D1
         B        SCAN              EXIT ON SR3
GETACPAS RES      0
         LCI      2
         LM,SR2   J:ACCN
         LI,R7    0
         LI,SR1   0
         B        0,R5
         TITLE    'PROMPT COMMAND VERB'
PRMPT    EQU      %
         LI,R3    D1                L/ADR OF DESTINATION STRING
         LI,R6    0                 L/0; INITIALIZE TERMINATOR CHAR REG
         BAL,SR3  SCAN              SCAN NEXT FIELD (PROMPT CHAR)
         LB,D1    D1                RJ/BYTE 0 TO BYTE 3
         LI,R5    BA(JB:PROMPT)     L/BA OF CURRENT PROMPT CHAR
         CI,R7    1                 C/# OF CHARS SCANNED W/1
         BG       SYNTAX            BG; TOO MANY, ILLEGAL
         BE       PRMPT5            BE; USE CHAR IN D1
         LW,D1    R6                L/TERMINATING CHARACTER; ONLY CHAR
         BNEZ     PRMPT5            B/ONE OF TEL'S TERM CHARS
         STB,D1   0,R5              RESET JB:PROMPT
PRMPT5   LI,R7    BA(JB:DPROMPT)    L/BA OF DEFAULT PROMPT CHAR
         STB,D1   0,R7              S/NEW DEFAULT PROMPT
         LB,SR2   0,R5              L/CURRENT PROMPT CHAR
         BNEZ     PROMPT            BNEZ; DON'T CHANGE
         STB,D1   0,R5              S/NEW CURRENT PROMPT CHAR
         B        PROMPT            B; GET NEXT COMMAND
         TITLE     'TERMINAL COMMAND VERB'
TERMINAL EQU      %
         LC       J:JIT             IGNORE THIS COMMAND IF
         BCS,2    PROMPT            NON-COC USER
         LW,D1    VERB1             BLANKS
         LI,R3     D1
         BAL,SR3   SCAN
         CI,R7     0                WAS DATA PRESENT?
         BE       COCSTAT           GIVE 'EM STATUS
         CI,R6    ','               , TERMINATED SCAN?
         BE       %+3               YES,SKIP CHECKING
         CI,R1     1
         BG        SYNTAX           INSURE NO TRAILING DATA
         OR,D1    VERB2             CONVERT POSS. LCASE STAT TO UPPER
         CW,D1    LSTAT             LOWER CASE 'STAT'US
         BE       COCSTAT
         LW,SR2   TELSTACK          GET STACK POINTER
         AI,SR2   1
         BUMP     4,R5              OPEN STACK UP
         LI,R5    0
         LW,SR3   TERMTYPE,R5       MOVE FPT TO STACK
         STW,SR3  *SR2,R5            FOR CHNGE CAL
         AI,R5    1
         CI,R5    4
         BL       %-4               B/MOVE NEXT FPT WORD
         LI,R7    SIZETAB1          L/INDEX OF LAST ENTRY IN TERM TAB
         LI,R1    3                 L/3; INDEX INTO FPT TO TERM TYPE
SRCHTAB1 CW,D1    TERMTAB1,R7
         BE       FOUNDP
         AI,R7    -1
         BGEZ      SRCHTAB1
         STW,D1   *SR2,R1           S/TEXT INTO TERM TYPE WORD IN FPT
         B        CHKFALGO          B; SEE IF ALGO SPECIFIED
FOUNDP   RES      0
         LW,R5    TERMTAB2,R7       L/TEXT FOR TERMINAL TYPE
         STW,R5   *SR2,R1           STORE COCTERM
         LB,R5    TERMTAB3,R7       ALGO BYTE
         AI,R1    -1
         SLS,R5   16                POSITION ALGO IN BITS 13 -> 15
         AI,R5    7                 +7; MASK FOR ALGO
         STW,R5   *SR2,R1           STORE ALGORITHM #
CHKFALGO ;
         CI,R6    ','               ALGOR OVERRIDE? PRES
         BNE      CHNGTYPE          NO, TAKE THE DEFAULT
         LW,D1    VERB1
         LI,R3    D1
         LI,R1    2                 DISP INTO BUFFER
         BAL,SR3  SCAN              SCAN FOR ALGO OVERIDE
         CI,R7    1
         BNE      SYNTAX
         BAL,SR4  DECBIN            CONVERT DEC #
         LI,R5    2                 INDX INTO FPT
         SLS,R7   16                POSITION ALGO IN BITS 13 -> 15
         AI,R7    7                 +7; MASK FOR ALGO
         STW,R7   *SR2,R5           PUT IN FPT
CHNGTYPE CAL1,8   *SR2
         BCS,8    CHNGERR           ERROR EXIT
         BUMP     -4,R5             RESTORE STACK
         B        PROMPT
CHNGERR  BUMP     -4,R5             MUST EVEN UP STACK
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=07, SUBCODE=00                        *
*E*      DESCRIPTION:                                                  *
*E*               THE USER'S TERMINAL TYPE SPECIFIED IN HIS            *
*E*               TERMINAL COMMAND WAS INVALID OR THE CHANGE           *
*E*               TERMINAL TYPE CAL WAS UNSUCCESSFUL.                  *
************************************************************************
         LI,D1    X'030700'         ERROR CODE & SUBCODE
         B        CMNERR1
*
*
COCSTAT  LW,SR2   M:UC+COCLN        GET THE COC LINE NUMBER
         BAL,SR4  HEX2EBC           CONVERT TO HEX
         LW,1     TELSTACK
         AI,1     1                 A WORK AREA
         LCI      3
         LM,3     LMSG
         LI,2     1
         STH,D2   4,2
         LCI      3
         STM,3    0,1               PUT AWAY MSG WITH LINE #
         LI,R2    9                 AND HOW LONG IT IS
         CAL1,1   WRITE             SO DO IT.
         CAL1,8   COCSTATX          GET LINE STATUS
         LB,R2    D2                GET LINE SPEED INDICATOR
         AND,R2   =7
         LCI      5
         LM,R3    MSLSPD
         LW,R6    SPEEDTAB,R2       GET EQUIVALENT BAUD
         LCI      5
         STM,R3   0,R1              STORE INTO BUFFER
         LI,R2    17
         CAL1,1   WRITE             WRITE LINE SPEED MESSAGE
*
         LB,SR2   SR3
         AND,SR2  =7
         BAL,SR4  HEX2EBC           CONVERT TO HEX
         LCI      5
         LM,R2    MTALRTHM
         STH,D2   R6
         LCI      5
         STM,R2   0,R1              STORE INTO BUFFER
         LI,R2    19
         CAL1,1   WRITE             WRITE TIMING ALGO. MESSAGE
         CAL1,8   COCSTATX          NOW GET STATUS OF LINE
         MTW,0    S:COUP            IS THE FEATURE ENABLED????
         BLE      COCSTAT2          B/NOPE, DONT TALK ABOUT IT...
         CI,SR1   X'1000'           IS THIS A 2741 LINE???
         BANZ     COCSTAT2          B/YUP, CAN'T DO COUPLING...
         LB,R7    SR3               LOOK AT COUPLE STATUS
         SLS,R7   -6                IN UPPER TWO BITS OF MODE4
         CI,R7    2                 IS THE COUPLED BIT SET??
         BAZ      COCSTAT0          B/NOPE, DONT CHECK TIE BYTE.
         LI,1     3
         CB,SR3   M:UC+COCLN,1      ARE WE COUPLED TO SOMEBODY
         BE       COCSTAT0          IF EQUAL, NOPE....
         LW,SR2   SR3               IF SO, GET # OF LINE COUPLED
         BAL,SR4  HEX2EBC           TO, GRUNCH TO CHARACTERS,
         LW,1     TELSTACK
         AI,1     1
         LCI      5
         LM,3     MCPLD
         STH,D2   R7                PLUNK IN LINE NUMBER
         LCI      5
         STM,3    0,1
         LI,2     18
         B        COCSTAT1+1
COCSTAT0 LI,R2    14                LENGTH OF MESSAGES
COCSTAT1 LW,R1    CPLMSG,R7         WHICH MESSAGE
         CAL1,1   WRITE             PRINT IT OUT..
COCSTAT2 CAL1,8   COCSTATX          GET SUPER EXTENDED STATUS
         LI,R1    TXTRTYPE          L/ADR OF 'TRANSLATION TYPE '
         LI,R2    18                L/SIZE OF 'TRANSLATION TYPE '
         CAL1,1   WRITE             WRITE OUT 'TRAN...'
         LW,R1    TELSTACK          L/TOP OF TELSTACK ADR
         AI,R1    1                 +1 TO ADR
         STW,D1   0,R1              S/TEXT TERM TYPE INTO STACK
         LI,R2    4                 L/4; SIZE OF MESSAGE
         CAL1,1   WRITE             PRINT THE TERMINAL TYPE
         LW,SR2   MODECW
         LI,SR3   MODECW
COCMLOOP SLS,SR2  1
         BEV      NOCOCM            BIT TO BE IGNORED
         AI,SR3   1
         LI,R1    RETN              NEW LINE
         LI,R2    1
         CAL1,1   WRITE
         LW,R1    *SR3
         BAL,R4   COCPRT            IDENTIFY MODE
         LI,R1    COCON             GIVE
         AI,SR1   0                  ON/
         BLZ      %+2                 OFF
         LI,R1    COCOFF               MSG
         LI,R2    4
         CAL1,1   WRITE
NOCOCM   SLS,SR1  1
         AI,SR2   0
         BNEZ     COCMLOOP          GO IF MORE TO CHECK
         B        PROMPT
COCPRT   EQU      %
         LB,R2    R1
         CAL1,1   WRITE
         B        0,R4
*
TERMTYPE DATA     X'06200000'       FPT FOR TRANS TBL
         DATA     X'06000000'       & COC IDLE ALGORITHM
         DATA     0                 IDLE FIELD
         DATA     0                 COCTERM FIELD
*
*
COCSTATC GEN,8,4,20 6,6,0           GET EXTENDED LINE STATUS
*
COCSTATX GEN,8,4,20 6,X'B',0        SUPER EXTENDED TERMINAL STATUS
TXTRTYPE TEXT     '
TRANSLATION TYPE '
MODECW   DATA     X'008C6CA0'
         GEN,8,24 8,MM0
         GEN,8,24 14,MM1
         GEN,8,24 19,MM2
         GEN,8,24 10,MM3
         GEN,8,24 15,MM4
         GEN,8,24 16,MM5
         GEN,8,24 12,MM6
         GEN,8,24 16,MM7
         GEN,8,24 14,MM8
*
COCON    TEXT     ' ON '
COCOFF   TEXT     ' OFF'
MM0      TEXT     'ECHOPLEX'
MM1      TEXT     'TAB SIMULATION'
MM2      TEXT     'UPPER CASE RESTRICT'
MM3      TEXT     'PAPER TAPE'
MM4      TEXT     'SPACE INSERTION'
MM5      TEXT     'LOWER CASE SHIFT'
MM6      TEXT     'PARITY CHECK'
MM7      TEXT     'RELATIVE TABBING'
MM8      TEXT     'BACKSPACE EDIT'
CPLMSG   DATA     MSRCP,MSRCP,MSACP,TELSTACK COUPLE STATUS MESSAGES
*
MSRCP    TEXT     'REJECT COUPLES'
MSACP    TEXT     'ACCEPT COUPLES'
MCPLD    TEXT     'COUPLED TO LINE '
         TEXT     '    '            FILLED BY LINE NUMBER
MSLSPD   TEXT     'LINE SPEED      '
         DATA     X'15404040'
MTALRTHM TEXT     'TIMING ALGORITHM'
         DATA     X'40401540'
SPEEDTAB TEXT     '110 '
         TEXT     '134 '
         TEXT     '300 '
         TEXT     '600 '
         TEXT     '1200'
         TEXT     '2400'
         TEXT     '4800'
         TEXT     '9600'
         TITLE    'PRINT COMMAND VERB'
* THE PRINT COMMAND CAUSES OUTPUT ACCUMULATED FOR THE LINE PRINTER TO BE
* PLACED ON THE PRINT QUEUE. OUTPUT DESTINED FOR THE LINE PRINTER FROM
* ALL ON-LINE COMPLIATIONS, ASSEMBLIES, PCL OPERATIONS, DELTA DUMPS,
* ETC., ARE ACCUMULATED ON RAD UNTIL THE PRINT COMMAND IS GIVEN.
PRINT    EQU      %
         CI,R1    1                 REMOTE WORK STATION ID ON PRINT
         BG       SYNTAX
         CAL1,9   6
         B        PROMPT
*
         TITLE    'ERASE COMMAND'
************************************************************************
*F*      NAME:    ERASE                                                *
*F*      PURPOSE:     THE ERASE COMMAND IS A SHORT WAY TO PERFORM THE  *
*F*               EQUIVALENT OF LDEV L1,(DELETE).  ITS EFFECT IS TO    *
*F*               DELETE ANY PENDING OUTPUT FOR THE L1 STREAM,  WHICH  *
*F*               IN MOST CASES WILL BE THE USER'S LINE PRINTER OUTPUT.*
************************************************************************
ERASE    EQU      %
         CI,R1    1                 NO ARGUEMENT
         BG       SYNTAX               IS PERMITTED.
         CAL1,8   ERASFPT           DO LDEV
         B        PROMPT
*
*        EXTEND COMMAND
*        EXTEND AVAILABLE CORE FOR NEXT PROCESSOR CALLED
*
EXTEND   EQU      %
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=00                        *
*E*      DESCRIPTION:                                                  *
*E*               EXTEND COMMAND ISSUED WHILE NOT AT JOB STEP          *
************************************************************************
         LI,R5    JSTEP
         AND,R5   J:TELFLGS         AT JOB STEP?
         BEZ      NTJBST            BR IF NOT
*
         LW,R5    EXTNDBIT
         STS,R5   J:TELFLGS         SET EXTEND BIT
         B        PROMPT
*
************************************************************************
*F*      NAME     ERROR                                                *
*F*      PURPOSE: THE ERROR COMMAND WILL CAUSE A TAPE DEVICE TO BE     *
*F*               ERRORED IF THE USER IS IN THE SIOW STATE AND         *
*F*               A KEYIN IS PENDING OR THE DEVICE IS MANUAL.          *
*F*                                                                    *
************************************************************************
ERROR    EQU      %
         LI,R4    0                 ASSUME THE USER SAID DONT
         LI,D1    DONTBIT           IS THE DONT FLAG SET
         AND,D1   J:TELFLGS         IF SO HE SAID DON'T ERROR
         BNEZ     %+2               DONT-->BRANCH
         LW,R4    ERRORFLG          GET THE BIT TO STORE
         LW,R5    ERRORFLG          GET THE MASK TO STORE THE BIT
         STS,R4   J:TELFLGS         STORE THE FLAGS
         B        PROMPT            AND GET OUT
*
*
*
         TITLE    'DECOUPLE,COUPLE VERBS'
DECOUPLE EQU      %                 DECOUPLE TERMINALS
         LI,D1    DONTBIT           IS THE DONT FLAG SET..
         AND,D1   J:TELFLGS         IF SO, HE SAY 'DONT DECOUPLE'
         BNE      GIVEBIRD          AND WE SAY 'DONT WHAT?'........
         CAL1,8   MDCPL             JUST ISSUE THE CAL
         B        PROMPT            AND LEAVE
         SPACE    2
COUPLE   EQU      %
         LI,D1    DONTBIT           SEE IF THE DONT FLAG
         AND,D1   J:TELFLGS         IS SET- IF IT IS, THIS
         BE       COUPLE1           IS A DONT COUPLE VERB
*
*        DON'T COUPLE ISSUED
         CI,R1    0                 DID THEY SAY 'DONT COUPLE XX'
         BG       GIVEMEH           YUP. GIVE 'EM EH.
         LI,R4    0                 TO RESET MODE4 BIT
         B        CPLCMN            GO DO COMMON M:CT
COUPLE1  CI,R1    1                 AN ARGUMENT? MUST MEAN
         BG       COUPLE2           COUPLE TO A TERMINAL
*
*        'COUPLE' TYPED- ISSUE PERMIT COUPLE CAL.
         LW,R4    Y008              TO SET MODE4 BIT
CPLCMN   AI,R4    X'80'             COUPLE PERMISSION BIT
         CAL1,8   MCTCPL            SET/RSET MODE4, BIT 0
         B        PROMPT
*
*        COUPLE XX ISSUED. ATTEMPT COUPLE TO TERMINAL
COUPLE2  LI,D1    0                 WHERE ARG WILL GO
         LI,R3    D1
         BAL,SR3  SCAN              GO GET IT
         CI,R7    2                 MORE THAN 2 CHRS IS
         BG       SYNTAX            AN ERROR.
         PUSH     2,R1
         BAL,R1   HEX2BIN           CONVERT IT
         PULL     2,R1
         CI,SR1   0                 CONVERSION ERRORS
         BL       SYNTAX            TO SYNTAX IF ERRORS
*
*        TRY TO COUPLE TO LINE NUMBER IN SR1.
*
         LI,R3    3                 CHECK TO SEE IF TRYING
         CB,SR1   M:UC+COCLN,R3     TO OURSELVES......
         BE       GIVEMEH           I WON'T DO IT......
         OR,SR1   =X'1D000000'      OTHERWISE OR IN THE FPT
         CAL1,8   SR1               AND ISSUE THE CAL.
         BCR,8    PROMPT            COUPLE SUCCESSFULL..
         BCS,4    COUPLE5           LINE NOT ON. TELL 'EM.
         LI,R1    NOLINE            UNSUCCESSFULL, TELL 'EM
         LI,R2    15                THE BAD NEWS
         CAL1,1   WRITE
         B        PROMPT            EXIT IN DISGUST.
COUPLE5  LI,R1    NOLINE
         LI,R2    28                GIVE 'EM THE BAD NEWS
         CAL1,1   WRITE
         B        PROMPT
NOLINE   TEXT     'COUPLE REFUSED. LINE NOT ON.'
         TITLE    'INFORM COMMAND VERB'
INFORM   EQU      %
         LW,D2    INFMFLG
         LI,D1    DONTBIT           SEE IF THE DONT FLAG SET
         AND,D1   J:TELFLGS         IF IT IS, ITS A DONT INFORM VERB
         BE       INFORM5
         STS,D1   J:TELFLGS         RESET THE INFORM FLAG
         B        PROMPT
INFORM5  EQU      %
         STS,D2   INFMFLG           SET THE INFORM FLAG
         B        PROMPT
         TITLE    'DISPLAY COMMAND VERB'
*
*        THE DISPLAY COMMAND OUTPUTS INFORMATION ABOUT THE CURRENT
*        SYSTEMS OPERATIONS.  THE INFO OUTPUT IS THE NO. OF USERS
*        CURRENTLY  ON THE SYSTEMS, AND THE CURRENT VALUES OF INTER-
*        ACTION  AND  COMPUTE RESPONSE  TIME.  THE OUTPUT IS  AS
*        FOLLOWS:
*        !DISPLAY
*        USERS ='XXX
*        ETMF  = XXX
*        RESPONSE 90%  >  XXX SECONDS
*        RADS  =  XXX GRANULES
*
DISPLAY  RES      0
          BAL,SR4   OUTCARR        OUTPUT LINE OF BALNKS
         CAL1,8   DISPFPT           GO GET DISPLAY INFO FROM MONITOR
         LW,D1    R7                NO. OF USERS
         BAL,SR4  BINDECBCD         GO CONVERT NO. IN D1- ANS. IN D2
         LW,R7    D2                PUT CONVERTED NO INTO R7
         LW,D1    R5                ETMF
         BAL,SR4  BINDECBCD         GO CONVERT TO DEC. - ANS. IN D2
         LW,R5    D2                RESET ETMF BOX WITH DEC VALUE
         LW,D1    R6                MEDIAN VALUE OF TERM RESPONSE TIME
         BAL,SR4  BINDECBCD         GO CONVERT TO DEC  FOR OUTPUT
         LW,R6    D2                RESET MEDIAN VALUE TO DEC.
*
         LW,R1    TELSTACK          GET OUTPUT BUFFER
         AI,R1    1                 ADDRESS
         LCI      3
         LM,SR1   USERSQT           GET USERS MESS AND STORE INTO BUFF
         STM,SR1  0,R1              FOR CONSOLE  PRINT OUT.
         STW,R7   2,R1              PUT NO. OF USERS INTO  MESSAGE
         LW,R2    CARRETRN          INSERT CARRIAGE RETURN
         STW,R2   3,R1              STORE INTO BUFFER AREA FOR OUTPUT
         LI,R2    13                NO. OF CHARS TO OUTPUT
         CAL1,1   WRITE             WRITE MESS. ON TYPEWRITER
         LCI      3                 PICKUP ETMF  QUOTE AND PUT INTO BUFF
         LM,SR1   ETMFQT            PUT ETMF VALUE INTO BUFFER
         STM,SR1  0,R1
         STW,R5   2,R1
         LW,R2    CARRETRN          INSERT CARRIAGE RETURN
         STW,R2   3,R1              STORE INTO BUFFER AREA FOR OUTPUT
         LI,R2    13
         CAL1,1   WRITE             OUTPUT ETMF MESS. ONTO TERMINAL
         LCI      7                 PICKUP MEAN TERM TIME
         LM,SR1   MEANQT            AND PUT INTO BUFFER TO BE PRINTED
         STM,SR1  0,R1
         STW,R6   4,R1              PUT MEAN VAL INTO BUFF TO BE PRINTED
         LW,R2    CARRETRN          INSERT CARRIAGE RETURN
         STW,R2   7,R1              STORE INTO BUFFER AREA FOR OUTPUT
         LI,R2    29                SIZE OF MESS TO OUTPUT IN BYTES
         CAL1,1   WRITE             OUTPUT ONTO TERMINAL
         LW,R3    J:JIT+PRDCRM      PERM. DISC SPACE REMAINING
         AW,R3    J:JIT+PRDPRM      PERM . DISC PACK SPACE REMAINING
         BGEZ     RADPLUS
         LI,R4    X'60'             NEG VALUE GET MINUS SIGN
         LCW,D1   R3                AND VALUE
         B        CONVBIN
RADPLUS  RES      0
         LI,R4    X'40'             BLANK FOR PLUS
         LW,D1    R3
CONVBIN  RES      0
         BAL,SR4  BINDECBCD         CONV BIN RAD VALUE TO DEC
         LW,R1    TELSTACK          GET BUFFER ADDRESS
         AI,R1    1
         LCI      7
         LM,R5    RADSQT            PICKUP 'RADS =  XXXXX GRANULES' QT
         STW,D2   R7                PUT IN NO. OF GRANULES AVAILABLE
         LI,R3    2                 PICKUP BYTE OFFSET
         STB,R4   R6,R3             STORE BYTE INTO OUTPUT BUFFER
         AI,R3    1                 SET STORE FOR LEAD BYTE OF RAD SIZE
         STB,D1   R6,R3             STORE LEAD BYTE OF RAD SIZE
         LW,SR4   CARRETRN          PUT IN SIZE BYTE
         LCI      7
         STM,R5   0,R1              PUT IT ALL INTO OUTPUT BUFFER
         LI,R2    25                BUFFER OUTPUT SIZE
         CAL1,1   WRITE             OUTPUT BUFFER ONTO  TTY
          BAL,SR4   OUTCARR        OUTPUT LINE OF BALNKS
         B        PROMPT            GO GET NXT  CMD
*
DISPFPT  RES      0
         DATA     X'13000000'
USERSQT  RES      0
         TEXT     'USERS =   '
ETMFQT   RES      0
         TEXT     'ETMF  =   '
MEANQT   RES      0
         TEXT     'RESPONSE 90%  <      MSECS  '
RADSQT   RES      0
         TEXT     'RADS =         GRANULES'
         TITLE    'STATUS  COMMAND  VERB'
*
*        THE  STATUS VERB IS PROCESSED  BELOW.  THE WORK IS  DONE
*        IN  THE  ROUTINE STATUSL.  NO REGISTERS ARE SET ON
*        ENTRY TO THE ROUTINE STATUSL.  THE LINE IS OUTPUT  TO THE
*        TERMINAL FROM THE  ROUTINE  STATUSL.
*
*
STATUS   RES      0
          BAL,SR4   OUTCARR        OUTPUT LINE OF BALNKS
         BAL,R2   STATUSL           GO COMPUTE AND PRINT OUTPUT LINE
          BAL,SR4   OUTCARR        OUTPUT LINE OF BALNKS
         B        PROMPT
          SPACE     4
*
*         THE FOLLOWING ROUTINE OUTPUTS ONE LINE OF BLANKS
*         SR4 IS  THE LINK REGISTER
*         R1 AND R2 ARE DESTROYED
OUTCARR   RES       0
          LI,R1     CARRETRN       POINT TO CARRIAGE RETURN WORD
          LI,R2     1              THE NO. OF CHARACTERS TO OUTPUT
          CAL1,1    WRITE          OUTPUT TO TERMINAL
          B         *SR4           EXIT
         TITLE    'SEND COMMAND'
************************************************************************
*F*      NAME:    SEND                                                 *
*F*      PURPOSE:     THE SEND COMMAND IS USED TO ENABLE/DISABLE       *
*F*               RECEIPT OF MESSAGES SENT TO THE USER TERMINAL        *
*F*               BY THE CP-V OPERATOR.                                *
*F*      DESCRIPTION:     THE DEFAULT SETTING FOR THE SEND FLAG IS     *
*F*               TO ALLOW OPERATOR MESSAGES.  WHEN THE USER SAYS      *
*F*               DONT SEND, ALL OPERATOR MESSAGES ARE DISALLOWED.     *
*F*               HOWEVER, ANY GLOBAL BROADCASTS WHICH ARE DEFERRED    *
*F*               WHILE THE USER IS NOT IN TEL WILL BE PRINTED BY      *
*F*               TEL THE NEXT TIME HE GETS CONTROL.  DONT SEND ALSO   *
*F*               DISALLOWS USE OF THE MESSGE COMMAND, SINCE THE USER  *
*F*               WOULD NOT BE ABLE TO RECEIVE ANY OPERATOR REPLY.     *
************************************************************************
SEND     EQU      %
         LI,R3    DONTBIT
         CW,R3    J:TELFLGS         CHECK FOR DONT
         BANZ     DNTSEND           USER SAID DONT SEND
         LI,R4    0                 TO RESET FLAG
         B        SENDCMN
DNTSEND  EQU      %
         LW,R4    Y002              MODE5 DEFER BIT
SENDCMN  EQU      %
         OR,R4    X20               MERGE MASK
         CAL1,8   CTFPT             SET/RSET DEFER MSG FLAG
         B        PROMPT
         TITLE    'MESSAGE COMMAND VERB'
************************************************************************
*F*      NAME:    MESSAGE                                              *
*F*      PURPOSE:     THE MESSAGE COMMAND IS USED TO SEND A MESSAGE    *
*F*               TO THE CP-V OPERATOR.                                *
************************************************************************
*D*      NAME:    MESSAGE                                              *
*D*      ENTRY:   MESSAGE0                                             *
*D*      REGISTERS:     NO REGISTERS ARE PRESERVED.                    *
*D*      CALL:    CALLED FROM TEL COMMAND SCAN                         *
*D*      DATA:    TELBUF - CONTAINS MESSAGE TEXT                       *
*D*               ATOZ - LIMITS FOR ALPHA CHARS                        *
*D*      INPUT:   JB:CCARS - SIZE OF MESSAGE                           *
*D*      OUTPUT:     THE MESSAGE IS TRANSMITTED TO THE OC              *
*D*      DESCRIPTION:     AN M:TS IS ISSUED TO SEE IF THE USER HAS     *
*D*               DISABLED RECEIPT OF OPERATOR MESSAGES.  IF THE MODE5 *
*D*               'DEFER' BIT IS SET, WE GIVE THE USER AN ERROR.  HE   *
*D*               SHOULD THEN ISSUE A 'SEND' COMMAND TO ALLOW THE      *
*D*               OPERATOR TO REPLY TO HIS MESSAGE.                    *
*D*                    BEFORE TRANSMITTING THE MESSAGE TEXT, IT IS     *
*D*               SCANNED FOR LOWERCASE ALPHA CHARACTERS, WHICH ARE    *
*D*               CONVERTED TO UPPER, SOTHE OPERATOR WON'T SEE GARBAGE.*
*D*               IF THE MESSAGE WON'T FIT ON ONE LINE, IT IS BROKEN   *
*D*               INTO TWO LINES WHICH ARE SENT TO THE OC SEPARATELY.  *
************************************************************************
         TITLE    'MESSAGE COMMAND VERB'
MESSAGE0 EQU      %
         BAL,D4   MESSAGE4          CHK FOR LOWER CASE CHARS
         LI,D4    0                 EXCEED FLG
         LB,R4    JB:CCARS          GET RECORD SIZE
         AI,R4    -2                SET INDX&DROP C/R
         CI,R4    73                CHK FOR MAX SIZE
         BLE      %+2
         LI,R4    73                SET TO MAX
         LW,R5    R4                SAVE THE PUF
         AI,R5    6                 ADD TABS &ASTERISK
         LW,R1    R5
         LB,R6    TELBUF,R4         GET THE BYTE
         STB,R6   TELBUF,R5         MOVE THE BYTE
         AI,R5    -1                DECRE
         BDR,R4   %-3               MOVE EM ALL
         B        MESSAGE1
*
MESSAGE  EQU      %
         BAL,D4   MESSAGE4          CHK FOR LOWER CASE CHARS
         LI,D4    0                 EXCEED FLG
         LB,R1    JB:CCARS          GET RECORD SIZE
         AI,R1    -2                DROP C/R& SPACE
*
MESSAGE1 CI,R1    51                WILL MESSAGE FIT ON ONE LINE...
         BLE      MESSAGE2          ---> YES.
         AI,R1    -51+7             NO. GET SIZE OF SECOND LINE
         LI,D4    1                   AND SET TWO-LINE FLAG.
MESSAGE2 LCI      2
         LM,R2    MSGMESS
         STM,R2   TELBUF
         CI,D4    1
         BNE      %+4
         LI,R5    51
         STB,R5   TELBUF            SET SIZE TO 51
         B        %+2
         STB,R1   TELBUF
         LCI      3
         LM,D1    SENDMES
         CAL1,2   D1                SEND THE MESSAGE
         CI,D4    1
         BNE      MESSAGE3
         LCI      2                 INSERT TABS & ASTERISK
         STM,R2   TELBUF+11         FOR 2ND PART OF MSG
         STB,R1   TELBUF+11         INSERT BYTE COUNT
         LI,D3    TELBUF+11         BUFFER ADDR FOR FPT IN REGS
         CAL1,2   D1                SEND 2ND HALF OF MESSAGE
MESSAGE3 B        PROMPT
*
*
         BOUND    8
MSGMESS  DATA     X'0005055C',X'5C5C5C40'
*
MESSAGE4 EQU      %                 CONVERT LOWER CASE CHARS
************************************************************************
*E*      ERROR:   GRP 03, 0D-00                                        *
*E*      DESCRIPTION:     USER WANTS TO SEND MESSAGE TO OPERATOR,      *
*E*               BUT HE WON'T BE ABLE TO RECEIVE A REPLY.             *
************************************************************************
         CAL1,8   COCSTATC          GET TERMINAL STATUS
         CW,SR4   Y2                MODE5 DEFER BIT
         BAZ      %+3               DEFER NOT SET, MSG O.K.
         LI,D1    X'030D00'         DISALLOW (ERRMSG KEY)
         B        CMNERR1
*
         LB,R1    JB:CCARS          GET RECORD SIZE
         LW,R4    R1
         AI,R4    -1
MESSAGE5 LB,R5    TELBUF,R4         GET DATA
         CLM,R5   ATOZ              IS IT LOWER CASE??
         BCS,6    %+2               NO
         AI,R5    X'40'             YES-MAKE IT UPPER
         STB,R5   TELBUF,R4
         AI,R4    -1
         BDR,R1   MESSAGE5
         B        *D4
*
*
         BOUND    8
ATOZ     DATA     X'A9',X'81'       Z......TO....A
*
         TITLE    'BACKUP COMMAND VERB'
BACKUP   EQU      %
         BAL,SR3  GETFIELD          GET FILE NAME
         BAL,SR4  FID                  & ACCT, PSWD, IF PRESENT
         BAL,R4   FMTELCL           SAFETY CLOSE
         BAL,SR4  FLOP              TEST IF FILE EXISTS
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=02, SUBCOODE=02                       *
*E*      DESCRIPTION:                                                  *
*E*               THE FILE NAMED ON THE BACKUP OR GET COMMAND          *
*E*               DOESN'T EXIST.                                       *
************************************************************************
         CI,R0    3                 DOES FILE EXIST?
         BNE      %+4               IT EXISTS.
         LI,D1    X'030202'         ERROR CODE & SUBCODE
         LI,R0    CLEANSTACK        SIMULATE
         B        T%ERR                BAL...
*
         LW,R1    M:TEL+33          GET FILE STATUS
         CI,R1    X'800'            TEST IF FILE IS TO BE BACKED UP
         BAZ      %+3
***********************************************************************
*E*      ERROR:
*E*               GROUP 03, CODE=02, SUBCODE=04
*E*      DESCRIPTION:
*E*               THE FILE NAMED ON THE BACKUP IS NOT TO BE BACKED UP.
*E*
***********************************************************************
         LI,D1    X'030204'         ERROR CODE & SUBCODE
         B        CMNERR1           TELL USER & ABORT
         CI,R1    X'10000'          TEST IF FILE WAS MODIFIED
         BANZ     %+3
***********************************************************************
*E*      ERROR:
*E*               GROUP 03, CODE=02, SUBCODE=05
*E*      DESCRIPTION:
*E*               THE FILE NAMED ON THE BACKUP HAS NOT BEEN MODIFIED
*E*               SINCE THE LAST FILL.
***********************************************************************
         LI,D1    X'030205'
         B        CMNERR1           TELL USER & ABORT
         CAL1,8   GETPG             GET A PAGE
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=02,SUBCODE=01                         *
*E*      DESCRIPTION:                                                  *
*E*               FAILED TO GET PAGE TO READ BACKUP RECORD             *
************************************************************************
         BCR,8    %+3               GOT PAGE
         LI,D1    X'030201'         NO PAGE, ERROR
         B        CMNERR1           TELL USER & ABORT
*
*  SWITCH ACCOUNT TO :SYS & DO OPEN INOUT
         LW,D3    SYSACT
         LW,D4    SYSACT+1
         XW,D3    J:ACCN
         XW,D4    J:ACCN+1
         LI,R1    4                 FOR INOUT
         CAL1,1   OPENBKUP
         STW,D3   J:ACCN            RESTORE USER'S
         STW,D4   J:ACCN+1             ACCOUNT
         CAL1,1   READBKUP          READ IN BACKUP RECORD
         LW,R5    M:TEL+13          GET CURRENT RECORD SIZE
         SLS,R5   -2                CONVERT TO WORDS
         LW,R7    R5
         AI,R5    10                SIZE OF AN ENTRY
         CI,R5    512               WILL IT FIT?
         BG       SIZER             NO
STLOOP   EQU      %
         LCI      10
         LM,SR3   FLOPBUF+8         MOVE ENTRY
         STM,SR3  *SR2,R7              TO RECORD
         AI,R7    10                NEW RECORD SIZE
         SLS,R7   2                    IN BYTES
WRITOUT  CAL1,1   WRITERC           WRITE OUT THE RECORD TO BACKUP FILE
         CAL1,8   PGDROP            DROP A PAGE
         BAL,R4   FMTELCL           CLOSE THE BACKUP FILE
         CAL1,6   BKUPCAL           SEND A CAL FOR THE BACKUP PROCESS
         B        PROMPT
         SPACE    3
ABRTN    EQU      %
         LB,SR3   SR3
         CI,SR3   3                 DOES THE BACKUP FILE EXIST
         BE       OPEN1             NO, GO OPEN IT 'OUT'
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=02,SUBCODE=03                         *
*E*      DESCRIPTION:                                                  *
*E*               WE GOT AN ABNORMAL TRYING TO OPEN F:BACKUP.          *
*E*               ASSUME IT'S BUSY & TELL USER TO TRY LATER.           *
************************************************************************
         STW,D3   J:ACCN            RESTORE USER'S
         STW,D4   J:ACCN+1             ACCOUNT
         CAL1,8   PGDROP            GIVE THE PAGE BACK
         LI,D1    X'030203'         ERROR CODE & SUBCODE
         B        CMNERR1           TELL USER
*
OPEN1    LI,R1    2                 FOR OUT MODE
         CAL1,1   OPENBKUP
         STW,D3   J:ACCN            RESTORE USER'S ACCOUNT
         STW,D4   J:ACCN+1
RDERT    LI,R7    0                 SET RECORD INDEX TO 0
         B        STLOOP
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=02, SUBCODE=00                        *
*E*      DESCRIPTION:                                                  *
*E*               THE BACKUP RECORD IS FULL & WE CAN'T ADD THE         *
*E*               USER'S REQUEST.  TELL USER & THEN GJOB FILL TO       *
*E*               DO THE CURRENT RECORD.                               *
************************************************************************
SIZER    EQU      %
         LI,D1    X'030200'         BACKUP RECORD FULL CODE
         BAL,R0   T%ERR             TYPE ERROR MSG
         B        WRITOUT+1
         TITLE    'JOB COMMAND VERB'
************************************************************************
*F*      NAME:    JOB                                                  *
*F*      PURPOSE:     THE JOB COMMAND IS USED TO INQUIRE INTO THE      *
*F*               STATUS OF BATCH JOBS. MULTIPLE SYSIDS ARE PERMITTED  *
*F*               ON A SINGLE JOB COMMAND LINE.                        *
************************************************************************
JOB      EQU      %
         CI,R1    1
         BLE      SYNTAX
         LI,D1    0                 CLEAR DATA RECIEVING AREA
         LI,R3    D1                LOAD ADDRESS WHERE DATA WILL BE PUT
         BAL,SR3  SCAN              AFTER THE SCAN; GO TO SCAN ROUTINE.
         CI,R7    4                 DOES THE FIELD CONTAIN MORE THAN
         BG       SYNTAX            FOUR CHARACTERS; YES=ERROR
         PUSH     2,R1
         CI,R7    0                 DOES THE FIELD CONTAIN ANY CHARS.
         BE       MULJOB            NO, GET NEXT FIELD
         BAL,R1   HEX2BIN           GO CONVERT FIELD TO BINARY
         CI,SR1   0                 WAS AN ILLEGAL CHARACTER PRESENT
         BGE      JOB2
         PULL     2,R1              YES; THERE WAS AN ERROR. RESTORE BUFFER
         B        SYNTAX            POINTER.
JOB2     CAL1,1   JOBCAL            ISSUE THE JOB CAL.
         CI,SR1   0                 IS THE JOB COMPLETED
         BE       JCMPLT            YES; GO TO THE JOB COMPLETED ROUTINE
         CI,SR1   1                 IS THE JOB RUNNING
         BE       JRUNNG            YES; GO TO THE JOB RUNNING ROUTINE
         CI,SR1   2                 IS THE JOB WAITING TO COMPUTE
         BE       JWAIT2RN          YES; GO TO THE WAITING TO RUN ROUTNE
         CI,SR1   3
         BE       JDNTEXT
         CI,SR1   4                 IS JOB WAITNG FOR SYMBIONT OUTPUT
         BE       JWAIT2OT          YES; GO TO WAITING FOR OUTPUT ROUTNE
GIVEMEH  EQU      %
         LI,R1    EHMSG             THE JOB NEVER EXISTED OR JID. IS
         LI,R2    4                 INDECIPHERABLE SEND OUT
         CAL1,1   WRITE             THE 'EH' MESSAGE.
         B        PROMPT            GO BACK & GIVE ANOTHER PROMPT
JCMPLT   EQU      %
         LI,D1    X'030900'         ERRMSG KEY FOR 'COMPLETED'
         B        JOBMSG            TELL USER & SCAN FOR MORE
JRUNNG   EQU      %
         LI,D1    X'030901'         ERRMSG KEY FOR 'RUNNING'
         B        JOBMSG
JDNTEXT  EQU      %
         LI,D1    X'030902'         ERRMSG KEY FOR 'DOESNT EXIST'
JOBMSG   LI,R0    MULJOB            TO LOOK FOR MORE SYSIDS
         B        T%ERR             TYPE MSG
JWAIT2RN EQU      %
         LW,D1    SR3               PUT # OF USERS IN RUN QUEUE INTO D1
         BAL,SR4  BINDECBCD         GO CONVERT NUMBER IN D1
         LW,D4    D2                CONVERTED NUMBER
         LI,D1    X'030903'         ERRMSG KEY FOR 'WAITING:'
         BAL,SR4  T%ERRTXT          GET THE TEXT FOR MSG
         STW,D4   3,R1              STORE HEX NUMBER INTO MSG
         LI,R0    MULJOB            TO CHECK FOR MORE SYSIDS
         B        T%WRTERR          WRITE MSG
JWAIT2OT EQU      %
         LI,D1    X'030904'         ERRMSG KEY FOR 'WAITING TO O/P'
         B        JOBMSG
MULJOB   EQU      %
         PULL     2,R1
         CI,R1    1
         BLE      PROMPT
         B        JOB+2
         TITLE    'SWITCH COMMAND VERB'
************************************************************************
*F*      NAME:    SWITCH                                               *
*F*      PURPOSE:     THE SWITCH COMMAND IS USED TO SET AND RESET      *
*F*               THE 6 PSEUDO-SENSE SWITCHES IN THE USER'S TCB.       *
*F*               SWITCH SETTINGS MAY NOT BE CHANGED EXCEPT AT         *
*F*               JOB STEP.                                            *
************************************************************************
SWITCH   EQU      %
         LI,R3    JSTEP             ARE WE
         CW,R3    J:TELFLGS            AT JOB STEP?
         BAZ      NTJBST            NO, ILLEGAL
         CI,R1    1                 A NULL ARGUMENT MEANS
         BLE      DISPSW            DISPLAY CURRENT SETTINGS
SWGKEY   EQU      %
         BAL,SR3  GETFIELD          SCAN FOR SET OR RSET
         CI,R6    '='               IS TERMINATOR CORRECT
         BNE      SYNTAX            NO
         CI,R7    5                 MAXIMUM KEYWORD SIZE
         BG       SYNTAX            TOO BIG, STOP NOW
         LB,D1    D1                CHECK ONLY 1ST CHAR
         CI,D1    'R'               IS IT RSET?
         BE       SWRSET            YES.
         CI,D1    'S'               IS IT SET?
         BNE      SYNTAX            NO, SO IT'S ILLEGAL
SWSET    EQU      %
         LI,D3    X'3F'             TO STORE 1'S FOR SET
         B        %+2
SWRSET   LI,D3    0                 TO STORE 0'S FOR RSET
         PUSH     D3                SAVE SET/RSET FLAG
         LI,SR4   6                 LOOP CNTR FOR 6 SWITCHES
         LI,D4    0
GETSW    BAL,SR3  GETFIELD          SCAN FOR SWITCH NUMBER
         CW,D1    TXALL             IS IT ALL?
         BNE      %+3               NO
         LI,D4    X'3F'             YES, ALL 6 SWITCHES
         B        GETSWX
         CI,R7    1                 IS FIELD LENGTH SINGLE DIGIT?
         BNE      SYNTAX            NO, ILLEGAL IF NOT ALL
         LB,R5    D1                GET CHAR
         CI,R5    '1'               CHECK IF IN LIMITS
         BL       SYNTAX
         CI,R5    '6'
         BG       SYNTAX
         AND,R5   M4                CONVERT TO BINARY
         LI,D1    X'40'             MAKE A BIT TO SHIFT
         LCW,R5   R5                FOR RIGHT SHIFT
         SLS,D1   0,R5              SHIFT TO PROPER POSITION
         OR,D4    D1                MERGE
         CI,R6    ','               MORE IN THIS GROUP?
         BNE      GETSWX            NO, GO STORE.
         BDR,SR4  GETSW             YES, GO DO IT
************************************************************************
*E*      ERROR:   GROUP 03, 0B-00                                      *
*E*      DESCRIPTION:     THE USER SPECIFIED MORE THAN 6 SWITCH        *
*E*               SETTING IN A SWITCH SET OR RESET GROUP.              *
************************************************************************
         LI,D1    X'030B00'         ERROR CODE & SUBCODE
         B        CMNERR1
*
GETSWX   EQU      %
         CI,R6    ';'               NEW GROUP COMING?
         BE       %+3               YES
         CI,R1    1                 END OF LINE?
         BGE      SYNTAX            NO, ERROR.
         PULL     D3
         STS,D3   J:JIT+SS          DO STORE FOR SET OR RESET
         CI,R1    1                 IS THERE MORE TO SCAN?
         BGE      SWGKEY            YES
         B        PROMPT
DISPSW   EQU      %
         LW,D1    J:JIT+SS          GET CURRENT SETTINGS
         SLS,D1   26                SHIFT LEFT ALL THE WAY
         LI,R2    2                 FOR WRITE.
         LI,R7    -6                COUNT
DSWLOOP  SLS,D1   1                 CHECK A BIT
         BCS,8    SWONE             IT'S ON
         LI,R1    TX0               IT'S OFF
         B        %+2
SWONE    LI,R1    TX1
         CAL1,1   WRITE             WRITE THE ONE OR ZERO
         BIR,R7   DSWLOOP           DO NEXT
         B        PROMPT
         TITLE    'BATCH COMMAND VERB'
BATCH2   EQU      %
         LD,R6    BATCH             LMN FOR LOAD
         LI,D1    0                 NO FURTHER SCAN
         B        GROUP2            GO TO LOAD
         TITLE    'ERROR HANDLING'
************************************************************************
*D*      NAME:    CMNERR1                                              *
*D*      CALL:                                                         *
*D*               B   CMNERR1                                          *
*D*      DESCRIPTION:                                                  *
*D*               THIS IS A COMMON ENTRY     POINT FOR REPORTING       *
*D*               TEL ERRORS TO THE USER.  EXIT IS EVENTUALLY TO       *
*D*               PROMPT, ALLOWING THE USER TO QUIT OR CONTINUE        *
*D*               THE INTERRRUPTED OPERATION.                          *
*D*      INPUT:                                                        *
*D*               D1 CONTAINS THE GROUP CODE (3), ERROR CODE, & SUBCODE*
*D*      INTERFACE:                                                    *
*D*               T%ERR  - TO GET AND PRINT THE ERROR MSG              *
*D*               SYN1 - TO CLEAN UP TEL'S STUFF                       *
************************************************************************
CMNERR1  EQU      %
         LI,R0    SYN1              SIMULATE BAL
         B        T%ERR             PRINT ERROR MSG
         TITLE    'TABLES, CONSTANTS, AND SUCH'
STKINIT  GEN,16,16   TSTAKSZ,0      TO INIT. TELSTACK SPD
DOLL     TEXT     '%'
SYS      TEXT     ':SYS'
ME       TEXT     'ME'
LP       TEXT     'LP'
NO       TEXT     'NO'
ON       TEXT     'ON'
OVER     TEXT     'OVER'
TX0      TEXT     '0'
TX1      TEXT     '1'
TXALL    TEXT     'ALL'
SUA60    DATA     X'600000'         SUA 60-XX CODE
EXLYBIT  EQU      Y04               EXECUTE ONLY BIT IN J:EXLY
OPENBIT  EQU      Y002              OPEN BIT IN DCB (X'00200000')
NBIT30   EQU      XFFFD
TENTHOU  EQU      Y0001             FOR CHARGES IN PENNIES.
CARRETRN DATA     X'0D000000'
EHMSG    DATA,4   X'C5C86F40',X'7C400000'
FLAGS    DATA     X'4120000B'
LMSG     TEXT     'LINE'            LINE # FOR TERMINAL
         TEXT     '    '            MESSAGE (FILLED)
         DATA     X'15000000'       FOLLOWED BY CR.
RETN     DATA     X'155A0000'
FLOPBITS DATA     X'C7400209'       WORD 1 OF FLOP PLIST
NAMEVLP  DATA     X'01000008'
*
*  BEGIN DOUBLEWORD TABLE
*
         BOUND    8
F0F9     DATA     X'F0',X'F9'
C1C6     DATA     X'C1',X'C6'
PCL      TEXTC    'PCL'
         TEXT     '    '
FDP      TEXTC    'FDP'
         TEXT     '    '
FDP1     TEXT     'FDP     '
UNDER    TEXT     'UNDER'
DELTA1   TEXT     'DELTA'
DELTA    TEXTC     'DELTA'
EDIT     TEXTC    'EDIT'
BATCH    TEXTC    'BATCH'
TXLINK   TEXTC    'LINK'
METASYM  TEXTC    'METASYM'
FORTRAN  TEXTC    'FORT'
ANSFORT  TEXTC    'ANSFORT'
LOGOFF   TEXTC    'LOGON'
BASIC    TEXTC    'BASIC'
XSHOW    TEXTC    'SHOW'
TXLYNX   TEXTC    'LYNX'
         BOUND    8
TM:SI    TEXTC    'M:SI'
TM:GO    TEXTC    'M:GO'
TM:LO    TEXTC    'M:LO'
TM:DO    TEXTC    'M:DO'
*
* END OF DOUBLEWORD TABLE
*
PARMSG   TEXT     'INPUT ERROR-RETRY'
BKMSG    TEXT     'QUIT?'
TXPLAT   ;
         TEXT     '     BLANK LINES AFTER HEADING  '
         TEXT     '     BLANK LINES BEFORE HEADING '
         TEXT     '     LINES PER PAGE             '
         TEXT     '     CHARACTERS PER LINE        '
ADRPLAT  ;
         DATA     BA(JB:LAPH)       BA OF LINES AFTER PAGE HEADING
         DATA     BA(JB:LBPH)       BA OF LINES BEFORE PAGE HEADINGS
         DATA     BA(JB:LPP)        BA OF LINES/PAGE
         DATA     BA(JB:PCW)        BA OF CHARS/LINE
#PLATS   EQU      %-ADRPLAT         # OF PLATEN DISPLAY ITEMS
NONE     TEXT     'NONE'
*
PATCH    RES      50
* THIS IS THE GENERAL PLIST FOR WRITING THROUGH THE M:UC DCB. THE BUFFER
* ADDRESS MUST BE IN R1 AND THE BUFFER SIZE MUST BE IN R2.
*
WRITE    GEN,8,24 X'11',M:UC
         GEN,8,24 X'34',0           P3,P4,P6
         GEN,1,31 1,R1
         GEN,1,31 1,R2
         GEN,32   0                 BTD
*
* PLIST FOR READING USER COMMANDS INTO TELBUF IN USER'S CONTEXT
*
READ     GEN,8,24 X'10',M:UC
         DATA     X'F0800000'       P1 P2 P3 P4 P9
         GEN,1,31 0,ABNRET
         GEN,1,31 0,ABNRET
         DATA     TELBUF
         GEN,1,31 0,80
 GEN,13,1,2,16    0,1,0,0           ACTIVATION CHARACTER SET 0
*
*
*
* PLIST FOR A 'ME' SPECIFICATION(OP LABEL=UC)
*
OPENME   GEN,8,24 X'14',0
         GEN,16,4,12  0,X'A',0
         GEN,16,16 4,0
         GEN,32   C'UC'
*
* PLIST TO READ AND WRITE THE LOGIN RECORD
*
RWUSR    GEN,8,24   X'10',M:TEL     MODIFY X'10' TO USE FOR WRITE
         DATA     X'B8000010'
         GEN,32   OPERR
         PZE      *R3               BUFFER ADDR IN R3
         GEN,32   LOGSIZE+LOGSIZE+LOGSIZE+LOGSIZE
         PZE      *R3               KEY ADDR IN BUFFER (R3)
RWUSRSZ  EQU      %-RWUSR
*
* FIRST TWO WORDS FOR RWUSR TO DO WRITE
*
WUSR     GEN,8,24   X'11',M:TEL
         DATA     X'B0000010'       KEY NOT SET
*
* PLIST USED TO OPEN THE LOGIN FILE FOR A CHANGE IN PASSWORD
*
OPUSR    GEN,8,24   X'14',M:TEL
         DATA     X'CB480219'
         DATA     OPERR             RETURNS IMMEDIATELY
         DATA     OPERR
         DATA     10                TRIES
         DATA     2                 DIRECT
         PZE      *2                MODE (IN R2)
         DATA     2                 SAVE
         DATA     16                KEYM
         GEN,8,8,8,8 1,0,2,2
          TEXTC     ':USERS'
         GEN,8,8,8,8 2,0,2,2
SECAC    TEXT     ':SYS'
         TEXT     '    '
         GEN,8,8,8,8 3,1,2,2
         DATA     X'DFEF803F'
         DATA     X'AFC0BF9F'
*
*
* DEVICE PLIST FOR TABS COMMAND VERB.
*
TABPL    GEN,8,24 X'28',M:UC
         GEN,1,31 1,0
         GEN,64   0
         GEN,64   0
         GEN,32   0
*
* PLIST  FOR OPENING THE BACKUP RECORD
*
OPENBKUP GEN,8,24   X'14',M:TEL
         DATA     X'F7480019'
         DATA     RDERT
         DATA     ABRTN             ABNORMAL RETURN
         PZE      *SR2
         DATA     2048              MAXIMUM RECORD SIZE
         DATA     2                 KEYED FILE
         DATA     2                 DIRRECT ACCESS
         GEN,1,14,17 1,0,R1         MODE
         DATA     2                 SAVE
         DATA     7                 MAXIMUM KEY LENGHT
         DATA,1   1,0,3,3
         TEXTC    'F:BACKUP'
         DATA,1   2,1,2,2
SYSACT   TEXT     ':SYS    '        ACCOUNT
*
* PLIST TO GET COMMON PAGE FOR SHOW COMMAND
GCOMNPG  GEN,8,24   X'C',1          GET 1 COMMON PAGE
*
* PLIST  TO GET A PAGE FOR THE PURPOSE OF READING IN THE BACKUP RECORD
GETPG    GEN,8,7,17  X'08',0,1
*
* PLIST  TO RELEASE A PAGE AFTER  WRITING OUT THE  BACKUP RECORD
PGDROP   GEN,8,7,17  X'09',0,1
*
* PLIST FOR READING THE BACKUP RECORD
*
READBKUP GEN,8,24   X'10',M:TEL
         DATA     X'B8000010'
         DATA     RDERT             READ ERROR RETURN
         GEN,1,14,17 1,0,SR2        BUFFER ADDRESS
         DATA     2048              BUFFER SIZE
         DATA     BKUPKEY           KEY ADDRESS
*
* PLIST FOR WRITING OUT THE BACKUP RECORD
*
WRITERC  GEN,8,24   X'11',M:TEL
         DATA     X'38000050'
         GEN,1,14,17 1,0,SR2        BUFFER ADDRESS
         PZE      *R7               SIZE OF RECORD
         DATA     BKUPKEY           KEY ADDRESS
*
BKUPKEY  TEXTC    'BACKUP'
*
*
* PLIST TO NOTIFY THE SYSTEM THAT THERE IS A FILE WHICH MUST BE BACKEDUP
*
BKUPCAL  GEN,8,24 6,0
         TEXTC    'FILL'
*
*
* PLIST FOR THE MESSAGE COMMAND
*
SENDMES  GEN,8,24 X'0',0
         GEN,1,31 1,0
         DATA     TELBUF            ADDRESS OF BUFFER
*
* PLIST FOR THE JOB COMMAND
*
JOBCAL   GEN,8,24   X'2F',M:TEL     JOBENT STATUS FPT
         DATA     0
*
*  PLIST FOR THE ERASE COMMAND
*
ERASFPT  GEN,8,24   X'1A',0         M:LDEV
         PZE      *X'40'
         DATA     'L1'
*
*   PLIST TO GET AND RELEASE SPECIAL BUFFER
*   PAGES IN CONTEXT AREA.
*
GPFPT    GEN,1,7,24  1,4,SR2        GET PAGE
FPFPT    GEN,1,7,24  1,5,SR2        RELEASE PAGE
*
*        PLIST FOR THE DECOUPLE COMMAND
*
MDCPL    GEN,8,1,23 X'1D',1,0
*
*  PLIST FOR M:CT (COUPLE)
*
MCTCPL   GEN,8,3,21   6,1,0
         DATA     X'04000000'
         PZE      *R4
*
*  PLIST FOR M:GETID CAL
*
GETID    GEN,8,24   X'D',0          USED FOR TP COMMAND
*
*  PLIST FOR M:CT CAL (SEND COMMAND)
*
CTFPT    GEN,8,3,21   6,1,0
         DATA     X'01000000'
         PZE      *R4
*
*  PLIST FOR M:CVM CAL (MAPPER)
*
MAPIT    GEN,1,7,24   1,7,SR3       PHYSICAL ADDRESS IN SR3
         PZE      *SR2              VIRTUAL ADDRESS IN SR2
*
*  PLIST FOR M:MASTER BEFORE SUA
*
MSTRMODE GEN,8,24   8,0
*
*   TABLE OF CONVERSIONS FOR TERMINAL COMMAND
*
TERMTAB1 TEXT      '33  '
         TEXT      '35  '
         TEXT      '37  '
         TEXT     '7015'
         TEXT     'ESTD'
         TEXT     'EAPL'
         TEXT     'SSTD'
         TEXT     'SAPL'
         TEXT     'MEMO'            MEMOREX
         TEXT     'EXEC'            EXECUPORT
         TEXT     'DATA'            DATAPOINT
         TEXT     'TI  '            TEXAS INSTRUMENTS SERIES 700
SIZETAB1 EQU      %-TERMTAB1-1
*
*
*SIZE OF TERMTAB1,2,3 ARE ALL THE SAME-PARALLEL TABLES.**
*
TERMTAB2 TEXT     '33  '
         TEXT     '35  '
         TEXT     '37  '
         TEXT     '7015'
         TEXT     'ESTD'
         TEXT     'EAPL'
         TEXT     'SSTD'
         TEXT     'SAPL'
         TEXT     '37  '
         TEXT     '33  '
         TEXT     '33  '
         TEXT     '37  '
SIZETAB2 EQU      BA(%)-BA(TERMTAB2)-1
*
*
*  IDLE ALGORITHM NUMBER TABLE
TERMTAB3 DATA,1   5,5,5,5           M33, M35, M37, 7015
         DATA,1   1,1,1             ESTD, EAPL, SSTD
         DATA,1   1,3,2,0           SAPL, MEMO, EXEC, DATAPOINT
         DATA,1   5                 TI
         BOUND    4
SIZETAB3 EQU      BA(%)-BA(TERMTAB3)-1
         TITLE    ' '
*
* THE FOLLOWING GROUPS OF CODE ARE THE VECTOR AMPLIFIERS FOR THE LOAD
* AND CONTINUE TYPE OF COMMANDS. THE COMMAND VERB IS TRANSLATED INTO LMN
*
ASSEMBLE LI,D1    PARSER
         LD,R6    METASYM
         B        GROUP2
COMPILE  LI,D1    PARSER
         LD,R6    FORTRAN
         B        GROUP2
ANSFCALL LI,D1    PARSER
         LD,R6    ANSFORT
         B        GROUP2
*
PCLCALL  LD,R6    PCL
         B        SPCASP            SET UNKLMN TO STOP SCAN
*
FIDER    BAL,SR4   FID              GO BREAK FID
         LI,R5    ONBIT+OVERBIT     WAS OVER/ON SPECIFIED?
         LS,R5    J:TELFLGS
         BEZ      TESTSI            NEITHER
         LI,D4    FIPROC            SET FLAG TO INDICATE...
         STS,D4   J:TELFLGS         ...FILE HAS BEEN PROCESSED
         B        *0                EXIT
         TITLE    'RUN, LINK, AND LYNX COMMAND VERBS'
RUN      EQU      %
         LD,R6    TXLYNX            PREPARE TO LOAD LYNX
ZAPGO    EQU      %                 HALT M:GO FILE EXTENTION
         LI,R5    -2
         AND,R5   J:CPPO
         STW,R5   J:CPPO
         LI,D1    0
         B        GROUP2            GO GET LINK OR LYNX
*
*
LINK     EQU      %
         LD,R6    TXLINK            PREPARE TO LOAD LINK
         B        ZAPGO             FIRST KILL M:GO FILE EXTENTION
*
*
*          BREAK PROCESSING   (RESETS BRK BIT)
*
*
BREAKER  RES      0
         AND,D2   NBIT30
         STW,D2   J:TELFLGS
         BAL,SR4  CPXBREAK          UNDO CPX MODE IF ACTIVE
         B        BUFINT
         TITLE    'VALID TEL COMMAND TABLES'
VECTOR1  CSECT    1                 SINGLE WORD BRANCH VECTOR
         NOP
VECTOR2  CSECT    1                 DOUBLEWORD BRANCH VECTOR
         NOP
VERB1    CSECT    1                 SINGLE WORD COMMANDS
         TEXT     '    '
*
         CMND     'COPY',LD6,PCL
         CMND     'EDIT',LD6,EDIT
         CMND     'GET',B,GET
         CMND     'JOB',B,JOB
         CMND     'LINK',B,LINK
         DCMND    'LIST',B,LIST
         CMND     'OFF',LD6,LOGOFF
         CMND     'RUN',B,RUN
         CMND     'FDP',B,FDPSET
         CMND     'QUIT',B,QUIT
         CMND     'SHOW',B,SHOW
         CMND     'SAVE',B,SAVE
         CMND     'DONT',B,DONT
         CMND     'TABS',B,TABS
         CMND     'SET',B,SET
         CMND     'META',B,ASSEMBLE
         CMND     'PCL',B,PCLCALL
         CMND     'STOP',B,QUIT
         CMND     'END',B,QUIT
         CMND     'BYE',LD6,LOGOFF
         CMND     'TP',B,TP
         DCMND    'SEND',B,SEND
         DCMND    'ECHO',B,ECHO
         CMND     'U',B,UDELT
         CMND     'L',LD6,PCL       PCL LIST
         CMND     'B',LD6,EDIT
         CMND     'D',LD6,PCL       PCL DELETE
         CMND     'C',LD6,PCL       PCL COPY
         CMND     'E',LD6,EDIT
         CMND     'M',B,MESSAGE0    MESSAGE
         CMND     'Q',B,QUIT        QUIT
         CMND     'S',B,START
         CMND     'PAGE',B,PAGE
         CMND     'XEQ',B,OX
         CMND     'DI',B,DISPLAY
         CMND     'ST',B,STATUS
         CMND     'T',B,TERMINAL
         CMND     'R',B,RESET
         CMND     'GO',B,CONTINUE
         CMND     'LYNX',B,RUN
         CMND     'ANSF',B,ANSFCALL
SIZVERB1 EQU      %-VECTOR1-1       CSECT LENGTH = NUM CMNDS
*
VERB2    CSECT    1                 DOUBLEWORD COMMANDS
*  NOTE: CSECT DIRECTIVE FORCES DOUBLEWORD BOUNDARY
         TEXT     '        '
         CMND     'RESTORE',B,GET
         CMND     'PROCEED',B,CONTINUE
         CMND     'RESET',B,RESET
         CMND     'BUILD',LD6,EDIT
         CMND     'BATCH',B,BATCH2
         CMND     'CANCEL',B,CANCEL
         DCMND    'COMMENT',B,COMMENT
         CMND     'FORT4',B,COMPILE
         CMND     'CONTINUE',B,CONTINUE
         CMND     'DELETE',LD6,PCL
         CMND     'DISPLAY',B,DISPLAY
         DCMND    'OUTPUT',B,OUTPUT
         DCMND    'ERROR',B,ERROR
         CMND     'START',B,START
LSTAT    CMND     'STATUS',B,STATUS
         CMND     'TERMINAL',B,TERMINAL
         CMND     'PLATEN',B,PLATEN
         CMND     'PASSWORD',B,PASSWORD
         CMND     'DELTA',B,DELTASET
         CMND     'PRINT',B,PRINT
         CMND     'MESSAGE',B,MESSAGE
         CMND     'BACKUP',B,BACKUP
         CMND     'EXTEND',B,EXTEND
         CMND     'SWITCH',B,SWITCH
         CMND     'DECOUPLE',B,DECOUPLE
         DCMND    'COUPLE',B,COUPLE
         DCMND    'INFORM',B,INFORM
         CMND     'ERASE',B,ERASE
         CMND     'PROMPT',B,PRMPT  SET DEFAULT PROMPT CHARACTER
         DCMND    'DEBUG',B,DEBUG
         CMND     'WHERE',B,WHERE
SIZVERB2 EQU      %-VECTOR2-1       CSECT LENGTH = NUM CMNDS
*
*  THE FOLLOWING TWO TABLES ARE BIT PARALLEL TO VERB1 & VERB2.
*  A 1 BIT INDICATES THAT THE COMMAND MAY BE PRECEDED BY 'DONT'
*
DBITS1   DATA     DBIT1             GENERATES SIZVERB1/32 WORDS
DBITS2   DATA     DBIT2             GENERATES SIZVERB2/32 WORDS
         USECT    TEL
*
*  THE FOLLOWING PAIRS ARE EXECUTED BY THE SCANCVT ROUTINE
*
SCNVBSIZ DATA     SIZVERB1          FOR SINGLE WORD SEARCH
         DATA     SIZVERB2          FOR DOUBLEWORD SEARCH
*
SCNVERB  CW,D1    VERB1,R5
         CD,D1    VERB2,R5
*
VECTORS  EXU      VECTOR1,R5
         EXU      VECTOR2,R5
*
DCMPRS   CW,SR1   DBITS1,R5
         CW,SR1   DBITS2,R5
         TITLE    'SUB-ROUTINES'
         PAGE
*
* THE FOLLOWING ARE ERROR AMPLIFYERS USED TO PRINT THE CORRECT MESSAGE.
*
NTJBST   LI,D1    X'030100'         ERROR CODE & SUBCODE
         LC       J:TELFLGS         IF ONLY ABORTED PROGRAM,
         BCS,4    INBREAK           THROW IT AWAY
         B        CMNERR1           TELL USER & PROMPT
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=01, SUBCODE=13                        *
*E*      DESCRIPTION:                                                  *
*E*               USER SAID START OR START UNDER WITH NO LM NAME.      *
*E*               THIS IMPLIES % FILE, BUT THERE ISN'T ONE, SO...      *
************************************************************************
STARTERR LI,D1    X'030113'         ERROR CODE & SUBCODE
         B        CMNERR1
*
BKOPT0   EQU      %
         LW,R1    IQUIT             SET IMPLIED QUIT COMMAND TO ALLOW
         STS,R1   J:TELFLGS         'CR' TO CAUSE PROCESSING OF CURRENT
         LW,R1    TELBUF            COMMAND. SAVE 1ST WORD OF COMMAND
         STW,R1   NLSAVE            FOR RESTORE AFTER NEXT READ
BKOPT    LI,R1    BKMSG
         LI,R2    5
         CAL1,1   WRITE
         B        SYN1
         PAGE
************************************************************************
*D*      NAME:    RD:USERS                                             *
*D*      CALL:                                                         *
*D*               BAL,R0   RD:USERS                                    *
*D*               CALLED BY PASSWORD AND SHOW COMMANDS                 *
*D*      REGISTERS:                                                    *
*D*               NO REGISTERS ARE PRESERVED                           *
*D*      INPUT:                                                        *
*D*               R2 - OPEN MODE. IN=1, INOUT =4                       *
*D*               J:ACCN,J:UNAME - USED TO FORM KEY FOR :USERS REC.    *
*D*               :LOGSZ - SIZE OF :USERS RECORD                       *
*D*      OUTPUT:                                                       *
*D*               USERS AUTHORIZATION RECORD IN MEMORY                 *
*D*               R3 - ADDRESS OF RECORD IN CORE                       *
*D*      SCRATCH:                                                      *
*D*               R1,R4,R5,R6,SR3,SR4,D1,D3,D4                         *
*D*      DATA:                                                         *
*D*               OPUSR, WORD 0, IS USED TO FORM WORD 0 OF READ FPT    *
*D*      DESCRIPTION:                                                  *
*D*               A BUFFER IS CREATED IN TELSTACK & THE :USERS         *
*D*               KEY IS PLACED IN IT.  :USERS IS OPENED IN THE MODE   *
*D*               SPECIFIED IN R2.  THE RECORD IS THEN READ IN ON      *
*D*               TOP OF THE KEY.  THE CALLER MUST RESTORE THE         *
*D*               TELSTACK SPACE, EXCEPT IF ERRORS OCCUR WHILE         *
*D*      ACCESSING :USERS.                                             *
************************************************************************
RD:USERS EQU      %
         LW,R3    TELSTACK          CREATE BUFFER...
         AI,R3    1
         BUMP     LOGSIZE+RWUSRSZ,R1
*
*  NOW FORM THE KEY FOR :USERS IN FRONT OF THE BUFFER.
*  KEY IS TEXTC ACCOUNT,BLANK,NAME
*
CONCAT   EQU      %
         LI,R4    0                 INITIALIZE COUNT
         LI,R5    -8                FOR 8 CHARACTER ACCOUNT
CONCATA  AI,R4    1                 COUNT THE CHAR
         LB,R6    J:ACCN+2,R5       GET ACCOUNT CHAR.
         CI,R6    ' '               IS IT BLANK?
         BE CONCATB                 YES
         STB,R6   *R3,R4            NO, STORE IT
         BIR,R5   CONCATA           DO NEXT CHAR.
         LI,R6    ' '               BLANK FOR SPACER
         AI,R4    1                 COUNT SPACER
CONCATB  STB,R6   *R3,R4            STORE SPACER
         LI,R5    -12               FOR 12 CHAR USER NAME
CONCATN  LB,R6    J:UNAME+3,R5      GET NAME CHAR
         CI,R6    ' '               IS IT BLANK?
         BE       CONCATE           YES, ALMOST DONE...
         AI,R4    1                 NO, COUNT IT
         STB,R6   *R3,R4            STORE CHAR.
         BIR,R5   CONCATN           DO NEXT
CONCATE  STB,R4   *R3               STORE COUNT
*
*  NOW CHANGE ACCOUNT TO :SYS & DO THE OPEN
*
         LCI      2
         LM,R5    SECAC
         LM,D3    J:ACCN            SAVE USER'S ACCOUNT
         STM,R5   J:ACCN
         LI,SR3   0                 SET UP TO CHECK FOR ERRORS
         CAL1,1   OPUSR             OPEN :USERS
         LCI      2                 RESTORE USER'S
         STM,D3   J:ACCN               ACCOUNT
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=05, SUBCODE=00                        *
*E*      DESCRIPTION:                                                  *
*E*               :USERS WAS BUSY WHEN ATTEMPTING OPEN INOUT           *
************************************************************************
         CI,SR3   0                 ANY ERROR ON OPEN?
         BE       GOTUSRO           NO, EVERYTHING FINE
*
* SINCE M:TEL ADDR IS LESS THAN X'10000', WE NEEDN'T WORRY
* ABOUT BIT 15 EVER.
         SLS,SR3  -16               RIGHT JUSTIFY ERROR CODE
         CI,SR3   X'1402'           IS :USERS BUSY?
         BNE      %+3               NO, SOME OTHERR ERROR
         LI,D1    X'030500'         YES, TELL USER
         B        R:UERR
         SPACE    5
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=05, SUBCODE=01                        *
*E*      DESCRIPTION:                                                  *
*E*               I/O ERROR OF SOME SORT ON TRYING TO OPEN :USERS      *
************************************************************************
         LI,D1    X'030501'         ERROR CODE & SUBCODE
         B        R:UERR
*
* MOVE READ FPT TO STACK & DO READ
*
GOTUSRO  EQU      %
         LCI      6                 SIZE OF FPT
         LM,R5    RWUSR             MOVE
         STM,R5   LOGSIZE,R3           FPT TO STACK
         CAL1,1   LOGSIZE,R3        READ THE USER'S RECORD
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=05, SUBCODE=02                        *
*E*      DESCRIPTION:                                                  *
*E*               I/O ERROR READING :USERS RECORD                      *
************************************************************************
         CI,SR3   0                 ANY ERROR?
         BNEZ     *R0               NOPE...
         LI,D1    X'030502'         ERROR CODE & SUBCODE
R:UERR   BUMP     -(LOGSIZE+RWUSRSZ),R5   CLEAN UP STACK
         B        CMNERR1
*
         PAGE
************************************************************************
*D*      NAME:    FLOP                                                 *
*D*      CALL:                                                         *
*D*               BAL,SR4   FLOP                                       *
*D*      REGISTERS:                                                    *
*D*               PRESERVES ALL REGISTERS EXCEPT R0                    *
*D*      INPUT:                                                        *
*D*               R7-SR1  -  FILE PASSWORD OR ZEROES                   *
*D*               SR2-SR3  -  FILE ACCOUNT OR ZEROES                   *
*D*               D1-D3  -  FILE NAME (NON-TEXTC), MAX 11 CHARS        *
*D*      OUTPUT:                                                       *
*D*               R0 - ZERO IF NO ERROR, OTHERWISE CONTAINS            *
*D*                    ERROR CODE, RIGHT JUSTIFIED.                    *
*D*      DATA:                                                         *
*D*               OPUSR - WORD 0 OF OPEN FPT                           *
*D*               NAME - FILE NAME VLP CONTR WD                        *
*D*               PACC - ACCOUNT VLP CONTR WD                          *
*D*               PPAS - PASSWORD VLP CONTR WD                         *
*D*      INTERFACE:                                                    *
*D*               NFND - CONVERTS FILE NAME TO TEXTC                   *
*D*      DESCRIPTION:                                                  *
*D*               A TEST OPEN FPT IS BUILT IN THE CONTEXT PAGE AT      *
*D*               'FLOPBUF'.  MODE IS SET TO OUT SO SAVE ROUTINE       *
*D*               CAN USE THE FPT BY TURNING OFF THE TEST BIT.         *
*D*               SINCE THE DCB IS NOT OPENED, THE CALLER NEED NOT     *
*D*               CLOSE IT.                                            *
************************************************************************
FLOP     PUSH     15,R1
         LW,R1    OPUSR             GET FPT WORD 0
         OR,R1    Y0008             TURN ON TEST BIT
         LW,R2    FLOPBITS          PARAM. PRES. BITS
         LI,R3    RFE               ERR
         LI,R4    RFE               ABN
         LI,R5    1                 ORG = CONSEC
         LI,R6    1                 ACC = SEQUEN
         LCI      6                 STORE FPT,
         STM,R1   FLOPBUF              WORDS 0-5
         LI,R6    2
         STW,R6   FLOPBUF+6         MODE = OUT
         STW,R6   FLOPBUF+7         DISP = SAVE
         LW,R6    PPAS              SKELETON PASSW VLP
         CI,R7    0                 IS PASSWORD PRESENT?
         BE       %+2               NO
         AI,R6    X'0200'           YES, TURN ON SIGNIF.
         LCI      3
         STM,R6   FLOPBUF+15        INSERT PASSWORD
         LW,SR1   PACC              SKELETON ACCOUNT VLP
         LCI      3
         STM,SR1  FLOPBUF+12        INSERT ACCOUNT
         BAL,SR3  NFND              MAKE NAME TEXTC
         LW,R5    NAME
         LCI      4
         STM,R5   FLOPBUF+8         INSERT NAME
         LI,SR3   0                 CLEAR ERROR RETURN
         CAL1,1   FLOPBUF           DO THE OPEN
         LB,R0    SR3               POSITION ANY ERROR CODE
         PULL     15,R1
         B        *SR4
RFE      B        *SR1              ERROR RETURN TO CAL+1
         PAGE
* THE 'NFND' ROUTINE IS USED WHEN A LMN HAS BEEN PRESENTED AS A COMMAND.
* IT FORMS A TEXTC LMN FORMAT IN REGS 6,7 AND 8. ENTRY IS WITH BAL,SR3.
* THE INPUT LMN MUST BE IN D1, D2 AND D3.
*
NFND     PUSH     2,R4
         LI,R4    0
         LD,R6    VERB2             BLANK FILL BUFFER
         LW,SR1   VERB1
NFND1    LB,R5    D1,R4
         CI,R5    C' '
         BE       NFND2
         AI,R4    1
NFND1A   EQU      %
         STB,R5   R6,R4
         B        NFND1
NFND2    EQU      %
         CI,R4    1                 ONE BYTE FILE NAME
         BE       NFND3             MIGHT BE IDG FILE FOR USER X'40'
NFND2A   EQU      %
         STB,R4   R6                INSERT COUNT
         PULL     2,R4
         B        *SR3
NFND3    LH,R4    R6                USER X'40' GETS BAD IDG FILES
         CI,R4    X'4000'           X'0100' NOT X'030040C7'
         BE       NFND4
         LI,R4    1
         B        NFND2A            OK - NOT THIS CASE
NFND4    LI,R4    2                 ELSE I^SERT USER# X'40'
         B        NFND1A            KEEP LOOKING FOR TERM. BLANK
         PAGE
*
* THE SCAN SUB-ROUTINE PROGRESSES THROUGH THE INPUT COMMAND PICKING UP
* THE NEXT FIELD. IT PROVIDES THE BOOKEEPING TO ALWAYS START AT THE
* BEGINNING OF A FIELD. FIELD TERMINATORS ARE DETERMINED BY THE CONTENTS
* OF TABLE 'TERMS'. LEADING AND TRAILING BLANKS ARE SUPPRESSED AS WELL
* AS SERVING AS A TERMINATOR. ALL DATA ENCLOSED WITHIN PARENS() IS
* IGNORED AND ANY CHARACTERS MAY BE USED.
*
* ENTRY IS MADE WITH A BAL,SR3 SCAN OR BAL,SR3 SCAN#
* A BAL TO SCAN# IS USED TO INCLUDE # AS A TERMINATOR FOR THE SET COMMAND
*   R2 =  BYTE DISPLACEMENT WITHIN INPUT FIELD(NEXT FIELDS' STARTING
*         POSITION).
*   R3 =  ADDRESS TO WHERE FIELD IS TO BE MOVED. ZERO IF NO MOVE IS TO
*         TAKE PLACE.
*   R1 =  REMAINING SIZE OF INPUT MESSAGE(ARS).
*
* ON EXIT, THE FOLLOWING IS IN THE REGISTERS:
*   R6 =  FIELD DELIMITER CHARACTER(EXCEPT EOM IS NEVER SEEN-R1=0).
*   R7 =  NUMBER OF CHARACTERS IN FIELD, EXCLUSIVE OF SEPERATORS.
*   SR1 = DESTROYED.
*   R5 =  INDEX INTO TERMS TABLE(CHARACTER TYPE THAT STOPPED THE SCAN).
*   R1 =  AS ABOVE BUT DECREMENTED BY NUMBER OF CHARACTERS SCANNED.
*   R2 =  AS ABOVE POSITIONED TO START OF NEXT FIELD
*
* NOTE-R1=0 IMPLIES END OF MESSAGE.
*
SCAN     LI,R5    SIZETERM-2        SKIP # AND - SIGNS
         B        SCAN2
SCAN#    LI,R5    SIZETERM
SCAN2    LI,SR1   0
         LI,R7    0
         PUSH     R0
         LI,R0    0                 CLEAR PAREN COUNTER
         PUSH     R5                SAVE TERMS TABLE SIZE
         LI,R5    0                 PRE-SET DELIMIT VECTOR TO BLANK
LOOP     BDR,R1   LOOP1
LOOP5    PULL     R0                REMOVE TERMS TABLE SIZE FROM STACK
         PULL     R0
         B        *SR3              REMAINING BYTES
LOOP1    EQU      %
         LB,R6    TELBUF,R2         CHAR
         AI,R2    1                 AND INCREMENT TO NEXT POSITION
         CI,R6    ' '               BLANK TEST
         BE       YBLK
         CI,R6    '('               PROVIDE SKIP ON PAREN FEATURE
         BE       PARENO
         CI,R6    ')'               END PAREN SKIP
         BE       PARENC
         CI,R6    X'05'             TAB TEST-SAME AS BLANK
         BNE      TERMTST
YBLK     CI,R7    0                 TEST FOR PREVIOUS DATA
         BEZ      LOOP              IGNORE LEADING BLANKS
         AI,SR1   1                 SET BLANK FLAG
         B        LOOP              SUPPRESS TRAILING BLANKS
TERMTST  EQU      %                 SCAN FOR TERMINATING CHARACTERS
         CI,R0    0
         BE       TERMTST1
         B        YBLK              FORCE BLANK LOGIC DURING SKIP
TERMTST1 EQU      %
         LW,R5    *TELSTACK         GET TERMS TABLE SIZE
         CB,R6    TERMS,R5
         BE       LOOP+1
         BDR,R5   %-2
         CI,SR1   0                 NOT A TERMINATOR-TEST BLANK FLAG
         BE       CHAROK            JUMP IF NOT SET
         AI,R1    1                 RESET POSITION TO START OF NEW FIELD
         AI,R2    -1
         LI,R6    ' '               FORCE BLANK DELIMITER
         B        LOOP+1
* NOTE:  MAX FIELD LENGTH =11.  THE FOLOWING TEST IS SPECIAL
*        CASE FOR THE WHERE COMMAND.
CHAROK   CI,SR3   WHSC
         BE       CHAROK5
         CI,SR3   DCBSCAN
         BE       CHAROK6
         CI,7     11
         BNE      CHAROK5
         LI,SR3   CHKULM            TOO MANY CHARS.
         B        LOOP5
CHAROK5  CI,R3    0                 IS DATA TO BE MOVED
         BE       %+2               NO
         STB,R6   *R3,R7            YES
         AI,R7    1                 COUNT CHARACTER
         B        LOOP              AND GO FOR NEXT ONE
CHAROK6  CI,R7    31
         BNE      CHAROK5
         LI,SR3   CHKULM
         B        LOOP5
PARENO   AI,R0    1                 BUMP PAREN COUNT
         B        LOOP
PARENC   AI,R0    -1                DECREMENT PAREN COUNT
         BGEZ     LOOP
         LI,R0    0                 CLEAR COUNT
         CI,R7    0                 STRAY CLOSE PAREN IS IGNORED
         BE       LOOP
         LI,SR3   CHKULM            BUT IS FLAGGED AS ERROR WHEN MORE
         B        LOOP5             CLOSE THAN OPENS EXIST.
*
* THE TERMS TABLE IS A BYTE TABLE CONTAINING A TERMINATOR CHARACTER IN
* EACH ENTRY. THE SCAN SUB-ROUTINE LOOKS AT THE TABLE FROM BACK TO FRONT
* AND THE FIRST ENTRY MUST BE A DUMMY. A SPACE SEPERATOR IS NOT NEEDED
* AS THIS LOGIC IS PERFORMED MORE EFFICIENTLY OUTSIDE OF THE TABLE.
* THE TERMINATOR # MUST BE LAST ENTRY IN TABLE
* THE TERMINATOR - MUST BE THE NEXT TO LAST ENTRY IN TABLE.
TERMS    DATA,1   C' '              DUM-DUMB
         DATA,1   C'?'  INDEX 1     ORDERING WITHIN
         DATA,1   C'='        2     THIS TABLE IS
         DATA,1   C'/'        3     IMPORTANT! IF
         DATA,1   C'.'        4     ADDITIONAL ENTRIES
         DATA,1   C'>'        5     ARE DESIRED,
         DATA,1   C'<'        6     ALWAYS ENTER
         DATA,1   C';'        7     THEM BELOW
         DATA,1   C','        8     THIS POINT!
         DATA,1   C''''             9
         DATA,1   '-'
         DATA,1   C'#'              10
SIZETERM EQU      BA(%)-BA(TERMS)-1
         BOUND    4
         PAGE
*
* 'STOPS' IS A VECTOR USED TO DEFINE THE TERMINATING CHARACTER AND ENTER
* THE CORRECT LOGIC. IT IS EMPLOYED DURING THE SCAN OF A COMPILE OR
* ASSEMBLE DIRECTIVE. THE FORMAT IS ORIENTED TO THE TERMS TABLE AND MAY
* NOT BE ALTERED WITHOUT CORRECT CORRESPONDENCE TO TERMS.
*
STOPS    RES      0
         B        *0                SPACE
         B        CHKULM            QUESTION MARK ILLEGAL
         B        CHKULM            =  ILLEGAL
         B        CHKULM            /  ILLEGAL
         B        FIDER             . IMPLIES COMPLEX FID
         B        CHKULM            >  ILLEGAL
         B        CHKULM            <  ILLEGAL
         B        CHKULM            ;  ILLEGAL
         B        *0                ","
         B        CHKULM
         B        CHKULM            - (MINUS)
         B        CHKULM
*
* THE FOLLOWING IS A UNIQUE TERMINATOR VECTOR FOR THE SET COMMAND.
* DEVICE CODE FIELD.
SETSTP   NOP                        THE ORDER OF THIS VECTOR IS KEYED
         B        SYNTAX            TO THE TERMS TABLE.
         B        SYNTAX            = ILLEGAL IN THIS FIELD
         B        SETFLE            / IMPLIES FILE PLIST
         B        SYNTAX            . ILLEGAL IN THIS FIELD
         B        SYNTAX            > ILLEGAL IN THIS FIELD
         B        SYNTAX            < ILLEGAL IN THIS FIELD
         NOP                        ; REQUIRES DEVICE OPTION PLIST
         B        SYNTAX            , ILLEGAL IN THIS FIELD
         B        SYNTAX
         B        SYNTAX
         B        SETNUMB           # IMPLIES DEVICE SERIAL NUMBER
         PAGE
* THE FOLLOWING IS ENTERED ANY TIME SOME UNINTELLIGIBLE ENTITY IS
* ENCOUNTERED DURING THE FIELD SCAN OR MESSAGE PARSE. THE ACTION IS TO
* PUT OUT THE ''EH'' MESSAGE AND TURN THE CONSOLE BACK TO THE USER FOR
* A RETRY. THE ENTIRE MSG MUST BE RE-ENTERED.
*
SYNTAX   EQU      %
         LW,D1    R2                SAVE ERROR POSITION
         BAL,SR4  BINDECBCD         CONVERT BINARY PLACE VALUE TO PRINT
         LCI      2
         LM,R6    EHMSG
         LI,R1    1                 PUT LAST 2 DIGITS IN MESSAGE.
         STH,D2   R7,R1
         LW,R1    TELSTACK
         AI,R1    1
         PUSH     2,R6
         LI,R2    8
         LC       J:JIT
         BCS,8    SYNWRT            ONLINE
         LI,R1    J:CCBUF
         LI,R2    80
         BAL,R4   BLANKBUF          BLANK CCBUF
         STW,R6   J:CCBUF+1         SAVE ERROR MESSAGE FOR CCI TO PRINT
         STW,R7   J:CCBUF+2
         LW,R1    Y8
         STS,R1   J:TELFLGS
         B        SYN1
SYNWRT   CAL1,1   WRITE
*
* ANY PREVIOUS PROCESSING WILL HAVE NO LASTING EFFECT AS THE A/M TABLE
* WILL BE READ FROM OISC AGAIN, THEREBY NULLIFYING ERROR MSG.
*
SYN1     EQU      %
         LW,R1    J:ABUF            RELEASE A-M BUFF AS REQ'D
         BEZ      SYN3
         LI,SR2   AMBUF
         DO1      DBUG=0            NORMAL MODE
         CAL1,8   FPFPT
         LI,R1    0
         STW,R1   J:ABUF
         LI,R1    SISET             WAS AN SI CREATED ON THIS CMD?
         LS,R1    J:TELFLGS
         BEZ      SYN3              NO
         LI,R1    -(SINOREL+1)      TURN OFF SI DONT RELEASE FLAG
         AND,R1   J:TELFLGS
         STW,R1   J:TELFLGS
SYN3     EQU      %                                                  RL2
CLEANSTACK RES    0
         LI,D1    STACK0            START OF STACK SPACE
         LW,D2    STKINIT           STACK SIZE
         STD,D1   TELSTACK          STORE STACK PTR DWD
         B        PROMPT            GIVE 'EM ANOTHER GO
*
*PROCESS A SYSTEM DETECTED ERROR.
*
SYSERR   EQU      %
         LW,R1    J:TELFLGS         TURN OFF ANY BREAK BIT
         AND,R1   NBIT30
         STW,R1   J:TELFLGS
         LI,R5    X'1FFFF'          MASK FOR STS LATER
         LB,R4    J:RNST
         CI,R4    4
         BAZ      ERRABN1
         LI,R4    32
         LI,R3    X'1FF'
         LS,R3    J:ASSIGN
         SLS,R3   1
         BCS,8    %+3
         AI,R4    -1
         B        %-3
         STS,R4   J:JIT+ERO
         LI,R4    X'B3'
         STB,R4   J:ABC
ERRABN1  EQU      %
*  READ THE ERROR MESSAGE FILE
         LI,R4    0
         LW,D1    J:JIT+ERO         GET ERROR SUBCODE
         SLD,D1   -8                AND HOLD IN D2
         LB,D1    J:ABC             GET MAJOR ERROR CODE
         SLD,D1   8                 AND MERGE SUB-CODE
         STB,R4   J:ABC             CLEAR...
         STB,R4   J:RNST            ...ERROR...
         STS,R4   J:JIT+ERO         ...CELLS
         BAL,R0   T%ERR             TYPE ERROR MSG
         LI,R2    0
         LI,R3    X'1FFFF'          MASK TO STS ERO
         STB,R2   J:ABC             CLEAR ANY ERROR FROM
         STB,R2   J:RNST            READING ERRMSG
         STS,R2   J:JIT+ERO
         SLS,D1   -8                SCRUB OFF SUBCODE
         CI,D1    X'A9'             A/M ERROR, SET BY T:AMRDWT
         BE       %+3               LOG 'EM OFF
         LW,R1    J:AMR             A/M ERROR
         BNEZ     SYSERR1           NO, GO PROMPT FOR INPUT
         LD,R6    LOGOFF            DO
         LW,SR1   VERB1              INTERPRITIVE
         LW,D2    SYS                 EXIT
         LW,D3    VERB2                 TO
         LD,SR3   VERB2                   LOGOFF
         LI,R0    JSTEP
         CW,R0    J:TELFLGS         EXIT IF AT JOB STEP...
         BANZ     %+3
         AWM,R0   J:TELFLGS         SET JOB STEP FLAG AND
         B        INBREAK           ABORT IF NOT...
         LI,0     0
         CAL1,9   1
SYSERR1  RES                        IF THERE IS A PROGRAM IN CORE
         LI,1     9                 SAVE IT FOR DEBUGGING.
         LI,6     -1                CHECK IF THERE ARE ANY ACCESSIBLE PAGES
         AND,6    J:JAC+4,1
         BDR,1    %-1
         AI,6     1
         BNEZ     %+3
         MTB,0    JB:PCDCB          OR ANY DCBS
         BEZ      XABORT
         INT,1    TSTACK+1          MAKE SURE THERE'S 2
         CI,1     38                ENVIRONMENTS IN THE STACK
         BL       XABORT            OTHERWISE ABORT (MEBBE SUA)
         LW,1     ABRTFLG           SET THE FLAG
         STS,1    J:TELFLGS
         LI,1     -19               AND THROW AWAY THE EXTRA
         MSP,1    TSTACK            ENVIRONMENT
         B        PROMPT
         PAGE
* THE FOLLOWING LOGIC IS PROVIDED TO HANDLE THE OCCURANCE OF AN ABNORMAL
* OR ERROR CONDITION INCURRED DURING THE READ OF THE USER TERMINAL.
* THE '05' ERROR IS IGNORED AS THE MESSAGE HAS ALREADY BEEN REPEATED BY
* THE TIME IT IS SENSED. OTHER ERRORS WILL OUTPUT A MESSAGE AND ALLOW
* THE USER TO TRY AGAIN.
*
*
ABNRET   STB,SR2  0,R2              S/USER PROMPT CHARACTER
         SLS,SR3  -24               POSITION ERROR CODE
         CI,SR3   X'05'
         BE       CLEANSTACK
         LI,R1    TELBUF            ECHO INPUT
         LW,R2    ARS
         BEZ      ABNRET5           NO INPUT
         SLS,R2   -17
         AI,R2    -1
         CAL1,1   WRITE
ABNRET5  EQU      %
         LI,R1    PARMSG            PUT OUT ERROR MSG.
         LI,R2    17
         CAL1,1   WRITE
         B        CLEANSTACK        GIVE ANOTHER TRY
         PAGE
************************************************************************
*D*      NAME:    MAPPER                                               *
*D*      CALL:    CALLED BY ROUTINES WHICH NEED TO LOOK AT MONITOR     *
*D*               TABLES:  PIDGMSG                                     *
*D*      REGISTERS:     USES SR1,SR2,SR3,SR4.  ALL OTHERS ARE UNTOUCHED*
*D*      INPUT:   SR1 - LINK REGISTER                                  *
*D*               SR3 - MONITOR ADDRESS TO BE EXAMINED                 *
*D*      OUTPUT:  SR2 - VIRTUAL ADDRESS (IN USER'S SPACE) OF MONITOR   *
*D*                     ADDRESS                                        *
*D*      SCRATCH: SR4 - CLOBBERED                                      *
*D*      DESCRIPTION:     MAPPER GETS TWO CONTIGUOUS DYNAMIC PAGES, FRE*S
************************************************************************
MAPPER   EQU      %
         LI,SR2   X'1FE00'          LAST VIRTUAL PAGE
         CAL1,8   MAPIT             DO THE 1ST SAD
         BCS,8    MAPFAIL           SAD FAILED; SUA
         LI,SR2   X'1FC00'          NEXT-TO-LAST VIRTUAL PAGE
         CAL1,8   MAPIT             DO THE 2ND SAD
         BCS,8    MAPFAIL           SAD FAILED; SUA
         LI,SR4   X'1FF'            MASK FOR STS
         STS,SR3  SR2               MERGE PG DISPL INTO VIRT PG ADDR
         LCI      0
         B        *SR1              RETURN
************************************************************************
*S*      SCREECH CODE:     60-04                                       *
*S*      REPORTED BY:     TEL                                          *
*S*      MESSAGE:     TEL ISSUED SINGLE USER ABORT ON YOU              *
*S*      TYPE:    SUA                                                  *
*S*      REGISTERS:     SR2 CONTAINS THE VIRTUAL PAGE ADDRESS THROUGH  *
*S*               WHICH WE WERE TRYING TO SAD.                         *
*S*      REMARKS:     THIS SCREECH INDICATES A PROBLEM IN MEMORY       *
*S*               MANAGEMENT OR A LOGIC PROBLEM IN TEL WHICH CAUSED    *
*S*               THE USER'S MAP TO BE LEFT 'DIRTY' FROM A PREVIOUS SAD*
************************************************************************
MAPFAIL  EQU      %
         CAL1,6   MSTRMODE          GET MSTRMODE
         SUA      X'60',4
************************************************************************
*D*      NAME:    UNMAPPER                                             *
*D*      CALL:    MUST BE CALLED AFTER EACH CALL TO MAPPER             *
*D*      REGISTERS:     USES SR1,SR2,SR4.  ALL OTHER ARE UNTOUCHED.    *
*D*      INPUT:   SR4 - LINK REGISTER                                  *
*D*      OUTPUT:  TWO VIRTUAL PAGES ARE RELEASED.                      *
*D*      SCRATCH: CLOBBERS SR1,SR2                                     *
*D*      DESCRIPTION:     UNMAPPER ISSUES M:FVP CALS FOR THE PAGE      *
*D*               INPUT IN SR2 AND THE PAGE FOLLOWING IT.              *
************************************************************************
UNMAPPER EQU      %
         LI,SR2   X'1FE00'          LAST VIRTUAL PAGE
         CAL1,8   FPFPT             FREE THE FIRST PAGE
         LI,SR2   X'1FC00'          NEXT-TO-LAST VIRTUAL PAGE
         CAL1,8   FPFPT             FREE THE SECOND PAGE
         B        *SR4              RETURN
         PAGE
************************************************************************
*D*      NAME:    HEX2EBC                                              *
*D*      REGISTERS:                                                    *
*D*               USES SR2,SR4,D1,D2. PRESERVES ALL OTHERS.            *
*D*      CALL:                                                         *
*D*               BAL,SR4   HEX2EBC                                    *
*D*      INPUT:                                                        *
*D*               BINARY NUMBER TO BE CONVERTED IN SR2                 *
*D*      OUTPUT:                                                       *
*D*               RETURNS EBCDIC RESULT IN D1 AND D2                   *
*D*      DESCRIPTION:                                                  *
*D*               THIS ROUTINE CONVERTS THE NUMBER IN SR2 TO           *
*D*               EBCDIC.  THE RESULT IS RIGHT JUSTIFIED AND           *
*D*               BLANK FILLED IN D1 & D2 WITH LEADING ZEROS           *
*D*               SUPPRESSED.                                          *
************************************************************************
HEX2EBC  EQU      %
         PUSH     3,R6
         LI,R6    HEX2ESKP          SET FOR SKIP LEADING ZEROS
         LD,D1    VERB2             CLEAR D1 & D2 TO BLANKS
         LI,R7    -8
HEX2EBC1 LI,SR1   0
         SLD,SR1  4                 MOST SIG. DIGIT TO SR1
         B        0,R6              NOP IF SKP FLAG SET
HEX2ESKP EQU      %
         CI,SR1   0                 IS IT LEADING ZERO?
         BE       HEX2EBC2          YES, IGNORE IT
         LI,R6    %+1               RESET SKP FLG TO BYPASS TEST
         CI,SR1   9                 NUMERIC?
         BG       %+3               NO, ALPHA
         AI,SR1   X'F0'
         B        %+2
         AI,SR1   C'A'-X'A'         TO MAKE EBCDIC
         STB,SR1  D3,R7
HEX2EBC2 BIR,R7   HEX2EBC1          DO NEXT DIGIT
         CW,D2    VERB1             ALL BLANKS MEANS ZERO VALUE
         BNE      %+2               RETURN, POSITIVE VALUE
         AI,D2    C'0'-C' '         MAKE RESULT ZERO
         PULL     3,R6              RESTORE SAVED REGS
         B        *SR4              RETURN
         PAGE
* THIS IS A SUB-ROUTINE WHICH CONVERTS A BINARY BUFFER POSITION TO A
* PRINTABLE DECIMAL VALUE.
* ENTER WITH
*        D1 = DIGIT TO BE CONVERTED(HEX).
*
* EXIT WITH
*        D1, D2 = 8 CHARACTER RESULT
*
*        REGS R1, D3 AND D4 ARE DESTROYED
*
BINDCB   RES      0                 STATUS ROUTINE ENTRY POINT
BINDECBCD EQU     %
         LI,R1    7
         LW,D4    D1
BINA     LI,D3    0
         DW,D3    XA
         AI,D3    X'F0'
         STB,D3   D1,R1
         AI,R1    -1
         BGEZ     BINA
         B        *SR4
         PAGE
* THE DECBIN ROUTINE WILL CONVERT AN EBCDIC DECIMAL CHARACTER STRING TP
* BINARY.
* ENTER WITH A BAL,SR4 AND:
*        R7 = NUMBER OF CHARACTERS
*        R3 = WORD ADDRESS OF FIRST CHARACTER
* EXIT WITH:
*        R7 = RESULT
*        OTHER REGISTERS ARE RETURNED INTACT
*
DECBIN   PUSH     3,SR2
         PUSH     R4
         LI,SR2   0
         LI,R4    0
DECBIN1  LB,SR4   *R3,R4
         AI,SR4   -X'F0'            REMOVE LEADING F
         BLZ      SYNTAX
         CI,SR4   X'A'
         BGE      SYNTAX
         MI,SR2   X'A'
         AW,SR2   SR4
         AI,R4    1
         BDR,R7   DECBIN1
         STW,SR2  R7
         PULL     R4
         PULL     3,SR2
         B        *SR4
         PAGE
*  THIS ROUTINE CONVERTS AN EBDIC HEX FIELD TO BINARY
*    ENTER: BAL,R1
*           D1 = NUMBER TO BE CONVERTED
*  EXIT  :
*           SR1 = BINARY RESULT
* WHEN A NON HEX CHARACTER IS ENCOUNTERED,  A NEGATIVE VALUE WILL
*  BE RETURNED IN SR1 TO INDICATE THE ERROR.
*
*  THE FOLLOWING REGISTERS WILL BE DESTROYED
*            R2
*             SR2
*
HEX2BIN  EQU      %
         LI,SR1   0
         LI,R2    0
SCN      LB,SR2   D1,R2
         CI,SR2   0
         BE       *R1
         CLM,SR2  F0F9
         BCR,9    CONTINU
         CLM,SR2  C1C6
         BCR,9    CONTINU-1
         B        ERBIN
         AI,SR2   9
CONTINU  SLS,SR2  28
         SLD,SR1  4
         AI,R2    1
         CI,R2    4
         BL       SCN
         B        *R1
*
ERBIN    LI,SR1   -1                INDICATE ERROR
         B        *R1
         PAGE
* THIS SUB-ROUTINE CREATES A 4 CHARACTER FILE NAME FOR % FILES. THE USER
* LINE NUMBER IS USED TO MAKE THE NAME UNIQUE. A TRAILING L OR R IS USED
* TO DIFFERENTIATE BETWEEN A ROM OR LMN FILE. THE 2 CHARACTER LINE
* ENTER ON BAL,SR4 WITH:
*        R5 = HEX L OR R RIGHT JUSTIFIED FOR DESIRED TYPE.
* EXIT WITH R5 CONTAINING COMPLETED NAME. R4 IS DESTROYED
*
NAME%    RES      0
         SLS,R5   8
         AI,R5    X'40'
         LW,R4    J:JIT
         STH,R4   R5
         B        *SR4
         PAGE
* THIS BIT OF LOGIC IS USED TO OBTAIN A COMPLEX FID PRIOR TO ENTERING
* THE NORMAL PROCESS FOR THE SI DCB. IF ACCOUNT HAS NOT BEEN SUPPLIED,
* IT IS OBTAINED FROM JIT. LMN IS CURRENTLY IN D1,D2, AND D3. RETURN
* ACCOUNT IN SR2,SR3 AND PASSWORD(OR ZEROS) IN R7,SR1.
*
FID      LI,R3    D1                GET NEXT SUB-FIELD
         PUSH     3,D1              SAVE LMN
         LB,R6    TELBUF,R2         FID.  THIS LOGIC
         CI,R6    ' '               IS FOR USE ON A LMN LOAD FROM
         BE       FID3              THE USER'S ACCOUNT
         LI,R6    0
         LD,D1    VERB2             BLANK FILL
         BAL,SR3  SCAN
         CI,R7    0                 WAS AN ACCOUNT GIVEN
         BE       FID3              NO
         PUSH     2,D1
FIDO     CI,R6    '.'               IS THERE A PASSWORD SUB-FIELD
         BE       FID4              YES
         LI,R7    0                 NO-PUT IN ZEROS
         LI,SR1   0
FID2     PULL     2,SR2             REGAIN ACCOUNT
         PULL     3,D1              REGAIN LMN
         B        *SR4              GO PROCESS THE RESULT
FID3     LCI      2                 GET ACCOUNT FROM JIT
         LM,SR2   J:ACCN
         PUSH     2,SR2
         B        FIDO
FID4     PUSH     3,D1
         LI,R3    D1
         LD,D1    VERB2
         BAL,SR3  SCAN
         STW,D1   R7
         STW,D2   SR1
         PULL     3,D1
         B        FID2
         PAGE
* THIS ROUTIN BLANKS THE SSPECIFIED BUFFER
*  R2 - BYTE COUNT
*  R1 - BUFFER ADDRESS
*
BLANKBUF EQU      %
         SLS,R1   2
         STB,R2   R1
         LI,R0    ' '
         MBS,0    3
         B        *R4
         PAGE
*
* THIS ROUTINE DELETES ANY INPUT SYMBIONT FILES IN THE SYMBIONT TABLES
* WITH THE SPECIFIED SYSID.  IF THE SYSID REFERS TO A RUNNING BATCH JOB
* THE JOB IS ABORTED(IF THE CURRENT USERS ACCOUNT = THE ACCOUNT OF
* THE SPECIFIED JOB).
*
CANCEL   EQU      %
         LI,D1    0                 0 SYSID BUFFER
         LI,D2    0
         LI,R3    D1
         BAL,SR3  SCAN              GET SYSID
         PUSH     2,R1              SAVE SCAN'S REGS
         CI,R7    4                 SYSID MUST BE < 5 CHARS
         BG       SYNTAX
         BAL,R1   HEX2BIN           CONVERT TO BINARY
         BLZ      SYNTAX            B IF ERROR
         LI,R0    X'40'             SUPPLY TRAILING BLANKS
         B        CNCL10
CNCL9    EQU      %
         STB,R0   D1,R7             IN SPECIFIED ID
         AI,R7    1
CNCL10   CI,R7    4                 DONE
         BL       CNCL9             NOT DONE
         LW,SR2   SR1               JOB ID
         LCI      2
         LM,D2    J:ACCN            USERS ACCT NUMBER
         CI,R5    4                 INDEX TO '.' - IS IT ID.ACCT
         BNE      CNCL12            NO --> GO CANCEL
         PULL     2,R1
         LI,R3    D2                BUFFER FOR ACCT
         LW,D2    VERB2             BLANKS
         LW,D3    VERB2
         BAL,SR3  SCAN              GET USER SPECIFIED ACCOUNT#.
         PUSH     2,R1
         CI,R7    8                 ACCT# IS 8 CHARACTERS OR LESS
         BG       SYNTAX
CNCL12   BAL,R4   FMTELCL           SAFTEY CLOSE
         CAL1,1   CANCL             DELETE THE JOB
         LI,D2    X'030A00'         ERRMSG KEY FOR 'CANCELED'
         XW,D1    D2                SAVE TEXT FOR ID IN D2
         BAL,SR4  T%ERRTXT          GET MSG
         STW,D2   1,R1              STORE ID INTO MSG
         AI,R2    -1
         STB,R2   *R1               MAKE MSG TEXTC
         CAL1,2   SENDCNCL
         BUMP     -(MAXMSG**-2),R2  GIVE MSG BUFFER BACK
*
MULIDS   PULL     2,R1
         CI,R1    1                 MORE ID'S?
         BLE      PROMPT            NOPE
         B        CANCEL            DO NEXT SYSID
*
CNCL20   EQU      %                 ABNORMAL ON DELETE
         LI,R2    1
         LB,R2    SR3,R2            GET SUBCODE
         SLS,R2   -1
         CI,R2    X'39'             IS IT THAT THE ID DOESNT EXIST
         BNE      CNCL30            B IF NO
************************************************************************
*E*      ERROR:   GROUP 3, CODE=0A, SUBCODE=01                         *
*E*      DESCRIPTION:     THE SYSID SPECIFIED DOES NOT MATCH THE       *
*E*               USER'S ACCOUNT OR IS INVALID.                        *
************************************************************************
         LI,D1    X'030A01'         ERROR CODE & SUBCODE
CNCLMSG  LI,R0    MULIDS            TO SCAN FOR MORE AFTER MSG
         B        T%ERR             TYPE ERROR MSG
*
CNCL30   EQU      %
         CI,R2    X'3A'             IS IT TOO LATE
         BNE      GIVEMEH           GIVE HIM EH
************************************************************************
*E*      ERROR:   GROUP 3, CODE=0A, SUBCODE=02                         *
*E*      DESCRIPTION:     THE SPECIFIED SYSID DOESN'T EXIST YET OR     *
*E*               HAS ALREADY COMPLETED                                *
************************************************************************
         LI,D1    X'030A02'         ERROR CODE & SUBCODE
         B        CNCLMSG
*
CANCL    EQU      %
         GEN,8,24   X'2F',M:TEL
         GEN,8,24 X'8C',0
         DATA     CNCL20            ABN
         PZE      *SR2
         DATA     D2
*  M:MESSGE FPT TO TELL OPERATOR 'CANCELED'
SENDCNCL EQU      %
         DATA     0
         PZE      *0
         PZE      *R1
         PAGE
*        R2       =FROM
*        R3       =TO
TELCCBUF RES      0
         LI,R2    TELBUF            FROM
         LI,R3    J:CCBUF           TO
         LW,R4    CPXUSR            COMMAND FILE??
         CW,R4    J:JIT
         BANZ     CPXBUF            YES - DONT MOVE BANG
         SLD,R2   2
BUFCOM   EQU      %
         LB,R4    JB:CCARS
         CI,R4    80                MAX CHARS
         BLE      %+3               SIZE O.K.
************************************************************************
*E*      ERROR:                                                        *
*E*               GROUP 03, CODE=08, SUBCODE=01                        *
*E*      DESCRIPTION:                                                  *
*E*               IN TRANSFERRING COMMAND TO OR FROM J:CCBUF,          *
*E*               THE SIZE IN J:PUF IS > 80.  THIS IS REALLY           *
*E*               A MORE SERIOUS PROBLEM THAN THE ERROR MSG            *
*E*               INDICATES, SINCE SOMEONE HAS UNDOUBTABLY STEPPED     *
*E*               ON THE JIT FIELD.                                    *
************************************************************************
         LI,D1    X'030801'         ERROR CODE & SUBCODE
         B        CMNERR1           TELL USER & ABORT
         CI,R2    1                 ONLY IF BANG SKIPPED WILL R2 BE
         BAZ      %+3               A NON WORD BOUNDARY VALUE...
         AI,R4    -1                DECREMENT COUNT
         STB,R4   JB:CCARS          MODIFY COUNT IN JIT
         STB,R4   R3
         MBS,R2   0
         B        *0
CCBUFTEL LI,R3    TELBUF            TO
         LI,R2    J:CCBUF
         SLD,R2   2
         B        BUFCOM
CPXBUF   LB,R4    TELBUF
         SLD,R2   2
         CI,R4    '!'
         BNE      BUFCOM            IF NOT BANG MOVE IT
         AI,R2    1                 ELSE DONT
         B        BUFCOM
         PAGE
************************************************************************
*D*      NAME:    FREEBUF1                                             *
*D*      CALL:    CALLED BEFORE EXITING OR ABORTING TEL                *
*D*      REGISTERS:     USES R4,R5,SR1,SR2,D4                          *
*D*      INPUT:   D4 - LINK REGISTER                                   *
*D*      OUTPUT:  SBUF1 IS RELEASED IF IT'S IN THE USER'S MAP          *
*D*      INTERFACE:     CALLS KILLMTEL TO RELEASE TEL'S DYNAMIC DCB    *
*D*      DESCRIPTION:     FREEBUF1 FIRST RELEASES M:TEL AND            *
*D*               THEN FREES SBUF1 (IF PRESENT).  THE CHECK IS SLIGHTLY*
*D*               REDUNDENT, SINCEE NOTHING IN TEL WOULD WORK IF WE    *
*D*               LOST SBUF1 BEFORE WE GOT HERE.                       *
************************************************************************
FREEBUF1 EQU      %
*
*  RELEASE M:TEL BEFORE LOSING PAGE
*
         BAL,R4   KILLMTEL          RELEASE M:TEL 'DCB'
         LW,5     ABRTFLG           RESET ABORTED PROGRAM FLAG
         STS,4    J:TELFLGS         WHEN LEAVING TEL
         BAL,R4   CHKBUF1           DO WE HAVE SBUF1?
         BE       FRBFXT            NO, RETURN
         STW,SR1  R4                SAVE SR1 FROM T:FVP
         LI,SR2   TELSTACK          YES,
         CAL1,8   FPFPT             LOSE IT
         LW,SR1   R4                RESTORE SR1 AND
FRBFXT   B        *D4               RETURN.
************************************************************************
*D*      NAME:    CHKBUF1                                              *
*D*      CALL:    CALLED AT INITIAL ENTRY TO TEL AND BEFORE EACH       *
*D*               EXIT OR ABORT (BY FREEBUF1).                         *
*D*      REGISTERS:     USES R4,R5,SR2.  ALL OTHERS ARE UNTOUCHED.     *
*D*      INPUT:   R4 - LINK REGISTER                                   *
*D*      OUTPUT:  RETURNS TO CALL+1 IF SBUF1 IS NOT IN USER'S MAP      *
*D*               RETURNS TO CALL+2 IF SBUF1 IS IN THE USER'S MAP      *
*D*      SCRATCH: CLOBBERS R5,SR2                                      *
*D*      DESCRIPTION:     JX:CMAP IS CHECKED FOR FPMC AT JSBUF1VP      *
************************************************************************
CHKBUF1  EQU      %
         LI,R5    JSBUF1VP          PAGE NUMBER OF SBUF1
         LI,SR2   FPMC              FREE PAGE MAP CONSTANT
         COMPARE,SR2   JX:CMAP,R5   DO WE HAVE THE BUFFER?
         BE       0,R4              NO, RETURN +1
         B        1,R4              YES, RETURN +2
*
         PAGE
         CLOSE    TYPE,DONE
         OPEN     TYPE,DONE
*
*        THE ROUTINE STATUS PRINTS OUT THE FOLLOWING LINE ON
*        THE USERS TERMINAL WHEN THE CALL   !STATUS    IS RECEIVED
*        FROM THE USER:
*                 CPU = M.MMMM CON = H:MM  INT = NN  CHG = XXXX
*        WHICH IS :
*            1.   CPU TIME IN MINUTES
*            2.   CONSOLE TIME IN HOURS AND MONUTES
*            3.   NUMBER OF INTERACTIONS
*            4.   TOTAL CHARGE UNITS
*        CONTENTS OF ALL REGESTERS CAN BE ASSUMED TO BE DESTROYED BY
*        THIS ROUTINE.
*
STATUSL  RES      0          CREATE STATUS LINE OUTPUT
         PSW,R2   TELSTACK          SAVE RETURN ADDRESS
* COMPUTE ELAPSED TIME
*
         LW,R1    TELSTACK          GET BUFFER ADDRESS FOR OUTPUT
         AI,R1    6                 MESSAGE
         PSW,R1   TELSTACK
         LI,R2    -19
STATUSL5 EQU      %
         LW,D1    TEXTJUNK+19,R2    MOVE OUTPUT TEXT TO BUILD BUFFER
         STW,D1   0,R1
         AI,R1    1
         BIR,R2   STATUSL5
         PLW,R1   TELSTACK
         LW,SR1   R1
         AI,R1    -4                SET INDEX TO HANDLE 4 WORDS FOR
*                                   TIME CAL
         DO1      FORSEC
         PSW,SR1  TELSTACK          SR1 DESTRYED BY M:TIME
         CAL1,8   TIMER
         DO1      FORSEC
         PLW,SR1  TELSTACK          RESTORE SR1
         BAL,SR4  TIMEVERT          CONVERT TIME TO BIN MIN FROM 12:00
         BAL,SR4  READAM            NOW D3 HAS MIN. FROM MIDN. IN BIN.
         LW,R1    J:ABUF            GET J:TIME FROM A/M TABLE
         LW,D3    12,R1
         CW,D2    D3                COMPARE LOGON TIME WITH LOGOFF TIME
         BGE      %+2               IS LOGOFF TIME LESS THAN LOGON TIME
         DO       FORSEC
1DAY     EQU      1440*60
         ELSE
1DAY     EQU      1440
         FIN
         AI,D2    1DAY              FOR CROSSING MIDNIGHT
         SW,D2    D3                SUBTRACT LOGON TIME FROM LOGOFF TIME
         DO       FORSEC=0
         PSW,D2   TELSTACK          SAVE MINUTES
         LI,D1    0                 SETUP D1 FOR DIVIDE INSTRUCTION.
         DW,D1   =60                GET TIME IN HRS AND MINUTES.
         STW,D1   SR2               SAVE MINUTES
         LW,D1    D2                CONVERT HOURS TO EBCDIC
         BAL,SR4  BINDCB
         LW,D1    SR2               GET MINUTES
         STW,D2   SR2               SAVE HOURS
         BAL,SR4  BINDCB            CONVERT MINUTES TO EBCDIC
         LI,D1    ' :'
         STH,D1   D2                D2 = ' :MM'
         LW,D1    SR2               GET HOURS AGAIN (IN EBCDIC)
         BAL,SR4  ZEROBK            CONVERT LEADING ZEROS TO BLANKS
         SCS,D2   8                 D2 = ':MM '
         SCD,D1   -8                D1,D2 = '   H','H:MM'
         ELSE
         LW,R7    SR1
         LI,D1    0
         DW,D1    =60               D1:=BIN SECS; D2:=BIN TOT MINS
         PSW,D2   TELSTACK          BIN TOT MINS ARE SAVED
         STW,D2   7,R7              TEMP SAVE OF BIN TOT MINS
         BAL,SR4  BINDCB            D2:=EBC SECS
         XW,D2    7,R7              D2:=BIN TOT MINS; SAVE EBC SECS
         LI,D1    0
         DW,D1    =60               D1:=BIN MINS; D2:=BIN HRS
         STW,D2   R6                R6:=BIN HRS
         BAL,SR4  BINDCB            D2:=EBC MINS
         LI,D1    ':'               ':' TO PRECEDE MM IN BUFFER
         SLS,D2   16                SHIFT EBC MINS NEXT TO ':'
         LI,R2    3                 COUNT FOR MBS
         LW,R3    R7                R3:=WA(DEST)
         SLS,R3   +2                R3:=BA(DEST)-6*4+2
         AI,R3    6*4+2             R3:=BA(DEST)
         STB,R2   R3                SET COUNT IN RU1
         LI,2     51                R2:=BA(SOURCE) (BYTE 3 OF D1)
         MBS,2    0                 :MM INTO BUFFER...
         LW,D1    R6                RESTORE BIN HRS
         BAL,SR4  BINDCB            D2:=EBC HRS
         SLS,R7   +1                R7 NOW HALF WORD ADDR
         STH,D2   6,R7              HH INTO BUFFER
         SLS,R7   -1                R7 WORD ADDR AGIAN
         LI,R1    7*4+1
         LI,D1    ':'
         STB,D1   *R7,R1            SS INTO BUFFER
         LW,D1    6,R7
         LW,D2    7,R7
         FIN
         LW,R7    SR1
         STW,D1   6,R7              PUT MINS + HRS TIME IN MESSAGE  BUFF
         STW,D2   7,R7              IN LOGON TO BE PRINTED OUT LATER
*
* COMPUTE CHARGE UNITS
*
         LW,R6    TELSTACK          GET BUFFER TO READ RATE FILE
         AI,R6       78
         BAL,R4   FMTELCL
         CAL1,1   ORATE
         CAL1,1   RRATE             READ IT
         BAL,R4   FMTELCL
         LW,R1    J:ABUF            CHECK IF THERE IS ANYTHING IN J:RAT
         LI,D1    X'70000'
         AND,D1   13,R1
         SLS,D1   -16
         BNEZ     %+2               IF J:RATE = 0, SET DEFAULTS
         AI,D1    1                 IF NOT, DEFAULT TO TABLE 1
         AW,R6    *D1,R6            SET UP POINTER IN RATE FILE
* TOTAL CPU TIME
         LW,D2    J:UTIME           TOTAL USER EXECUTE TIME
         AW,D2    J:UTIME+1         TOTAL USER OVERHEAD TIME
         AW,D2    J:PTIME           TOTAL PROCESSOR EXECUTION TIME
         AW,D2    J:PTIME+1         TOTAL PROCESSOR OVERHEAD TIME
         MW,D1    0,R6
         LD,D3    D1
* CORE-TIME
         LW,D2    J:UTIME+2         USER CORE-TIME FACTOR
         AW,D2    J:PTIME+2         PROCESSOR CORE-TIME FACTOR
         MW,D1    1,R6
         AD,D3    D1
* TERMINAL INTERACTIONS
         LI,D2    X'1FFFF'          LOAD MASK
         AND,D2   J:INTER           GET NUMBER OF CONSOLE INTERACTIONS
         MW,D1    2,R6
         AD,D3    D1
* I/O CALS
         LW,D2    J:CALCNT          GET NUMBER OF I/O CALS
         MW,D1    3,R6
         AD,D3    D1
* ELAPSED TIME
         PLW,D2   TELSTACK          LOAD ELAPSED TIME
*        TOTAL NUMBER OF I/O OPERATIONS
         LI,D1    X'FFFF'
         AND,D1   J:JIT+TPACCESS
         LI,D2    X'FFFF'
         AND,D2   J:JIT+DCACCESS
         AW,D1    D2
         LI,D2    X'FFFF'
         AND,D2   J:JIT+DPACCESS
         AW,D1    D2
         LW,D2    D1
         MW,D1    4,R6
         AD,D3    D1                CHARGES IN PENNIES
* TAPES
Z4       EQU      0
         REF,1    JB:TMTS,JB:PMTS
         LI,D2    0
         LI,R5    JB:TMTS+Z4
         LB,R0    0,R5              TAPES MOUNTED
         AW,D2    R0
         LI,R5    JB:PMTS+Z4
         LB,R0    0,R5              PACKS MOUNTED
         AW,D2    R0
         MW,D1    5,R6
         AD,D3    D1
         LW,R0    CPO+J:JIT         GET CARD INPUT COUNT
         SLS,R0  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         LW,D2    CPO+J:JIT         GET CARD PUNCH OUT COUNT
         SLS,D2  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         AW,D2    R0                ADD CD INPUT COUNT TO PUNCHOUT COUNT
         LW,R0    J:CPPO            GET PROCESSOR PAGES OUT COUNT
         SLS,R0  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         AW,D2    R0                ADD CURRENT PROCESSOR PGS OUT TO TOT
         LW,R0    CUPO+J:JIT        GET CURRENT USER PAGES OUT COUNT
         SLS,R0  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         AW,D2    R0                ADD RESULT TO TOTAL
         LW,R0    CDPO+J:JIT        GET DIAGNOSTIC PAGES OUT COUNT
         SLS,R0  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         AW,D2    R0                ADD COUNT TO TOTAL
         MW,D1    7,R6
         AD,D3    D1
         DW,D3    TENTHOU
         LW,D1    D4                CHG UNITS IN PENNIES.
CHARGES  BAL,SR4  BINDCB            CONVERT CHG UNITS TO EBCDIC
         BAL,SR4  ZEROBK            CONVERT LEADING ZEROS TO BLANKS
         LW,R7    SR1
         STW,D1   13,R7             PUT CHRG UNITS IN MSGE BUFFER IN
         STW,D2   14,R7             LOGON-PRINT OUT LATER FOR ON LINE.
*
*        GET TOTAL CPU TIME
*
         LW,D1    J:UTIME           GET TOT USER EXECU TIME FOR CURR.JOB
         AW,D1    J:UTIME+1         ADD TOT USER EXECU TIME TO TOTAL
         AW,D1    J:PTIME           ADD TOT PROCESS EXEC TIME TO TOT
         AW,D1    J:PTIME+1         ADD PROCESSOR OH TIME TO OTHER TOTAL
         DH,D1    =X'00030000'      CONVERTS TICS TO MINUTES
         BAL,SR4  BINDCB            CONVERT TIME TO EBCDIC
         SLS,D1   8
         AI,D1    '.'
         BAL,SR4  ZEROBK            CONVERT LEADING ZEROS TO BLANKS
         LW,R7    SR1
         LCI      2                 MOVE TO MESSAGE AREA
         STM,D1   2,R7
*
*        GET CONSOLE INTERACTIONS
*
         LI,D1    X'1FFFF'
         AND,D1   J:INTER           STRIP OFF 1ST-1/2 WD-NO. INTERACTION
         BAL,SR4  BINDCB            CONVERT THE NUMBER TO BCD
         BAL,SR4  ZEROBK            CONVERT LEADING ZEROS TO BLANKS
         LW,R7    SR1
         STW,D2   10,R7             PUT NO. INTERACT. IN ON-LINE MSGE
*
*        GET NUMBER OF CALS
*
         LW,D1    J:CALCNT          GET NUMBER OF I/O CALS
         BAL,SR4  BINDCB            CONVERT THE NUMBER TO BCD
         BAL,SR4  ZEROBK            CONVERT LEADING ZEROS TO BLANKS
         LCI      2
         STM,D1   17,R7             STORE IN ON-LINE MSGE
*
*        FORMAT MESSAGE FOR OUTPUT
*
         LW,R4    TELSTACK          GET ADDRESS OF OUTPUT BUFFER
         AI,R4    78
         LW,R5    SR1               GET ADDRESS OF TEXT TO BE OUTPUT
         LI,R3    76                LOAD MESSAGE SIZE
         LI,R1    0                 LOAD POINTER TO PROCURING AREA
         LI,R2    0                 LOAD POINTER TO STORAGE AREA
         B        HXX
HXXL     CI,D1    ' '
         BE       HXXB
HXX      LB,D1    *R5,R1            PICKUP TEXT BYTE
HXXC     STB,D1   *R4,R2            STORE INTO BUFFER OUTPUT AREA
         AI,R2    1                 COUNT
HXXU     AI,R1    1
         BDR,R3   HXXL
         CAL1,1   TYPE
         B        DONE              FINISHED WITH ROUTINE
HXXB     RES      0                 NEXT
         LB,D1    *R5,R1
         CI,D1    ' '
         BNE      HXXC              NO
         B        HXXU              YES
DONE     RES      0                 DONE WHEN WE GET HERE
*
*********END OF ROUTINE**********
*
         PLW,R2   TELSTACK
         B        *R2               RETURN
         PAGE
* THE TIMEVERT SUB-ROUTINE PULLS THE HOUR/MINUTE TIME FROM TIMBUF AND
* CONVERTS IT INTO A BINARY, MINUTES FROM MIDNIGHT REPRESENTATION, AND
* STORES THE RESULT IN JIT.
* ENTER WITH BAL,SR4. TIMBUF MUST HAVE HAD A M:TIME DONE INTO IT.
*
*        IF SECFLAG SET, SR2 MUST CONTAIN DATA FROM M:TIME
TIMEVERT RES      0
         DO       FORSEC=0
         LW,D1     *R1
         LI,R3       12
         LI,R2    2
         BAL,SR3    DECBIN10
         STW,R4   R3                MICKEY MOUSE FOR MI INSTRUCTION
         MI,R3    60                CONVERT HOURS TO MINUTES
         PSW,R3   TELSTACK          SAVE RESULTS
         LW,D1    *R1               AND GET MINUTES VALUE
         AI,R1    1
         LW,D2    *R1
         SLD,D1   24
         LI,R3    12
         LI,R2    2
         BAL,SR3    DECBIN10
         PLW,D2   TELSTACK
         AW,D2    R4                CURRENT TIME  TO D2
         B        *SR4
         ELSE
         LB,R3    SR2               GET HRS
         MI,R3    60*60             HRS -> SECS
         STW,R3   D2                ACCRUE IN D2
         SLS,SR2  8                 SHIFY IN MINS
         LB,R3    SR2
         MI,R3    60                GET MINS -> SECS
         AW,D2    R3                ACCRUE
         SLS,SR2  8                 SHIFT IN SECS
         LB,R3    SR2               GET SECS
         AW,D2    R3
         B        *SR4              RETURN
         FIN
*
*        CHANGE   LEAD  ZEROS  INTO  BLANKS
*        D1-D2   = DCB   ALSO  ANSWER
*        D4,R1    USED
*
ZEROBK   LI,R1   -8                 CHARACTER COUNT AND BYTE POINTER
ZEROBK1  LB,D4    D1+2,R1           GET NEXT CHARACTER FROM LEFT
         CI,D4    '0'               IS IT A ZERO
         BNE      *SR4              IF NOT, EXIT
         LI,D4    ' '               IF IT IS, SUBSTITUTE A SPACE
         STB,D4   D1+2,R1
         CI,R1    -2                DON'T CONVERT LAST ZERO
         BE       *SR4
         BIR,R1   ZEROBK1
         B        *SR4
         PAGE
*
* PLIST TO OBTAIN DATE/TIME
*
TIMER    GEN,8,1,23  X'90',FORSEC,R1
*
*        COME HERE ON OPEN OR READ ERROR OF RATE FILE
*
M1RATER  BAL,R4   FMTELCL
RATEERR  RES      0
         SLD,D1   -64               ZERO CHARGE UNITS DESTINATION
         PLW,SR1  TELSTACK
         LW,SR1   TELSTACK          CALCULATE ADDRESS OF
         AI,SR1    6                 TEST AREA
         B        CHARGES           CONTINUE PROCESSING
         PAGE
*
*        RATE FILE PARAMETER LISTS
*
ORATE    RES      0
         GEN,8,24 X'14',M:TEL
         DATA     X'CF400009'       P1,P2,P5,P6,P7,P8,P10,F9,F12
         DATA     RATEERR           ERROR RETURN ADDRESS
         DATA     RATEERR           ABNORMAL RETURN ADDRESS
         DATA     10                RECOVERY TRIES
         DATA     1                 CONSECUTIVE
         DATA     1                 SEQUENTIAL ACCESS
         DATA     1                 INPUT MODE
         DATA     2                 SAVE
         DATA     X'01000202'       FILE NAME
         TEXTC    ':RATE'
         DATA     X'02010202'       ACCOUNT
         TEXT     ':SYS    '
*
RRATE    RES      0
         GEN,8,24 X'10',M:TEL
         DATA     X'F4000000'       P1,P2,P3,P4,P6
         DATA     M1RATER           ERROR AD
         DATA     M1RATER           ABN AD
         GEN,1,31   1,R6            BUFFER AREA
         DATA     288               MAXIMUM SIZE
         DATA     0                 BYTE DISPLACEMENT
*
*
*        TYPE ON USER'S TERMINAL
*
TYPE     GEN,8,24 X'11',M:UC        WRITE TO USER'S TERMINAL
         DATA     X'30000000'       P3,P4
         GEN,1,31   1,R4            BUFFER MESSAGE
         GEN,1,31 1,R2              BUFFER SIZE IN R2
         PAGE
*        CONVERTS EBCDIC STRING TO BINARY
*        R2 V NO. OF CHARACTERS
*        R3 = WORD ADDRESS OF 1ST CHARACTER
*        R4 = RESULT
*        ENTER WITH BAL ON SR3
*        CCI IS SET IF AYN ERRORS OCCURERS
*
DECBIN10 RES      0
         LI,R4    0
         LI,R5    0
DECBIN11 RES      0
         LB,R6    *R3,R4
         AI,R6    -X'F0'            REMOVE LEADING 'F'
         MI,R5    10                MULTIPLY BY 10
         BCS,4    DECBIN21          CHK FOR ILLEGAL RESULTS
         AW,R5    R6
         AI,R4    1
         BDR,R2   DECBIN11
         STW,R5   R4
         LCI      0                 SET CCI = 0 FOR GOOD RESULT
         B        *SR3              EXIT
DECBIN21 RES      0
         LCI      8                 SET CCU = 1 FOR BAD RESULT
         B        *SR3
         PAGE
TEXTJUNK RES      0
CPU      DATA,1   X'15'             MESSAGE AREA
         DATA,3   'CPU'
         TEXT     ' =  '
CPUV     TEXT     '    '            FILLED
         TEXT     '    '            FILLED
         TEXT     '  CO'
         TEXT     'N=  '
CONV     TEXT     '    '            FILLED
         TEXT     '    '            FILLED
         TEXT     ' INT'
         TEXT     ' =  '
INTV     TEXT     '    '            FILLED
         TEXT     ' CHG'
         TEXT     ' =  '
CHGV     TEXT     '    '            FILLED
         TEXT     '    '            FILLED
CALSV    TEXT     ' CAL'
         TEXT     'S = '
         TEXT     '    '            FILLED
         TEXT     '    '            FILLED
         DATA     0                 END OF MESSAGE
         END      TEL

