home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
music.tar.gz
/
music.tar
/
imusic.asm
next >
Wrap
Assembly Source File
|
1984-10-15
|
117KB
|
2,615 lines
PRINT NOGEN
MACRO
&LABEL WRTERM &MSG
LCLA &CNT
LCLC &LEN
&CNT SETA K'&MSG-2
&LEN SETC '&CNT'
&LABEL XC IOBUF,IOBUF BLANK OUT IOBUF
MVI IOBUF,C' '
MFSET REPLY,IO,R=(WR)
MVC IOBUF+1(&LEN),=C&MSG
LA R2,&LEN+1
ST R2,IOARG+4
MFREQ REPLY
MEND
PRINT NOGEN
KERMIT TITLE 'KERMIT-MUSIC'
KERMIT CSECT
* KERMIT -
*
* Kermit - KL10 Error-free Reciprocol Micro Interface Transfer
* MUSIC version 1.2
*
* This program is the IBM MUSIC side of a file transfer system.
* It can be used to transfer files between a micro and a system
* running MUSIC under VM/SP.
* See the KERMIT manual for the complete program specifications
* to which this program and any other component of the system
* must adhere.
*
* Marie Schriefer, Indiana University - Purdue University, Indianaplis
* October, 1984
* This version of Kermit was created by modifying the VM/CMS Kermit
* from March 1982.
*
* This latest version of 12-11-85, will support the IBM SERIES1/7171
* protocol device. Changes made by Tulane University.
* Contact John Voigt, Tulane University Computer Services Dept.
* Room 102, Richardson Bldg, New Orleans LA 70118-5698
* <SYSBJAV%TCSVM.BITNET@WICSVM.ARPA>
*
* Permission is granted to any individual or institution to copy
* or use this program, except for explicitly commercial purposes.
*
* Note that this version has only been tested using the IBM PC version
* of Kermit as the remote side.
*
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
*
* EXTERNAL MACROS/MODULES CALLED -
* The following MACLIBs are needed to assemble this:
* $MCM.MACLIB, $MCS.MACLIB
*
*
*
SPACE
REGS
MUSVC
SPACE
SOH EQU X'01' ^a FOR START OF HEADER CHAR
SBA EQU X'11' FOR SERIES1/7171
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
CR EQU X'0D' MUSIC'S CARRIAGE RETURN
FLG1 EQU X'80' INTERRUPT SENT FROM MICRO
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' FILE 'FILNAM' IS NOW OPEN
FLG6 EQU X'04' END-OF-FILE FOUND
ISS1 EQU X'01' series 1/7171 terminal
S1INIT EQU X'80' series 1 initialized
EJECT
KERMIT CSECT
STM R14,R12,12(R13) SAVE REGS
BALR R12,0 ESTABLISH
USING *,R12 ADDRESSABILITY
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
L R15,=A(INIT)
BALR R14,R15 CALL THE INITIALIZATION
SR R15,R15 ZERO RC INITIALLY (IF EXIT)
*
OPENTERM MFSET REPLY,OPEN,R=(RDOK,WROK,DDORDS,ENQSHR) OPEN
MFREQ REPLY TERMINAL
CALL NPRMPT DON'T WRITE OUT MUSIC PROMPT
PROMPT WRTERM 'KERMIT-MUSIC>' WRITE PROMPT
MFSET REPLY,IO,R=(RD,FILL) SET FOR READ
XC IOBUF,IOBUF CLEAR BUFFER
MVC IOARG+4,IOBUFLEN
CALL TRIN TRANSLATE INPUT
MFREQ REPLY READ
*
* PARSE INPUT INTO 1 TO 3 WORDS
*
CALL NOTRIN
MVC COMMAND,BLANKS MOVE BLANKS TO COMMAND
MVC WORD2,BLANKS
MVC WORD3,BLANKS
LA R1,IOBUF POINT TO INPUT BUFFER
LA R15,FINDWORD GO FIND COMMAND
BALR R14,R15 BRANCH
LTR R4,R4 COMMAND FOUND?
BZ PROMPT NO, GO PROMPT
CH R4,=H'3' COMMAND LENGTH GREATER THAN 3?
BNH MOVEOK NO, BRANCH
LA R4,3 MOVE ONLY 3 CHARS OF COMMAND
MOVEOK DS 0H
BCTR R4,0 SUBTRACT ONE FOR EXECUTE
EX R4,MOVECMD MOVE COMMAND
LA R15,FINDWORD GO FIND NEXT WORD
BALR R14,R15
LTR R4,R4 WORD FOUND?
BZ CMDCHK NO, GO CHECK COMMAND
CH R4,=H'17' GREATER THAN 22?
BH LENGERR YES, GO GIVE ERROR
ST R4,WORD2LEN SAVE THE LENGTH
BCTR R4,0 SUBTRACT ONE FOR EXECUTE
EX R4,MOVEWRD2 NO, MOVE TO WORD TWO
LA R15,FINDWORD GO GET NEXT WORD
BALR R14,R15 BRANCH
LTR R4,R4 WORD FOUND?
BZ CMDCHK NO, GO PROCESS COMMAND
CH R4,=H'17' GREATER THAN 17?
BNH MOVEOK3 NO, GO DO MOVE
LA R4,17 YES, TRUNCATE TO 8
MOVEOK3 DS 0H
ST R4,WORD3LEN SAVE LENGTH OF WORD
BCTR R4,0 SUBTRACT ONE FOR EXECUTE
EX R4,MOVEWRD3 MOVE REST OF INPUT
B CMDCHK
LENGERR DS 0H
WRTERM 'The filename or 2nd word of the command is too longX
. MUSIC filenames'
WRTERM 'may be up to 17 characters long.'
B PROMPT
*
FINDWORD DS 0H
LA R5,IOBUFEND-1 ADDR OF END OF INPUT - 1
SR R5,R1 LENGTH OF REST OF INPUT
LR R6,R1 POINTER TO INPUT BUFFER
EX R5,TRTNONBL FIND START OF NEXT WORD
BZ NOWORD FIRST LETTER FOUND
CLI 0(R1),CR CARRIAGE RETURN?
BNE NXTWORD YES, GO CHECK COMMAND
NOWORD DS 0H
LA R4,0 NO WORD
BR R14 RETURN
NXTWORD DS 0H
LA R5,IOBUFEND-1 GET END OF INPUT BUFFER
SR R5,R1 GET LENGTH LEFT
LR R6,R1 START OF SECOND WORD
SR R1,R1 CLEAR FOR TRANSLATE
EX R5,TRTBLANK FIND NEXT BLANK OR CR
BZ CMDERR ERROR IF NOT FOUND
LR R4,R1 ADDR OF BLANK AFTER WORD
SR R4,R6 LENGTH OF NEXT WORD
BR R14 RETURN
TRTBLANK TRT 0(0,R6),BLANKTBL LOOK FOR NEXT BLANK
TRTNONBL TRT 0(0,R6),NONBLANK LOOK FOR NON BLANK CHAR
MOVECMD MVC COMMAND(0),0(R6) MOVE COMMAND TO COL. 1
MOVEWRD2 MVC WORD2(0),0(R6) MOVE SECOND WORD OF COMMAND
MOVEWRD3 MVC WORD3(0),0(R6) MOVE SECOND WORD TO COL. 5
*
CMDCHK DS 0H
MVI ERRNUM,X'FF' RESET ERROR FOR THIS TIME
CLI COMMAND,C'E' CHECK FOR 'EXIT' COMMAND
BNE CHKQ NO, BRANCH TO CHECK Q
CLI WORD2,C'?' YES, IS IT QUESTION OR EXIT?
BNE RET EXIT, SO GO RETURN
WRTERM 'The EXIT command causes KERMIT to terminate.'
B PROMPT
*
CHKQ DS 0H
CLI COMMAND,C'Q' CHECK FOR 'QUIT' COMMAND
BNE CHKQUES NO, BRANCH
CLI WORD2,C'?' QUESTION ABOUT QUIT?
BNE RET NO, GO RETURN
WRTERM 'The QUIT command causes KERMIT to terminate.'
B PROMPT
*
CHKQUES DS 0H
CLI COMMAND,C'?' NEED HELP ?
BNE CHKSET
WRITECMD DS 0H
WRTERM 'Legal Commands are: '
WRTERM 'RECEIVE, SEND, HELP, EXIT, QUIT, SET, STATUS, SHOW,*
?'
B PROMPT
*
CHKSET CLC COMMAND,=CL3'SET' IS IT THE SET COMMAND ?
BE STSWITCH
CLC COMMAND,=C'STA' IS IT THE STATUS COMMAND?
BE STATSW
CLC COMMAND,=C'SHO' IS IT THE SHOW COMMAND?
BE SHOSW
CLC COMMAND,=C'HEL' NEED HELP ?
BE HELPSW
NI FLAGS,X'FF'-FLG2 TURN OFF OVERWRITE FLAG (INIT)
CLC COMMAND,=C'REC'
BNE SS MAYBE IT'S A SEND COMMAND
*
* RECEIVE COMMAND
*
CLI WORD2,C'?' NEED HELP?
BNE RR2
WRTERM 'SPECIFY: RECeive (filename)'
WRTERM ' '
WRTERM 'The filename is optional. If given, the file will X
be stored under that name.'
WRTERM 'If missing, the file will be stored with the name fX
rom the SEND command.'
B PROMPT
*
RR2 DS 0H
CLI WORD2,C' ' FILENAME GIVEN?
BE RSWITCH NO, CONTINUE
OI FLAGS,FLG2 TURN ON OVERWRITE FLAG
MVC FILNAM(22),WORD2 MOVE FILNAME
TRT FILNAM(18),BLANKTBL FIND FIRST BLANK
BNZ RR3
WRTERM 'ERROR IN FILE NAME.'
B PROMPT
RR3 DS 0H
LA R2,FILNAM START OF FILE NAME
SR R1,R2 SUBTRACT START FROM END
ST R1,FNAMLEN STORE FILE NAME LENGTH
MVI PREV,X'00' ZERO OUT PREV. LINE FLAG
XC RBUF,RBUF CLEAR BUFFER
LA R5,RBUF GET ADDRESS OF BUFFER
ST R5,MUSARG+8 STORE IN MUSARG
MVC MUSARG+4(4),=F'256'
MFSET MUSFIL,OPEN,R=(OKNEW,WROK)
MFREQ MUSFIL,BAD=BADOPEN
OI FLAGS,FLG5 TURN ON FILE OPEN FLAG
RSWITCH DS 0H
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
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
*
* SEND COMMAND
*
SS CLC COMMAND,=C'SEN'
BNE CMDERR UNRECOGNIZED COMMAND
CLI WORD2,C'?' NEED HELP?
BNE SS2 NO, BRANCH
WRTERM 'SPECIFY: SEND filename1 (filaname2)'
WRTERM ' '
WRTERM 'Send the MUSIC file, filename1, to the micro.' If x
filename2'
WRTERM 'is given, send the name to the micro to use as the X
file name there.'
WRTERM ' '
B PROMPT
SS2 DS 0H
CLI WORD2,C' ' FILENAME GIVEN?
BNE SS3
WRTERM 'No filename specifed'
B PROMPT
SS3 DS 0H
MVC FILNAM(22),WORD2
MVC FNAMLEN(4),WORD2LEN STORE FILE NAME LENGTH
LA R5,BUF GET ADDRESS OF BUFFER
ST R5,MUSARG+8 STORE IN MUSARG
MVC MUSARG+4(4),=F'256'
MFSET MUSFIL,OPEN,R=(OKOLD,RDOK)
MFREQ MUSFIL,BAD=BADOPEN
OI FLAGS,FLG5 TURN ON FILE OPEN FLAG
SSWITCH DS 0H
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
MVC OLDERR(1),ERRNUM ERROR SETTING OF THIS RUN
SSW1 LTR R5,R5 CHECK THE RETCODE
BZ PROMPT ALL OKAY
WRTERM 'Error in sending file. Try again.'
B PROMPT ERROR - TRY AGAIN
*
BADOPEN DS 0H
XC IOBUF,IOBUF CLEAR IOBUF
LA R5,IOBUF+1 GET ERROR MESSAGE IN IO BUFFER
ST R5,MUSARG+8
MVC MUSARG+4(4),IOBUFLEN SET MAX LENGTH
MFSET MUSFIL,MSG GET ERROR MESSAGE
MFREQ MUSFIL,BAD=STATBAD
L R5,MUSARG+4 GET LENGTH OF MESSAGE
LA R5,1(R5) ADD ONE FOR CC
ST R5,IOARG+4 STORE MESSAGE LENGTH
MVC MUSARG+4(4),=F'256' RESET TO 256
MVI IOBUF,C' ' SET CARRIAGE CONTROL TO BLANK
MFSET REPLY,IO,R=(WR) SET UP TO WRITE ERROR MSG
MFREQ REPLY
B PROMPT AND LEAVE
*
*
*
CMDERR WRTERM 'INVALID COMMAND'
B PROMPT INVALID COMMAND - TRY AGAIN
SPACE 3
*
*
*
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
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
STATSW EQU *
CLI WORD2,C'?' NEED HELP?
BNE GIVSTAT
WRTERM 'The STATUS command gives the final status'
WRTERM 'of the previous KERMIT command.'
B PROMPT
GIVSTAT CLI OLDERR,X'FF' WAS THERE AN ERROR LAST TIME?
BNE FAIL
WRTERM 'Kermit completed successfully'
B PROMPT
FAIL DS 0H
XC IOBUF,IOBUF CLEAR IOBUF
CLI OLDERR,X'FE' ERROR ON MFREQ?
BE STATUS1 YES, BRANCH
IC R5,OLDERR GET OFFSET INTO ERROR TABLE
M R4,=F'20' OFFSET := ERRNUM * 20
LA R5,ERRTAB(R5)
CLI OLDERR,S1ERRNUM WAS IT A SERIES1 ERROR?
BNE FAIL1 NO, THE WRITE OUT THE ERROR
LA R1,X'F0' GET READY TO UNPK ERROR CODES
ICM R1,B'1110',KERFSRET MOVE IN THE ERROR CODES
SRL R1,4 GET RID OF LOWER ZERO
ST R1,WORK1 SAVE IT
UNPK S1RETC(6),WORK1(4) MAKE IT SORTA-PRINTABLE
TR S1RETC(6),HEXTB PRETTY IT UP
FAIL1 MVC IOBUF+1(20),0(R5) MOVE MESSAGE
B STATWR BRANCH TO WRITE STATUS
STATUS1 DS 0H
MVC MUSFIL+8(1),MUSERR MOVE IN ERROR CODE
LA R5,IOBUF+1
ST R5,MUSARG+8
MVC MUSARG+4(4),IOBUFLEN SET MAX LENGTH
MFSET MUSFIL,MSG
MFREQ MUSFIL,BAD=STATBAD
MVC MUSARG+4(4),=F'256'
STATWR DS 0H
MFSET REPLY,IO,R=(WR)
MVI IOBUF,C' ' BLANK OUT CC
MVC IOARG+4,IOBUFLEN
MFREQ REPLY
B PROMPT AND LEAVE
STATBAD DS 0H
MVC IOBUF+1,=C'BAD ERROR CODE FOUND IN MUSERR'
MVC MUSARG+4(4),=F'256'
B STATWR
*
HELPSW DS 0H
WRTERM 'EXIT back to MUSIC'
WRTERM 'QUIT and go back to MUSIC'
WRTERM 'RECEIVE file from PC'
WRTERM 'SEND file to PC'
WRTERM 'SET a parameter'
WRTERM 'SHOW the value of a parameter'
WRTERM 'STATUS of previous Kermit command'
WRTERM '? - list the available Kermit commands'
WRTERM ' '
WRTERM 'For details on a command, issue the command followex
d by ?'
WRTERM 'All commands may be shortened to 3 characters.'
WRTERM ' '
B PROMPT
*
*
RET EQU *
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
INIT CSECT
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 IOBUF,IOBUF
LA R0,BUF GET BUFFER ADDR
LA R1,L'BUF GET LENGTH OF BUFFER
SR R15,R15 SET MOVE LENGTH AND PAD TO ZERO
MVCL R0,R14 CLEAR OUT BUFFER
LA R0,RBUF CLEAR
LA R1,L'RBUF OUT
SR R15,R15 THE
MVCL R0,R14 BUFFER
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
MVI S1FLAGS,X'01' DEFAULT TO SERIES1 ON
XC SAVPL,SAVPL CLEAR
XC SAVPLDAT,SAVPLDAT BUFFER
XC RSAVPL,RSAVPL POINTERS
XC NUMTRY,NUMTRY
MVC FILNAM,=22X'20' BLANK OUT FILNAM & NAME
MVC FNAMLEN,=F'0' MOVE ZERO TO FILE NAME LENGTH
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
MVC LRECL(1),DLRECL SET DEFAULTS, JUST IN CASE
MVC RFM(1),DRECFM
MVC QUOCHAR(1),DQUOTE
MVC RQUO(1),DQUOTE
MVC REOL(1),DEOL
MVC SEOL(1),DEOL
MVC DLYTIME(4),DDLYTIM SET DELAY TIME FOR SINIT
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
*
*
PARMS CSECT GLOBAL DATA LIST
REPLY MFARG 0,NAME=TERM,ARG=IOARG
MFGEN
MUSFIL MFARG 0,NAME=FILNAM,ARG=MUSARG,INFIN=INFARG1,INFOUT=INFARG2
MFGEN
KERMFARG MFARG FSIO,U=9,FSARG=KERFSARG,PHYS=KERPHYS,RLAB=KERFSRET
MFGEN
KERFSARG MFVAR FSARG,PICT=Y,PRE=KERM
KERPHYS MFVAR PHYS,PICT=Y,PRE=KERM
IOARG DC A(0,132,IOBUF)
IOBUF DC XL132'00'
IOBUFEND DS 0CL1
TERM DC CL22'SYSTERM'
IOBUFLEN DC F'132'
MUSARG DS 0F
DC A(0)
MUSRLEN DC A(256)
DC A(BUF)
INFARG1 DC A(10,30,-1)
LRECL DC AL2(80)
RFM DC AL1(02)
DC AL1(0)
DC XL4'0000C0C0'
INFARG2 DC A(20,20,-1)
DC AL2(80)
DC AL1(02)
DC AL1(0)
DC XL4'0000C0C0'
**************************************************************
* W A R N I N G : THE FOLLOWING S1ORDS MUST IMMEDIATELY *
* PRECEDE THE SNDPKT BUFFER. THEY CAUSE THE *
* SERIES1/7171 TO ENTER TRANSPARENCY MODE. *
* *
**************************************************************
S1ORDS DS 0D
DC X'40',AL1(SBA),X'5D7F',AL1(SBA),X'0001' TRANSPARENCY
S1ORDSL EQU *-S1ORDS
SNDPKT DS CL130 SEND THIS TO MICRO
ORG SNDPKT
PHDR DS X
PLEN DS X
PNUM DS X
PTYPE DS X
PDATA DS 0C
ORG ,
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
S1FLAGS DC X'01' SERIES 1 FLAGS
COMMAND DS CL3
WORD2 DS CL22
WORD3 DS CL22
WORD2LEN DC F'0' LENGTH OF PARM IN WORD2
WORD3LEN DC F'0' LENGTH OF PARM IN WORD3
DS 0F
BUF DS CL256 FSREAD INTO HERE
DS CL2 EXTRA BYTES IN CASE 256 CHARS
RBUF DS CL256 FSWRITE 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
MAXPACK DC F'94' MAX PACKET SIZE
RECL DS F RECORD LEN (WITHOUT BLANKS)
RPSIZ DC F'94' MAX RECEIVE PACKET SIZE
DSSIZ DC F'40' 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
SAVPLDAT DC F'0' POINTER WITHIN SDAT, 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
WORK1 DS F FOR FSIO ERROR
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
FNAMLEN DS F FILE NAME LENGTH
FILNAM DS CL22 SEND/REC FILENAME
BLANKS DC CL22' ' BLANKS
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
DLRECL DC X'0050' DEFAULT LRECL SIZE OF 80
DRECFM DC X'02' DEFAULT RECFM - FIXED COMPRESSED
PREV DS C PREVIOUS CHAR REC (IN PTCHR)
DLYTIME DS F DELAY TIME BEFORE SEND INIT
DDLYTIM DC F'15' DEFAULT DELAY TIME
ERRNUM DS X ERROR NUMBER,IN CASE WE DIE
OLDERR DS X ERROR OF PREVIOUS EXECUTION
MUSERR DS X ERROR FROM MUSIC MACRO MFREQ
STYPE DS C TYPE OF PACKET SENT
RTYPE DS C TYPE OF PACKET RECEIVED
* THIS IS THE ASCII TO EBCDIC TABLE
ATOE DC X'00010203372D2E2F1605250B0C0D0E0F'
DC X'101112133C3D322618193F271C1D1E1F'
DC X'405A7F7B5B6C507D4D5D5C4E6B604B61'
DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F'
DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6'
DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D'
DC X'79818283848586878889919293949596'
DC X'979899A2A3A4A5A6A7A8A9C04FD0A107'
*THIS IS THE EBCDIC TO ASCII CONVERSION TABLE
*CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL
ETOA DC X'000102030009007F0000000B0C0D0E0F'
DC X'1011121300000800181900001C1D1E1F'
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'
*
* 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
DC CL20'ERROR OPENING FILE ' ERR MSG #17
S1ERRMSG DS 0CL20
DC CL13'FSIO ERROR = ' ERR MSG #18
S1RETC DC CL6' '
DC CL1' '
S1ERRNUM EQU 18 ERROR NUMBER FOR SERIES1/7171
*
BLANKTBL DS 0XL256
DC 13XL1'00'
DC X'02'
DC 50XL1'00'
DC X'01' STOP ON A SPACE
DC 191XL1'00'
*
NONBLANK DS 0XL256
DC 64XL1'01'
DC X'00' STOP ON A NON-BLANK
DC 191XL1'01'
*
NAMETBL DS 0XL256
DC 75XL1'01'
DC XL1'00' '.'
DC 15XL1'01'
DC XL1'00' '$'
DC 31XL1'01'
DC 2XL1'00' '#' AND '@'
DC 68XL1'01'
DC 9XL1'00' ABCDEFGHI
DC 7XL1'01'
DC 9XL1'00' JKLMNOPQR
DC 8XL1'01'
DC 8XL1'00' STUVWXYZ
DC 6XL1'01'
DC 10XL1'00' 0123456789
DC 6XL1'01'
*
INPTTY DS 0D
* 0 1 2 3 4 5 6 7 8 9 A B C D E F
* ZLZL@ @ SPSPR'R'DEDEP P 0 0 P P
DC X'00007C7C404079791010D7D7F0F09797' 0
* BSBSH H ( ( H H CNCNX X 8 8 X X
DC X'1616C8C84D4D88881818E7E7F8F8A7A7' 1
* ETETD D $ $ D D TFTFT T 4 4 T T
DC X'3737C4C45B5B84843C3CE3E3F4F4A3A3' 2
* FFFFL L , , L L FSFSR/R/< < +-+-
DC X'0C0CD3D36B6B93931C1CE0E04C4C4F4F' 3
* SXSXB B " " B B TNTNR R 2 2 R R
DC X'0202C2C27F7F82821212D9D9F2F29999' 4 48 & 49 CHANGED
* LFLFJ J * * J J SBSBZ Z : : Z Z FROM 0101
DC X'2525D1D15C5C91913F3FE9E97A7AA9A9' 5
* AKAKF F & & F F SYSYV V 6 6 V V
DC X'2E2EC6C6505086863232E5E5F6F6A5A5' 6
DC X'0E0ED5D54B4B95951E1E5F5F6E6EA1A1' 7
* SHSHA A ! ! A A XNXNQ Q 1 1 Q Q
DC X'0101C1C15A5A81811111D8D8F1F19898' 8
* TBTBI I ) ) I I EMEMY Y 9 9 Y Y
DC X'0505C9C95D5D89891919E8E8F9F9A8A8' 9
* WRWRE E % % E E NKNKU U 5 5 U U
DC X'2D2DC5C56C6C85853D3DE4E4F5F5A4A4' A
* RTRTM M - - M M GSGSS)S)= = B)B)
DC X'0D0DD4D4606094941D1DBDBD7E7ED0D0' B
* EMEMC C # # C C XFXFS S 3 3 S S
DC X'0303C3C37B7B83831313E2E2F3F3A2A2' C
* VTVTK K + + K K ESESS(S(; ; B(B(
DC X'0B0BD2D24E4E92922727ADAD5E5E7878' D
* BLBLG G ' ' G G EBEBW W 7 7 W W
DC X'2F2FC7C77D7D87872626E6E6F7F7A6A6' E
* SISIO O / / O O USUSBSBS? ?
DC X'0F0FD6D6616196961F1F6D6D6F6F0707' F
* 0 1 2 3 4 5 6 7 8 9 A B C D E F
OUTTTY DS 0D
* 0 1 2 3 4 5 6 7 8 9 A B C D E F
* ZLSHSXEXTFTB DL VTFFRTSOSI
DC X'008141C0009000FF000000D130B171F0' 0
* DEXN RSNLBSILCNEM FSGSRSUS
DC X'098848C9000011001899000039B878F9' 1
* BPLFEBES WRAKBL
DC X'000000000050E8D80000000000A060E1' 2
* SY TN XFNK SB
DC X'00006900000000210000000028A90059' 3
* SP B)S)R/. < ( + |
DC X'0500000000000000000000743C14D43F' 4
* & +-! $ * ) ; ^
DC X'6500000000000000000084245595DD7B' 5
* - / R' , % _ > ?
DC X'B4F500000000000000003F35A5FA7DFC' 6
* B(S(: # @ ' = "
DC X'000000000000000000065CC503E4BD44' 7
* A B C D E F G H I
DC X'008747C627A666E7179600DE00000000' 8
* J K L M N O P Q R
DC X'0056D736B777F60F8E4E00BE00000000' 9
* S T U V W X Y Z
DC X'007ECF2EAF6FEE1E9F5F000000DB0000' A
*
DC X'00000000000000000000000000BB0000' B
* A B C D E F G H I
DC X'DE8242C322A363E21293000000000000' C
* J K L M N O P Q R --
DC X'BE53D233B272F30A8B4B000000000000' D
* S T U V W X Y Z
DC X'3A00CA2BAA6AEB1B9A5A000000000000' E
* 0 1 2 3 4 5 6 7 8 9 DL
DC X'0C8D4DCC2DAC6CED1D9C3F0000000000' F
* 0 1 2 3 4 5 6 7 8 9 A B C D E F
HEXTB EQU *-X'F0' ORIGIN TABLE BACK A WAYS - ONLY NEED F0-FF
DC X'F0F1F2F3F4F5F6F7F8F9C1C2C3C4C5C6'
LTORG
EJECT
SET CSECT
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
CLI WORD2,C'?' NEED HELP ?
BNE NOQ
WRTERM 'RECfm, End-of-line, Quote, Lrecl, Packet-size, DelaX
y-time, RETry-count, SERIES1.'
B SETOK
NOQ DS 0H
CLC =CL7'SERIES1',WORD2 SET SERIES1/7171?
BNE NOSER1 NO - TRY NEXT OPTION
CLI WORD3,C'?' WANT INFO?
BNE CHKSERON NO -_ SEE IF SET 'ON'
WRTERM 'ON or OFF'
B SETOK FINISHED
CHKSERON CLC =CL2'ON',WORD3 TURN IT ON?
BNE CHKSEROF NO - TRY OFF
OI S1FLAGS,ISS1 SET THE BIT
B SETOK FINISHED
CHKSEROF CLC =CL3'OFF',WORD3 TURN IT OFF?
BNE SERINV NO - THEN WE HAVE A PROBLEM
NI S1FLAGS,X'FF'-ISS1 TURN OFF THE S1 BIT
B SETOK FINISHED HERE
SERINV WRTERM 'Op must be ON or OFF'
B SETOK MAYBE THEY'LL TRY AGAIN
NOSER1 CLC WORD2(4),=CL4'REC '
BE RECFM
CLC WORD2(5),=CL5'RECFM'
BNE NOREC
RECFM DS 0H PICK UP RECORD FORMAT
CLI WORD3,C'?'
BNE CHKFM
WRTERM 'F, FC, V, or VC (default of FC)'
B SETOK
CHKFM DS 0H
CLC WORD3(2),=CL2'F ' FIXED FORMAT?
BNE TRYFC
MVI RFM,X'01' MARK FIXED
B SETOK
TRYFC DS 0H
CLC WORD3(2),=CL2'FC' FIXED COMPRESSED FORMAT?
BNE TRYV
MVI RFM,X'02' MARK FIXED COMPRESSED
B SETOK
TRYV DS 0H
CLC WORD3(2),=CL2'V ' VARIABLE FORMAT?
BNE TRYVC
MVI RFM,X'03' MARK VARIABLE
B SETOK
TRYVC DS 0H
CLC WORD3(2),=CL2'VC' VARIABLE COMPRESSED FORMAT?
BNE RECERR
MVI RFM,X'04' MARK VARIABLE COMPRESSED
B SETOK
RECERR WRTERM 'Error in record format. F, FC, V, VC allowed.'
B SETERR
*
NOREC DS 0H
CLC WORD2(2),=C'Q ' QUOTE CHARACTER?
BE QUOTE YES, BRANCH
CLC WORD2(5),=CL5'QUOTE' QUOTE CHAR?
BNE NOQUO NO, GO TRY NEXT
QUOTE DS 0H
CLI WORD3,C' ' VALUE NOT SUPPLIED?
BNE GIVQ
WRTERM 'Quote character cannot be a blank. Re-specify.'
B SETERR
GIVQ CLI WORD3,C'?'
BNE GETQUO
WRTERM 'The single charater used to transmit control '
WRTERM 'characters (default is #).'
B SETOK
GETQUO MVC QUOCHAR(1),WORD3 SET NEW QUOTE CHAR
TR QUOCHAR(1),ETOA GET ASCII FORM
CLI WORD3+1,C' ' IS IT ONLY ONE CHAR?
BE ISQOK
WRTERM 'one character only'
B SETERR
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).'
B SETERR
*
NOQUO DS 0H
CLC WORD2(2),=C'L ' LRECL?
BE RECLENG YES, BRANCH
CLC WORD2(5),=C'LRECL' LRECL SIZE?
BNE NORCL NO, BRANCH
RECLENG DS 0H
CLI WORD3,C'?' HELP ?
BNE GETREC
WRTERM 'Logical record length (default of 80).'
B SETOK
GETREC CLI WORD3,C' ' NO VALUE GIVEN?
BNE CALC
WRTERM 'No record length given. Re-specify.'
B SETERR
CALC CLI WORD3,X'F0' MUST BE >= TO 0
BL BADREC
CLI WORD3,X'F9' MUST BE <= TO 9
BH BADREC
XC PKVAR,PKVAR EMPTY IT OUT
SR R4,R4 LENGTH OF NUMBER
CLI WORD3+1,C' ' TWO DIGITS?
BNE CALC2
EX R4,PCK
B TST
CALC2 LA R4,1(R4) ADD ONE
CLI WORD3+2,C' ' THREE DIGITS?
BNE CALC3
EX R4,PCK
B TST
CALC3 LA R4,1(R4) IS THERE AN ERROR?
CLI WORD3+3,C' '
BNE BADREC
EX R4,PCK
TST CVB R7,PKVAR
C R7,=X'00000100' MAX OF 256 FOR LRECL
BH BADREC
STH R7,LRECL SET THE LRECL VALUE
B SETOK
BADREC WRTERM 'LRECL must be a number from 0 to 256.'
B SETERR
*
NORCL DS 0H
CLI WORD2,C'E' EOL CHARACTER?
BE EOL YES, BRANCH
CLC WORD2(3),=C'END' EOL CHARACTER
BNE NOEND
EOL DS 0H
CLI WORD3,C' ' NOT DATA
BNE EOLCHAR
WRTERM 'No End-of-Line character specified.'
B SETERR
EOLCHAR CLI WORD3,C'?' NEED HELP?
BNE GETEOL
WRTERM 'A two digit number between 00 and 31 (dec).'
WRTERM '(The default is 13.)'
B SETOK
GETEOL CLI WORD3,X'F0' MUST BE >= TO 0
BL BADEOL
CLI WORD3,X'F9' MUST BE <= TO 9
BH BADEOL
XC PKVAR,PKVAR USE TO CONVERT VALUE
CLI WORD3+1,C' ' INPUT MUST BE TWO CHARS
BE BADEOL
CLI WORD3+2,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,=X'0000001F' 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
*
NOEND DS 0H
CLI WORD2,C'P' CHANGE PACKET SIZE?
BE PAC YES, BRANCH
CLC WORD2(3),=C'PAC' CHANGE RECEIVE PACKET SIZE
BNE NOPAC NO, GO CHECK NEXT
PAC DS 0H
CLI WORD3,C' ' NO DATA
BNE GETPAC
WRTERM 'No receive packet size specified.'
B SETERR
GETPAC CLI WORD3,C'?' NEED HELP?
BNE CALC4
WRTERM 'Receive packet size (range: 26-94 decimal).'
WRTERM '(The default is 94.)'
B SETOK
CALC4 CLI WORD3,X'F0' MUST BE >= TO 0
BL BADPAC
CLI WORD3,X'F9' MUST BE <= TO 9
BH BADPAC
XC PKVAR,PKVAR USE TO CONVERT VALUE
CLI WORD3+1,C' ' INPUT MUST BE TWO CHARS
BE BADPAC
CLI WORD3+2,C' ' TWO CHARS, AT MAX
BNE BADPAC
PACK PKVAR(8),WORD3(2) 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 'Bad packet size - must be between 26-94 (decimal).'
B SETERR
NOPAC DS 0H
CLC WORD2(2),=C'D ' DELAY TIME?
BE DELAY YES, BRANCH
CLC WORD2(5),=CL5'DELAY' DELAY TIME?
BNE NODLY NO, ERROR
DELAY DS 0H
CLI WORD3,C' ' VALUE NOT SUPPLIED?
BNE GIVD
WRTERM 'The DELAY time cannot be a blank. Re-specify.'
B SETERR
GIVD CLI WORD3,C'?'
BNE GETDLY
WRTERM 'The time in seconds before KERMIT will send '
WRTERM 'the first packet. (The default is 15.)'
B SETOK
GETDLY CLI WORD3,X'F0' MUST BE >= TO 0
BL BADDLY
CLI WORD3,X'F9' MUST BE <= TO 9
BH BADDLY
XC PKVAR,PKVAR USE TO CONVERT VALUE
SR R4,R4 LENGTH OF NUMBER
CLI WORD3+1,C' ' TWO DIGITS?
BNE DLY2
EX R4,PCK
B CALCDLY
DLY2 LA R4,1(R4) ADD ONE
CLI WORD3+2,C' ' THREE DIGITS?
BNE DLY3
EX R4,PCK
B CALCDLY
DLY3 LA R4,1(R4) IS THERE AN ERROR?
CLI WORD3+3,C' '
BNE BADDLY
EX R4,PCK
CALCDLY CVB R7,PKVAR
C R7,=F'120' MAX OF 120 SECONDS FOR DELAY
BH BADDLY
ST R7,DLYTIME SET THE DELAY VALUE
B SETOK
BADDLY WRTERM 'DELAY must be a number from 0 - 120.'
B SETERR
*
NODLY DS 0H
CLC WORD2(4),=C'RET ' RETRY?
BE RETRYCNT YES, BRANCH
CLC WORD2(5),=C'RETRY' LRECL SIZE?
BNE SETERR NO, BRANCH
RETRYCNT DS 0H
CLI WORD3,C'?' HELP ?
BNE GETRET
WRTERM 'The number of times a packet may be re-sent.'
WRTERM 'The default is 5.'
B SETOK
GETRET CLI WORD3,C' ' NO VALUE GIVEN?
BNE RETCALC
WRTERM 'No retry count given. Re-specify.'
B SETERR
RETCALC CLI WORD3,X'F0' MUST BE >= TO 0
BL BADRET
CLI WORD3,X'F9' MUST BE <= TO 9
BH BADRET
XC PKVAR,PKVAR EMPTY IT OUT
SR R4,R4 LENGTH OF NUMBER
CLI WORD3+1,C' ' TWO DIGITS?
BNE RETCALC2
EX R4,PCK
B RETTST
RETCALC2 LA R4,1(R4) ADD ONE
CLI WORD3+2,C' ' THREE DIGITS?
BNE RETCALC3
EX R4,PCK
B RETTST
RETCALC3 LA R4,1(R4) IS THERE AN ERROR?
CLI WORD3+3,C' '
BNE BADRET
EX R4,PCK
RETTST CVB R7,PKVAR
C R7,=X'00000064' MAX OF 100 FOR RETRY
BH BADRET
ST R7,MAXTRY SET THE LRECL VALUE
B SETOK
BADRET WRTERM 'RETRY count must be a number from 0 to 100.'
B SETERR
*
SETERR DS 0H
MVC QUOCHAR(1),DQUOTE RESET VALUE, JUST IN CASE
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),WORD3(0)
LTORG
DROP R11
DROP R12
EJECT
SHOW CSECT
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
CLI WORD2,C'?' NEED HELP ?
BNE SHOREC
WRTERM 'RECfm, End-of-line, Quote, Lrecl, Packet-size, DelaX
y-time, RETry-count, SERIES1.'
B SHOWOK
SHOREC CLC WORD2(5),=CL5'RECFM'
BE RFM1
CLC WORD2(4),=CL4'REC '
BNE SHOQUO
RFM1 DS 0H
CLI RFM,X'01' RECFM=F?
BNE RFM2 NO, BRANCH
WRTERM 'The RECORD FORMAT is FIXED.'
B SHOWOK
RFM2 DS 0H
CLI RFM,X'02' RECFM=FC?
BNE RFM3 NO, BRANCH
WRTERM 'The RECORD FORMAT is FIXED COMPRESSED.'
B SHOWOK
RFM3 DS 0H
CLI RFM,X'03' RECFM=FC?
BNE RFM4 NO, BRANCH
WRTERM 'The RECORD FORMAT is VARIABLE.'
B SHOWOK
RFM4 DS 0H
CLI RFM,X'04'
BNE RFMERR
WRTERM 'The RECORD FORMAT is VARIABLE COMPRESSED.'
B SHOWOK
RFMERR DS 0H
MVI RFM,X'02' SET RECFM TO FC
WRTERM 'The RECORD FORMAT is FIXED COMPRESSED.'
B SHOWOK
*
SHOQUO DS 0H
CLC WORD2(5),=C'QUOTE'
BE QUO1
CLC WORD2(2),=C'Q '
BNE SHORCL
QUO1 DS 0H
MVC MSGQCHAR(1),QUOCHAR GET QUOTE CHARACTER
TR MSGQCHAR(1),ATOE TRANSLATE TO EBCDIC
MVC SHOWMSG(24),MSGQUOTE MOVE QUOTE MESSAGE
B SHOWIT
*
SHORCL DS 0H
CLC WORD2(5),=C'LRECL'
BE LREC1
CLC WORD2(2),=C'L '
BNE SHOEND
LREC1 DS 0H
SR R4,R4 ZERO IT OUT
LH R4,LRECL
CVD R4,PKVAR
UNPK MSGLCHAR(3),PKVAR+6(2)
OI MSGLCHAR+2,X'F0'
MVC SHOWMSG(24),MSGLRECL
B SHOWIT
*
SHOEND DS 0H
CLC WORD2(3),=C'END'
BE SHOEND2
CLC WORD2(3),=C'EOL'
BE SHOEND2
CLC WORD2(2),=C'E '
BNE SHOPAC
SHOEND2 DS 0H
SR R4,R4 ZERO IT OUT
IC R4,SEOL
CVD R4,PKVAR CONVERT TO DECIMAL
UNPK MSGECHAR(2),PKVAR+6(2) UNPACK
OI MSGECHAR+1,X'F0' MAKE LAST DIGIT A NUMBER
MVC SHOWMSG(24),MSGEOL MOVE MESSAGE
B SHOWIT
*
SHOPAC DS 0H
CLC WORD2(3),=C'PAC' PACKET LENGTH ?
BE PAC1
CLC WORD2(2),=C'P '
BNE SHODLY
PAC1 DS 0H
L R4,RPSIZ GET RECEIVE PACKET SIZE
CVD R4,PKVAR CONVERT TO DECIMAL
UNPK MSGPSIZE(3),PKVAR+6(2) UNPACK
OI MSGPSIZE+2,X'F0' MAKE LAST DIGIT A NUMBER
MVC SHOWMSG(24),MSGPAC MOVE MESSAGE
B SHOWIT
*
SHODLY CLC WORD2(5),=CL5'DELAY' SHOW DELAY VALUE?
BE DELAY1
CLC WORD2(2),=C'D '
BNE SHORET NO, ERROR IN SHOW REQUESR
DELAY1 DS 0H
L R4,DLYTIME GET DELEAY TIME
CVD R4,PKVAR CONVERT TO DECIMAL
UNPK MSGDTIME(3),PKVAR+6(2) UNPACK
OI MSGDTIME+2,X'F0' MAKE LAST DIGIT A NUMBER
MVC SHOWMSG(24),MSGDLY MOVE MESSAGE
B SHOWIT
SHORET DS 0H
CLC WORD2(5),=C'RETRY'
BE RET1
CLC WORD2(4),=CL4'RET'
BNE SHOSER1 MAYBE IT'S FOR SERIES1/7171?
RET1 DS 0H
SR R4,R4 ZERO IT OUT
L R4,MAXTRY
CVD R4,PKVAR
UNPK MSGRTCNT(3),PKVAR+6(2)
OI MSGRTCNT+2,X'F0'
MVC SHOWMSG(24),MSGRETRY
B SHOWIT
SHOSER1 DS 0H HERE TO SHOW SERIES1 STATUS
CLC =CL7'SERIES1',WORD2 COULD IT BE?
BNE SHOERR NO - UNKNOWN PARM THEN
MVC MSGSER10(8),=CL8'ON' ASSUME IT IS ON
TM S1FLAGS,ISS1 TEST IT
BO SHOSER2 WE GUESSED CORRECTLY
MVC MSGSER10(8),=CL8'OFF' CORRECT THE MESSAGE
SHOSER2 MVC SHOWMSG(24),MSGSER1 Move in the text
B SHOWIT
*
SHOERR LA R15,4 SET A NON-ZERO RETCODE
B SHOWRET
*
SHOWIT DS 0H
XC IOBUF,IOBUF CLEAR IOBUF
MVI IOBUF,C' ' MOVE BLANK TO CC
MVC IOARG+4,IOBUFLEN
MFSET REPLY,IO,R=(WR)
MVC IOBUF+1(24),SHOWMSG
MFREQ REPLY
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
SHOWMSG DS CL24
MSGQUOTE DS 0CL24
DC CL23'The QUOTE character is '
MSGQCHAR DC CL1' '
MSGLRECL DS 0CL24
DC CL19'THE LRECL VALUE IS '
MSGLCHAR DC CL5' '
MSGEOL DS 0CL24
DC CL21'THE EOL CHARACTER IS '
MSGECHAR DC CL3' '
MSGPAC DS 0CL24
DC CL19'THE PACKET SIZE IS '
MSGPSIZE DC CL5' '
MSGDLY DS 0CL24
DC CL18'THE DELAY TIME IS '
MSGDTIME DC CL6' '
MSGRETRY DS 0CL24
DC CL19'THE RETRY COUNT IS '
MSGRTCNT DC CL5' '
MSGSER1 DS 0CL24
DC CL16'Series1/7171 is '
MSGSER10 DC CL8' '
LTORG
DROP R11
DROP R12
EJECT
SEND CSECT
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
TM S1FLAGS,ISS1 IS THIS A SERIES1/7171 TERMINAL
BNO SNDX NO NEED TO INITIALIZE THEN
LA R1,1 SET PARM FOR INITIALIZE
L R15,=A(INTRINI) GET ADDR OF SERIES1 INIT ROUTINE
BALR R14,R15 GO TO IT!!
SNDX L R0,DLYTIME GET DELAY TIME
SVC $DLYEXC WAIT
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
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
CLI ERRNUM,S1ERRNUM WAS IT A FSIO/SERIES1 ERROR?
BE SLOOP DON'T CHANGE IT TO DEFAULT CODE
MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE
B SLOOP
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
CLI WORD3,C' ' FILENAME IN WORD3?
BE SF2 NO, BRANCH
MVC SDAT(17),WORD3 YES, MOVE FILENAME FOR SEND
MVC LSDAT(4),WORD3LEN MOVE LENGTH OF NAME TO SEND LEN
B SF3
SF2 DS 0H
MVC SDAT(17),FILNAM PUT FILENAME IN BUFFER
MVC LSDAT(4),FNAMLEN LENGTH OF SDAT (FILE NAME LENG)
SF3 DS 0H
TR SDAT(17),ETOA TRANSLATE TO ASCII
L R3,NUMTRY
LA R3,1(R3) INCREMENT TRIAL COUNTER
ST R3,NUMTRY
MVI STYPE,AF PACKET TYPE = FILE HEADER
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(OPNFIL) GO OPEN FILE AND GET FIRST REC
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
CLI ERRNUM,S1ERRNUM WAS IT A FSIO/SERIES1 ERROR?
BE SLOOP DON'T CHANGE IT TO DEFAULT CODE
MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE
B SLOOP
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 DS 0H
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 R4,LRDAT GET DATA LENGTH
LTR R4,R4 ANY DATA?
BZ AOKNOZ NO, NORMAL ACK
CLI RDAT,X'58' ASCII X?
BE STOPSEND
CLI RDAT,X'5A' ASCII Z?
BNE AOKNOZ
STOPSEND DS 0H
OI FLAGS,FLG1 TURN ON INTERRUPT BIT
MFSET MUSFIL,CLOSE CLOSE FILE
MFREQ MUSFIL,BAD=SERROR
NI FLAGS,X'FF'-FLG5 TURN OFF FILE OPEN FLAG
MVI STATE,C'Z' SET EOF STATE
B SLOOP GO ACT LIKE END OF FILE
AOKNOZ DS 0H
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'
CLI ERRNUM,S1ERRNUM WAS IT A FSIO/SERIES1 ERROR?
BE SLOOP DON'T CHANGE IT TO DEFAULT CODE
MVI ERRNUM,X'07' ILLEGAL PACKET TYPE
B SLOOP
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
CLI FLAGS,FLG1 WAS SEND INTERRUPTED?
BNO EOFNORM NO, NORMAL EOF
MVI LSDAT+1,X'01' SET DATA LENGTH TO ONE
MVI SDAT,X'44' PUT ASCII 'D' IN SEND DATA
EOFNORM DS 0H
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
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
CLI ERRNUM,S1ERRNUM WAS IT A FSIO/SERIES1 ERROR?
BE SLOOP DON'T CHANGE IT TO DEFAULT CODE
MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE
B SLOOP
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
CLI ERRNUM,S1ERRNUM WAS IT A FSIO/SERIES1 ERROR?
BE SLOOP DON'T CHANGE IT TO DEFAULT CODE
MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE
B SLOOP
OPNFIL DS 0H
LA R5,BUF GET ADDRESS OF BUFFER
ST R5,MUSARG+8 STORE IN MUSARG
MVC MUSARG+4(4),=F'256'
MFSET MUSFIL,OPEN,R=(OKOLD,RDOK) OPEN MUSIC FILE
MFREQ MUSFIL,BAD=SERROR
OI FLAGS,FLG5 FLAG FILE OPEN
GTCHR DS 0H
TM FLAGS,FLG6 EOF ALREADY?
BO SETEOF YES, GO CLOSE FILE
TM FLAGS,FLG3 SEE IF THERE'S STUFF IN BUF
BO STUFF ONES -> STUFF'S THERE
MVI BUF,C' ' BLANK OUT INPUT AREA
MVC BUF+1(255),BUF
MFSET MUSFIL,IO,R=(RD) READ A RECORD
MFREQ MUSFIL,EOF=SETEOF,BAD=SERROR
B OK8
SETEOF DS 0H
L R9,SAVPLDAT CURRENT ADDR IN SDAT
LTR R9,R9 IS THERE DATA TO SEND?
BZ SETEOF2 NO, CONTINUE WITH EOF
STC R9,LSDAT+3 SAVE PACKET DATA LENGTH
OI FLAGS,FLG6 TURN ON EOF FLAG
XC SAVPLDAT,SAVPLDAT ZERO OUT SDAT COUNT
BR R14 RETURN
SETEOF2 DS 0H
NI FLAGS,X'FF'-FLG6 TURN OFF EOF FLAG
MFSET MUSFIL,CLOSE CLOSE FILE
MFREQ MUSFIL,BAD=SERROR
NI FLAGS,X'FF'-FLG5 TURN OFF FILE OPEN FLAG
MVI STATE,C'Z'
BR R14
SERROR MVI STATE,C'A' ABORT ON FILE SYSTEM ERROR
MVC MUSERR(1),MUSFIL+8 GET RETURN CODE
MVI ERRNUM,X'FE' SET ERROR CODE
BR R14 RETURN
OK8 L R5,MUSARG+4 GET NUMBER OF BYTES READ IN
LR R4,R5 SAVE ALSO IN R4
BCTR R4,0 SUBTRACT ONE
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 DS 0H
SR R5,R5 WILL HOLD QUOCHAR
IC R5,QUOCHAR
L R8,SAVPL WHERE WE LEFT OFF
L R9,SAVPLDAT INDEX INTO SDAT WHERE WE STOPPED
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,R9 FIND DIF BETWEEN THE TWO
C R4,TWO SEE IF HAVE AT LEAST 2 BYTES
BL FULL NO, GO SEND PACKET
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
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
C R9,SIZE SEE IF REACHED LIMIT
BNL FULL
C R8,RECL SEE IF REACHED LIMIT
BNL FULL2
B LOOP
FULL EQU *
STC R9,LSDAT+3 THIS ONE TOO
ST R8,SAVPL HERE TOO
OI FLAGS,FLG3 TURN ON FLAG - STUFF IN BUF
XC SAVPLDAT,SAVPLDAT ZERO OUT SDAT INDEX
BR 14
FULL2 EQU *
ST R9,SAVPLDAT SAVE PLACE IN BUFFER
XC SAVPL,SAVPL RESET THIS
NI FLAGS,X'FF'-FLG3 TURN OFF LEFTOVER DATA FLAG
B GTCHR
*
ABORT DS 0H
CLI ERRNUM,X'FE' ERROR NUM = FE?
BNE SERROR1 YES, BRANCHCH
MVI BUF,C' ' BLANK
MVC BUF+1(255),BUF OUT BUF
MFSET MUSFIL,MSG
MVC MUSARG+4(4),SIZE SET MAX MESSAGE SIZE
MFREQ MUSFIL
L R5,MUSARG+4 GET LENGTH OF ERROR MESSAGE
ST R5,LSDAT STORE LENGTH TO SEND
BCTR R5,0 SUBTRACT ONE FOR EXECUTE
EX R5,MOVESERR MOVE MESSAGE TO SDAT
EX R5,TRANSERR TRANSLATE TO ASCII
SERROR1 DS 0H
TM FLAGS,FLG5 FILE OPEN?
BNO NOTOPEN
MFSET MUSFIL,CLOSE
MFREQ MUSFIL
NI FLAGS,X'FF'-FLG5 TURN OFF FILE OPEN FLAG
NOTOPEN DS 0H
CLI ERRNUM,X'0A' DID THE MICRO DIE?
BE NOERRP NO ERROR PACKET IF SO
MVI STYPE,AE ERROR PACKET
MVC N(4),NUM SYNCH PACKET NUMBERS
CLI ERRNUM,X'FE' ERROR = FF?
BE SERROR2 YES, BRANCH
SR R5,R5
IC R5,ERRNUM GET RIGHT MESSAGE NUMBER
M R4,=F'20' OFFSET := ERRNUM * 20
LA R5,ERRTAB(R5)
CLI OLDERR,S1ERRNUM WAS IT A SERIES1 ERROR?
BNE NOTOPEN1 NO, THE WRITE OUT THE ERROR
LA R1,X'F0' GET READY TO UNPK ERROR CODES
ICM R1,B'1110',KERFSRET MOVE IN THE ERROR CODES
SRL R1,4 GET RID OF LOWER ZERO
ST R1,WORK1 SAVE IT
UNPK S1RETC(6),WORK1(4) MAKE IT SORTA-PRINTABLE
TR S1RETC(6),HEXTB PRETTY IT UP
NOTOPEN1 MVC SDAT(20),0(R5) SPACK NEEDS THE DATA HERE
TR SDAT(20),ETOA TRANSLATE TO ASCII
MVC LSDAT,=F'20' STORE THE DATA LENGTH
SERROR2 DS 0H
L R15,=A(SPACK)
BALR R14,R15 SEND ERROR PACKET & DIE
NOERRP LA R15,4 SET NON-ZERO RETCODE
B SENDRET PREPARE TO LEAVE
COMPLETE SR R15,R15 ZERO WILL BE RETCODE
SENDRET EQU *
TM S1FLAGS,ISS1 ON A SERIES1/7171?
BNO SENDRET2 NO - SKIP OVER DE-INIT STUFF
LR R2,R15 SAVE THE RETCODE
SR R1,R1 SET PARM FOR END FULL SCREEN I/O
L R15,=A(INTRINI)
BALR R14,R15
LR R15,R2 RESTORE THE RETURN CODE
SENDRET2 L R13,4(R13)
L R14,12(R13)
LM R0,R12,20(R13)
BR R14
SENDSAVE DS 18F
TRANS TR BUF(0),ETOA EBCDIC TO ASCII TRANSLATION
MOVESERR MVC SDAT(0),BUF MOVE MESSAGE TO SDAT
TRANSERR TR SDAT(0),ETOA TRANSLATE TO ASCII
LTORG
DROP R11
DROP R12 DON'T NEED THEM ANYMORE
EJECT
SPACK 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
XC SNDPKT,SNDPKT
SR R9,R9
MVI PHDR,SOH ADD CONTROL-A 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 DS 0H
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
L R7,LSDAT GET DATA LENGTH
BCTR R7,0 SUBTRACT 1 FOR EX FUNCTION
EX R7,MOVE MOVE THE DATA TO SNDPKT
NODAT DS 0H
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
L R6,LSDAT GET DATA LENGTH
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
TM S1FLAGS,ISS1 WE A SERIES1/7171 TERM?
BNO SENDTTY NOPE - THEN DO IT THE ASCII WAY
LA R7,S1ORDSL(R6) BUMP UP LENGTH FOR XPARENCY
ST R7,KERMFSWL SAVE IN FSARG BLOCK
XC RECPKT,RECPKT CLEAR OUT THE RECEIVE BUFFER
MVC KERMARSZ(4),=F'-1' SET NEGATIVE RBC
MFREQ KERMFARG DO THE FULL SCREEN WRITE-ERASE/READ
CLI KERFSRET,X'00' ZERO RETCODE??
BE SPRET GREAT - WE'RE DONE HERE
MVI ERRNUM,S1ERRNUM SET SERIES1/7171/FSIO ERROR
MVI STATE,C'A' WE WILL ABORT THIS ONE
B SPRET AND EXIT
SENDTTY TR SNDPKT(130),ATOE SEND IN EBCDIC
SR R4,R4
LA R4,7 CC,SOH, PLEN,PNUM,PTYP,CHKSUM,0D
A R4,LSDAT ADD IN LENGTH OF DATA
ST R4,IOARG+4 STORE LENGTH TO WRITE
MFSET REPLY,IO,R=(WR)
MVI IOBUF,X'41' USE CC OF X'41' FOR NO TRANSLATE
MVC IOBUF+1(130),SNDPKT
TR IOBUF+1(131),OUTTTY
MFREQ REPLY
SPRET L R13,4(R13)
L R14,12(R13)
LM R0,R12,20(R13)
BR 14
SPSAVE DS 18F
MOVE MVC PDATA(0),SDAT
LTORG
DROP R11
DROP R12 DON'T NEED THEM ANYMORE
EJECT
RPACK CSECT
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
TM S1FLAGS,ISS1 ARE WE ON A SERIES1/7171?
BNO RECTTY GET IT THE ASCII WAY
*
* NOTE: AS A RESULT OF THE SEND OPERATION A READ SHOULD ALWAYS
* HAVE BEEN DONE. THEREFORE ALL WE DO IS CHECK IN THE
* BUFFER TO MAKE SURE DATA WAS RECEIVED.
*
MVC RECPKT(L'RECPKT-3),RECPKT+3 SKIP THE FAKE AID
NC RECPKT,NOHIBITS TURN OFF THE PARITY STUFF
L R0,KERMARSZ GET SIZE OF PACKET
S R0,=F'4' LESS AID,CURSOR ADDR AND CR
BM RPACK9 NOT ENUF RECEIVED
LA R6,RECPKT POINT TO PACKET
AR R6,R0 ADD IN LENGTH
MVC 0(4,R6),=F'0' PATCH UP THE END
B RPACKA AND SKIP OVER THE TTY STUFF
RECTTY EQU *
MFSET REPLY,IO,R=(RD)
MVC IOARG+4,IOBUFLEN
MFREQ REPLY
TR IOBUF(132),INPTTY
MVC RECPKT,IOBUF
TR RECPKT(130),ETOA
RPACKA EQU *
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
CLI 0(R7),SOH IS IT CONTROL-A
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
CLI 0(R7),SOH IS IT CONTROL-A
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
C R7,=A(SOH) IS IT CONTROL-A
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
C R7,=A(SOH) IS IT CONTROL-A
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
CLI TEMP+3,SOH IS IT CONTROL-A
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
C R7,=A(SOH) IS IT CONTROL-A
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
CR R5,R7 COMPUTED VS RECEIVED CHECKSUM
BE RPRET
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
RPACK9 DS 0H
MVI ERRNUM,S1ERRNUM SET SERIES1/7171 ERROR
MVI STATE,C'A' SAY WE'RE ABORTING
B RPRET AND EXIT
RPSAVE DS 18F
NOHIBITS DC (L'RECPKT)X'7F'
LTORG
DROP R11
DROP R12 DON'T NEED THEM ANYMORE
EJECT
RECEIVE CSECT
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
TM S1FLAGS,ISS1 IS THIS A SERIES1/7171?
BNO RECIN1 NO, HTEN SKIP INITIALIZATION
LA R1,1 SET INIT PARM
L R15,=A(INTRINI)
BALR R14,R15 GO INIT FOR SERIES1/7171
RECIN1 SR R6,R6 GET ZERO
ST R6,NUMTRY ZERO THIS OUT
ST R6,N HERE TOO
XC RBUF,RBUF ZERO OUT THE BUFFER
XC RSAVPL,RSAVPL CLEAR SAVE PLACE
MVI PREV,X'00' ZERO OUT PREVIOUS LINE
MVI STATE,C'R' SET TO RECEIVE STATE
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
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
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
CLI ERRNUM,S1ERRNUM SERIES1 ERROR?
BE RLOOP DON'T MASK IT
MVI ERRNUM,X'07' ILLEGAL PACKET TYPE
B RLOOP
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
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
TM FLAGS,FLG2 OVERWRITE THE NAME SENT?
BNO ROPENFIL NO, GO OPEN THE FILE
MVC LSDAT(4),FNAMLEN GET FILE NAME LENGTH
MVC SDAT(17),FILNAM MOVE FILNAM TO TO SEND DATA
TR SDAT(17),ETOA TRANSLATE TO ASCII
B RFACK GO SEND ACK
ROPENFIL DS 0H
L R4,LRDAT GET SIZE OF FILNAM
LTR R4,R4 CHECK LENGTH
BZ SAYNO DIE IF NO FILENAME
C R4,=F'17' LENGTH GREATER THAN 17 CHARS?
BNH RFNAMEOK NO, NAME IS OK
LA R4,17 TRUNCATE NAME TO 17 CHARACTERS
RFNAMEOK DS 0H
MVC FILNAM,=22X'20' INITIALIZE TO BLANKS
ST R4,FNAMLEN STORE FILE NAME LENGTH
BCTR R4,0 SUBTRACT ONE FOR EXECUTE
EX R4,MOVEFNAM MOVE THE FILE NAME
TR FILNAM(22),ATOE TRANSLATE TO EBCDIC
LA R4,FILNAM(R4) POINT TO LAST CHARACTER
CLI 0(R4),C'.' PERIOD?
BNE RFNAME2 NO, NAME IS OK
MVI 0(R4),C' ' YES, CHANGE TO BLANK
RFNAME2 DS 0H
LA R5,RBUF GET ADDRESS OF BUFFER
ST R5,MUSARG+8 STORE IN MUSARG
MVC MUSARG+4(4),=F'256'
MFSET MUSFIL,OPEN,R=(OKNEW,WROK)
MFREQ MUSFIL,BAD=RERROR
OI FLAGS,FLG5 TURN ON FILE OPEN FLAG
*
RFACK DS 0H
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
CLI ERRNUM,S1ERRNUM SERIES1 ERROR?
BE RLOOP DON'T MASK IT
MVI ERRNUM,X'07' ILLEGAL PACKET TYPE
B RLOOP
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
CLI STATE,C'A' ABORT ON FILE SYSTEM ERROR
BE RLOOP
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
TM FLAGS,FLG5 IS FILE ALREADY OPEN?
BO RDFACK YES, BRANCH
TM FLAGS,FLG2 OVERWRITE THE NAME SENT?
BNO RDFOPEN NO, GO OPEN FILE
MVC LSDAT(4),FNAMLEN GET FILE NAME LENGTH
MVC SDAT(17),FILNAM MOVE FILNAM TO TO SEND DATA
TR SDAT(17),ETOA TRANSLATE TO ASCII
B RDFACK GO SEND ACK
RDFOPEN DS 0H
L R4,LRDAT GET SIZE OF FILNAM
LTR R4,R4 CHECK LENGTH
BZ SAYNO DIE IF NO FILENAME
C R4,=F'17' LENGTH GREATER THAN 17 CHARS?
BNH RDFNAMOK NO, NAME IS OK
LA R4,17 TRUNCATE NAME TO 17 CHARACTERS
RDFNAMOK DS 0H
MVC FILNAM,=22X'20' INITIALIZE TO BLANKS
ST R4,FNAMLEN STORE FILE NAME LENGTH
BCTR R4,0 SUBTRACT ONE FOR EXECUTE
EX R4,MOVEFNAM MOVE THE FILE NAME
TR FILNAM(22),ATOE TRANSLATE TO EBCDIC
LA R4,FILNAM(R4) POINT TO LAST CHARACTER
CLI 0(R4),C'.' PERIOD?
BNE RDFNAME2 NO, NAME IS OK
MVI 0(R4),C' ' YES, CHANGE TO BLANK
RDFNAME2 DS 0H
LA R5,RBUF GET ADDRESS OF BUFFER
ST R5,MUSARG+8 STORE IN MUSARG
MVC MUSARG+4(4),=F'256'
MFSET MUSFIL,OPEN,R=(OKNEW,WROK)
MFREQ MUSFIL,BAD=RERROR
OI FLAGS,FLG5 TURN ON FILE OPEN FLAG
RDFACK DS 0H
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
RDOK MVI STYPE,AY ACK THE PACKET
XC LSDAT,LSDAT NO DATA
L R4,LRDAT GET DATA LENGTH
LTR R4,R4 ANY DATA?
BZ RDZEOF NO, NORMAL EOF
CLI RDAT,X'44' DISCARD FILE?
BNE RDZEOF NO, CONTINUE
MFSET MUSFIL,CLOSE,R=(DEL) SET TO DELETE FILE
B RDZCLOSE BRANCH
RDZEOF DS 0H
MFSET MUSFIL,CLOSE
RDZCLOSE DS 0H
MFREQ MUSFIL,BAD=RERROR
NI FLAGS,X'FF'-FLG5 TURN OFF FILE OPEN FLAG
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
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
CLI ERRNUM,S1ERRNUM SERIES1 ERROR?
BE RLOOP DON'T MASK IT
MVI ERRNUM,X'07' ILLEGAL PACKET TYPE
B RLOOP
SAYNO DS 0H
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
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
LH 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
SR R15,R15 ZERO OUT RETURN CODE
CLI PREV,X'4D' ARE WE IN MIDDLE OF LINE?
BER R14 LEAVE IF NOT
ST R9,RSAVPL SAVE OUR PLACE
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
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,X'02' IS IT VARIABLE FORMAT?
BH VAR YES, BRANCH
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
ST R10,MUSARG+4 STORE LENGTH
LA R9,RBUF GET ADDR OF BUFFER
ST R9,MUSARG+8 STORE ADDRESS IN MUSARG
SR R9,R9 SET RBUF POINTER BACK TO ZERO
MFSET MUSFIL,IO,R=(WR)
MFREQ MUSFIL,BAD=RERROR
B RLUP GET NEXT LINE IF OK
RERROR DS 0H
MVI STATE,C'A' SET FOR ABORT
MVC MUSERR(1),MUSFIL+8 GET ERROR CODE
MVI ERRNUM,X'FE' SET ERROR CODE
B RLOOP
RABORT DS 0H
CLI ERRNUM,X'FE' ERROR NUM = FE?
BNE RERROR1 YES, BRANCHCH
MVI RBUF,C' ' BLANK
MVC RBUF+1(255),RBUF OUT RBUF
MFSET MUSFIL,MSG
MVC MUSARG+4(4),SIZE SET MAX MESSAGE SIZE
MFREQ MUSFIL
L R5,MUSARG+4 GET LENGTH OF ERROR MESSAGE
ST R5,LSDAT STORE LENGTH TO SEND
BCTR R5,0 SUBTRACT ONE FOR EXECUTE
EX R5,MOVEERR MOVE MESSAGE TO SDAT
EX R5,TRANERR TRANSLATE TO ASCII
RERROR1 DS 0H
TM FLAGS,FLG5 FILE OPEN?
BNO RNOTOPEN
MFSET MUSFIL,CLOSE
MFREQ MUSFIL
NI FLAGS,X'FF'-FLG5 TURN OFF FILE OPEN FLAG
RNOTOPEN DS 0H
CLI ERRNUM,X'0A' DID THE MICRO DIE?
BE RNOERRP NO ERROR PACKET IF SO
MVI STYPE,AE ERROR PACKET
MVC N(4),NUM SYNCH PACKET NUMBERS
CLI ERRNUM,X'FE' ERROR = FF?
BE RERROR2 YES, BRANCH
SR R5,R5
IC R5,ERRNUM GET RIGHT MESSAGE NUMBER
M R4,=F'20' OFFSET := ERRNUM * 20
LA R5,ERRTAB(R5)
CLI OLDERR,S1ERRNUM WAS IT A SERIES1 ERROR?
BNE RNOTOPN1 NO, THE WRITE OUT THE ERROR
LA R1,X'F0' GET READY TO UNPK ERROR CODES
ICM R1,B'1110',KERFSRET MOVE IN THE ERROR CODES
SRL R1,4 GET RID OF LOWER ZERO
ST R1,WORK1 SAVE IT
UNPK S1RETC(6),WORK1(4) MAKE IT SORTA-PRINTABLE
TR S1RETC(6),HEXTB PRETTY IT UP
RNOTOPN1 MVC SDAT(20),0(R5) SPACK NEEDS THE DATA HERE
TR SDAT(20),ETOA TRANSLATE TO ASCII
MVC LSDAT,=F'20' STORE THE DATA LENGTH
RERROR2 DS 0H
L R15,=A(SPACK)
BALR R14,R15 SEND ERROR PACKET & DIE
RNOERRP LA R15,4 SET NON-ZERO RETCODE
B RECRET PREPARE TO LEAVE
RCOMP SR R15,R15 RETCODE OF ZERO
RECRET TM S1FLAGS,ISS1 SERIES1/7171?
BNO RECRET2 NO - THEN NO NEED TO DE-INIT
LR R2,R15 PRESERVE THE RETCODE
SR R1,R1 SET P-REG
L R15,=A(INTRINI)
BALR R14,R15 GO TO IT
LR R15,R2 RESTORE THE RETCODE
RECRET2 L R13,4(R13)
L R14,12(R13)
LM R0,R12,20(R13)
BR 14
RECSAVE DS 18F
MOVEFNAM MVC FILNAM(0),RDAT PICK UP FNAME
PAD MVC 1(0,R9),0(R9) PAD OUT WITH SPACES
MOVEERR MVC SDAT(0),RBUF MOVE MESSAGE TO SDAT
TRANERR TR SDAT(0),ETOA TRANSLATE TO ASCII
LTORG
DROP R11
DROP R12 DON'T NEED THEM ANYMORE
EJECT
*
* INITIALIZE FOR GOING VIA SERIES/1.
INTRINI CSECT
USING INTRINI,R15 establish addressability
STM R0,R14,INTRSAV save caller's regs
LR R12,R15
DROP R15
USING INTRINI,R12
L R11,=A(PARMS)
USING PARMS,R11
LTR R1,R1 anything in R1?
BZ INTRCLR no: do clean up
TM S1FLAGS,S1INIT Initialized already? [13]
BO INTRRET Yes just leave [13]
OI S1FLAGS,S1INIT Else init and flag as done [13]
LA R1,INTRMSG SET UP ADDR OF INIT MSG
ST R1,KERMFSWB AND SAVE IN PLIST
LA R1,LINTRMSG AND LENGTH
ST R1,KERMFSWL THIS TOO SHALL BE PASSED
MVI KERMFSFG,WRTERASE+SKIPRD+OWNWCC
MFREQ KERMFARG DO IT
CLI KERFSRET,X'00' ANY ERRORS?
BE INTRIN1 NO - GREAT
ABEND 64 THAT'S ALL FOLKS
INTRIN1 DS 0H
LA R1,S1ORDS POINT TO BEGINNING OF SEND PACKET
ST R1,KERMFSWB SET WRITE BUFFER ADDR
LA R1,RECPKT POINT TO BEGINNING OF SEND PACKET
ST R1,KERMFSRB SET READ BUFFER ADDR
LA R1,L'RECPKT POINT TO BEGINNING OF SEND PACKET
ST R1,KERMFSRL SET READ BUFFER ADDR
MVI KERMFSFG,WRTERASE+OWNWCC SET FSIO OPTIONS
B INTRRET
INTRCLR EQU *
NI S1FLAGS,X'FF'-S1INIT Turn off flag
INTRRET EQU *
LM R0,R14,INTRSAV restore caller's regs
BR R14 return to caller
INTRSAV DS 15F reg save area
WRTERASE EQU X'80' FSIO WRITE ERASE
INTRMSG DC X'C4',AL1(SBA),X'4040'
DC C'Ready for file transfer...'
LINTRMSG EQU *-INTRMSG
OWNWCC EQU X'02' WE WILL USE OWN WCC IN FSIO
SKIPRD EQU X'04' SKIP THE READ OPERATION
LTORG
DROP R11
DROP R12
END KERMIT