Columbia Kermit

home *** CD-ROM | disk | FTP | other *** search

/ Columbia Kermit / kermit.zip / music / imusic.asm next >

Wrap

Assembly Source File | 2020-01-01 | 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