//KERMITT JOB (JOB),
//             'INSTALL KERMITT',
//             CLASS=A,
//             MSGCLASS=A,
//             MSGLEVEL=(1,1),
//             USER=IBMUSER,
//             PASSWORD=SYS1
//BUILD  EXEC ASMFCL,PARM.ASM='OBJECT,NODECK,XREF',
//             MAC1='SYS1.MACLIB',MAC2='SYS1.AMODGEN'
//*                                          
//ASM.SYSIN DD DATA,DLM=@@ 
KERMIT   TITLE     'KERMIT-IBM'
*----------------------------------------------------                   0000000
*   CX-80 Protocol Converter Version @ PRC/GIS      *                   0000000
*----------------------------------------------------                   0000000
         MACRO
         REGISTER
         LCLA  &N
         SPACE
***********************************************************************
*              GENERAL REGISTER EQUATES                               *
***********************************************************************
         SPACE
&N       SETA  0
.LOOP    ANOP
R&N      EQU   &N
         AIF   (&N EQ 15).OUT
&N       SETA  &N+1
         AGO   .LOOP
.OUT     ANOP
         SPACE
         MEND
         MACRO
&LABEL   BINCVRT &REG,&AREA,&DBLWRK
.*
.*  CONVERT THE CONTENTS OF &REG TO DECIMAL AND EDIT INTO &AREA.
.*  &AREA IS A FIELD OF LENGTH SIX THAT WILL CONTAIN THE INTEGER
.*  STRING WITH LEADING BLANKS SUPRESSED.  &DBLWRK IS A DOUBLE
.*  WORK SPACE.
.*
&LABEL   CVD   &REG,&DBLWRK
         MVC   &AREA.(6),=X'402020202120'
         ED    &AREA.(6),&DBLWRK+5
         MEND
****************                                                        0000000
*                                                                       0000000
*         ----> THE WRTERM AND PROMPT MACROS ARE REWRITTEN TO ALLOW     0000000
* IT TO ASSEMBLE UNDER IFOX00.                                          0000000
*                                                                       0000000
*         MACRO
*&LAB     WRTERM &MSG
*         LCLC   &MS
*         LCLA   &LN
*&MS      SETC  '&MSG'
*&LN      SETA  K'&MS
*&LN      SETA  &LN-2
*&LAB     TPUT  &MS,&LN
*         MEND
*         MACRO
*&LAB     PROMPT &MSG
*         LCLC   &MS
*         LCLA   &LN
*&MS      SETC  '&MSG'
*&LN      SETA  K'&MS
*&LN      SETA  &LN-2
*&LAB     TPUT  &MS,&LN,ASIS
*         MEND
         MACRO                                                          0000000
&LAB     WRTERM &MSG                                                    0000000
         LCLC   &LEN                                                    0000000
&LEN     SETC   'L'''                                                   0000000
&LAB     B      WRX&SYSNDX                                              0000000
WRT&SYSNDX DC   C&MSG                                                   0000000
WRX&SYSNDX TPUT WRT&SYSNDX,&LEN.WRT&SYSNDX                              0000000
         MEND                                                           0000000
         MACRO                                                          0000000
&LAB     PROMPT &MSG                                                    0000000
         LCLC   &LEN                                                    0000000
&LEN     SETC   'L'''                                                   0000000
&LAB     B      WRX&SYSNDX                                              0000000
WRT&SYSNDX DC   C&MSG                                                   0000000
WRX&SYSNDX TPUT WRT&SYSNDX,&LEN.WRT&SYSNDX,ASIS                         0000000
         MEND                                                           0000000
         MACRO
         RDTERM &BUFF
         TGET &BUFF,130
         MEND
         PRINT ON,GEN                                                   0000000
KERMIT   CSECT
*
*         ----------------------------------------
*
*  KERMIT/TSO   -
*
*  Kermit - KL10 Error-ridden Reciprocol Micro Interface Transfer
*  IBM Version 1.0
*
*  This program is the IBM MVS/TSO side of a file transfer system.
*  It can be used to transfer files between a micro and a system
*  running under MVS/TSO. It MUST be run as a Command Processor.
*  See the KERMIT manual for the complete program specifications
*  to which this program and any other component of the system
*  must adhere.
*
*  Ronald J. Rusnak, University of Chicago Computation Center
*  BITNET address, SYSRONR at UCHIVM1
*  MAILNET address, SYSTEMS.RON@UCHICAGO.MAILNET
*  ARPA forwarding address, SYSTEMS.RON%UCHICAGO@MIT-MULTICS.ARPA
*  May 1984
*
*  Developed by the modification of the IBM CMS version written by
*  Daphne Tzoar, Columbia University Center for Computing Activities
*  March 1982
*
* Copyright (C) 1984 University of Chicago
*
* Permission is granted to any individual or institution to copy
* or use this program, except for explicitly commercial purposes.
*
*
*        The following external subroutines are required:
*          -DYNALC - MVS dynamic allocation interface.
*
*
*         ----------------------------------------
*
* Note that this is an experimental version; all changes should
* be forwarded to the author.
*
         EJECT
* REGISTER USAGE -
* R1 -
* R2 -
* R3 -
* R4 -
* R5 -
* R6 -
* R7 -
* R8 -
* R9 -
* R10 -
* R11 - BASE REGISTER FOR GLOBAL DATA AREA
* R12 - PROGRAM BASE
* R13 - SAVE AREA
* R14 - SUBROUTINE LINKAGE
* R15 - SUBROUTINE LINKAGE
*
         SPACE
*        PRINT     NOGEN
         REGISTER
         IKJCPPL
         IKJUPT
         SPACE
AD       EQU       68                  DATA PACKET (ASCII 'D')
AN       EQU       78                  NAK
AZ       EQU       90                  EOF PACKET
AS       EQU       83                  INIT PACKET
AY       EQU       89                  ACK
AF       EQU       70                  FILE PACKET
AB       EQU       66                  BREAK PACKET
AE       EQU       69                  ERROR PACKET
ERCOD    EQU       12                  MEANS EOF WITH 'FSREAD'
FLG1     EQU       X'80'               IS FILE THE FIRST OR NOT
FLG2     EQU       X'40'               OVERWRITE SENT FILENAME?
FLG3     EQU       X'20'               ONE = SENT ONLY PARTIAL RECORD
FLG4     EQU       X'10'               NAK FROM MICRO(0) OR RPACK(1)?
FLG5     EQU       X'08'               ALLOCATED MORE SPACE (DMSFREE)
         EJECT
         DCBD      DSORG=(PS)
         EJECT
**********************************************************************
*                                                                    *
*        KERMIT-TSO PROGRAM                                          *
*                                                                    *
**********************************************************************
KERMIT   CSECT
         STM       R14,R12,12(R13)
         BALR      R12,0
         USING     *,R12
         LA        R14,KSAVE
         ST        R13,4(R14)
         ST        R14,8(R13)
         LR        R13,R14
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA
         L         R11,=A(PARMS)
         USING     PARMS,R11
         TM        0(R1),X'80'     IS THIS A COMMAND PROCESSOR?
         BO        NOTCP           NO, THEN REFUSE USER
*
* collect users mvs-tso prefix.
*
         L         R2,CPPLUPT-CPPL(,R1)  GET TO UPT
         XR        R3,R3                 CLEAR R3
         IC        R3,UPTPREFL-UPT(,R2)  GET LENGTH
         BCTR      R3,0
         ST        R3,PREFIXL  SAVE FOR LATER
         MVC       PREFIX(*-*),UPTPREFX-UPT(R2)  MOVE PREFIX
         EX        R3,*-6
         GTSIZE ,                  GET TERMINAL INFO
         LTR       R0,R0           IS THIS A ASCII TERMINAL?
         BNZ       TERMOK          NO, THEN DON'T WARN ABOUT CX80
*        BZ        TERMOK           GIVE WARNING MESSAGE                0000000
         WRTERM    'WARNING: USE CX-80 PROTOCOL CONVERTER ONLY'         0000000
TERMOK   WRTERM    'KERMIT-TSO VERSION 1.CX (&SYSDATE,&SYSTIME)'        0000000
*                                                                       0000000
* no translation from EBCDIC to ASCII needed in passthrough             0000000
*                                                                       0000000
*------------------------------------------------------------------     0000000
         L         R15,=A(INIT)
         BALR      R14,R15             CALL THE INITIALIZATION
         WRTERM    ' '
**********************************************************************
*                                                                    *
*        MAIN COMMAND PROCESSING ROUTINE                             *
*                                                                    *
**********************************************************************
PROMPT   PROMPT    'KERMIT-CX80>'
         RDTERM    INPUT
*
         TR        INPUT,UPPER         UPPERCASE INPUT
         LA        R1,INPUT            R1 GETS ADDRESS OF STRING
         L         R0,=F'130'          R0 GETS THE LENGTH
         L         R15,=A(PARSER)
         BALR      R14,R15             DO TOKENIZING
*
         LM        R7,R9,PARSELST      SAVE ADDR OF TOKENIZED LIST
         L         R6,0(,R7)           GET THE PTR TO FIRST OPERAND
NOPRO    MVI       ERRNUM,X'FF'        RESET ERROR FOR THIS TIME
         CLI       0(R6),C' '          BARE CARRIAGE RETURN?
         BE        PROMPT              IGNORE IT
         CLI       0(R6),C'E'          CHECK FOR 'EXIT' COMMAND
         BE        LEAVE
         CLI       0(R6),C'Q'          CHECK FOR 'QUIT' COMMAND
         BE        LEAVE
         CLI       0(R6),C'?'          NEED HELP ?
         BNE       SETCHK
         WRTERM    'Legal Commands are: '
   WRTERM    'Receive, Send, Help, Exit, Quit, Set, Status, Show .'
         B         PROMPT
SETCHK   CLC       =C'SET',0(R6)       IS IT THE SET COMMAND ?
         BE        STSWITCH
         CLC       =C'ST',0(R6)        IS IT THE STATUS COMMAND?
         BE        STATSW
         CLC       =C'SH',0(R6)        IS IT THE SHOW COMMAND?
         BE        SHOSW
         CLC       =C'HE',0(R6)        NEED HELP ?
         BE        HELPSW
         OI        FLAGS,FLG1          SET FLG1 - IT'S THE FIRST FILE
         NI        FLAGS,X'FF'-FLG2    TURN OFF OVERWRITE FLAG (INIT)
         CLC       =C'RE',0(R6)
         BNE       SS                  MAYBE IT'S A SEND COMMAND
**********************************************************************
*        PROCESS RECEIVE COMMAND                                     *
**********************************************************************
         BXH       R7,R8,RR3           GET NEXT OPERAND
         L         R6,0(,R7)           GET POINTER TO NEXT OPERAND
         CLI       0(R6),C'?'          NEED HELP?
         BNE       RR2
         WRTERM    'Specify dsname to be created for RECEIVE.'
         B         PROMPT
RR2      CLI       0(R6),C' '          MORE WORDS ?
         BE        RR3                 NO, THEN PROMPT
         MVC       DSNAMEX(80),=CL80' ' BLANK DSNAME
         LA        R1,DSNAMEX          POINT TO DSNAME BUFFER
         LA        R2,44               MAX LENGTH OF DSNAME
         SR        R5,R5               ZERO THE LENGTH
RR4      CLI       0(R6),C' '          IS THIS END OF FIELD
         BE        RR5                 YES, THEN PROCESS DSNAME
         MVC       0(1,R1),0(R6)       MOVE A CHARACTER
         LA        R6,1(,R6)           MOVE ALONG INPUT BUFFER
         LA        R1,1(,R1)           MOVE ALONG DSNAME BUFFER
         LA        R5,1(,R5)           UP THE LENGTH COUNT
         BCT       R2,RR4              KEEP LOOKING FOR END
         WRTERM    'Dsname too long'
*
*  allocate a new data set for receive
*  dynaloc will not prefix - so we have to do this by hand.
*
RR3      WRTERM    'Enter data set name for RECEIVE.'
         MVC       DSNAMEX(80),=CL80' '   BLANK FIELD
         TGET      DSNAMEX,44           GET DSNAME
         TR        DSNAMEX(80),UPPER    MAKE UPPER CASE DSN
         LR        R5,R1                  SAVE TGET LENGTH
RR5      LA        R6,DSNAMEX             SOURCE
         MVC       DSNAME(44),=CL44' ' BLANK FIELD
         LA        R2,DSNAME           PLACE TO STUFF DSNAME
         CLI       DSNAMEX,C''''       TEST IF QUOTED
         BE        GBDSNQ1             BR IF SO
*
*  we'll prefix the dsname "by hand".
*
         L         R3,PREFIXL          ELSE GET EX LEN
         MVC       0(*-*,R2),PREFIX    MOVE PREFIX TO BUFFER
         EX        R3,*-6              MOVE IT
         LA        R2,1(R3,R2)         NEXT POS IN BUFFER
         MVI       0(R2),C'.'          PUT A DOT IN THERE
         LA        R2,1(,R2)           PLACE FOR REST OF DSNAME
         B         GBDSNQ2             CONTINUE
GBDSNQ1  DS        0H                  X
         LA        R6,1(,R6)           PAST QUOTE
         S         R5,=F'2'            REDUCE LENGTH BY 2
*
*  build the parm list to the MVS dynalc routine.
*
GBDSNQ2  DS        0H
         BCTR      R5,0                DEC LEN FOR  EX
         MVC       0(*-*,R2),0(R6)     COMPLETE DSNAME
         EX        R5,*-6
         MVC       DDNAME(8),=CL8'KEROUT'
         MVC       DISP1(4),=F'0'      A NEW DATA SET
         MVC       DISP2(4),=F'1'      CATLG
         MVC       INOUT(4),=F'1'      OUTPUT
         MVC       RECFMX(4),=F'1'     FB DATA SET
         MVC       TRACK(4),=F'5'      5 TRACK ALLOC
*
* select a model dcb.  either f or v
*
         MVC       KEROUT(MODDCBFL),MODDCBF
         CLI       RFM,C'F'           DOES USER WANT FB
         BE        MAKDCB             YES
         MVC       KEROUT(MODDCBVL),MODDCBV  USE V MODEL
MAKDCB   DS        0H
*
* NOW CHECK THE LRECL AND BLKSIZE BEFORE OPEN
*
         SR        R1,R1      CLEAR R1
         IC        R1,LRECL   GET LRECL
         SR        R2,R2               CLEAR R2
         LH        R3,BLKSIZE GET BLKSIZE
         CLI       RFM,C'V'            IS THIS VARIABLE
         BE        CHKFIXD             NO, THEN CHECK AS IF FIXED
         DR        R2,R1               SEE IF BLKSIZE IS A MULTIPLE
         LTR       R2,R2                 OF THE LRECL
         BNZ       CHKBLKER            YES, THEN SET LRECL AND BLKSIZE
         LH        R3,BLKSIZE          GET BLKSIZE
         B         SETLB
CHKBLKER WRTERM    'BLKSIZE not multiple of LRECL for RECFM=F'
         B         PROMPT
CHKFIXD  SH        R3,=H'4'            ADJUST BLKSIZE
         CR        R1,R3               IS LRECL =< BLKSIZE - 4
         BNH       CHKFIXD2            YES, THEN SET LRECL AND BLKSIZE
         WRTERM    'LRECL not less than BLKSIZE - 4 FOR RECFM=V'
         B         PROMPT
CHKFIXD2 AH        R3,=H'4'            READJUST BLKSIZE
SETLB    DS        0H
         STH       R1,KEROUT+(DCBLRECL-IHADCB) STUFF IN DCB
         STH       R3,KEROUT+(DCBBLKSI-IHADCB)
         ST        R3,BLKSIZEX             BLKSIZE
         ST        R1,LRECLX               LRECL
         LOCATE    DATASET
         LTR       R15,R15             DOES DATASET EXIST?
         BNZ       RRALOC              NO, THEN ALLOC A NEW ONE
         PROMPT    'Dataset exists, reply "OK" to overwrite: '
         TGET      WRKBUFF,3
         OC        WRKBUFF(3),=CL80' '  UPPER CASE REPLY
         CLC       =C'OK',WRKBUFF
         BNE       PROMPT               BR, IF NOT OK
         MVC       DISP1,=F'1'          MAKE DISP OLD
         MVC       DISP2,=F'3'          KEEP
RRALOC   L         R15,=V(DYNALC)      -> ENTRY POINT
         LA        R1,DYNAPARM         PARMS FOR ALLOC
         BALR      R14,R15             DO IT
*
         ICM       R1,B'1111',DYNALCRC GET RETURN OCDE
         BNZ       PROMPT              BR IF FAILURE
*
* ... then we'll merge in these dcb attributes
*
MAKDCBX  DS        0H
         NI    FLAGS,X'FF'-FLG3    turn off left-over data              0000000
         OPEN      (KEROUT,(OUTPUT))
         TM        KEROUT+(DCBOFLGS-IHADCB),DCBOFOPN
         BO        GBOPNA
         WRTERM    'Open for dataset failed.'
         B         PROMPT
*
*  a breeze...
*
GBOPNA   DS        0H
         WRTERM    'Receive waiting...'
         L         R15,=A(RECEIVE)
         BALR      R14,R15             CALL RECEIVE PORTION
         LTR       R5,R15              CHECK RETURN CODE
         BNZ       LNON
         MVI       ERRNUM,X'FF'
LNON     DS        0H
*
*  close any open data sets.
*
         CLOSE     (KERIN,,KEROUT)
         MVC       OLDERR(1),ERRNUM    ERROR SETTING OF THIS RUN
         LTR       R5,R5               CHECK THE RETCODE
         BZ        PROMPT              ALL OKAY
         WRTERM    'Error in receiving file. Try again.'
         B         PROMPT              ERROR - TRY AGAIN
SS       CLC       =C'SEN',0(R6)
         BNE       ERR                 UNRECOGNIZED COMMAND
**********************************************************************
*        PROCESS SEND COMMAND                                        *
**********************************************************************
         BXH       R7,R8,SS3           NO MORE LEFT
         L         R6,0(R7)            PICK UP  NEXT OPERAND
         CLI       0(R6),C'?'          NEED HELP?
         BNE       SS2
         WRTERM    'Specify dataset name.'
         B         PROMPT
SS2      CLI       0(R6),C' '          MORE DATA ?
*
*  User wants to send a data set - well...
*
         BE        SS3                 NO, THEN PROMPT
         MVC       DSNAMEX(80),=CL80' ' BLANK DSNAME
         LA        R1,DSNAMEX          POINT TO DSNAME BUFFER
         LA        R2,44               MAX LENGTH OF DSNAME
         SR        R5,R5               CLEAR LENGTH
SS4      CLI       0(R6),C' '          IS THIS END OF FIELD
         BE        SS5                 YES, THEN PROCESS DSNAME
         MVC       0(1,R1),0(R6)       MOVE A CHARACTER
         LA        R6,1(,R6)           MOVE ALONG INPUT BUFFER
         LA        R1,1(,R1)           MOVE ALONG DSNAME BUFFER
         LA        R5,1(,R5)           UP THE LENGTH COUNT
         BCT       R2,SS4              KEEP LOOKING FOR END
         WRTERM    'Dsname too long'
         B         PROMPT
SS3      WRTERM    'Enter dataset name to send.'
         MVC       DSNAMEX(80),=CL80' '   BLANK FIELD
         TGET      DSNAMEX,44           GET DSNAME
         TR        DSNAMEX(80),UPPER    MAKE UPPER CASE DSN
         LR        R5,R1                  SAVE TGET LENGTH
SS5      LA        R6,DSNAMEX             SOURCE
         MVC       DSNAME(44),=CL44' ' BLANK FIELD
         LA        R2,DSNAME           PLACE TO STUFF DSNAME
         CLI       DSNAMEX,C''''       TEST IF QUOTED
         BE        GBDSNQ3             BR IF SO
*
*  user tests if i know how to prefix a dsname.
*
         L         R3,PREFIXL          ELSE GET EX LEN
         MVC       0(*-*,R2),PREFIX    MOVE PREFIX TO BUFFER
         EX        R3,*-6              MOVE IT
         LA        R2,1(R3,R2)         NEXT POS IN BUFFER
         MVI       0(R2),C'.'          PUT A DOT IN THERE
         LA        R2,1(,R2)           PLACE FOR REST OF DSNAME
         B         GBDSNQ4             CONTINUE
GBDSNQ3  DS        0H                  X
         LA        R6,1(,R6)           PAST QUOTE
         S         R5,=F'2'            REDUCE LENGTH BY 2
*
*  build a "control block"
*
GBDSNQ4  DS        0H
         BCTR      R5,0                DEC LEN FOR  EX
         MVC       0(*-*,R2),0(R6)     COMPLETE DSNAME
         EX        R5,*-6
         LA        R5,DSNAME+43        POINT TO END OF DSNAME
         LA        R4,44               LENGTH OF DSNAME
SSFINDL1 CLI       0(R5),C' '          IS IT BLANK?
         BNE       SSFINDL2            NO, THEN FOUND END OF DSN
         BCTR      R5,0                DECREMENT PTR
         BCT       R4,SSFINDL1         LOOP TILL FOUND
         WRTERM    'Dsname cannot be entirely blank'
         B         PROMPT
SSFINDL2 LR        R3,R5               REMEMBER END OF DSN
         LA        R2,2                TRY TO FIND 2 LEVELS
SSFINDL3 CLI       0(R5),C'.'          IS IT A DOT?
         BE        SSFINDL4            YES, THEN HANDLE IT
SSFINDL5 BCTR      R5,0                DECREMENT PTR
         BCT       R4,SSFINDL3         LOOP TILL FOUND
         B         SSFINDE             BR IF FRONT OF DSN
SSFINDL4 BCT       R2,SSFINDL5         FIND ANOTHER LEVEL
SSFINDE  MVC       FILNAM,=CL80' '     BLANK FILNAM
         LA        R5,1(,R5)           MOVE TO FRONT OF LEVEL
         SR        R3,R5               FIND LENGTH TO MOVE
         CH        R3,=H'17'           TRUNC IF TOO LONG
         BNH       *+8                 NOT TOO LONG
         LA        R3,=H'17'           FORCE MAX LENGTH
         MVC       FILNAM(*-*),0(R5)   MOVE INSTRUCTION FOR EXECUTE
         EX        R3,*-6              GO MOVE THE DATA
         STH   R3,FILNAML          SAVE LENGTH - 1
         MVC       DDNAME(8),=CL8'KERIN'
         MVC       DISP1(4),=F'2'    DISP=SHR
         MVC       DISP2(4),=F'3'    KEEP
         MVC       INOUT(4),=F'0'  INPUT
         LA        R1,DYNAPARM
         L         R15,=V(DYNALC)    GET EMTRY POINT
         BALR      R14,R15           DO IT
         ICM       R1,B'1111',DYNALCRC GET RETURN CODE
         BNZ       PROMPT
*
*  open the users data set
*
         OPEN      (KERIN,(INPUT))
         TM        KERIN+(DCBOFLGS-IHADCB),DCBOFOPN
         BO        GBOPNB
         WRTERM    'Open for dataset failed.'
         B         PROMPT
GBOPNB   DS        0H
         TM        KERIN+(DCBRECFM-IHADCB),DCBRECV IS RECFM=V
         BO        SSDELAY         YES, THEN WAIT
         TM        KERIN+(DCBRECFM-IHADCB),DCBRECF IS RECFM=F
         BO        SSDELAY         YES, THEN WAIT
         WRTERM    'Invalid RECFM, only fixed and variable supported'
         CLOSE     KERIN
         B         PROMPT
SSDELAY  DS        0H
         MVC  WRKBUFF(37),=C'Waiting ..... seconds before sending.'
         L         R1,DELAY
         SR        R0,R0
         D         R0,=F'100'
         BINCVRT   R1,WRKBUFF+7,DBLWRK
         TPUT      WRKBUFF,37
         STIMER    WAIT,BINTVL=DELAY
         B         SSWITCH
ERR      WRTERM    'Invalid command'
         B         PROMPT              INVALID COMMAND - TRY AGAIN
         SPACE     3
SSWITCH  EQU       *
         L         R15,=A(SEND)
         BALR      R14,R15             CALL SEND PORTION
         LTR       R5,R15              CHECK RETURN CODE
         BNZ       LINON
         MVI       ERRNUM,X'FF'        WORKED OK
LINON    DS        0H
*
*  close any open data sets.
*
         CLOSE     (KERIN,,KEROUT)
         MVC       OLDERR(1),ERRNUM    ERROR SETTING OF THIS RUN
         LTR       R5,R5               CHECK THE RETCODE
         BZ        PROMPT              ALL OKAY
         WRTERM    'Error in sending file. Try again.'
         B         PROMPT              ERROR - TRY AGAIN
**********************************************************************
*        PROCESS SET COMMAND                                         *
**********************************************************************
STSWITCH EQU       *
         L         R15,=A(SET)
         BALR      R14,R15             CALL "SET" SUBROUTINE
         LTR       R15,R15             CHECK RETCODE
         BZ        PROMPT
         WRTERM    'Illegal Set Command'
         B         PROMPT
**********************************************************************
*        PROCESS SHOW COMMAND                                        *
**********************************************************************
SHOSW    EQU       *
         L         R15,=A(SHOW)
         BALR      R14,R15             CALL "SHOW" SUBROUTINE
         LTR       R15,R15             CHECK RETCODE
         BZ        PROMPT
         WRTERM    'Illegal Show Command'
         B         PROMPT
**********************************************************************
*        PROCESS STATUS COMMAND                                      *
**********************************************************************
STATSW   EQU       *
         BXH       R7,R8,GIVSTAT       NO MORE LEFT
         L         R6,0(R7)            PICK UP  NEXT OPERAND
         CLI       0(R6),C'?'          NEED HELP?
         BNE       GIVSTAT
         WRTERM    'Confirm with a carriage return'
         B         PROMPT
GIVSTAT  CLI       OLDERR,X'FF'        WAS THERE AN ERROR LAST TIME?
         BNE       FAIL
         WRTERM    'Kermit completed successfully'
         B         PROMPT
FAIL     SR        R5,R5
         IC        R5,OLDERR           GET OFFSET INTO ERROR TABLE
         M         R4,=F'20'           OFFSET := ERRNUM * 20
         LA        R5,ERRTAB(R5)
*G       WRTERM    (R5),20             PRINT ERROR MSG ON SCREEN
         TPUT      (R5),20
         B         PROMPT              AND LEAVE
**********************************************************************
*        PROCESS HELP COMMAND                                        *
**********************************************************************
HELPSW   BXH       R7,R8,GIVHLP        NO MORE LEFT
         L         R6,0(R7)            PICK UP  NEXT OPERAND
         CLI       0(R6),C'?'          NEED HELP?
         BNE       GIVHLP
         WRTERM    'Confirm with a carriage return'
         B         PROMPT
GIVHLP   DS        0H
         WRTERM    'Enter ? at prompt to receive list of commands.'
         WRTERM  'Enter ? after a command to receive list of operands'
         B         PROMPT
**********************************************************************
*        PROCESS EXIT COMMAND                                        *
**********************************************************************
LEAVE    BXH       R7,R8,KRET        ANY MORE OPERANDS?
         L         R6,0(,R7)           GET ADDRESS OF OPERAND
         CLI       0(R6),C'?'          NEED HELP?
         BNE       KRET                NO, JUST LEAVE
         WRTERM    'Confirm with a carriage return'
         B         PROMPT
BADDEV   WRTERM    'An Ascii terminal must be used.'
         B         RET
NOTCP    WRTERM    'KERMIT-TSO must be running as a command processor'
         WRTERM    'Contact your local systems programmer'
         B         RET
KRET     EQU       *
RET      EQU       *
*
*  close any open data sets.
*  dynalc has a free=close so.....
*
         TM        KERIN+(DCBOFLGS-IHADCB),DCBOFOPN
         BNO       RETGB1
         CLOSE     KERIN
RETGB1   DS        0H
         TM        KEROUT+(DCBOFLGS-IHADCB),DCBOFOPN
         BNO       RETGB2
         CLOSE     KEROUT
RETGB2   DS        0H
         CLOSE     DEBUG
         L         R13,4(R13)
         L         R14,12(R13)
         LM        R0,R12,20(R13)
         BR        R14
KSAVE    DS        18F                 KERMIT'S SAVE AREA
         LTORG
         DROP      R11
         DROP      R12                 NO LONGER NEED THEM
         EJECT
**********************************************************************
*                                                                    *
*        ROUTINE TO PROCESS SET COMMAND                              *
*                                                                    *
**********************************************************************
SET      DS        0H
         STM       R14,R12,12(R13)     SAVE CALLER'S REGISTERS
         BALR      R12,0               ESTABLISH ADDRESSABILITY
         USING     *,R12
         LA        R14,SETSAVE         ADDRESS OF MY SAVE AREA
         ST        R13,4(R14)          SAVE CALLER'S
         ST        R14,8(R13)
         LR        R13,R14
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA
         L         R11,=A(PARMS)
         USING     PARMS,R11           ESTABLISH ADDRESSABILITY
         BXH       R7,R8,SETHLP
         L         R6,0(R7)            PICK UP NEXT OPERAND
         CLI       0(R6),C'?'          NEED HELP ?
         BNE       NOQ
SETHLP   WRTERM    'Blksize, Debug, Delay, End-of-line, Lrecl,'
         WRTERM    'Quote, Packet-size, Recfm, Space, Start-of-line'
         B         SETOK
**********************************************************************
*                           SET RECFM                                *
**********************************************************************
NOQ      CLC       =C'RE',0(R6)
         BNE       NOREC
         BXH       R7,R8,SETNFM        MORE OPERANDS?
         L         R6,0(R7)            PICK UP RECORD FORMAT
         CLI       0(R6),C'?'
         BNE       CHKFM
         WRTERM    'f or v (default of v)'
         B         SETOK
CHKFM    CLI       0(R6),C'V'          REDUNDANT
         BE        FMSET
         CLI       0(R6),C'F'          FIXED FORMAT?
         BNE       RECERR
FMSET    MVC       RFM(1),0(R6)        PICK UP RECFM
         B         SETOK
RECERR   WRTERM    'Fixed and variable files only'
         B         SETERR
**********************************************************************
*                         SET QUOTE                                  *
**********************************************************************
NOREC    CLC       =C'QU',0(R6)        QUOTE CHARACTER
         BNE       NOQUO
         BXH       R7,R8,SETNFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C' '          VALUE NOT SUPPLIED?
         BNE       GIVQ
SETNFM   WRTERM    '?NOT CONFIRMED'
         B         SETERR
GIVQ     CLC       =C'? ',0(R6)
         BNE       GETQUO
         WRTERM    'a single character'
         B         SETOK
GETQUO   MVC       QUOCHAR(1),0(R6)    SET NEW QUOTE CHAR
         TR        QUOCHAR(1),ETOA     GET ASCII FORM
         CLI       1(R6),C' '          IS IT ONLY ONE CHAR?
         BE        ISQOK
         WRTERM    'one character only'
         B         BADQUO
ISQOK    CLI       QUOCHAR,X'21'       CAN'T BE LESS THAN 32
         BL        BADQUO
         CLI       QUOCHAR,X'7E'       CAN'T BE LARGER THAN 126
         BH        BADQUO
         CLI       QUOCHAR,X'3E'       HAS TO BE BETWEEN 32-62
         BNH       SETOK
         CLI       QUOCHAR,X'60'       OR BETWEEN 96-126
         BNL       SETOK
BADQUO   WRTERM    'Must fall between 41-76,140,or 173-176 (octal).'
         MVC       QUOCHAR(1),DQUOTE   RESET VALUE, JUST IN CASE
         B         SETERR
**********************************************************************
*                         SET LRECL                                  *
**********************************************************************
NOQUO    CLC       =C'LR',0(R6)        LRECL SIZE
         BNE       SETBLK
         BXH       R7,R8,SETNFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C'?'          HELP ?
         BNE       GETREC
         WRTERM    'Logical Record Length (default of 80).'
         B         SETOK
GETREC   CLI       0(R6),C' '          NO VALUE GIVEN
         BNE       CALC
         WRTERM    '?not confirmed'
         B         SETERR
CALC     CLI       0(R6),X'F0'         MUST BE >= TO 0
         BL        BADREC
         CLI       0(R6),X'F9'         MUST BE <= TO 9
         BH        BADREC
         XC        PKVAR,PKVAR         EMPTY IT OUT
         SR        R4,R4               LENGTH OF NUMBER
         CLI       1(R6),C' '          TWO DIGITS?
         BNE       CALC2
         EX        R4,PCK
         B         TST
CALC2    LA        R4,1(R4)            ADD ONE
         CLI       2(R6),C' '          THREE DIGITS?
         BNE       CALC3
         EX        R4,PCK
         B         TST
CALC3    LA        R4,1(R4)            IS THERE AN ERROR?
         CLI       3(R6),C' '
         BNE       BADREC
         EX        R4,PCK
TST      CVB       R7,PKVAR
         C         R7,=F'255'          MAX OF 255 FOR LRECL
         BH        BADREC
         STC       R7,LRECL            SET THE LRECL VALUE
         B         SETOK
BADREC   WRTERM    'A number with a maximum of 255.'
         B         SETERR
**********************************************************************
*                         SET BLKSIZE                                *
**********************************************************************
SETBLK   CLC       =C'BL',0(R6)        BLOCK SIZE
         BNE       SETSPACE
         BXH       R7,R8,SETNFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C'?'          HELP ?
         BNE       GETBLK
         WRTERM    'Blocksize (default of 80).'
         B         SETOK
GETBLK   CLI       0(R6),C' '          NO VALUE GIVEN
         BNE       BLKCALC
         WRTERM    '?not confirmed'
         B         SETERR
BLKCALC  XC        PKVAR,PKVAR         EMPTY IT OUT
         SR        R4,R4               LENGTH OF NUMBER
         LA        R7,5                MAX LENGTH OF NUMBER
         LR        R5,R6               SAVE START OF STRING
BLKCALC1 CLI       0(R6),X'F0'         MUST BE >= TO 0
         BL        BADBLK
         CLI       0(R6),X'F9'         MUST BE <= TO 9
         BH        BADBLK
         CLI       1(R6),C' '          FOUND LAST DIGIT?
         BE        BLKCALC2
         LA        R4,1(R4)            COUNT NUMBER OF DIGITS
         LA        R6,1(R6)            POINT TO NEXT DIGIT
         BCT       R7,BLKCALC1         KEEP CHECKING
         B         BADBLK
BLKCALC2 EX        R4,BLKPCK
         B         BLKTST
BLKTST   CVB       R7,PKVAR
         C         R7,=F'32767'        MAX OF 32767 FOR BLKSIZE
         BH        BADBLK
         STH       R7,BLKSIZE          SET THE BLKSIZE
         B         SETOK
BADBLK   WRTERM    'A number with a maximum of 32767'
         B         SETERR
**********************************************************************
*                         SET TRACK ALLOCATION                       *
**********************************************************************
SETSPACE CLC       =C'SP',0(R6)        BLOCK SIZE
         BNE       SETEOL
         BXH       R7,R8,SETNFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C'?'          HELP ?
         BNE       GETSPC
         WRTERM    'Dataset space allocation (default of 5 tracks).'
         B         SETOK
GETSPC   CLI       0(R6),C' '          NO VALUE GIVEN
         BNE       SPCCALC
         WRTERM    '?not confirmed'
         B         SETERR
SPCCALC  XC        PKVAR,PKVAR         EMPTY IT OUT
         SR        R4,R4               LENGTH OF NUMBER
         LA        R7,5                MAX LENGTH OF NUMBER
         LR        R5,R6               SAVE START OF STRING
SPCCALC1 CLI       0(R6),X'F0'         MUST BE >= TO 0
         BL        BADSPC
         CLI       0(R6),X'F9'         MUST BE <= TO 9
         BH        BADSPC
         CLI       1(R6),C' '          FOUND LAST DIGIT?
         BE        SPCCALC2
         LA        R4,1(R4)            COUNT NUMBER OF DIGITS
         LA        R6,1(R6)            POINT TO NEXT DIGIT
         BCT       R7,SPCCALC1         KEEP CHECKING
         B         BADSPC
SPCCALC2 EX        R4,SPCPCK
         B         SPCTST
SPCTST   CVB       R7,PKVAR
         C         R7,=F'99999'        MAX OF 99999 FOR SPACE
         BH        BADSPC
         ST        R7,TRACK            SET THE ALLOCATION
         B         SETOK
BADSPC   WRTERM    'A number with a maximum of 99999'
         B         SETERR
**********************************************************************
*                         SET END-OF-LINE CHARACTER                  *
**********************************************************************
SETEOL   CLC       =C'EN',0(R6)        EOL CHARACTER
         BNE       NOEND
         BXH       R7,R8,SETNFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C' '          NOT DATA
         BNE       EOLCHAR
         WRTERM    '?not confirmed'
         B         SETERR
EOLCHAR  CLI       0(R6),C'?'          NEED HELP?
         BNE       GETEOL
         WRTERM    'A two digit number between 00 and 31 (dec).'
         B         SETOK
GETEOL   CLI       0(R6),X'F0'         MUST BE >= TO 0
         BL        BADEOL
         CLI       0(R6),X'F9'         MUST BE <= TO 9
         BH        BADEOL
         XC        PKVAR,PKVAR         USE TO CONVERT VALUE
         CLI       1(R6),C' '          INPUT MUST BE TWO CHARS
         BE        BADEOL
         CLI       2(R6),C' '          TWO CHARS, AT MAX
         BNE       BADEOL
         PACK      PKVAR(8),0(2,R6)    PICK UP TWO CHARACTERS
         CVB       R7,PKVAR            PUT PACKED DECIMAL INTO REG
         C         R7,=F'31'           MAX OF 31 DECIMAL
         BH        BADEOL
         STC       R7,SEOL             SET SEND EOL VALUE
         B         SETOK
BADEOL   WRTERM    'Must be a two digit value less than 31 (dec).'
         B         SETERR
**********************************************************************
*                         SET PACKET-SIZE                            *
**********************************************************************
NOEND    CLC       =C'PA',0(R6)        CHANGE RECEIVE PACKET SIZE
         BNE       NOPAC
         BXH       R7,R8,SETNFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C' '          NO DATA
         BNE       GETPAC
         WRTERM    '?not confirmed'
         B         SETERR
GETPAC   CLI       0(R6),C'?'          NEED HELP?
         BNE       CALC4
         WRTERM    'Receive packet size (range: 26-94 decimal).'
         B         SETOK
CALC4    CLI       0(R6),X'F0'         MUST BE >= TO 0
         BL        BADPAC
         CLI       0(R6),X'F9'         MUST BE <= TO 9
         BH        BADPAC
         XC        PKVAR,PKVAR         USE TO CONVERT VALUE
         CLI       1(R6),C' '          INPUT MUST BE TWO CHARS
         BE        BADPAC
         CLI       2(R6),C' '          TWO CHARS, AT MAX
         BNE       BADPAC
         PACK      PKVAR(8),0(2,R6)    PICK UP TWO CHARS
         CVB       R7,PKVAR            PUT PACKED DECIMAL INTO REG
         C         R7,=F'26'           THIS IS MIN
         BL        BADPAC
         C         R7,MAXPACK          THIS IS THE MAX
         BH        BADPAC
         ST        R7,RPSIZ            USE THIS VALUE NOW
         B         SETOK
BADPAC   WRTERM    'Must be between 26-94 (decimal).'
         B         SETERR
**********************************************************************
*                         SET DEBUG ON:OFF                           *
**********************************************************************
NOPAC    CLC       =C'DEB',0(R6)      IS THIS DEBUG?
         BNE       SETSOH              NO, THEN SEE IF SET SOH
         BXH       R7,R8,SETNFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C' '          IS THERE AN OPERAND?
         BE        DEBERR              NO, THEN ASK FOR ONE.
         CLC       =C'ON',0(R6)        IS IT TIME TO TURN ON
         BE        DEBON               YES, OPEN FILE
         CLC       =C'OF',0(R6)       IS IT TIME TO TURN OFF
         BE        DEBOFF              YES, CLOSE FILE
         B         DEBERR              YES, GIVE MESSAGE
DEBERR   WRTERM    'Command is SET DEBUG ON : OFF'
         B         SETERR
DEBON    OPEN      (DEBUG,(OUTPUT))
         TM        DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN  IS IT OPEN?
         BO        SETOK
         WRTERM    'Unable to open debug file, debug disabled.'
         B         SETERR
DEBOFF   CLOSE     DEBUG
         B         SETOK
**********************************************************************
*                         SET START-OF-HEADER CHARACTER              *
**********************************************************************
SETSOH   CLC       =C'ST',0(R6)       SOH CHARACTER
         BNE       NOSOH               NO, THEN TRY DELAY
         BXH       R7,R8,SETNFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C' '          NOT DATA
         BNE       SOHCHAR
         WRTERM    '?not confirmed'
         B         SETERR
SOHCHAR  CLI       0(R6),C'?'          NEED HELP?
         BNE       GETSOH
         WRTERM    'A two digit number between 00 and 31 (dec).'
         B         SETOK
GETSOH   CLI       0(R6),X'F0'         MUST BE >= TO 0
         BL        BADSOH
         CLI       0(R6),X'F9'         MUST BE <= TO 9
         BH        BADSOH
         XC        PKVAR,PKVAR         USE TO CONVERT VALUE
         CLI       1(R6),C' '          INPUT MUST BE TWO CHARS
         BE        BADSOH
         CLI       2(R6),C' '          TWO CHARS, AT MAX
         BNE       BADSOH
         PACK      PKVAR(8),0(2,R6)    PICK UP TWO CHARACTERS
         CVB       R7,PKVAR            PUT PACKED DECIMAL INTO REG
         C         R7,=F'31'           MAX OF 31 DECIMAL
         BH        BADSOH              ERROR, TOO BIG
         STC       R7,SSOH             SET SEND SOH VALUE
         STC       R7,RSOH             SET RECEIVE SOH VALUE
         B         SETOK
BADSOH   WRTERM    'Must be a two digit value less than 31 (dec).'
         B         SETERR
**********************************************************************
*                      SET DELAY VALUE                               *
**********************************************************************
NOSOH    CLC       =C'DEL',0(R6)       CHANGE RECEIVE PACKET SIZE
         BNE       SETERR
         BXH       R7,R8,SETNFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C' '          NO DATA
         BNE       GETDELAY
         WRTERM    '?not confirmed'
         B         SETERR
GETDELAY CLI       0(R6),C'?'          NEED HELP?
         BNE       DLYCALC
         WRTERM    'Receive packet size (range: 26-94 decimal).'
         B         SETOK
DLYCALC  XC        PKVAR,PKVAR         EMPTY IT OUT
         SR        R4,R4               LENGTH OF NUMBER
         LA        R7,5                MAX LENGTH OF NUMBER
         LR        R5,R6               SAVE START OF STRING
DLYCALC1 CLI       0(R6),X'F0'         MUST BE >= TO 0
         BL        BADDELAY
         CLI       0(R6),X'F9'         MUST BE <= TO 9
         BH        BADDELAY
         CLI       1(R6),C' '          FOUND LAST DIGIT?
         BE        DLYCALC2
         LA        R4,1(R4)            COUNT NUMBER OF DIGITS
         LA        R6,1(R6)            POINT TO NEXT DIGIT
         BCT       R7,DLYCALC1         KEEP CHECKING
         B         BADDELAY
DLYCALC2 EX        R4,DLYPCK
         B         DLYTST
DLYTST   CVB       R7,PKVAR
         LTR       R7,R7               THIS IS MIN
         BNP       BADDELAY
         C         R7,=F'99999'        THIS IS THE MAX
         BH        BADDELAY
         MH        R7,=H'100'          MAKE IT 100THS OF SECONDS
         ST        R7,DELAY            USE THIS VALUE NOW
         B         SETOK
BADDELAY WRTERM    'Must be between 1-99999 (DECIMAL).'
         B         SETERR
SETERR   LA        R15,4               SET A NON-ZERO RETCODE
         B         SETRET
SETOK    SR        R15,R15             RETCODE OF 0
*
SETRET   L         R13,4(R13)
         L         R14,12(R13)
         LM        R0,R12,20(R13)
         BR        R14
SETSAVE  DS        18F
PCK      PACK      PKVAR(8),0(0,R6)
BLKPCK   PACK      PKVAR(8),0(0,R5)
SPCPCK   PACK      PKVAR(8),0(0,R5)
DLYPCK   PACK      PKVAR(8),0(0,R5)
         LTORG
         DROP      R11
         DROP      R12
         EJECT
**********************************************************************
*                                                                    *
*        ROUTINE TO PROCESS SHOW COMMAND                             *
*                                                                    *
**********************************************************************
SHOW     DS        0H
         STM       R14,R12,12(R13)     SAVE CALLER'S REGISTERS
         BALR      R12,0               ESTABLISH ADDRESSABILITY
         USING     *,R12
         LA        R14,SHOWSAVE        ADDRESS OF MY SAVE AREA
         ST        R13,4(R14)          SAVE CALLER'S
         ST        R14,8(R13)
         LR        R13,R14
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA
         L         R11,=A(PARMS)
         USING     PARMS,R11           ESTABLISH ADDRESSABILITY
         BXH       R7,R8,SHONFM        ANY MORE OPERANDS
         L         R6,0(R7)            GET NEXT TOKEN
         CLI       0(R6),C'?'          NEED HELP ?
         BNE       SHOREC
         WRTERM    'State'
         B         SHOWOK
SHONFM   WRTERM    '?NOT CONFIRMED'
         B         SHOWERR
SHOREC   CLI       0(R6),C'S'          IS THIS SHOW STATE
         BNE       SHOWERR
         MVC       WRKBUFF(18),=C'Record format is .'
         MVC       WRKBUFF+17(1),RFM
         TPUT      WRKBUFF,18
         TR        QUOCHAR(1),ATOE     GET EBCDIC VERSION
         MVC       WRKBUFF(20),=C'Quote character is .'
         MVC       WRKBUFF+19(1),QUOCHAR
         TPUT      WRKBUFF,20
         TR        QUOCHAR(1),ETOA     KEEP THE ASCII FORM AROUND
         SR        R4,R4               ZERO IT OUT
         IC        R4,LRECL
         MVC       WRKBUFF(8),=C'Lrecl is'
         BINCVRT   R4,WRKBUFF+8,DBLWRK
         TPUT      WRKBUFF,14
         LH        R4,BLKSIZE
         MVC       WRKBUFF(10),=C'Blksize is'
         BINCVRT   R4,WRKBUFF+10,DBLWRK
         TPUT      WRKBUFF,16
         L         R4,TRACK
         MVC       WRKBUFF(32),=C'Space allocation is ..... tracks'
         BINCVRT   R4,WRKBUFF+19,DBLWRK
         TPUT      WRKBUFF,32
         SR        R4,R4               ZERO IT OUT
         IC        R4,SSOH
       MVC WRKBUFF(44),=C'Start-of-header character is ..... (decimal)'
         BINCVRT   R4,WRKBUFF+28,DBLWRK
         TPUT      WRKBUFF,44
         SR        R4,R4               ZERO IT OUT
         IC        R4,SEOL
         MVC WRKBUFF(40),=C'End-of-line character is ..... (decimal)'
         BINCVRT   R4,WRKBUFF+24,DBLWRK
         TPUT      WRKBUFF,40
         MVC WRKBUFF(38),=C'Receive packet size is ..... (decimal)'
         L         R1,RPSIZ
         BINCVRT   R1,WRKBUFF+22,DBLWRK
         TPUT      WRKBUFF,38
         MVC       WRKBUFF(28),=C'Delay value is ..... seconds'
         L         R1,DELAY
         SR        R0,R0
         D         R0,=F'100'
         BINCVRT   R1,WRKBUFF+14,DBLWRK
         TPUT      WRKBUFF,28
         MVC       WRKBUFF(9),=C'Debug is '
         MVC       WRKBUFF+9(3),=C'off'
         TM        DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN  IS IT OPEN?
         BZ        SHOWDBG
         MVC       WRKBUFF+9(3),=C'on '
SHOWDBG  TPUT      WRKBUFF,12
         B         SHOWOK
SHOWERR  LA        R15,4               SET A NON-ZERO RETCODE
         B         SHOWRET
SHOWOK   SR        R15,R15             ZERO RETCODE
*
SHOWRET  L         R13,4(R13)
         L         R14,12(R13)
         LM        R0,R12,20(R13)
         BR        R14
SHOWSAVE DS        18F
         LTORG
         DROP      R11
         DROP      R12
*
         EJECT
**********************************************************************
*                                                                    *
*        ROUTINE TO INITIALIZE PARAMETER AREA                        *
*                                                                    *
**********************************************************************
INIT     DS        0H
         STM       R14,R12,12(R13)
         BALR      R12,0
         USING     *,R12
         LA        R14,ISAVE
         ST        R13,4(R14)
         ST        R14,8(R13)
         LR        R13,R14
*
* INITIALIZE VARIABLES THAT GET CHANGED DURING EXECUTION
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA LIST
         L         R11,=A(PARMS)
         USING     PARMS,R11
         XC        SNDPKT,SNDPKT       CLEAR OUT THESE BUFFERS
         XC        RECPKT,RECPKT
         XC        INPUT,INPUT
         LA        R0,BUF
         LA        R1,L'BUF            ; CLEAR OUT THE BUFFER.
         SR        R15,R15
         MVCL      R0,R14
         LA        R0,RBUF
         LA        R1,L'RBUF
         SR        R15,R15
         MVCL      R0,R14
         XC        SDAT,SDAT
         XC        RDAT,RDAT
         XC        N,N                 SET VARIABLES TO ZERO
         XC        NUM,NUM
         XC        LSDAT,LSDAT
         XC        LRDAT,LRDAT
         MVI       FLAGS,X'00'         CLEAR ALL FLAGS
         XC        SAVPL,SAVPL
         XC        RSAVPL,RSAVPL
         XC        NUMTRY,NUMTRY
         MVC       FILNAM,=18X'20'     BLANK OUT FILNAM & NAME
         MVC       NAME,=18X'20'
         MVI       PREV,X'00'
         MVI       ERRNUM,X'FF'        SET TO NO ERROR FOR NOW
         MVI       OLDERR,X'FF'        SAME HERE
         XC        PKVAR,PKVAR         ZERO IT OUT
         XC        OLDTRY,OLDTRY
         XC        SPSIZ,SPSIZ
         XC        SIZE,SIZE
         XC        TEMP,TEMP
         XC        STORLOC,STORLOC
         MVC       DELAY,DDELAY        SET DEFAULT DELAY
         MVC       LRECL(1),DLRECL     SET DEFAULTS, JUST IN CASE
         MVC       BLKSIZE(2),DBLKSIZE SET DEFAULTS, JUST IN CASE
         MVC       TRACK,DTRACK        DEFAULT SPACE OF 5 TRACKS
         MVC       RFM(1),DRECFM
         MVC       QUOCHAR(1),DQUOTE
         MVC       RQUO(1),DQUOTE
         MVC       REOL(1),DEOL
         MVC       SEOL(1),DEOL
         MVC       SSOH(1),DSOH
         MVC       RSOH(1),DSOH
         MVI       STATE,C' '
         MVI       STYPE,C' '
         MVI       RTYPE,C' '
*
INITRET  L         R13,4(R13)
         L         R14,12(R13)
         LM        R0,R12,20(R13)
         BR        R14
ISAVE    DS        18F
         LTORG
         DROP      R11
         DROP      R12
         EJECT
**********************************************************************
*                                                                    *
*        ROUTINE TO PROCESS SEND COMMAND                             *
*                                                                    *
**********************************************************************
SEND     DS        0H
         STM       R14,R12,12(R13)     SAVE CALLER'S REGISTERS
         BALR      R12,0               ESTABLISH ADDRESSABILITY
         USING     *,R12
         LA        R14,SENDSAVE        ADDRESS OF MY SAVE AREA
         ST        R13,4(R14)          SAVE CALLER'S
         ST        R14,8(R13)
         LR        R13,R14
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA
         L         R11,=A(PARMS)
         USING     PARMS,R11           ESTABLISH ADDRESSABILITY
         MVI       STATE,C'S'
         SR        R3,R3
         ST        R3,N
         ST        R3,NUMTRY
OKSND    TM        FLAGS,FLG1          IS THIS THE FIRST FILE?
         BNO       SLOOP
         NI        FLAGS,X'FF'-FLG1    TURN OFF FIRST FILE FLAG
**********************************************************************
*        MAIN SEND LOOP                                              *
**********************************************************************
SLOOP    CLI       STATE,C'D'          SEND DATA STATE
         BE        SDATA
         CLI       STATE,C'F'          SEND FILE STATE
         BE        SFILE
         CLI       STATE,C'S'          SEND INIT STATE
         BE        SINIT
         CLI       STATE,C'Z'          END OF FILE STATE
         BE        SEOF
         CLI       STATE,C'B'          SEND BREAK STATE
         BE        SBREAK
         CLI       STATE,C'C'          COMPLETE STATE
         BE        COMPLETE
         CLI       STATE,C'A'          ABORT STATE
         BE        ABORT               ERROR - GO TO ABORT STATE
         MVI       ERRNUM,X'02'        UNRECOGNIZED STATE
         B         ABORT               OTHERWISE, DIE
**********************************************************************
*        CREATE AND SEND INITIALIZATION PACKET                       *
**********************************************************************
SINIT    CLC       NUMTRY,IMXTRY       SEE IF CAN SEND
         BL        OK1                 YES WE CAN
         MVI       STATE,C'A'          NOPE, GO INTO ABORT STATE
         B         SLOOP
OK1      L         R5,SPACE            MAKE CHARACTER PRINTABLE
         A         R5,RPSIZ            ADD REC PACKET SIZE
         STC       R5,SDAT             ADD SIZE INFO TO BUFFER
         L         R5,SPACE
         A         R5,=F'8'            8 FOR TIMEOUT
         STC       R5,SDAT+1
         L         R5,SPACE            SEND ZERO + " " FOR NPAD
         STC       R5,SDAT+2           WE'RE THE SLOW GUYS
         SR        R5,R5               PAD WITH NULLS
         L         R3,O1H
         XR        R5,R3               CTL FUNCTION (XOR WITH 64)
         STC       R5,SDAT+3           DON'T NEED PADCHAR EITHER
         SR        R5,R5               ZERO IT OUT FOR NEXT TWO GUYS
         IC        R5,REOL             EOL CHAR I NEED
         A         R5,SPACE            MAKE PRINTABLE
         STC       R5,SDAT+4
         IC        R5,QUOCHAR          MY QUOTE CHAR
         STC       R5,SDAT+5
         L         R3,NUMTRY
         LA        R3,1(R3)            INCREMENT TRIAL COUNTER
         ST        R3,NUMTRY
         MVI       STYPE,AS            PACKET TYPE = SEND INITIATE
         MVC       LSDAT(4),=F'6'     BUFFER SIZE FOR THIS SEND
         L         R4,DSSIZ            GET DEFAULT SPSIZ
         S         R4,FIVE             FOR NOW, USE DEFAULT SPSIZ....
         ST        R4,SIZE             ....TO SET VALUE OF SIZE
         L         R15,=A(SPACK)       GET ADDRESS OF ROUTINE 'SPACK'
         BALR      14,15               SAVE * AND GO TO SPACK
         CLI       STATE,C'A'
         BE        ABORT
         L         15,=A(RPACK)        GET ADDRESS OF 'RPACK'
         BALR      14,15               SAVE * AND GO TO RPACK
         CLI       RTYPE,AE            ERROR PACKET?
         BNE       Y1                  NO, THEN MAYBE AN ACK
         MVI       ERRNUM,X'0A'        MICRO DIED
         MVI       STATE,C'A'          AND DIE
         B         SLOOP
Y1       CLI       RTYPE,AY            SEE IF GOT ACK
         BNE       N1                  MAYBE IT'S 'N'
         CLC       N,NUM               CHECK MESSAGE NUMBERS
         BE        AOK1
         MVI       ERRNUM,X'08'        PACKET LOST
         B         SLOOP
AOK1     SR        R4,R4               ZERO OUT REGISTER
         IC        R4,RDAT             USE SPSIZ THE MICRO WANTS
         S         R4,SPACE            SUBTRACT THE ' '
         C         R4,=F'26'           BUFFER HAS TO BE >= 26
         BNL       CH1                 SO FAR, SO GOOD
         MVI       STATE,C'A'          ABORT THEN
         MVI       ERRNUM,X'00'        INVALID DATA-PACKET-SIZE ERROR
         B         SLOOP
CH1      C         R4,MAXPACK          MAX PACKET SIZE
         BNH       CH2                 CONTINUE IF <= TO MAX
         MVI       STATE,C'A'          DIE
         MVI       ERRNUM,X'00'        INVALID DATA-PACKET-SIZE ERROR
         B         SLOOP
CH2      STC       R4,SPSIZ+3          USE SPSIZ THE MICRO WANTS
         S         R4,FIVE
         ST        R4,SIZE             SET SIZE TO SPSIZ-5
         CLC       LRDAT(4),=F'4'      USING DEFAULTS?
         BNH       NOCHG               YUP
         LA        R5,RDAT             POINTER TO THE BUFFER
         SR        R7,R7
         IC        R7,4(R5)            SEOL MICRO WANTS
         S         R7,SPACE            UNCHAR (IE - SUBTRACT SPACE)
         STC       R7,SEOL
NOCHG    MVI       STATE,C'F'          PUT INTO SEND FILE STATE
         XC        NUMTRY,NUMTRY       RESET TO ZERO
         L         R3,N
         LA        R3,1(R3)            ADD ONE
         ST        R3,N                STORE VALUE INCREMENTED BY 1
         NC        N(4),=X'0000003F'   MASK TO GET MOD 64
         B         SLOOP
N1       CLI       RTYPE,AN            SEE IF IT'S 'N'
         BNE       AB1                 IF NOT, DIE
         TM        FLAGS,FLG4          DID MICRO NAK OR I REJECTED?
         BO        SLOOP               LEAVE ERR MSG AS IS IF I DID
         MVI       ERRNUM,X'09'        MICRO NAK'ED
         B         SLOOP
AB1      MVI       STATE,C'A'          ELSE, ABORT
         MVI       ERRNUM,X'07'        UNRECOGNIZED PACKET TYPE
         B         SLOOP
**********************************************************************
*        CREATE AND SEND FILE PACKET                                 *
**********************************************************************
SFILE    CLC       NUMTRY,MAXTRY       EXCEEDED NO. OF TRIES ALLOWED?
         BL        OK2                 NOPE, STILL OK
         MVI       STATE,C'A'          ABORT IF YES
         B         SLOOP
OK2      DS        0H
         TR        FILNAM,ETOA
         LH    R5,FILNAML          GET LENGTH OF FILENAME - 1
         MVC   SDAT(*-*),FILNAM    USE FOR EXECUTE
         EX    R5,*-6              GO MOVE FILENAME TO BUFFER
         LA    R5,1(,R5)           UP THE FILE LENGTH TO BE EXACT
         L         R3,NUMTRY
         LA        R3,1(R3)            INCREMENT TRIAL COUNTER
         ST        R3,NUMTRY
         MVI       STYPE,AF            PACKET TYPE = FILE HEADER
         ST        R5,LSDAT            SET BUFFER SIZE
         TR        FILNAM,ATOE
SNDFIL   L         R15,=A(SPACK)       GET ADDRESS OF 'SPACK'
         BALR      14,15               SAVE * AND GO TO SPACK
         CLI       STATE,C'A'
         BE        ABORT
         L         15,=A(RPACK)        GET ADDRESS OF 'RPACK'
         BALR      14,15               SAVE * AND GO TO RPACK
         CLI       RTYPE,AE            ERROR PACKET?
         BNE       Y2                  MAYBE AN ACK
         MVI       ERRNUM,X'0A'        MICRO DIED
         MVI       STATE,C'A'          SO WE DO TOO
         B         SLOOP
Y2       CLI       RTYPE,AY            SEE IF GOT ACK
         BNE       N2                  MAYBE GOT AN 'N'
         CLC       N,NUM               DO WE HAVE THE CORRECT ACK?
         BE        AOK2
         MVI       ERRNUM,X'08'        MISSING A PACKET SOMEWHERE
         B         SLOOP
AOK2     MVI       STATE,C'D'          PREPARE FOR SEND-DATA STATE
         XC        NUMTRY,NUMTRY       RESET COUNTER
         L         R3,N
         LA        R3,1(R3)            ADD ONE
         ST        R3,N                STORE INCREMENTED VALUE
         NC        N(4),=X'0000003F'   MASK TO GET MOD 64
         L         15,=A(GTCHR)
         BALR      14,15               DO GET-CHAR AND COME BACK
         B         SLOOP
N2       CLI       RTYPE,AN
         BNE       AB2                 ELSE, DIE
         TM        FLAGS,FLG4          DID MICRO NAK OR I REJECTED?
         BO        SLOOP               LEAVE ERR MSG AS IS IF I DID
         MVI       ERRNUM,X'09'        MICRO NAK'ED
         B         SLOOP
AB2      MVI       STATE,C'A'          ELSE, ABORT
         MVI       ERRNUM,X'07'        UNRECOGNIZED PACKET TYPE
         B         SLOOP
**********************************************************************
*        CREATE AND SEND DATA PACKETS                                *
**********************************************************************
SDATA    CLC       NUMTRY,MAXTRY       CAN WE DO IT?
         BL        OK4                 YES
         MVI       STATE,C'A'          ELSE ABORT
         B         SLOOP
OK4      L         R3,NUMTRY
         LA        R3,1(R3)            INCREMENT COUNTER
         ST        R3,NUMTRY
         MVI       STYPE,AD            PACKET TYPE = DATA
         L         R15,=A(SPACK)
         BALR      14,15               GO TO SPACK AND RETURN
         CLI       STATE,C'A'
         BE        ABORT
         L         15,=A(RPACK)
         BALR      14,15               SAME FOR RPACK
         CLI       RTYPE,AE            ERROR PACKET?
         BNE       Y4                  MAYBE AN ACK
         MVI       ERRNUM,X'0A'        MICRO DIED
         MVI       STATE,C'A'          SO WE DO TOO
         B         SLOOP
Y4       CLI       RTYPE,AY            SEE IF GOT 'ACK'
         BNE       N4                  SEE IF IT'S AN 'N'
         CLC       N,NUM               DO WE HAVE THE CORRECT ACK?
         BE        AOK4
         MVI       ERRNUM,X'08'        MISSING A PACKET
         B         SLOOP
AOK4     XC        NUMTRY,NUMTRY       RESET COUNTER
         L         R3,N
         LA        R3,1(R3)            INCREMENT COUNTER
         ST        R3,N
         NC        N(4),=X'0000003F'   MASK TO GET MOD 64
         L         15,=A(GTCHR)
         BALR      14,15               DO GET-CHAR AND RETURN
         B         SLOOP
N4       CLI       RTYPE,AN
         BNE       AB4
         TM        FLAGS,FLG4          DID MICRO NAK OR I REJECTED?
         BO        SLOOP               LEAVE ERR MSG AS IS IF I DID
         MVI       ERRNUM,X'09'        MICRO NAK'ED
         B         SLOOP
AB4      MVI       STATE,C'A'
         MVI       ERRNUM,X'07'        ILLEGAL PACKET TYPE
         B         SLOOP
**********************************************************************
*        CREATE AND SEND EOF PACKET                                  *
**********************************************************************
SEOF     CLC       NUMTRY,MAXTRY       CAN WE DO IT?
         BL        OK5                 BRANCH IF YES
         MVI       STATE,C'A'          ABORT IF NO
         B         SLOOP
OK5      L         R3,NUMTRY
         LA        R3,1(R3)            ADD ONE
         ST        R3,NUMTRY           STORE INCREMENTED COUNTER
         MVI       STYPE,AZ            PACKET TYPE = EOF
         XC        LSDAT,LSDAT         LENGTH OF ZERO
         L         R15,=A(SPACK)
         BALR      14,15               SAVE * AND GO TO SPACK
         CLI       STATE,C'A'
         BE        ABORT
         L         15,=A(RPACK)
         BALR      14,15               SAME FOR RPACK
         CLI       RTYPE,AE            ERROR PACKET?
         BNE       Y5                  MAYBE AN ACK
         MVI       ERRNUM,X'0A'        MICRO DIED
         MVI       STATE,C'A'          SO WE DO TOO
         B         SLOOP
Y5       CLI       RTYPE,AY            CHECK FOR 'ACK'
         BNE       N5                  MAYBE WAS A 'NAK'
         CLC       N,NUM               CORRECT ACK?
         BE        AOK5
         MVI       ERRNUM,X'08'        LOST A PACKET
         B         SLOOP
AOK5     L         R3,N
         LA        R3,1(R3)            ADD ONE
         ST        R3,N                STORE VALUE INCREMENTED BY 1
         NC        N(4),=X'0000003F'   MASK TO GET MOD 64
         MVI       STATE,C'F'          SET TO SEND FILE FOR NOW
*
*
*  WE JUST PROCESS ONE FILE FOR NOW.
*
DIEOK    MVI       STATE,C'B'          BREAK CONNECTION
         B         SLOOP
N5       CLI       RTYPE,AN
         BNE       AB5                 DIE IF NOT A NAK
         TM        FLAGS,FLG4          DID MICRO NAK OR I REJECTED?
         BO        SLOOP               LEAVE ERR MSG AS IS IF I DID
         MVI       ERRNUM,X'09'        MICRO NAK'ED
         B         SLOOP
AB5      MVI       STATE,C'A'          ELSE, ABORT
         MVI       ERRNUM,X'07'        UNRECOGNIZED PACKET TYPE
         B         SLOOP
**********************************************************************
*        CREATE AND SEND BREAK PACKET                                *
**********************************************************************
SBREAK   CLC       NUMTRY,MAXTRY       OVER OUR LIMIT?
         BL        OK6                 BRANCH IF NO
         MVI       STATE,C'A'          ABORT IF YES
         B         SLOOP
OK6      L         R3,NUMTRY
         LA        R3,1(R3)            ADD ONE
         ST        R3,NUMTRY           INCREMEMTED TRIAL COUNTER
         MVI       STYPE,AB            PACKET TYPE = BREAK
         XC        LSDAT,LSDAT         LENGTH = ZERO
         L         R15,=A(SPACK)
         BALR      14,15               SAVE * AND GO TO SPACK
         CLI       STATE,C'A'
         BE        ABORT
         L         15,=A(RPACK)
         BALR      14,15               SAVE * AND GO TO RPACK
         CLI       RTYPE,AE            ERROR PACKET?
         BNE       Y6                  MAYBE AN ACK
         MVI       ERRNUM,X'0A'        MICRO DIED
         MVI       STATE,C'A'          THEN WE DO TOO
         B         SLOOP
Y6       CLI       RTYPE,AY            CHECK FOR ACK
         BNE       N6                  CHECK FOR 'N'
         CLC       N,NUM               CORRECT ACK?
         BE        AOK6
         MVI       ERRNUM,X'08'        LOST A PACKET
         B         SLOOP
AOK6     MVI       STATE,C'C'          COMPLETED STATE
         B         SLOOP
N6       CLI       RTYPE,AN            CHECK FOR 'N'
         BNE       AB6                 DIE IF NOT A NAK
         TM        FLAGS,FLG4          DID MICRO NAK OR I REJECTED?
         BO        SLOOP               LEAVE ERR MSG AS IS IF I DID
         MVI       ERRNUM,X'09'        MICRO NAK'ED
         B         SLOOP
AB6      MVI       STATE,C'A'          ELSE,ABORT
         MVI       ERRNUM,X'07'        UNRECOGNIZED PACKET TYPE
         B         SLOOP
**********************************************************************
*        CREATE AND SEND ABORT PACKET                                *
**********************************************************************
ABORT    DS        0H
         TM        FLAGS,FLG1          DYING ON FILE-NOT-FOUND?
         BO        NOERRP              IF SO, THEN NO ERROR PACKET
         CLI       ERRNUM,X'0A'        DID THE MICRO DIE?
         BE        NOERRP              NO ERROR PACKET IF SO
         MVI       STYPE,AE            ERROR PACKET
         MVC       LSDAT(4),=F'20'     ALL MSGS ARE THIS LONG
         MVC       N(4),NUM            SYNCH PACKET NUMBERS
         SR        R5,R5
         IC        R5,ERRNUM           GET RIGHT MESSAGE NUMBER
         M         R4,=F'20'           OFFSET := ERRNUM * 20
         LA        R5,ERRTAB(R5)
         MVC       SDAT(20),0(R5)      SPACK NEEDS THE DATA HERE
         TR        SDAT(20),ETOA
         L         R15,=A(SPACK)
         BALR      R14,R15             SEND ERROR PACKET & DIE
NOERRP   LA        R15,4               SET NON-ZERO RETCODE
         B         SENDRET             PREPARE TO LEAVE
**********************************************************************
*        PROCESS COMPLETE                                            *
**********************************************************************
COMPLETE SR        R15,R15             ZERO WILL BE RETCODE
SENDRET  L         R13,4(R13)
         L         R14,12(R13)
         LM        R0,R12,20(R13)
         BR        R14
         EJECT
**********************************************************************
*                                                                    *
*  ROUTINE TO GET A CHARACTER FROM INPUT BUFFER WILL READ DISK TO    *
*        FILL THE BUFFER.                                            *
*                                                                    *
**********************************************************************
GTCHR    DS        0H
         TM        FLAGS,FLG3          SEE IF THERE'S STUFF IN BUF
         BO        STUFF               ONES -> STUFF'S THERE
*
*  GO TO COMMON ROUTINE TO READ SOME BYTES
*
         LA        R15,READX       LOCATE READ ROUTINE
         BALR      R15,R15         COME AND GO ON SAME REG
*
         LTR       R4,R1               PUT RESULT OF READ IN R4
         BZ        OK8
         CH        R4,=Y(ERCOD)        RETCODE OF 12 MEANS EOF
         BNE       ERR1                TRY IT AGAIN
         MVI       STATE,C'Z'          MAKE TO EOF STATE
         BR        R14
ERR1     MVI       STATE,C'A'          ABORT ON FILE SYSTEM ERROR
         MVI       ERRNUM,X'0C'        INVALID RECORD LENGTH
         C         R4,=F'8'            WAS OUR GUESS RIGHT?
         BER       R14                 IF YES, RETURN
         MVI       ERRNUM,X'0D'        ELSE, GOT AN I/O ERROR
         BR        R14
OK8      LR        R5,R0               GET NUMBER OF BYTES READ IN
         LR        R4,R5               SAVE ALSO IN R4
         BCTR      R4,0                SUBTRACT 1 FOR EX COMMAND
         EX        R4,TRANS            EBCDIC TO ASCII TRANSLATION
         LA        R8,BUF              GET LOCATION OF BUFFER INPUT
         LA        R9,BUF(R4)          LAST POSITION IN THAT BUFFER
X4       CLI       0(R9),X'20'         IS THIS A BLANK?
         BNE       X5                  NO, FOUND LAST CHAR OF LINE
         BCTR      R9,0
         CR        R9,R8
         BNL       X4                  FIND LAST CHAR
         SR        R5,R5               ALL BLANKS
         B         FOO
X5       SR        R9,R8
         LR        R5,R9               LENGTH OF LINE
         LA        R5,1(R5)            ADD ONE
FOO      LA        R9,BUF(R5)          FIRST BLANK SPACE AFTER DATA
         MVC       0(1,R9),=X'0D'      ADD ASCII CR
         LA        R9,1(R9)            INCREMENT POINTER
         MVC       0(1,R9),=X'0A'      AND ADD ASCII LF
         LA        R5,2(R5)            TWO EXTRA BYTES OF DATA NOW
         ST        R5,RECL             LRECL + 2 (FOR CRLF)
         SR        R8,R8               ZERO OUT INDEX FOR BUF
STUFF    SR        R9,R9               SAME FOR INDEX FOR SDAT
         SR        R10,R10             CHARACTER COUNTER
         SR        R5,R5               WILL HOLD QUOCHAR
         IC        R5,QUOCHAR
         L         R8,SAVPL            WHERE WE LEFT OFF
         C         R8,RECL             SEE IF ARE AT LIMIT
         BNL       FULL2               LEAVE IF REACHED OR EXCEEDED
         SR        R7,R7
LOOP     IC        R7,BUF(R8)          PICK UP BYTE
         CR        R7,R5               IS IT THE QUOTE CHARACTER?
         BE        SPECIAL
         C         R7,DEL              IS IT THE CHARDEL?
         BE        SPECIAL
         C         R7,SPACE            IS IT A CONTROL CHARACTER?
         BL        SPECIAL
         B         ADDIT
SPECIAL  L         R4,SIZE             MUNGE VALUE WHILE IN R4
         SR        R4,R10              FIND DIF BETWWEN THE TWO
         C         R4,TWO              SEE IF HAVE AT LEAST 2 BYTES
         BNL       ROOM                YES,CAN ADD
         STC       R10,LSDAT+3         SET LSDAT TO VAL OF COUNTER
         OI        FLAGS,FLG3          SET FLAG TO SHOW STUFF'S THERE
         ST        R8,SAVPL            SAVE PLACE IN BUF
         BR        14                  LEAVE THIS ROUTINE
ROOM     LA        R4,SDAT(R9)         WHERE IT'S GOING
         MVC       0(1,R4),QUOCHAR     MOVE QUOTE CHAR THERE
         LA        R9,1(R9)            INCREMENT SDAT COUNTER
         LA        R10,1(R10)          INCREMENT CHARACTER COUNTER
         CR        R7,R5               DON'T ADD ¬O100 TO THIS
         BE        ADDIT               IT'S ALREADY PRINTABLE
         A         R7,O1H              ADD ¬O100 TO CHAR
         N         R7,=X'0000007F'     GET MOD ¬O200
ADDIT    STC       R7,SDAT(R9)         ADD THE CHARACTER
         LA        R9,1(R9)            INCREMENT SDAT COUNTER
         LA        R8,1(R8)            INCREMENT BUF COUNTER
         LA        R10,1(R10)          INCREMENT CHARACTER COUNTER
         C         R8,RECL             SEE IF REACHED LIMIT
         BNL       FULL2
         C         R9,SIZE             SEE IF REACHED LIMIT
         BNL       FULL
         B         LOOP
FULL     EQU       *
         STC       R10,LSDAT+3         THIS ONE TOO
         ST        R8,SAVPL            HERE TOO
         OI        FLAGS,FLG3          TURN ON FLAG - STUFF IN BUF
         BR        14
FULL2    EQU       *
         STC       R10,LSDAT+3         THIS ONE TOO
         XC        SAVPL,SAVPL         RESET THIS
         NI        FLAGS,X'FF'-FLG3    TURN OFF LEFTOVER DATA FLAG
         BR        14
SENDSAVE DS        18F
TRANS    TR        BUF(0),ETOA         EBCDIC TO ASCII TRANSLATION
TRNS     TR        SNDPKT(0),ATOE      BACK FROM ASCII TO EBCDIC
PARSE    DC        32X'00'
         DC        X'01'               STOP ON A SPACE
         DC        223X'00'
FIRST    MVC       SDAT(0),FILNAM      PICK UP THE FN
SECOND   MVC       0(0,R7),FILNAM+8    PICK UP FT
         LTORG
         DROP      R11
         DROP      R12                 DON'T NEED THEM ANYMORE
         EJECT
**********************************************************************
*                                                                    *
*        ROUTINE TO PROCESS SEND PACKET REQUEST                      *
*   needs to send cx80 passthru controlk chars prior to sending      *
**********************************************************************
SPACK    DS        0H     CSECT
         STM       R14,R12,12(R13)     SAVE CALLER'S REGISTERS
         BALR      R12,0               ESTABLISH ADDRESSABILITY
         USING     *,R12
         LA        R14,SPSAVE          ADDRESS OF MY SAVE AREA
         ST        R13,4(R14)          SAVE CALLER'S
         ST        R14,8(R13)
         LR        R13,R14
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA
         L         R11,=A(PARMS)
         USING     PARMS,R11           ESTABLISH ADDRESSABILITY
         SR        R9,R9
         MVC       PHDR,SSOH           ADD SOH TO PACKET
         CLC       LSDAT,SIZE          NEED DATA SIZE <= SPSIZ-5
         BNH       FINE
         MVI       ERRNUM,X'00'        DATA SIZE EXCEEDS MAX LIMIT
         MVI       STATE,C'A'          ABORT ON THIS
         B         SPRET
FINE     L         R4,=F'35'           USE ¬o43 TO OFFSET DATA
         A         R4,LSDAT            ADD IT TO LSDAT
         STC       R4,PLEN
         AR        R9,R4               AND THEN ADD IT TO CHECKSUM
         CLC       N,ZERO              CHECK IF N IS VALID
         BNL       T1                  OK IF >= TO 0
         MVI       ERRNUM,X'01'        ILLEGAL MESSAGE NUMBER
         MVI       STATE,C'A'
         B         SPRET
T1       CLC       N,O1H               SEE IF IS <= OCTAL 100
         BNH       T2
         MVI       ERRNUM,X'01'        ILLEGAL MESSAGE NUMBER
         MVI       STATE,C'A'
         B         SPRET
T2       L         R4,SPACE            OFFSET THIS VALUE TOO
         A         R4,N                ADD IT TO N
         ST        R4,TEMP
         MVC       PNUM(1),TEMP+3
         A         R9,TEMP             AND ADD TO CHECKSUM
         CLI       STYPE,X'41'         ASCII 'A'
         BL        T3                  CAN'T BE LESS THAN THIS
         CLI       STYPE,X'5A'         ASCII 'Z'
         BNH       T4                  CAN'T BE GREATER
T3       MVI       ERRNUM,X'07'        ILLEGAL PACKET TYPE
         MVI       STATE,C'A'          DIE ON THIS
         B         SPRET
T4       MVC       PTYPE(1),STYPE      ADD MESSAGE TYPE
         SR        R2,R2               ZERO IT OUT
         IC        R2,STYPE
         AR        R9,R2               ADD TO CHECKSUM
         L         R6,LSDAT            HOW MUCH DATA
         LTR       R6,R6               TEST IT OUT
         BZ        NODAT
         SR        R5,R5               USE TO GET DATA
         SR        R3,R3               USE TO HOLD DATA
DATCHK   IC        R3,SDAT(R5)         PICK UP CHAR
         AR        R9,R3               ADD TO CHECKSUM
         LA        R5,1(R5)            BUMP POINTER
         BCTR      R6,0
         LTR       R6,R6               MORE DATA?
         BNZ       DATCHK
NODAT    L         R6,LSDAT            WILL NEED THIS LATER
         LR        R7,R6               MUNGE WHILE IN R7
         BCTR      R7,0                SUBTRACT 1 FOR EX FUNCTION
         EX        R7,MOVE             MOVE THE DATA TO SNDPKT
         ST        R9,TEMP             WE'LL NEED THIS SOON
         N         R9,=X'000000C0'     GET MOD 192
         M         R8,ONE              CARRY OVER THE SIGN BIT
         D         R8,O1H              GET MOD 64
         A         R9,TEMP             ADD THE TWO VALUES
         N         R9,=X'0000003F'     GET MOD 64 OF CHECKSUM
         A         R9,SPACE            ADD OFFSET
         STC       R9,PDATA(R6)        ADD CHECKSUM AFTER DATA
         LA        R6,1(R6)            MOVE POINTER
         IC        R9,SEOL             ADD SEND END OF PACKET CHAR
         STC       R9,PDATA(R6)
         LA        R6,5(R6)            VALUE OF LSDAT+5
         TR        SNDPKT(130),HIBITON    SET MARK PARITY FOR CX80
         TM        DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN  IS IT OPEN?
         BZ        SPNODEB
         MVC       WRKBUFF(2),=H'20'
         XC        WRKBUFF+2(2),WRKBUFF+2
         MVC       WRKBUFF+4(16),=CL16'TPUT SEND PACKET'
         PUT       DEBUG,WRKBUFF
         LA        R1,4(,R6)           ADJUST LENGTH
         STH       R1,WRKBUFF          SET RDW
         EX        R6,DBGMVC1          MOVE IN DATA
         PUT       DEBUG,WRKBUFF
*PNODEB  TPUT      SNDPKT,(R6),CONTROL USES FULLSCR FOR CX80
*PNODEB  TPUT      SNDPKT,(R6),FULLSCR
SPNODEB  A         R6,4                                                 0000000
         TPUT      CX80WCC,(R6),FULLSCR                                 0000000
PSTHRU   TPUT      PASTHRU,4,FULLSCR   PUT CX80 IN PTHRU MODE AGAIN     0000000
         LTR       R15,R15             WAS THERE ANY ERROR?
         BZ        SPRET               NO, THEN JUST RETURN
         MVI       ERRNUM,10           SET MICRO DIED
         MVI       STATE,C'A'          ABORT ON THIS
SPRET    L         R13,4(R13)
         L         R14,12(R13)
         LM        R0,R12,20(R13)
         BR        14
SPSAVE   DS        18F
MOVE     MVC       PDATA(0),SDAT
DBGMVC1  MVC       WRKBUFF+4(*-*),SNDPKT
         LTORG
         DROP      R11
         DROP      R12                 DON'T NEED THEM ANYMORE
         EJECT
**********************************************************************
*                                                                    *
*        ROUTINE TO PROCESS RECEIVE PACKET REQUEST                   *
*                                                                    *
**********************************************************************
RPACK    DS        0H
         STM       R14,R12,12(R13)     SAVE CALLER'S REGISTERS
         BALR      R12,0               ESTABLISH ADDRESSABILITY
         USING     *,R12
         LA        R14,RPSAVE          ADDRESS OF MY SAVE AREA
         ST        R13,4(R14)          SAVE CALLER'S
         ST        R14,8(R13)
         LR        R13,R14
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA
         L         R11,=A(PARMS)
         USING     PARMS,R11           ESTABLISH ADDRESSABILITY
***************************************************************         0000000
*                                                                       0000000
*    THIS SECTION OF CODE IS MODIFIED FOR THE CX80 PASSTHRU             0000000
*    THE WCC FOR PASSTHRU IS SENT PRIOR AND POST ANY TGET               0000000
*    OPERATIONS.  IF SOH IS DETECTED, NEED TGET AGAIN AND               0000000
*    OFFSET FOR THE AIDBYTE.                                            0000000
*                                                                       0000000
*                                                                       0000000
*                                                                       0000000
*                                                                       0000000
*        TPUT      PASTHRU,4,FULLSCR **CX80**                           0000000
MORGET   TGET      RECPKT,130,ASIS
*  GET   TGET      AIDBYTE,131,ASIS    **CX 80 AID BYTE HERE **
         TPUT      PASTHRU,4,FULLSCR **CX80**                           0000000
         CLC       RECPKT+1,X'81'                                       0000000
         BNE       NOTHEX81                                             0000000
         TGET      RECPKT,130,ASIS
         TPUT      PASTHRU,4,FULLSCR **CX80**                           0000000
         MVC       RECPKT,X'81'                                         0000000
         NC        RECPKT(130),HBTOFF                                   0000000
***************************************************************         0000000
NOTHEX81 LTR       R15,R15             WAS THERE AN ERROR?
         BZ        RPTSTDB             NO, THEN TEST FOR DEBUG
         MVI       RTYPE,AE            SET AN ERROR
         B         RPRET
RPTSTDB  TM        DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN  IS IT OPEN?
         BZ        RDNODEB
         LA        R8,4(,R1)       SAVE LENGTH
         MVC       WRKBUFF(2),=H'19'
         XC        WRKBUFF+2(2),WRKBUFF+2
         MVC       WRKBUFF+4(15),=CL15'TGET REC PACKET'
         PUT       DEBUG,WRKBUFF
         STH       R8,WRKBUFF          SET RDW
         EX        R8,DBGMVC2          MOVE IN DATA
         PUT       DEBUG,WRKBUFF
*DNODEB  TR        RECPKT(130),ETOA CX80- NO TRANSLATION NEEDED
RDNODEB  NI        FLAGS,X'FF'-FLG4    ASSUME MICRO'LL NAK-NOT RPACK
         SR        R8,R8               INDEX REG FOR RECPKT
         SR        R5,R5               CHECKSUM REGISTER
TRY      LA        R7,RECPKT(R8)       ADDRESS OF CHARACTER
         CLC       RSOH,0(R7)          IS IT START OF HEADER
         BE        READIN              YES; SO FAR, SO GOOD
         LA        R8,1(R8)            TRY NEXT CHARACTER
         C         R8,=F'130'          SEE IF EXCEED BUFFER
         BL        TRY
         MVI       ERRNUM,X'03'        NO "SOH" ERROR
         B         BADP
READIN   SR        R9,R9               ZERO OUT INDEX REG FOR RDAT
         LA        R8,1(R8)            INCREMENT COUNTER
         LA        R7,RECPKT(R8)       PICK UP LOC OF CHAR COUNT
         CLC       RSOH,0(R7)          IS IT START OF HEADER?
         BE        READIN              START OVER
         CLC       0(1,R7),DQUOTE      COUNT+' '+3 AND ¬d35
         BNL       CONT                CONTINUE IF >=
         MVI       ERRNUM,X'04'        BAD LENGTH ATTRIBUTE
         B         BADP
CONT     IC        R5,0(R7)            START CHECKSUM
         LR        R7,R5               MUNGE IN R7 TO GET LRDAT
         S         R7,=F'35'           LENGTH OF DATA
         STC       R7,LRDAT+3
         LA        R8,1(R8)            INCREMENT
         SR        R7,R7               ZERO IT OUT
         IC        R7,RECPKT(R8)       PICK UP PACKET NUMBER
         CLM       R7,B'0001',RSOH     IS IT START OF HEADER
         BE        READIN
         AR        R5,R7               ADD TO CHECKSUM
         S         R7,SPACE            SUBTRACT THE ' '
         STC       R7,NUM+3            NUM := RECEIVED PACKET NO.
         LA        R8,1(R8)            INCREMENT COUNTER
         IC        R7,RECPKT(R8)       PICK UP MESSAGE TYPE
         CLM       R7,B'0001',RSOH     IS IT START OF HEADER?
         BE        READIN
         AR        R5,R7               ADD TO CHECKSUM
         STC       R7,RTYPE            PUT INTO RTYPE
         LA        R8,1(R8)            GO TO NEXT BYTE
         L         R4,LRDAT            COUNTER TO GET ALL DATA
LUP      C         R4,ZERO             SEE IF PICKED UP ALL DATA
         BE        FIN
         XC        TEMP,TEMP           ZERO IT OUT
         LA        R7,RECPKT(R8)       NEXT LOCATION IN BUFFER
         MVC       TEMP+3(1),0(R7)     PICK UP NEXT BYTE
         CLC       RSOH,TEMP+3         IS IT START OF HEADER
         BE        READIN
         LA        R7,RDAT(R9)         WHERE THE DATA'S GOING
         MVC       0(1,R7),TEMP+3      AND MOVE IT
         A         R5,TEMP             ADD TO CHECKSUM
         LA        R8,1(R8)            ADD ONE
         LA        R9,1(R9)            ADD ONE
         BCTR      R4,0                DECREMENT COUNTER
         B         LUP
FIN      SR        R7,R7               ZERO OUT REGISTER
         IC        R7,RECPKT(R8)       GET CHECKSUM
         CLM       R7,B'0001',RSOH     IS IT START OF HEADER
         BE        READIN
         ST        R5,TEMP             WE'LL NEED THIS SOON
         N         R5,=X'000000C0'     GET MOD 192
         M         R4,ONE              CARRY OVER THE SIGN BIT
         D         R4,O1H              GET MOD 64
         A         R5,TEMP             ADD THE TWO VALUES
         N         R5,=X'0000003F'     GET MOD 64
         A         R5,SPACE            ADD OFFSET
NODEBG9  CR        R5,R7               COMPUTED VS RECEIVED CHECKSUM
         BE        RPRET
         TM        DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN
         BZ        NODEBG2             BYPASS IF NO DEBUG ON
*                              LENGTH OF WRKBUFF FOR PUT                0000000
         MVC       WRKBUFF(2),=H'18'
         XC        WRKBUFF+2(2),WRKBUFF+2
         MVC       WRKBUFF+4(14),=CL14'CHECKSUM ERROR'
*  ADDED LINES FORCHECKSUM DISPLAY ON ERROR IN DEBUG FILE 6/27/85 KMG   0000000
*        ST        R5,TEMP                                              0000000
*        MVC       WRKBUFF+18(1),TEMP                                   0000000
*        ST        R7,TEMP                                              0000000
*        MVC       WRKBUFF+19(1),TEMP                                   0000000
*        MVC       WRKBUFF+20(22),RECPKT                                0000000
* --------------------- KMG                                             0000000
         PUT       DEBUG,WRKBUFF
NODEBG2  MVI       ERRNUM,X'05'        BAD CHECKSUM ERROR
BADP     MVI       RTYPE,AN            RETURN A NAK
         OI        FLAGS,FLG4          RPACK NAK'ED THE PACKET
RPRET    L         R13,4(R13)
         L         R14,12(R13)
         LM        R0,R12,20(R13)
         BR        14
DBGMVC2  MVC       WRKBUFF+4(*-*),RECPKT
RPSAVE   DS        18F
         LTORG
         DROP      R11
         DROP      R12                 DON'T NEED THEM ANYMORE
         EJECT
**********************************************************************
*                                                                    *
*  DISK FILE READ ROUTE WITH DEBUGGING CODE                          *
*  AT EXIT R1 CONTAINS 0 FOR SUCCESSFUL READ OR 12 FOR EOF           *
*          R0 CONTAINS RECORD LENGTH OR ZERO FOR EOF                 *
**********************************************************************
READX    DS        0H
         USING     PARMS,R11           ESTABLISH ADDRESSABILITY
         STM       R12,R15,READSAVE
         BALR      R12,0
         USING     *,R12
         TM        KERIN+(DCBRECFM-IHADCB),DCBRECV  VARIABLE?
         BO        RDVAR
         GET       KERIN,BUF
         B         RDTSTDB
RDVAR    GET       KERIN,BUF-4
RDTSTDB  TM        DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN  IS IT OPEN?
         BZ        RDNODBG
         MVC       WRKBUFF(2),=H'12'
         XC        WRKBUFF+2(2),WRKBUFF+2
         MVC       WRKBUFF+4(8),=CL8'QSAM GET'
         PUT       DEBUG,WRKBUFF
         LH        R1,KERIN+(DCBLRECL-IHADCB) GET LRECL
         STH       R1,WRKBUFF      SAVE IN DEBUG BUFF
         EX        R1,DBGMVC3
         PUT       DEBUG,WRKBUFF
RDNODBG  XR        R1,R1               SET RETURN CODE =0
         LH        R0,KERIN+(DCBLRECL-IHADCB)  GET RECORD LENGTH
         TM        KERIN+(DCBRECFM-IHADCB),DCBRECV  VARIABLE?
         BZ        *+12                NO, THEN SKIP
         LH        R0,BUF-4            GET LENGTH FROM RDW
         SH        R0,=H'4'            REMOVE RDW LENGTH
         LM        R12,R15,READSAVE
         BR        R15
DBGMVC3  MVC       WRKBUFF+4(*-*),KERIN
*
INEOF    DS        0H
         LA        R1,ERCOD        SET RC=12
         XR        R0,R0           SET LENGTH =  0
         LM        R12,R15,READSAVE
         BR        R15             RETURN
         LTORG
         DROP      R11
         DROP      R12
         EJECT
**********************************************************************
*                                                                    *
*        ROUTINE TO PROCESS RECEIVE COMMAND                          *
*                                                                    *
**********************************************************************
RECEIVE  DS        0H
         STM       R14,R12,12(R13)     SAVE CALLER'S REGISTERS
         BALR      R12,0               ESTABLISH ADDRESSABILITY
         USING     *,R12
         LA        R14,RECSAVE         ADDRESS OF MY SAVE AREA
         ST        R13,4(R14)          SAVE CALLER'S
         ST        R14,8(R13)
         LR        R13,R14
* USE R11 AS BASE REGISTER FOR THE GLOBAL DATA AREA, 'PARMS'
         L         R11,=A(PARMS)
         USING     PARMS,R11
         SR        R6,R6               GET ZERO
         ST        R6,NUMTRY           ZERO THIS OUT
         ST        R6,N                HERE TOO
         MVI       STATE,C'R'          SET TO RECEIVE STATE
         TPUT      PASTHRU,17,FULLSCR  PUT CX80 IN PASSTHRU+MSG TO EFF  0000000
**********************************************************************
*        MAIN RECEIVE PROCESSING LOOP                                *
**********************************************************************
RLOOP    CLI       STATE,C'D'          RECEIVE DATA STATE
         BE        RDATA
         CLI       STATE,C'F'          RECEIVE FILE STATE
         BE        RFILE
         CLI       STATE,C'R'          RECEIVE INIT STATE
         BE        RINIT
         CLI       STATE,C'C'          COMPLETE STATE
         BE        RCOMP
         CLI       STATE,C'A'          ABORT STATE
         BE        RABORT
         MVI       ERRNUM,X'02'        UNRECOGNIZED STATE
         B         RABORT              ELSE, DIE
**********************************************************************
*        PROCESS INITIALIZATION PACKET                               *
**********************************************************************
RINIT    CLC       NUMTRY,IMXTRY       SEE IF CAN RECEIVE
         BL        ROK1                YES, WE CAN
         MVI       STATE,C'A'          NOPE, GO INTO ABORT STATE
         B         RLOOP
ROK1     L         R3,NUMTRY
         LA        R3,1(R3)            INCREMENT TRIAL COUNTER
         ST        R3,NUMTRY
         XC        RSAVPL,RSAVPL       CLEAR BUFFER OUT *KMG PRC*       0000000
         L         R4,DSSIZ            DEFAULT SEND PACKET SIZE
         S         R4,FIVE             USE DEFAULT TO SET "SIZE"
         ST        R4,SIZE             IN CASE WE DIE BEFORE IT'S SET
         L         R15,=A(RPACK)       GET INIT INFORMATION
         BALR      R14,R15
         CLI       RTYPE,AE            ERROR PACKET?
         BNE       RY1                 ALL OK
         MVI       ERRNUM,X'0A'        MICRO DIED
         MVI       STATE,C'A'          SO WE DO TOO
         B         RLOOP
RY1      CLI       RTYPE,AS            IS IT A SEND-INIT PACKET
         BNE       RN1                 MAYBE IT GOT CLOBBERED
         SR        R4,R4               ZERO OUT REGISTER
         IC        R4,RDAT             GET FIRST CHARACTER
         S         R4,SPACE            SUBTRACT THE ' '
         C         R4,=F'26'           MIN SPACK SIZE
         BNL       RCH1                SO FAR, SO GOOD
         MVI       STATE,C'A'          ELSE, ABORT
         MVI       ERRNUM,X'00'        INVALID DATA-PACKET-SIZE ERROR
         B         RLOOP
RCH1     C         R4,MAXPACK          MAX PACKET SIZE
         BNH       RCH2
         MVI       STATE,C'A'          ABORT IF SIZE IS ILLEGAL
         MVI       ERRNUM,X'00'        BAD SEND DATA LENGTH
         B         RLOOP
RCH2     STC       R4,SPSIZ+3          USE THE VALUE AS SEND SIZE
         S         R4,FIVE
         ST        R4,SIZE             SET IT TO SPSIZ-5
         CLC       LRDAT(4),=F'4'      USING ALL DEFAULTS ?
         BNH       NOCH                YUP
         LA        R5,RDAT             POINT TO THE BUFFER
         SR        R7,R7
         IC        R7,4(R5)            SEOL THE MICRO WANTS
         S         R7,SPACE            UNCHAR (SUBTRACT ' ')
         STC       R7,SEOL
         CLC       LRDAT(4),FIVE       ANY MORE DATA?
         BNH       NOCH                JUST USE DEFAULTS
         MVC       RQUO(1),5(R5)       SET NEW QUOCHAR VALUE
NOCH     MVC       N(4),NUM            SYNCH PACKET NUMBERS
         MVI       STYPE,AY            SET MESSAGE TYPE TO ACK
         MVC       LSDAT(4),=F'6'     SET LENGTH OF DATA SENDING
         L         R5,SPACE            MAKE CHARACTER PRINTABLE
         A         R5,RPSIZ            ADD REC PACKET SIZE
         STC       R5,SDAT             ADD SIZE INFO TO BUFFER
         L         R5,SPACE
         A         R5,=F'8'            8 FOR TIMEOUT
         STC       R5,SDAT+1
         L         R5,SPACE            SEND ZERO + " " FOR NPAD
         STC       R5,SDAT+2           WE'RE THE SLOW GUYS
         SR        R5,R5               PAD WITH NULLS
         L         R3,O1H
         XR        R5,R3               CTL FUNCTION (XOR WITH 64)
         STC       R5,SDAT+3           DON'T NEED PADCHAR EITHER
         SR        R5,R5               ZERO IT OUT FOR NEXT TWO GUYS
         IC        R5,REOL             EOL CHAR I NEED
         A         R5,SPACE            MAKE PRINTABLE
         STC       R5,SDAT+4
         IC        R5,QUOCHAR          MY QUOTE CHAR
         STC       R5,SDAT+5
         L         R15,=A(SPACK)       ADDRESS OF SPACK
         BALR      R14,R15             SAVE * AND GO TO SPACK
         CLI       STATE,C'A'
         BE        RABORT
         MVI       STATE,C'F'          SET TO RECEIVE FILE STATE
         MVC       OLDTRY(4),NUMTRY    SAVE TRIAL COUNTER
         XC        NUMTRY,NUMTRY       RESET COUNTER TO ZERO
         L         R3,N
         LA        R3,1(R3)            ADD ONE
         ST        R3,N                STORE VALUE INCREMENTED BY 1
         NC        N(4),=X'0000003F'   MASK TO GET MOD 64
         B         RLOOP
RN1      CLI       RTYPE,AN            MAYBE IT'S A NAK
         BNE       RSELSE
         MVI       STYPE,AN            SEND A NAK PACKET
         XC        LSDAT,LSDAT         NO DATA
         L         R15,=A(SPACK)
         BALR      R14,R15
         B         RLOOP
RSELSE   MVI       STATE,C'A'          ELSE,ABORT
         MVI       ERRNUM,X'07'        ILLEGAL PACKET TYPE
         B         RLOOP
**********************************************************************
*        PROCESS FILE PACKET                                         *
**********************************************************************
RFILE    CLC       NUMTRY,MAXTRY       EXCEEDED NO. OF TRIALS ALLOWED
         BL        ROK2                NOPE, STILL OK
         MVI       STATE,C'A'          ABORT IF YES
         B         RLOOP
ROK2     L         R3,NUMTRY
         LA        R3,1(R3)            INCREMENT TRIAL COUNTER
         ST        R3,NUMTRY
         L         R15,=A(RPACK)       GET ADDRESS OF RPACK
         BALR      R14,R15             GO THERE AND RETURN WHEN DONE
         CLI       RTYPE,AE            ERROR PACKET?
         BNE       RY2                 MAYBE AN ACK
         MVI       ERRNUM,X'0A'        MICRO DIED
         MVI       STATE,C'A'          SO WE DO TOO
         B         RLOOP
RY2      CLI       RTYPE,AS            STILL IN INIT STATE?
         BNE       RNZ                 TRY FOR AN EOF
         CLC       OLDTRY,MAXTRY       CAN WE TRY AGAIN?
         BL        ROLD
         MVI       STATE,C'A'          ELSE, ABORT
         B         RLOOP
ROLD     L         R3,OLDTRY
         LA        R3,1(R3)            INCREMENT COUNTER
         ST        R3,OLDTRY
         L         R3,N                GET PACKET NUMBER SENT
         BCTR      R3,0                SUBTRACT ONE FROM IT
         C         R3,NUM              NUM MUST EQUAL N-1
         BE        RNUM
         MVI       ERRNUM,X'08'        PREVIOUS PACKET MISSING
         B         RNAK                SEND A NAK
RNUM     MVI       STYPE,AY            ACK PACKET
         ST        R3,N                MAKE SEND SEQ NO. = N-1
         MVC       LSDAT(4),=F'6'     SET DATA LENGTH VARIABLE
         L         R15,=A(SPACK)
         BALR      R14,R15             GO TO SPACK AND RETURN
         CLI       STATE,C'A'
         BE        RABORT
         L         R4,N
         LA        R4,1(R4)            ADD ONE
         ST        R4,N                RESTORE N TO PROPER VALUE
         XC        NUMTRY,NUMTRY       RESET COUNTER TO ZERO
         B         RLOOP
RNZ      CLI       RTYPE,AZ
         BNE       RNF                 MAYBE IT'S AN 'F'
         CLC       OLDTRY,MAXTRY       CAN WE TRY AGAIN?
         BL        ROLD2
         MVI       STATE,C'A'          ELSE,ABORT
         B         RLOOP
         SPACE 1                                                        0000000
ROLD2    L         R3,OLDTRY
         LA        R3,1(R3)            INCREMENT COUNTER
         ST        R3,OLDTRY
         L         R3,N                GET PACKET NUMBER SENT
         BCTR      R3,0                SUBTRACT ONE FROM IT
         C         R3,NUM              NUM MUST EQUAL N-1
         BE        RNUM2
         MVI       ERRNUM,X'08'        PREVIOUS PACKET MISSING
         B         RNAK                SEND A NAK
RNUM2    MVI       STYPE,AY            ACK PACKET
         ST        R3,N                SEND SEQ := N-1
         XC        LSDAT,LSDAT         NO DATA
         L         R15,=A(SPACK)
         BALR      R14,R15
         CLI       STATE,C'A'
         BE        RABORT
         L         R4,N
         LA        R4,1(R4)            ADD ONE
         ST        R4,N                RESTORE N TO PROPER VALUE
         XC        NUMTRY,NUMTRY       RESET COUNTER TO ZERO
         B         RLOOP
RNF      CLI       RTYPE,AF
         BNE       RNB                 WELL, IT'S NOT A FNAME
         CLC       NUM,N               THEY HAVE TO BE EQUAL
         BE        RNUM3
         MVI       ERRNUM,X'08'        PREVIOUS PACKET MISSING
         B         RNAK                SEND A NAK
RNUM3    MVI       STYPE,AY            ACK PACKET
         XC        LSDAT,LSDAT         NO DATA
OVER     L         R15,=A(SPACK)
         BALR      R14,R15             SEND ACK
         CLI       STATE,C'A'
         BE        RABORT
         MVC       OLDTRY(4),NUMTRY    KEEP NUMTRY FOR LATER
         XC        NUMTRY,NUMTRY       RESET TO ZERO
         L         R3,N
         LA        R3,1(R3)            ADD ONE
         ST        R3,N                INCREMENT COUNTER
         NC        N(4),=X'0000003F'   MASK TO GET MOD 64
         MVI       STATE,C'D'          DATA RECEIVE STATE
         B         RLOOP
RNB      CLI       RTYPE,AB            SEE IF IT'S A BREAK
         BNE       RNN                 MAYBE GOT A NAK
         CLC       NUM,N
         BE        RNUM4
         MVI       ERRNUM,X'08'        PREVIOUS PACKET MISSING
         B         RNAK                SEND A NAK
RNUM4    MVI       STYPE,AY            ACK PACKET
         XC        LSDAT,LSDAT         NO DATA
         L         R15,=A(SPACK)
         BALR      R14,R15
         CLI       STATE,C'A'
         BE        RABORT
         MVI       STATE,C'C'          COMPLETE STATE
         B         RLOOP
RNN      CLI       RTYPE,AN            SEE IF GOT A NAK
         BNE       RNELSE
RNAK     MVI       STYPE,AN            SEND A NAK PACKET
         XC        LSDAT,LSDAT         NO DATA
         L         R15,=A(SPACK)
         BALR      R14,R15
         B         RLOOP               DO NOTHING ON A NAK
RNELSE   MVI       STATE,C'A'          ABORT OTHERWISE
         MVI       ERRNUM,X'07'        ILLEGAL PACKET TYPE
         B         RLOOP
**********************************************************************
*        RECEIVE DATA PACKETS                                        *
**********************************************************************
RDATA    CLC       NUMTRY,MAXTRY       HAVE WE EXCEEDED OUR LIMIT?
         BL        ROK3
         MVI       STATE,C'A'          ELSE, ABORT
         B         RLOOP
ROK3     L         R4,NUMTRY
         LA        R4,1(R4)            INCREMENT
         ST        R4,NUMTRY           SAVE INCREMENTED COUNTER
         L         R15,=A(RPACK)
         BALR      R14,R15             CALL RPACK
         CLI       RTYPE,AE            ERROR PACKET?
         BNE       RY3                 MAYBE AN ACK
         MVI       ERRNUM,X'0A'        MICRO DIED
         MVI       STATE,C'A'          WE ABORT TOO
         B         RLOOP
RY3      CLI       RTYPE,AD            IS THIS A DATA PACKET?
         BNE       RDF                 MAYBE IT'S AN FNAME PACKET
         CLC       N,NUM               CHECK FOR RIGHT PACKET
         BNE       DIF
         L         R15,=A(PTCHR)
         BALR      R14,R15             PUT CHARACTERS INTO FILE
         LTR       R7,R7               CHECK FOR NO ERROR
         BZ        OKWR                NO ERROR
         MVI       STATE,C'A'          ABORT ON FILE SYSTEM ERROR
         B         RLOOP
OKWR     MVI       STYPE,AY            ACK PACKET
         XC        LSDAT,LSDAT         NO DATA
         L         R15,=A(SPACK)
         BALR      R14,R15
         CLI       STATE,C'A'
         BE        RABORT
         MVC       OLDTRY(4),NUMTRY    SAVE NUMTRY'S VALUE IN OLDTRY
         XC        NUMTRY,NUMTRY       RESET NUMTRY
         L         R3,N
         LA        R3,1(R3)
         ST        R3,N                INCREMENT COUNTER
         NC        N(4),=X'0000003F'   MASK TO GET MOD 64
         B         RLOOP
DIF      CLC       OLDTRY,MAXTRY       CAN WE DO IT?
         BL        DIFNUM
         MVI       STATE,C'A'          AND ABORT
         B         RLOOP
DIFNUM   L         R4,OLDTRY
         LA        R4,1(R4)
         ST        R4,OLDTRY           INCREMENT THIS COUNTER
         L         R4,N
         BCTR      R4,0
         C         R4,NUM              NUM MUST EQUAL N-1
         BE        DIFOK
         MVI       ERRNUM,X'08'        PREVIOUS PACKET MISSING
         B         RDN1                SEND A NAK
DIFOK    XC        NUMTRY,NUMTRY       RESET COUNTER TO ZERO
         MVI       STYPE,AY            ACK PACKET
         XC        LSDAT,LSDAT         NO DATA
         ST        R4,N                SET N TO N-1 TO RESEND PACKET
         L         R15,=A(SPACK)
         BALR      R14,R15             SEND THE PACKET
         CLI       STATE,C'A'
         BE        RABORT
         L         R4,N
         LA        R4,1(R4)            ADD ONE
         ST        R4,N                RESTORE N TO PROPER VALUE
         B         RLOOP               AND RETURN
RDF      CLI       RTYPE,AF            SENDING FILENAME AGAIN?
         BNE       RDZ
         CLC       OLDTRY,MAXTRY       CAN WE DO IT?
         BL        FILOVER             TRYING IT AGAIN
         MVI       STATE,C'A'          IF NO, ABORT
         B         RLOOP
FILOVER  L         R4,OLDTRY
         LA        R4,1(R4)
         ST        R4,OLDTRY           SAVE INCREMENTED VALUE
         L         R4,N
         BCTR      R4,0                NEED VALUE OF N-1
         C         R4,NUM              N-1 MUST EQUAL NUM
         BE        FILOK
         MVI       ERRNUM,X'08'        PREVIOUS PACKET MISSING
         B         RDN1                SEND A NAK
FILOK    XC        NUMTRY,NUMTRY       RESET TO ZERO
         XC        LSDAT,LSDAT         NO DATA
         MVI       STYPE,AY            ACK PACKET AGAIN
         ST        R4,N                SET N TO N-1 FOR NOW
OVRWRT   L         R15,=A(SPACK)
         BALR      R14,R15
         CLI       STATE,C'A'
         BE        RABORT
         L         R4,N
         LA        R4,1(R4)            ADD ONE
         ST        R4,N                RESTORE N TO PROPER VALUE
         B         RLOOP               AND RETURN
RDZ      CLI       RTYPE,AZ            IS THIS AN EOF PACKET?
         BNE       RDN
         CLC       N,NUM               ARE THEY EQUAL
         BE        RDOK
         MVI       ERRNUM,X'08'        PREVIOUS PACKET MISSING
         B         RDN1                SEND A NAK
         SPACE 1                                                        0000000
RDOK     MVI       STYPE,AY            ACK THE PACKET
         XC        LSDAT,LSDAT         NO DATA
         L         R15,=A(SPACK)
         BALR      R14,R15
         MVC       OLDTRY(4),NUMTRY    SAVE NUMTRY'S VALUE HERE
         XC        NUMTRY,NUMTRY       AND RESET COUNTER
         L         R3,N
         LA        R3,1(R3)
         ST        R3,N                STORE VALUE INCREMENTED BY 1
         NC        N(4),=X'0000003F'   MASK TO GET MOD 64
         MVI       STATE,C'F'          TRY FOR ANOTHER FILE
         B         RLOOP
         SPACE 1                                                        0000000
RDN      CLI       RTYPE,AN            DO WE NEED TO SEND A NAK?
         BNE       RDELSE
RDN1     MVI       STYPE,AN            SEND A NAK
         XC        LSDAT,LSDAT         NO DATA
         L         R15,=A(SPACK)
         BALR      R14,R15
         B         RLOOP
RDELSE   MVI       STATE,C'A'          UNRECOGNIZED PACKET - ABORT
         MVI       ERRNUM,X'07'        ILLEGAL PACKET TYPE
         B         RLOOP
SAYNO    MVI       STYPE,AN            SEND A NAK PACKET
         XC        LSDAT,LSDAT         NO DATA
         MVI       ERRNUM,X'0B'        ILLEGAL FILENAME ERROR
         L         R15,=A(SPACK)
         BALR      R14,R15
         B         RLOOP
**********************************************************************
*        RECEIVE ABORT PROCESS                                       *
**********************************************************************
RABORT   DS        0H
         CLI       ERRNUM,X'0A'        DID THE MICRO DIE?
         BE        RNOERRP             NO ERROR PACKET IF SO
         MVI       STYPE,AE            ERROR PACKET
         MVC       LSDAT(4),=F'20'     ALL MSGS ARE THIS LONG
         MVC       N(4),NUM            SYNCH PACKET NUMBERS
         SR        R5,R5
         IC        R5,ERRNUM
         M         R4,=F'20'           OFFSET := ERRNUM * 20
         LA        R5,ERRTAB(R5)
         MVC       SDAT(20),0(R5)      SPACK NEEDS THE DATA HERE
         TR        SDAT(20),ETOA
         L         R15,=A(SPACK)
         BALR      R14,R15             SEND ERROR PACKET & DIE
RNOERRP  LA        R15,4               SET A NON-ZERO RETCODE
         B         RECRET              PREPARE TO LEAVE
**********************************************************************
*        RECEIVE COMPLETE PROCESS                                    *
**********************************************************************
RCOMP    SR        R15,R15             RETCODE OF ZERO
RECRET   L         R13,4(R13)
         L         R14,12(R13)
         LM        R0,R12,20(R13)
         BR        14
         EJECT
**********************************************************************
*                                                                    *
*  ROUTINE TO PUT A CHARACTER IN OUTPUT BUFFER AND DUMP WHEN FULL    *
*                                                                    *
**********************************************************************
PTCHR    SR        R4,R4               USE TO HOLD QUOCHAR
         SR        R6,R6               USE TO HOLD LRECL
         SR        R8,R8               COUNTER WITHIN RDAT
         L         R9,RSAVPL           COUNTER WITHIN RBUF
         IC        R4,RQUO
         IC        R6,LRECL
         L         R5,LRDAT            COUNTER TO GET ALL DATA
RLUP     SR        R7,R7               USE TO PICK UP CHAR
         LTR       R5,R5               MORE DATA LEFT?
         BNZ       MOR                 LEAVE IF ALL DONE
         CLI       PREV,X'4D'          ARE WE IN MIDDLE OF LINE?
         BER       R14                 LEAVE IF NOT
         ST        R9,RSAVPL           SAVE OUR PLACE
         SR        R7,R7               ZERO RETCODE
         BR        R14
MOR      BCTR      R5,0                DECREMENT CHAR COUNTER
         IC        R7,RDAT(R8)         GET DATA FROM RDAT
         CR        R7,R4               IS IT THE QUOTE CHARACTER?
         BNE       REGULAR
         BCTR      R5,0                DECREMENT CHAR COUNT
         LA        R8,1(R8)            MOVE POINTER
         IC        R7,RDAT(R8)         PICK UP SPECIAL CHAR
         C         R7,=X'0000004D'     IS IT A CR? (CHAR(CR))
         BNE       NOCR                WRITE OUT RECORD IF YES
         MVI       PREV,X'4D'          JUST HAD A CR
         LA        R8,1(R8)            IGNORE CONTROL CHAR
         B         RFIN
NOCR     C         R7,=X'0000004A'     HOW ABOUT A LF? (CHAR(LF))
         BNE       NOLF                IF YES, WRITE OUT RECORD
         LA        R8,1(R8)            IGNORE CONTROL CHAR
         CLI       PREV,X'4D'          WAS LAST THING CR?
         BNE       RFIN                NOPE, THEN KEEP ON
         B         RLUP                IGNORE LF IF PREV=CR
NOLF     CR        R7,R4               IS IT THE QUOCHAR
         BE        REGULAR             DON'T CONVERT IF IT IS
         A         R7,O1H              ADD ¬O100
         N         R7,=X'0000007F'     GET MOD ¬O200
REGULAR  STC       R7,RBUF(R9)         STORE CHAR IN RBUF
         LA        R9,1(R9)            MOVE RBUF COUNTER
         LA        R8,1(R8)            MOVE RDAT COUNTER
         MVI       PREV,X'00'          BLANK OUT CR IF WAS THERE
         C         R9,=F'255'          ONLY 256 CHARS ALLOWED
         BNH       RLUP                AND CONTINUE
         LR        R10,R9              USE MAX LENGTH OF 256
         B         WRFIL               AND WRITE TO FILE
RFIN     LTR       R10,R9              GET DATA SIZE
         BZ        FUDGE               GOTTA FAKE A BLANK LINE
         C         R7,=X'0000004D'     IS IT A CR?  (CHAR(CR))
         BE        WRFIL
         C         R7,=X'0000004A'     HOW ABOUT A LF? (CHAR(LF))
         BE        WRFIL
         ST        R10,RSAVPL          SAVE DATA RECEIVED SO FAR
         SR        R7,R7               ZERO RETCODE
         BR        14
FUDGE    MVI       RBUF,X'20'          MAKE FIRST CHAR A SPACE
         LA        R10,1(R10)          LENGTH OF ONE
WRFIL    XC        RSAVPL,RSAVPL       RESET THE POINTER
         TR        RBUF(256),ATOE      MAKE EBCDIC AGAIN
         CLI       RFM,C'V'            IS IT VARIABLE FORMAT?
         BE        VAR
         CR        R10,R6
         BH        PUR                 IGNORE DATA AFTER LRECL VALUE
         CR        R10,R6              PAD OUT TO LRECL SIZE ?
         BE        VAR                 NOPE, IT'S OK.
         LR        R2,R6               GET LRECL SIZE
         SR        R2,R10              PAD WITH THIS MANY SPACES
         BCTR      R2,0                MINUS ONE FOR THE 'EX'
         LA        R9,RBUF(R10)        START PADDING HERE
         MVI       0(R9),C' '          PUT IN THE FIRST SPACE
         LTR       R2,R2
         BZ        PUR                 DON'T PAD IF SIZE DIF WAS ONE
         BCTR      R2,0                SUBRTRACT SPACE WE JUST ADDED
         EX        R2,PAD              PAD OUT BUFFER
PUR      LR        R10,R6              LENGTH HAS TO BE THIS SIZE
VAR      DS        0H                                             RJR
         LA        R15,WRITEX
         BALR      R15,R15
         SR        R9,R9               START AT BEGINNING OF RBUF
         B         RLUP                GET NEXT LINE IF OK
RECSAVE  DS        18F
PAD      MVC       1(0,R9),0(R9)       PAD OUT WITH SPACES
         LTORG
*
         EJECT
**********************************************************************
*                                                                    *
*  DISK FILE WRITE ROUTE WITH DEBUGGING CODE                         *
*                                                                    *
**********************************************************************
WRITEX   DS        0H
         USING     PARMS,R11
         STM       R12,R15,WRITSAVE
         BALR      R12,0
         USING     *,R12
         LA        R0,RBUF             POINT TO RBUF
         TM        KEROUT+(DCBRECFM-IHADCB),DCBRECV VARIABLE?
         BZ        WRITEX2             NO, THEN DON'T ADJUST
         LA        R0,RBUF-4           POINT TO RDW
         LR        R15,R10             GET THE LENGTH
         AH        R15,=H'4'           INCLUDE LENGTH OF RDW
         SR        R1,R1
         STH       R1,RBUF-2           CLEAR RDW
         IC        R1,LRECL            GET LRECL
         CR        R15,R1              IS THE RECORD GT MAX LRECL?
         BNH       *+6                 NO, THEN IT'S OK
         LR        R15,R1              ELSE SET TO MAX
         STH       R15,RBUF-4
WRITEX2  DS        0H
         PUT       KEROUT,(0)
         TM        DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN  IS IT OPEN?
         BZ        WRNODBG
         MVC       WRKBUFF(2),=H'12'
         XC        WRKBUFF+2(2),WRKBUFF+2
         MVC       WRKBUFF+4(8),=CL8'QSAM PUT'
         PUT       DEBUG,WRKBUFF
         EX        R10,DBGMVC4
         LA        R1,4(,R10)
         STH       R1,WRKBUFF
         PUT       DEBUG,WRKBUFF
WRNODBG  LM        R12,R15,WRITSAVE
         BR        R15
DBGMVC4  MVC       WRKBUFF+4(*-*),RBUF
         DROP      R11
         DROP      R12
         LTORG
         EJECT
**********************************************************************
*                                                                    *
*        ROUTINE TO PARSE COMMANDS AND CREATE PARSE TABLE            *
*                                                                    *
**********************************************************************
PARSER   STM       R14,R12,12(R13)     SAVE REGISTERS
         LR        R12,R15             MOVE THE BASE REGISTER
         USING     PARSER,R12          ##
         L         R11,=A(PARMS)       GET ADDRESS OF WORKAREAS
         USING     PARMS,R11
         LR        R3,R0               R3 = TEXT LENGTH
         BCTR      R1,0                R1 ==> BYTE BEFORE PARM
         LA        R3,0(R1,R3)         R3 ==> END OF LINE
         LA        R2,1                R2 = PARSING INCREMENT
         LA        R5,PTRTBL           R5 ==> TARGET AREA
         LA        R6,4                R6 = POINTER INCREMENT
         STM       R5,R6,PARSELST      SAVE FOR PARSING
         LA        R7,PTRTBL+PTRTBLL-4 R7 ==> END OF TARGET
*
SCNTOKEN BXH       R1,R2,SCNFINIS      SCAN FOR PARM START
         CLI       0(R1),C' '          FOUND A BLANK?
         BE        SCNTOKEN            YES, THEN KEEP LOOKING
         ST        R1,0(,R5)           SAVE PTR TO OPERAND
         BXH       R5,R6,SCNFINIS      BR ON END OF TARGET AREA
SCNLASTC BXH       R1,R2,SCNFINIS      SCAN TO END OF OPERAND
         CLI       0(R1),C' '          IS THIS BLANK AT END OF OPERAND
         BNE       SCNLASTC            IF SO, MOVE TOKEN
         LR        R9,R1               REMEMBER JUST AFTER OPERAND
         B         SCNTOKEN            FIND START OF NEXT OPERAND
SCNFINIS MVI       0(R9),C' '          MARK THE END OF OPERANDS
         ST        R9,0(R5)            SAVE POINTER TO END
         ST        R5,PARSELST+8       SAVE END TARGET
         LM        R14,R12,12(R13)     RESTORE THE REGISTERS
         BR        R14                 RETURN TO CALLER
         LTORG
HBTOFF  DC        X'7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F'           0000000
        DC        X'7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F'           0000000
        DC        X'7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F'           0000000
        DC        X'7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F'           0000000
        DC        X'7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F'           0000000
        DC        X'7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F7F'           0000000
        DC        X'7F7F7F7F7F7F7F7F7F7F'                               0000000
         DROP      R11
         DROP      R12                 DON'T NEED THEM ANYMORE
         EJECT
PARMS    DS        0H                  GLOBAL DATA LIST
         USING PARMS,R11
*** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **         0000000
*** DO NOT SEPARATE THE FOLLOWING TWO LABELS  ** ** ** ** ** **         0000000
*** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **         0000000
CX80WCC  DC        X'27F1F770'         CX80-PASSTHRU WCC'S   **         0000000
SNDPKT   DS        CL134               SEND THIS TO MICRO    **
*** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** ** **         0000000
         ORG       SNDPKT
PHDR     DS        X
PLEN     DS        X
PNUM     DS        X
PTYPE    DS        X
PDATA    DS        0C
         ORG       ,
*IDBYTE  DC        X'70'               DUMMY PLACE FOR CX80 BYTE        0000000
RECPKT   DS        CL130               RECEIVE THIS FROM MICRO
LSDAT    DS        F                   SEND PACKET SIZE
LRDAT    DS        F                   RECEIVE PACKET SIZE
FLAGS    DC        X'00'               USE TO TEST OUR FLAGS
NAME     DC        18X'20'             NAME OF FILE(S) TO SEND
         DS        0F
         DS        0F
INPUT    DS        CL130               INPUT BUFFER
         DS        0F
         DS        F                   RDW FOR VARIABLE RECORDS
BUF      DS        CL260               DISK READ INTO HERE
         DS        F                   RDW FOR VARIABLE RECORDS
RBUF     DS        CL260               DISK WRITE FROM HERE
N        DC        F'0'                SEND PACKET NUMBER
NUM      DC        F'0'                RECEIVE PACKET NUMBER
NUMTRY   DC        F'0'                TRIAL COUNTER FOR TRANSFERS
OLDTRY   DS        F                   COUNTER FOR PREVIOUS PACKET
STORLOC  DS        F                   POINTER TO EXTRA STORAGE
*MAXPACK  DC        F'94'               MAX PACKET SIZE
PASTHRU  DC      17X'27F1F770C9CEA0D0C1D3D3D4C8D2D58D8A'                0000000
MAXPACK  DC        F'80'               MAX PACKET SIZE
RECL     DS        F                   RECORD LEN (IF RECFM = V)
*RPSIZ    DC        F'94'               MAX RECEIVE PACKET SIZE
RPSIZ    DC        F'80'               MAX/deflt RECEIVE PACKET SIZE
*DSSIZ    DC        F'40'               DEFAULT MAX SEND PACKET SIZE
DSSIZ    DC        F'80'               DEFAULT MAX SEND PACKET SIZE
SPSIZ    DS        F                   SEND PACKET SIZE
MAXTRY   DC        F'5'                NO. OF TIMES TO RETRY PACKET
IMXTRY   DC        F'16'               NO. OF INITIAL TRIALS ALLOWED
SIZE     DS        F                   MAX SIZE FOR SEND DATA
DEL      DC        F'127'              OCTAL 177 (DELETE CHAR)
ZERO     DC        F'0'
ONE      DC        F'1'
FIVE     DC        F'5'
TWO      DC        F'2'
SPACE    DC        F'32'               ASCII SPACE
O1H      DC        F'64'               OCTAL 100
O2H      DC        F'128'              OCTAL 200
SAVPL    DC        F'0'                POINTER WITHIN BUF,INIT=0
RSAVPL   DC        F'0'                POINTER IN 'PTCHR',INIT=0
DQUOTE   DC        X'23'               DEFAULT QUOTE CHARACTER = #
QUOCHAR  DS        X                   QOUTE CHAR WE'LL SEND
RQUO     DS        X                   MICRO'S QUOTE CHAR
TEMP     DS        F                   TEMPORARY SPACE
         DS        0D
PKVAR    DS        D                   USE FOR PICKING UP INTEGER
SDAT     DS        CL130               TEMP PLACE FOR SEND DATA
RDAT     DS        CL130               TEMP PLACE FOR RECEIVE DATA
FILNAML  DS    H                   LENGTH OF FILENAME
FILNAM   DS        CL18                SEND/REC FILENAME
STATE    DS        C                   OUR CURRENT STATE
DEOL     DC        X'0D'               DEFAULT END OF PACKET (CR)
REOL     DS        X                   EOL CHAR I NEED (CR)
SEOL     DS        X                   EOL I'LL SEND
DSOH     DC        X'01'               DEFAULT START OF HEADER (CTL A)
RSOH     DS        X                   RECEIVE START OF HEADER
SSOH     DS        X                   SEND START OF HEADER
*DLRECL  DC        X'50'               DEFAULT LRECL SIZE OF 80
DLRECL   DC        X'FF'               DEFAULT LRECL SIZE OF 255
LRECL    DS        X                   LRECL PROGRAM WILL USE
*DBLKSIZE DC       H'80'               DEFAULT BLKSIZE OF 80
DBLKSIZE DC        H'255'              DEFAULT BLKSIZE OF 255
BLKSIZE  DS        H                   BLKSIZE PROGRAM WILL USE
DTRACK   DC        F'5'                DEFAULT SPACE ALLOCATION
DRECFM   DC        C'F'                DEFAULT WITH FIXED RECFM
RFM      DS        C                   RECFM PROGRAM WILL USE
PREV     DS        C                   PREVIOUS CHAR REC (IN PTCHR)
BLIP     DS        X                   SAVE USER'S BLIP CHAR
LINSIZ   DS        F                   SAVE USER'S CONSOLE LINESIZE
ERRNUM   DS        X                   ERROR NUMBER,IN CASE WE DIE
OLDERR   DS        X                   ERROR OF PREVIOUS EXECUTION
STYPE    DS        C                   TYPE OF PACKET SENT
RTYPE    DS        C                   TYPE OF PACKET RECEIVED
*
READSAVE DS        4F              REGISTER SAVEAREA
WRITSAVE DS        4F              REGISTER SAVEAREA
PARSELST DS        3F                  PTRS TO OPERAND STACK
PTRTBL   DS        15F                 OPERAND STACK
PTRTBLL  EQU       *-PTRTBL            LENGTH OF PTRTBL
DBLWRK   DS        D
IDSYS    DC        F'2'                MVS TSO
DDNAME   DC        CL8' '              DDNAME TO ALLOCATE
DSNAME   DC        CL80' '             DSNAME TO ALLOCATE
DSNAMEX  DC        CL80' '             WRKBUFFER
MEMBER   DC        CL8' '              MEMBER NAME FOR PDS ALLOC
CMSXXX   DC        CL8' '              USED IN CMS ONLY
CMSYYY   DC        CL8' '
CMSZZZ   DC        CL2' '
DISP1    DC        F'2'                DISP (0=NEW,1=OLD,2=SHR)
DISP2    DC        F'3'                DISP (0=UNCAT,1=CAT,3=KEEP)
INOUT    DC        F'2'                0=INPUT,1=OUTPUT,2=INOUT)
RECFMX   DC        F'1'                1=FB,2=VBS
BLKSIZEX DC        F'3600'             FOR NEW DATA SETS ONLY
LRECLX   DC        F'80'               ....
DEV      DC        CL8'SYSDA'          DEVICE
TRACK    DC        F'20'               # TRACKS TO ALLOC FOR NEW DSETS
DYNALCRC DC        F'0'                RETURN CODE FROM FUNCTION
WRKBUFF  DS        CL280
PREFIX   DC        CL8' '              USERS DSET PREFIX FROM UPT
PCOUT    DC        CL20'=::C::::::CCD:B:E:::'                           0000000
ASCIIX   DC        CL1'H'                                               0000000
PCIN     DC        CL20' '                                              0000000
PREFIXL  DC        F'0'                PREFIX LENGTH-1
DDELAY   DC        F'2000'             DEFAULT DELAY TIME
DELAY    DS        F                   DELAY TIME
*
*  THIS IS THE DYNALC PARM LIST USED FOR BOTH ALLOCATION AND
*  CREATION OF  DATA SETS.
*
DYNAPARM DS 0F
 DC A(IDSYS,DDNAME,DSNAME,MEMBER,CMSXXX,CMSYYY,CMSZZZ,DISP1,DISP2)
 DC A(INOUT,RECFMX,BLKSIZEX,LRECLX,DEV,TRACK)
 DC X'80',AL3(DYNALCRC)
*
* TABLE TO TRANSLATE TO UPPER CASE
*
UPPER    DC    256AL1(*-UPPER)
         ORG   UPPER+X'81'
         DC    C'ABCDEFGHI'
         ORG   UPPER+X'91'
         DC    C'JKLMNOPQR'
         ORG   UPPER+X'A2'
         DC    C'STUVWXYZ'
         ORG
* THIS IS THE TABLE TO SET SENDPACKS PARITY TO MARK FOR CX80
HIBITON  DC        X'808182838485868788898A8B8C8D8E8F'
         DC        X'909192939495969798999A9B9C9D9E9F'
         DC        X'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF'
         DC        X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'
         DC        X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF'
         DC        X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'
         DC        X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF'
         DC        X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF'
         DC        X'808182838485868788898A8B8C8D8E8F'
         DC        X'909192939495969798999A9B9C9D9E9F'
         DC        X'A0A1A2A3A4A5A6A7A8A9AAABACADAEAF'
         DC        X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF'
         DC        X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF'
         DC        X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF'
         DC        X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF'
         DC        X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF'
*THIS IS THE ORIGINAL EBCDIC TO ASCII CONVERSION TABLE
*CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL
*ETOA    DC        X'000102030009007F0000000B0C0D0E0F'
*G       DC        X'1011121300000800181900001C1D1E1F'
*        DC        X'10111213000D0800181900001C1D1E1F'
*        DC        X'00000000000A171B0000000000050607'
*        DC        X'0000160000000004000000001415001A'
*        DC        X'20000000000000000000002E3C282B7C'
*        DC        X'2600000000000000000021242A293B5E'
*        DC        X'2D2F00000000000000007C2C255F3E3F'
*        DC        X'000000000000000000603A2340273D22'
*        DC        X'00616263646566676869007B00000000'
*        DC        X'006A6B6C6D6E6F707172007D00000000'
*        DC        X'007E737475767778797A0000005B0000'
*        DC        X'000000000000000000000000005D0000'
*        DC        X'7B414243444546474849000000000000'
*        DC        X'7D4A4B4C4D4E4F505152000000000000'
*        DC        X'5C00535455565758595A000000000000'
*        DC        X'303132333435363738397C0000000000'
* THIS IS THE PRC MODIFIED ASCII TO EBCDIC TABLE 6/28/85 9:00
*                    0.1.2.3.4.5.6.7.8.9.A.B.C.D.E.F.                   0000000
ATOE     DC        X'00010203372D2E2F1605250B0C0D0E0F'
         DC        X'101112133C3D322618193F271C1D1E1F'
         DC        X'405A7F7B5B6C507D4D5D5C4E6B604B61'
         DC        X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F'
         DC        X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6'
         DC        X'D7D8D9E2E3E4E5E6E7E8E9ADCFBDB06D'
         DC        X'BF818283848586878889919293949596'
         DC        X'979899A2A3A4A5A6A7A8A98B4F9B5F07'
*THIS IS THE PRC MODIFIED EBCDIC TO ASCII CONVERSION TABLE 6/28/85 9:00
*CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL
*                    0.1.2.3.4.5.6.7.8.9.A.B.C.D.E.F.                   0000000
ETOA     DC        X'000102030009007F0000000B0C0D0E0F'
         DC        X'10111213000D0800181900001C1D1E1F'
         DC        X'00000000000A171B0000000000050607'
         DC        X'0000160000000004000000001415001A'
         DC        X'20000000000000000000002E3C282B7C'
         DC        X'2600000000000000000021242A293B7E'
         DC        X'2D2F00000000000000007C2C255F3E3F'
         DC        X'000000000000000000603A2340273D22'
         DC        X'00616263646566676869007B00000000'
         DC        X'006A6B6C6D6E6F707172007D00000000'
         DC        X'007E737475767778797A0000005B0000'
         DC        X'5E0000000000000000000000005D0060'
         DC        X'7B41424344454647484900000000005C'
         DC        X'7D4A4B4C4D4E4F505152000000000000'
         DC        X'5C00535455565758595A000000000000'
         DC        X'303132333435363738397C0000000000'
*
* TABLE OF ERROR MESSAGES (IN CASE WE ABORT)
ERRTAB   DC        CL20'Bad send-packet size'    ERR MSG #0
         DC        CL20'Bad message number'      ERR MSG #1
         DC        CL20'Unrecognized state'      ERR MSG #2
         DC        CL20'No SOH encountered'      ERR MSG #3
         DC        CL20'Bad character count'     ERR MSG #4
         DC        CL20'Bad checksum'            ERR MSG #5
         DC        CL20'Disk is full'            ERR MSG #6
         DC        CL20'Illegal packet type'     ERR MSG #7
         DC        CL20'Lost a packet'           ERR MSG #8
         DC        CL20'Micro sent a NAK'        ERR MSG #9
         DC        CL20'Micro aborted'           ERR MSG #10
         DC        CL20'Illegal file name'       ERR MSG #11
         DC        CL20'Invalid lrecl'           ERR MSG #12
         DC        CL20'Permanent I/O error'     ERR MSG #13
         DC        CL20'Disk is read-only'       ERR MSG #14
         DC        CL20'Recfm conflict'          ERR MSG #15
         DC        CL20'Err allocating space'    ERR MSG #16
DATASET CAMLST     NAME,DSNAME,,WRKBUFF
KERIN DCB DDNAME=KERIN,DSORG=PS,MACRF=(GM),                            X
               EODAD=INEOF
KEROUT DCB DDNAME=KEROUT,DSORG=PS,MACRF=(PM),LRECL=80,BLKSIZE=84,      X
               RECFM=VB
DEBUG  DCB DDNAME=DEBUG,DSORG=PS,MACRF=(PM),LRECL=260,BLKSIZE=2048,    X
               RECFM=VB
MODDCBF DCB DDNAME=KEROUT,DSORG=PS,MACRF=(PM),LRECL=80,BLKSIZE=80,     X
               RECFM=FB
MODDCBFL EQU *-MODDCBF
MODDCBV DCB DDNAME=KEROUT,DSORG=PS,MACRF=(PM),LRECL=80,BLKSIZE=84,     X
               RECFM=VB
MODDCBVL EQU *-MODDCBV
         END KERMIT
@@
//LKED.SYSLMOD DD DSN=SYS2.LINKLIB,DISP=SHR  <== TARGET
//LKED.SYSIN DD *
  NAME KERMITT(R)
//*