PRINT ON,GEN 00010000 KERMIT TITLE 'KERMIT-EC' 00020003 MACRO 00030000 REGISTER 00040000 LCLA &N 00050000 SPACE 00060000 *********************************************************************** 00070000 * GENERAL REGISTER EQUATES * 00080000 *********************************************************************** 00090000 SPACE 00100000 &N SETA 0 00110000 .LOOP ANOP 00120000 R&N EQU &N 00130000 AIF (&N EQ 15).OUT 00140000 &N SETA &N+1 00150000 AGO .LOOP 00160000 .OUT ANOP 00170000 SPACE 00180000 MEND 00190000 MACRO 00200000 &LABEL BINCVRT ®,&AREA,&DBLWRK 00210000 .* 00220000 .* CONVERT THE CONTENTS OF ® TO DECIMAL AND EDIT INTO &AREA. 00230000 .* &AREA IS A FIELD OF LENGTH SIX THAT WILL CONTAIN THE INTEGER 00240000 .* STRING WITH LEADING BLANKS SUPRESSED. &DBLWRK IS A DOUBLE 00250000 .* WORK SPACE. 00260000 .* 00270000 &LABEL CVD ®,&DBLWRK 00280000 MVC &AREA.(6),=X'402020202120' 00290000 ED &AREA.(6),&DBLWRK+5 00300000 MEND 00310000 MACRO 00320000 **************************************************************** 00330000 * üTA MAKPOKOMAHäA éúMEHEHA ðPéMEHéTEìøHO K COBETCKOMõ TSO SVS 00340000 **************************************************************** 00350000 &LAB WRTERM &MSG 00360000 LCLC &MS 00370000 LCLA &LN 00380000 &MS SETC '&MSG' 00390000 &LN SETA K'&MS 00400000 &LN SETA &LN-2 00410000 &LAB B IHBE&SYSNDX 00420000 IHBT&SYSNDX DC C&MS 00430000 IHBE&SYSNDX DS 0H 00440000 TPUT IHBT&SYSNDX,&LN 00450000 MEND 00460000 **************************************************************** 00470000 * üTA MAKPOKOMAHäA éúMEHEHA ðPéMEHéTEìøHO K COBETCKOMõ TSO SVS 00480000 **************************************************************** 00490000 MACRO 00500000 &LAB PROMPT &MSG 00510000 LCLC &MS 00520000 LCLA &LN 00530000 &MS SETC '&MSG' 00540000 &LN SETA K'&MS 00550000 &LN SETA &LN-2 00560000 &LAB B IHBE&SYSNDX 00570000 IHBT&SYSNDX DC C&MS 00580000 IHBE&SYSNDX DS 0H 00590000 TPUT IHBT&SYSNDX,&LN,ASIS 00600000 MEND 00610000 MACRO 00620000 RDTERM &BUFF 00630000 TGET &BUFF,130 00640000 MEND 00650000 KERMIT CSECT 00660003 * 00670000 * ---------------------------------------- 00680000 * 00690000 * KERMIT/TSO - 00700003 * 00710000 * KERMIT - KL10 ERROR-FREE RECIPROCOL MICRO INTERFACE TRANSFER 00720003 * IBM VERSION 1.0 00730000 * 00740000 * THIS PROGRAM IS THE IBM MVS/TSO SIDE OF A FILE TRANSFER SYSTEM. 00750000 * IT CAN BE USED TO TRANSFER FILES BETWEEN A MICRO AND A SYSTEM 00760000 * RUNNING UNDER MVS/TSO. IT MUST BE RUN AS A COMMAND PROCESSOR. 00770000 * SEE THE KERMIT MANUAL FOR THE COMPLETE PROGRAM SPECIFICATIONS 00780003 * TO WHICH THIS PROGRAM AND ANY OTHER COMPONENT OF THE SYSTEM 00790000 * MUST ADHERE. 00800000 * 00810000 * RONALD J. RUSNAK, UNIVERSITY OF CHICAGO COMPUTATION CENTER 00820000 * BITNET ADDRESS, SYSRONR AT UCHIVM1 00830000 * MAILNET ADDRESS, SYSTEMS.RON@UCHICAGO.MAILNET 00840000 * ARPA FORWARDING ADDRESS, SYSTEMS.RON%UCHICAGO@MIT-MULTICS.ARPA 00850000 * MAY 1984 00860000 * 00870000 * DEVELOPED BY THE MODIFICATION OF THE IBM CMS VERSION WRITTEN BY 00880000 * DAPHNE TZOAR, COLUMBIA UNIVERSITY CENTER FOR COMPUTING ACTIVITIES 00890000 * MARCH 1982 00900000 * 00910000 * COPYRIGHT (C) 1984 UNIVERSITY OF CHICAGO 00920000 * 00930000 * PERMISSION IS GRANTED TO ANY INDIVIDUAL OR INSTITUTION TO COPY 00940000 * OR USE THIS PROGRAM, EXCEPT FOR EXPLICITLY COMMERCIAL PURPOSES. 00950000 * 00960000 * 00970000 * THE FOLLOWING EXTERNAL SUBROUTINES ARE REQUIRED: 00980000 * -DYNALC - MVS DYNAMIC ALLOCATION INTERFACE. 00990000 * 01000000 * 01010000 * ---------------------------------------- 01020000 * 01030000 * NOTE THAT THIS IS AN EXPERIMENTAL VERSION; ALL CHANGES SHOULD 01040000 * BE FORWARDED TO THE AUTHOR. 01050000 * 01060000 * ðPOçPAMMA MOäéæéãéPOBAHA ðPéMEHéTEìøHO K TSO SVS B.â.öOPHéãKéM 01070000 * çìABHùê BùþéCìéTEìøHùê ãEHTP MðC, MOCKBA, 1986ç, OKTñâPø-HOñâPø 01080000 * 01090000 * 01100000 * B ðPOçPAMMõ BHECEHù CìEäõàýéE OCHOBHùE éúMEHEHéñ: 01110000 * 1. éúMEHEHù CéMBOìù HAþAìA úAçOìOBKA é KOHãA CTPOKé ðPéMEHéTEìøHO 01120000 * K COBETCKOMõ TCAM äìñ Að/70. 01130000 * 2. OTKìàþEHA BOúMOöHOCTø éúMEHñTø SOH é EOL. 01140000 * 3. BBEäEHA ðEPEäAþA æAêìOB TéðA BIN. 01150000 * 4. OâECðEþEHA ðPEæéKCAãéñ BOCøMOçO âéTA. 01160000 * 5. éúMEHEHA OâPAâOTKA úAðPOCA HA âOìøûéE ðAKETù (âOìøûE 94). 01170000 * 6. OâECðEþEHA BOúMOöHOCTø úAçPõúKé ðOìøúOBATEìøCKéX TAâìéã 01180000 * ðEPEKOäéPOBKé. 01190000 * 7. OâECðEþEHA BOúMOöHOCTø COúäAHéñ KOMAHäHùX ðPOãEäõP. 01200000 * 01210000 * 01220000 EJECT 01230000 * REGISTER USAGE - 01240000 * R1 - 01250000 * R2 - 01260000 * R3 - 01270000 * R4 - 01280000 * R5 - 01290000 * R6 - 01300000 * R7 - 01310000 * R8 - 01320000 * R9 - 01330000 * R10 - 01340000 * R11 - BASE REGISTER FOR GLOBAL DATA AREA 01350000 * R12 - PROGRAM BASE 01360000 * R13 - SAVE AREA 01370000 * R14 - SUBROUTINE LINKAGE 01380000 * R15 - SUBROUTINE LINKAGE 01390000 * 01400000 SPACE 01410000 REGISTER 01420000 IKJCPPL 01430000 IKJPSCB BCTABìEHO J 01440000 IKJUPT 01450000 IKJPGPB BCTABìEHO J 01460000 IKJIOPL BCTABìEHO J 01470000 SPACE 01480000 AD EQU 68 DATA PACKET (ASCII 'D') 01490000 AN EQU 78 NAK 01500000 AZ EQU 90 EOF PACKET 01510000 AS EQU 83 INIT PACKET 01520000 AY EQU 89 ACK 01530000 AF EQU 70 FILE PACKET 01540000 AB EQU 66 BREAK PACKET 01550000 AE EQU 69 ERROR PACKET 01560000 ERCOD EQU 12 MEANS EOF WITH 'FSREAD' 01570000 FLG1 EQU X'80' IS FILE THE FIRST OR NOT 01580000 FLG2 EQU X'40' OVERWRITE SENT FILENAME? 01590000 FLG3 EQU X'20' ONE = SENT ONLY PARTIAL RECORD 01600000 FLG4 EQU X'10' NAK FROM MICRO(0) OR RPACK(1)? 01610000 FLG5 EQU X'08' ALLOCATED MORE SPACE (DMSFREE) 01620000 BINF EQU X'04' EQU 1 - BINARY DATA J 01630000 D8QUO EQU X'26' DEFAULT 8-BIT QUOTE (C'&') J 01640000 EJECT 01650000 DCBD DSORG=(PS) 01660000 EJECT 01670000 ********************************************************************** 01680000 * * 01690000 * KERMIT-TSO PROGRAM * 01700003 * * 01710000 ********************************************************************** 01720000 KERMIT CSECT 01730003 STM R14,R12,12(R13) 01740000 BALR R12,0 01750000 USING *,R12 01760000 LA R14,KSAVE 01770000 ST R13,4(R14) 01780000 ST R14,8(R13) 01790000 LR R13,R14 01800000 * USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 01810000 L R11,=A(PARMS) 01820000 USING PARMS,R11 01830000 TM 0(R1),X'80' IS THIS A COMMAND PROCESSOR? 01840000 BO NOTCP NO, THEN REFUSE USER 01850000 * 01860000 * COLLECT USERS MVS-TSO PREFIX. 01870000 * 01880000 * üTO MECTO MOäéæéãéPOBAHO B CBñúé C TEM, þTO B SVS HET ðPEæéKCA 01890000 * B KAþECTBE ðPEæéKCA BùâéPAETCñ USERID 01900000 * L R2,CPPLUPT-CPPL(,R1) GET TO UPT âùìO 01910000 L R2,CPPLPSCB-CPPL(,R1) GET TO PSCB J 01920000 XR R3,R3 CLEAR R3 01930000 * IC R3,UPTPREFL-UPT(,R2) GET LENGTH âùìO 01940000 IC R3,PSCBUSRL-PSCB(,R2) GET LENGTH J 01950000 BCTR R3,0 01960000 ST R3,PREFIXL SAVE FOR LATER 01970000 MVC PREFIX(*-*),PSCBUSER-PSCB(R2) MOVE PREFIX MOä. J 01980000 EX R3,*-6 01990000 * TO FILL IOPL BEGIN J 02000000 USING CPPL,R1 02010000 LA 14,IOPLL IOPL ADDR. 02020000 USING IOPL,R14 02030000 L R15,CPPLUPT ADDR. OF UPT FROM CPPL 02040000 ST R15,IOPLUPT TO IOPL 02050000 L R15,CPPLECT ADDR. OF ECT FROM CPPL 02060000 ST R15,IOPLECT TO IOPL 02070000 LA R15,ECBPTGT ADDR. OF ECB 02080000 ST R15,IOPLECB TO IOPL 02090000 LA R15,PUTGET ADDR. OF MF=L FORM 02100000 USING PGPB,R15 02110000 XC PGPBIBUF(4),PGPBIBUF FOR TEST FOR FIRST FREEMAIN J 02120000 GTSIZE 02130000 LTR R0,R0 IS THIS A GRAPHICS DEVICE? 02140000 NOP 0 BNZ BADDEV YES, THEN REFUSE USER BPEMEHHO 02150000 L R15,=A(INIT) 02160000 BALR R14,R15 CALL THE INITIALIZATION 02170000 WRTERM 'KERMIT-TSO VERSION 3.06' R 02180003 WRTERM ' ' 02190000 ********************************************************************** 02200000 * * 02210000 * MAIN COMMAND PROCESSING ROUTINE * 02220000 * * 02230000 ********************************************************************** 02240000 PROMPT LA R15,PUTGET MF=L FORM BEGIN J 02250000 L R1,PGPBIBUF ADDR OF INPUT BUFFER 02260000 LTR R1,R1 BUFFER EXIST ? 02270000 BZ IMADPROM NO 02280000 LH 0,0(R1) GET LENGTH 02290000 FREEMAIN R,LV=(R0),A=(R1),SP=1 AND FREE OLD COM. BUFFER 02300000 IMADPROM DS 0H IMMADIATE PROMPT 02310000 PUTGET PARM=PUTGET,OUTPUT=(OLD,SINGLE,MODE), *02320000 TERMPUT=(ASIS),MF=(E,IOPLL) 02330000 LA R15,PUTGET 02340000 L R15,PGPBIBUF ADDR OF NEW COMMAND 02350000 LH R1,0(R15) LENGTH 02360000 BCTR R1,0 FOR EX COM. 02370000 MVI INPUT,C' ' ZERO INPUT FIELD 02380000 MVC INPUT+1(129),INPUT 02390000 MVC INPUT(0),4(R15) MOVE COM. TO INPUT BUFFER 02400000 EX R1,*-6 END J 02410000 * 02420000 TR INPUT,UPPER UPPERCASE INPUT 02430000 LA R1,INPUT R1 GETS ADDRESS OF STRING 02440000 L R0,=F'130' R0 GETS THE LENGTH 02450000 L R15,=A(PARSER) 02460000 BALR R14,R15 DO TOKENIZING 02470000 * 02480000 LM R7,R9,PARSELST SAVE ADDR OF TOKENIZED LIST 02490000 L R6,0(,R7) GET THE PTR TO FIRST OPERAND 02500000 NOPRO MVI ERRNUM,X'FF' RESET ERROR FOR THIS TIME 02510000 CLI 0(R6),C' ' BARE CARRIAGE RETURN? 02520000 BE PROMPT IGNORE IT 02530000 CLI 0(R6),C'E' CHECK FOR 'EXIT' COMMAND 02540000 BE LEAVE 02550000 CLI 0(R6),C'Q' CHECK FOR 'QUIT' COMMAND 02560000 BE LEAVE 02570000 CLI 0(R6),C'?' NEED HELP ? 02580000 BNE SETCHK 02590000 WRTERM 'LEGAL COMMANDS ARE: ' 02600000 WRTERM 'RECEIVE, SEND, HELP, EXIT, QUIT, SET, STATUS, SHOW .' 02610000 B PROMPT 02620000 SETCHK CLC =C'SET',0(R6) IS IT THE SET COMMAND ? 02630000 BE STSWITCH 02640000 CLC =C'ST',0(R6) IS IT THE STATUS COMMAND? 02650000 BE STATSW 02660000 CLC =C'SH',0(R6) IS IT THE SHOW COMMAND? 02670000 BE SHOSW 02680000 CLC =C'HE',0(R6) NEED HELP ? 02690000 BE HELPSW 02700000 OI FLAGS,FLG1 SET FLG1 - IT'S THE FIRST FILE 02710000 NI FLAGS,X'FF'-FLG2 TURN OFF OVERWRITE FLAG (INIT) 02720000 CLC =C'RE',0(R6) 02730000 BNE SS MAYBE IT'S A SEND COMMAND 02740000 ********************************************************************** 02750000 * PROCESS RECEIVE COMMAND * 02760000 ********************************************************************** 02770000 BXH R7,R8,RR3 GET NEXT OPERAND 02780000 L R6,0(,R7) GET POINTER TO NEXT OPERAND 02790000 CLI 0(R6),C'?' NEED HELP? 02800000 BNE RR2 02810000 WRTERM 'SPECIFY DSNAME TO BE CREATED FOR RECEIVE.' 02820000 B PROMPT 02830000 RR2 CLI 0(R6),C' ' MORE WORDS ? 02840000 BE RR3 NO, THEN PROMPT 02850000 MVC DSNAMEX(80),=CL80' ' BLANK DSNAME 02860000 LA R1,DSNAMEX POINT TO DSNAME BUFFER 02870000 LA R2,44 MAX LENGTH OF DSNAME 02880000 SR R5,R5 ZERO THE LENGTH 02890000 RR4 CLI 0(R6),C' ' IS THIS END OF FIELD 02900000 BE RR5 YES, THEN PROCESS DSNAME 02910000 MVC 0(1,R1),0(R6) MOVE A CHARACTER 02920000 LA R6,1(,R6) MOVE ALONG INPUT BUFFER 02930000 LA R1,1(,R1) MOVE ALONG DSNAME BUFFER 02940000 LA R5,1(,R5) UP THE LENGTH COUNT 02950000 BCT R2,RR4 KEEP LOOKING FOR END 02960000 WRTERM 'DSNAME TOO LONG' 02970000 * 02980000 * ALLOCATE A NEW DATA SET FOR RECEIVE 02990000 * DYNALOC WILL NOT PREFIX - SO WE HAVE TO DO THIS BY HAND. 03000000 * 03010000 RR3 WRTERM 'ENTER DATA SET NAME FOR RECEIVE.' 03020000 MVC DSNAMEX(80),=CL80' ' BLANK FIELD 03030000 TGET DSNAMEX,44 GET DSNAME 03040000 TR DSNAMEX(80),UPPER MAKE UPPER CASE DSN 03050000 LR R5,R1 SAVE TGET LENGTH 03060000 RR5 LA R6,DSNAMEX SOURCE 03070000 MVC DSNAME(44),=CL44' ' BLANK FIELD 03080000 LA R2,DSNAME PLACE TO STUFF DSNAME 03090000 CLI DSNAMEX,C'''' TEST IF QUOTED 03100000 BE GBDSNQ1 BR IF SO 03110000 * 03120000 * WE'LL PREFIX THE DSNAME "BY HAND". 03130000 * 03140000 L R3,PREFIXL ELSE GET EX LEN 03150000 MVC 0(*-*,R2),PREFIX MOVE PREFIX TO BUFFER 03160000 EX R3,*-6 MOVE IT 03170000 LA R2,1(R3,R2) NEXT POS IN BUFFER 03180000 MVI 0(R2),C'.' PUT A DOT IN THERE 03190000 LA R2,1(,R2) PLACE FOR REST OF DSNAME 03200000 B GBDSNQ2 CONTINUE 03210000 GBDSNQ1 DS 0H X 03220000 LA R6,1(,R6) PAST QUOTE 03230000 S R5,=F'2' REDUCE LENGTH BY 2 03240000 * 03250000 * BUILD THE PARM LIST TO THE MVS DYNALC ROUTINE. 03260000 * 03270000 GBDSNQ2 DS 0H 03280000 BCTR R5,0 DEC LEN FOR EX 03290000 MVC 0(*-*,R2),0(R6) COMPLETE DSNAME 03300000 EX R5,*-6 03310000 MVC DDNAME(8),=CL8'KEROUT' 03320000 MVC DISP1(4),=F'0' A NEW DATA SET 03330000 MVC DISP2(4),=F'1' CATLG 03340000 MVC INOUT(4),=F'1' OUTPUT 03350000 MVC RECFMX(4),=F'1' FB DATA SET 03360000 MVC TRACK(4),=F'5' 5 TRACK ALLOC 03370000 * 03380000 * SELECT A MODEL DCB. EITHER F OR V 03390000 * 03400000 MVC KEROUT(MODDCBFL),MODDCBF 03410000 CLI RFM,C'F' DOES USER WANT FB 03420000 BE MAKDCB YES 03430000 MVC KEROUT(MODDCBVL),MODDCBV USE V MODEL 03440000 MAKDCB DS 0H 03450000 * 03460000 * NOW CHECK THE LRECL AND BLKSIZE BEFORE OPEN 03470000 * 03480000 SR R1,R1 CLEAR R1 03490000 IC R1,LRECL GET LRECL 03500000 SR R2,R2 CLEAR R2 03510000 LH R3,BLKSIZE GET BLKSIZE 03520000 CLI RFM,C'V' IS THIS VARIABLE 03530000 BE CHKFIXD NO, THEN CHECK AS IF FIXED 03540000 DR R2,R1 SEE IF BLKSIZE IS A MULTIPLE 03550000 LTR R2,R2 OF THE LRECL 03560000 BNZ CHKBLKER YES, THEN SET LRECL AND BLKSIZE 03570000 LH R3,BLKSIZE GET BLKSIZE 03580000 B SETLB 03590000 CHKBLKER WRTERM 'BLKSIZE NOT MULTIPLE OF LRECL FOR RECFM=F' 03600000 B PROMPT 03610000 CHKFIXD SH R3,=H'4' ADJUST BLKSIZE 03620000 CR R1,R3 IS LRECL =< BLKSIZE - 4 03630000 BNH CHKFIXD2 YES, THEN SET LRECL AND BLKSIZE 03640000 WRTERM 'LRECL NOT LESS THAN BLKSIZE - 4 FOR RECFM=V' 03650000 B PROMPT 03660000 CHKFIXD2 AH R3,=H'4' READJUST BLKSIZE 03670000 SETLB DS 0H 03680000 STH R1,KEROUT+(DCBLRECL-IHADCB) STUFF IN DCB 03690000 STH R3,KEROUT+(DCBBLKSI-IHADCB) 03700000 ST R3,BLKSIZEX BLKSIZE 03710000 ST R1,LRECLX LRECL 03720000 LOCATE DATASET 03730000 LTR R15,R15 DOES DATASET EXIST? 03740000 BNZ RRALOC NO, THEN ALLOC A NEW ONE 03750000 PROMPT 'DATASET EXISTS, REPLY "OK" TO OVERWRITE: ' 03760000 TGET WRKBUFF,3 03770000 OC WRKBUFF(3),=CL80' ' UPPER CASE REPLY 03780000 CLC =C'OK',WRKBUFF 03790000 BNE PROMPT BR, IF NOT OK 03800000 MVC DISP1,=F'1' MAKE DISP OLD 03810000 MVC DISP2,=F'3' KEEP 03820000 RRALOC L R15,=V(DYNALC) -> ENTRY POINT 03830000 LA R1,DYNAPARM PARMS FOR ALLOC 03840000 BALR R14,R15 DO IT 03850000 * 03860000 ICM R1,B'1111',DYNALCRC GET RETURN OCDE 03870000 BNZ PROMPT BR IF FAILURE 03880000 * 03890000 * ... THEN WE'LL MERGE IN THESE DCB ATTRIBUTES 03900000 * 03910000 MAKDCBX DS 0H 03920000 OPEN (KEROUT,(OUTPUT)) 03930000 TM KEROUT+(DCBOFLGS-IHADCB),DCBOFOPN 03940000 BO GBOPNA 03950000 WRTERM 'OPEN FOR DATASET FAILED.' 03960000 B PROMPT 03970000 * 03980000 * A BREEZE... 03990000 * 04000000 GBOPNA DS 0H 04010000 WRTERM 'RECEIVE WAITING...' 04020000 L R15,=A(RECEIVE) 04030000 BALR R14,R15 CALL RECEIVE PORTION 04040000 LTR R5,R15 CHECK RETURN CODE 04050000 BNZ LNON 04060000 MVI ERRNUM,X'FF' 04070000 LNON DS 0H 04080000 * 04090000 * CLOSE ANY OPEN DATA SETS. 04100000 * 04110000 * ECìé æAêì BIN, BùBOäéM ðOCìEäHéê âìOK , äOðOìHññ HõìñMé J BEGIN 04120000 TM FLAGS,BINF IS FILE BIN ? 04130000 BZ CLOSE NO = OK 04140000 ST R6,SAVR6 FOR FUTURE USE 04150000 ST R10,SAVR10 04160000 SR R6,R6 04170000 IC R6,LRECL LRECL 04180000 L R10,RSAVPL PART NOT WRITED 04190000 LTR R10,R10 HAVE SOMETHING 04200000 BZ CLOSE NO - OK 04210000 CRR10R6 CR R10,R6 04220000 BNH LA15RBU 04230000 ST R10,RSAVPL 04240000 LR R10,R6 LENGHTH=LRECL 04250000 L R15,=A(WRITEX) 04260000 BALR R15,R15 WRITE LAST RECORD 04270000 L R10,RSAVPL 04280000 SR R10,R6 04290000 BE CLOSE 04300000 BCTR R10,0 FOR EX COM. J 04310000 LA R15,RBUF(R6) J 04320000 MVC RBUF(*-*),0(R15) TO BEGIN OF BUF. J 04330000 EX R10,*-6 J 04340000 LA R10,1(R10) RETURN LEN J 04350000 B CRR10R6 GRATER THEN LRECL ? J 04360000 LA15RBU LA R15,RBUF(R6) 04370000 LA R10,RBUF(R10) 04380000 ZEROR BCTR R15,0 FIRST SYMBOL FOR ZERO 04390000 CR R15,R10 04400000 BL ZEROE ALL ZEROES ADDED 04410000 MVI 0(R15),0 04420000 B ZEROR 04430000 ZEROE LR R10,R6 LENGHTH=LRECL 04440000 L R15,=A(WRITEX) 04450000 BALR R15,R15 WRITE LAST RECORD 04460000 XC RSAVPL(4),RSAVPL 04470000 L R6,SAVR6 04480000 L R10,SAVR10 J END 04490000 CLOSE CLOSE (KERIN,,KEROUT) 04500000 MVC OLDERR(1),ERRNUM ERROR SETTING OF THIS RUN 04510000 LTR R5,R5 CHECK THE RETCODE 04520000 BZ PROMPT ALL OKAY 04530000 WRTERM 'ERROR IN RECEIVING FILE. TRY AGAIN.' 04540000 B PROMPT ERROR - TRY AGAIN 04550000 SS CLC =C'SEN',0(R6) 04560000 BNE ERR UNRECOGNIZED COMMAND 04570000 ********************************************************************** 04580000 * PROCESS SEND COMMAND * 04590000 ********************************************************************** 04600000 BXH R7,R8,SS3 NO MORE LEFT 04610000 L R6,0(R7) PICK UP NEXT OPERAND 04620000 CLI 0(R6),C'?' NEED HELP? 04630000 BNE SS2 04640000 WRTERM 'SPECIFY DATASET NAME.' [ ] 04650000 B PROMPT 04660000 SS2 CLI 0(R6),C' ' MORE DATA ? 04670000 * 04680000 * USER WANTS TO SEND A DATA SET - WELL... 04690000 * 04700000 BE SS3 NO, THEN PROMPT 04710000 MVC DSNAMEX(80),=CL80' ' BLANK DSNAME 04720000 LA R1,DSNAMEX POINT TO DSNAME BUFFER 04730000 LA R2,44 MAX LENGTH OF DSNAME 04740000 SR R5,R5 CLEAR LENGTH 04750000 SS4 CLI 0(R6),C' ' IS THIS END OF FIELD 04760000 BE SS5 YES, THEN PROCESS DSNAME 04770000 MVC 0(1,R1),0(R6) MOVE A CHARACTER 04780000 LA R6,1(,R6) MOVE ALONG INPUT BUFFER 04790000 LA R1,1(,R1) MOVE ALONG DSNAME BUFFER 04800000 LA R5,1(,R5) UP THE LENGTH COUNT 04810000 BCT R2,SS4 KEEP LOOKING FOR END 04820000 WRTERM 'DSNAME TOO LONG' 04830000 B PROMPT 04840000 SS3 WRTERM 'ENTER DATASET NAME TO SEND.' 04850000 MVC DSNAMEX(80),=CL80' ' BLANK FIELD 04860000 TGET DSNAMEX,44 GET DSNAME 04870000 TR DSNAMEX(80),UPPER MAKE UPPER CASE DSN 04880000 LR R5,R1 SAVE TGET LENGTH 04890000 SS5 LA R6,DSNAMEX SOURCE 04900000 MVC DSNAME(44),=CL44' ' BLANK FIELD 04910000 LA R2,DSNAME PLACE TO STUFF DSNAME 04920000 CLI DSNAMEX,C'''' TEST IF QUOTED 04930000 BE GBDSNQ3 BR IF SO 04940000 * 04950000 * USER TESTS IF I KNOW HOW TO PREFIX A DSNAME. 04960000 * 04970000 L R3,PREFIXL ELSE GET EX LEN 04980000 MVC 0(*-*,R2),PREFIX MOVE PREFIX TO BUFFER 04990000 EX R3,*-6 MOVE IT 05000000 LA R2,1(R3,R2) NEXT POS IN BUFFER 05010000 MVI 0(R2),C'.' PUT A DOT IN THERE 05020000 LA R2,1(,R2) PLACE FOR REST OF DSNAME 05030000 B GBDSNQ4 CONTINUE 05040000 GBDSNQ3 DS 0H X 05050000 LA R6,1(,R6) PAST QUOTE 05060000 S R5,=F'2' REDUCE LENGTH BY 2 05070000 * 05080000 * BUILD A "CONTROL BLOCK" 05090000 * 05100000 GBDSNQ4 DS 0H 05110000 BCTR R5,0 DEC LEN FOR EX 05120000 MVC 0(*-*,R2),0(R6) COMPLETE DSNAME 05130000 EX R5,*-6 05140000 LA R5,DSNAME+43 POINT TO END OF DSNAME 05150000 LA R4,44 LENGTH OF DSNAME 05160000 SSFINDL1 CLI 0(R5),C' ' IS IT BLANK? 05170000 BNE SSFINDL2 NO, THEN FOUND END OF DSN 05180000 BCTR R5,0 DECREMENT PTR 05190000 BCT R4,SSFINDL1 LOOP TILL FOUND 05200000 WRTERM 'DSNAME CANNOT BE ENTIRELY BLANK' 05210000 B PROMPT 05220000 SSFINDL2 LR R3,R5 REMEMBER END OF DSN 05230000 LA R2,2 TRY TO FIND 2 LEVELS 05240000 SSFINDL3 CLI 0(R5),C'.' IS IT A DOT? 05250000 BE SSFINDL4 YES, THEN HANDLE IT 05260000 SSFINDL5 BCTR R5,0 DECREMENT PTR 05270000 BCT R4,SSFINDL3 LOOP TILL FOUND 05280000 B SSFINDE BR IF FRONT OF DSN 05290000 SSFINDL4 BCT R2,SSFINDL5 FIND ANOTHER LEVEL 05300000 SSFINDE MVC FILNAM,=CL80' ' BLANK FILNAM 05310000 LA R5,1(,R5) MOVE TO FRONT OF LEVEL 05320000 SR R3,R5 FIND LENGTH TO MOVE 05330000 CH R3,=H'17' TRUNC IF TOO LONG 05340000 BNH *+8 NOT TOO LONG 05350000 LA R3,=H'17' FORCE MAX LENGTH 05360000 MVC FILNAM(*-*),0(R5) MOVE INSTRUCTION FOR EXECUTE 05370000 EX R3,*-6 GO MOVE THE DATA 05380000 STH R3,FILNAML SAVE LENGTH - 1 05390000 MVC DDNAME(8),=CL8'KERIN' 05400000 MVC DISP1(4),=F'2' DISP=SHR 05410000 MVC DISP2(4),=F'3' KEEP 05420000 MVC INOUT(4),=F'0' INPUT 05430000 LA R1,DYNAPARM 05440000 L R15,=V(DYNALC) GET EMTRY POINT 05450000 BALR R14,R15 DO IT 05460000 ICM R1,B'1111',DYNALCRC GET RETURN CODE 05470000 BNZ PROMPT 05480000 * 05490000 * OPEN THE USERS DATA SET 05500000 * 05510000 OPEN (KERIN,(INPUT)) 05520000 TM KERIN+(DCBOFLGS-IHADCB),DCBOFOPN 05530000 BO GBOPNB 05540000 WRTERM 'OPEN FOR DATASET FAILED.' 05550000 B PROMPT 05560000 GBOPNB DS 0H 05570000 TM KERIN+(DCBRECFM-IHADCB),DCBRECV IS RECFM=V 05580000 BO SSDELAY YES, THEN WAIT 05590000 TM KERIN+(DCBRECFM-IHADCB),DCBRECF IS RECFM=F 05600000 BO SSDELAY YES, THEN WAIT 05610000 WRTERM 'INVALID RECFM, ONLY FIXED AND VARIABLE SUPPORTED' 05620000 CLOSE KERIN 05630000 B PROMPT 05640000 SSDELAY DS 0H 05650000 MVC WRKBUFF(37),=C'WAITING ..... SECONDS BEFORE SENDING.' 05660000 L R1,DELAY 05670000 SR R0,R0 05680000 D R0,=F'100' 05690000 BINCVRT R1,WRKBUFF+7,DBLWRK 05700000 TPUT WRKBUFF,37 05710000 STIMER WAIT,BINTVL=DELAY 05720000 B SSWITCH 05730000 ERR WRTERM 'INVALID COMMAND' 05740000 B PROMPT INVALID COMMAND - TRY AGAIN 05750000 SPACE 3 05760000 SSWITCH EQU * 05770000 L R15,=A(SEND) 05780000 BALR R14,R15 CALL SEND PORTION 05790000 LTR R5,R15 CHECK RETURN CODE 05800000 BNZ LINON 05810000 MVI ERRNUM,X'FF' WORKED OK 05820000 LINON DS 0H 05830000 * 05840000 * CLOSE ANY OPEN DATA SETS. 05850000 * 05860000 CLOSE (KERIN,,KEROUT) 05870000 MVC OLDERR(1),ERRNUM ERROR SETTING OF THIS RUN 05880000 LTR R5,R5 CHECK THE RETCODE 05890000 BZ PROMPT ALL OKAY 05900000 WRTERM 'ERROR IN SENDING FILE. TRY AGAIN.' 05910000 B PROMPT ERROR - TRY AGAIN 05920000 ********************************************************************** 05930000 * PROCESS SET COMMAND * 05940000 ********************************************************************** 05950000 STSWITCH EQU * 05960000 L R15,=A(SET) 05970000 BALR R14,R15 CALL "SET" SUBROUTINE 05980000 LTR R15,R15 CHECK RETCODE 05990000 BZ PROMPT 06000000 WRTERM 'ILLEGAL SET COMMAND' 06010000 B PROMPT 06020000 ********************************************************************** 06030000 * PROCESS SHOW COMMAND * 06040000 ********************************************************************** 06050000 SHOSW EQU * 06060000 L R15,=A(SHOW) 06070000 BALR R14,R15 CALL "SHOW" SUBROUTINE 06080000 LTR R15,R15 CHECK RETCODE 06090000 BZ PROMPT 06100000 WRTERM 'ILLEGAL SHOW COMMAND' 06110000 B PROMPT 06120000 ********************************************************************** 06130000 * PROCESS STATUS COMMAND * 06140000 ********************************************************************** 06150000 STATSW EQU * 06160000 BXH R7,R8,GIVSTAT NO MORE LEFT 06170000 L R6,0(R7) PICK UP NEXT OPERAND 06180000 CLI 0(R6),C'?' NEED HELP? 06190000 BNE GIVSTAT 06200000 WRTERM 'CONFIRM WITH A CARRIAGE RETURN' 06210000 B PROMPT 06220000 GIVSTAT CLI OLDERR,X'FF' WAS THERE AN ERROR LAST TIME? 06230000 BNE FAIL 06240000 WRTERM 'KERMIT COMPLETED SUCCESSFULLY' 06250003 B PROMPT 06260000 FAIL SR R5,R5 06270000 IC R5,OLDERR GET OFFSET INTO ERROR TABLE 06280000 M R4,=F'20' OFFSET := ERRNUM * 20 06290000 LA R5,ERRTAB(R5) 06300000 *G WRTERM (R5),20 PRINT ERROR MSG ON SCREEN 06310000 TPUT (R5),20 06320000 B PROMPT AND LEAVE 06330000 ********************************************************************** 06340000 * PROCESS HELP COMMAND * 06350000 ********************************************************************** 06360000 HELPSW BXH R7,R8,GIVHLP NO MORE LEFT 06370000 L R6,0(R7) PICK UP NEXT OPERAND 06380000 CLI 0(R6),C'?' NEED HELP? 06390000 BNE GIVHLP 06400000 WRTERM 'CONFIRM WITH A CARRIAGE RETURN' 06410000 B PROMPT 06420000 GIVHLP DS 0H 06430000 WRTERM 'ENTER ? AT PROMPT TO RECEIVE LIST OF COMMANDS.' 06440000 WRTERM 'ENTER ? AFTER A COMMAND TO RECEIVE LIST OF OPERANDS' 06450000 B PROMPT 06460000 ********************************************************************** 06470000 * PROCESS EXIT COMMAND * 06480000 ********************************************************************** 06490000 LEAVE BXH R7,R8,KRET ANY MORE OPERANDS? 06500000 L R6,0(,R7) GET ADDRESS OF OPERAND 06510000 CLI 0(R6),C'?' NEED HELP? 06520000 BNE KRET NO, JUST LEAVE 06530000 WRTERM 'CONFIRM WITH A CARRIAGE RETURN' 06540000 B PROMPT 06550000 BADDEV WRTERM 'AN ASCII TERMINAL MUST BE USED.' 06560000 B RET 06570000 NOTCP WRTERM 'KERMIT-TSO MUST BE RUNNING AS A COMMAND PROCESSOR' 06580003 WRTERM 'CONTACT YOUR LOCAL SYSTEMS PROGRAMMER' 06590000 B RET 06600000 KRET EQU * 06610000 RET EQU * 06620000 * 06630000 * CLOSE ANY OPEN DATA SETS. 06640000 * DYNALC HAS A FREE=CLOSE SO..... 06650000 * 06660000 TM KERIN+(DCBOFLGS-IHADCB),DCBOFOPN 06670000 BNO RETGB1 06680000 CLOSE KERIN 06690000 RETGB1 DS 0H 06700000 TM KEROUT+(DCBOFLGS-IHADCB),DCBOFOPN 06710000 BNO RETGB2 06720000 CLOSE KEROUT 06730000 RETGB2 DS 0H 06740000 CLOSE DEBUG 06750000 L R13,4(R13) 06760000 L R14,12(R13) 06770000 LM R0,R12,20(R13) 06780000 BR R14 06790000 KSAVE DS 18F KERMIT'S SAVE AREA 06800003 LTORG 06810000 DROP R11 06820000 DROP R12 NO LONGER NEED THEM 06830000 EJECT 06840000 ********************************************************************** 06850000 * * 06860000 * ROUTINE TO PROCESS SET COMMAND * 06870000 * * 06880000 ********************************************************************** 06890000 SET DS 0H 06900000 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 06910000 BALR R12,0 ESTABLISH ADDRESSABILITY 06920000 USING *,R12 06930000 LA R14,SETSAVE ADDRESS OF MY SAVE AREA 06940000 ST R13,4(R14) SAVE CALLER'S 06950000 ST R14,8(R13) 06960000 LR R13,R14 06970000 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 06980000 L R11,=A(PARMS) 06990000 USING PARMS,R11 ESTABLISH ADDRESSABILITY 07000000 BXH R7,R8,SETHLP 07010000 L R6,0(R7) PICK UP NEXT OPERAND 07020000 CLI 0(R6),C'?' NEED HELP ? 07030000 BNE NOQ 07040000 SETHLP WRTERM 'BLKSIZE, DEBUG, DELAY, TRT, LRECL, FILE' J 07050000 WRTERM 'QUOTE, PACKET-SIZE, RECFM, SPACE' J 07060000 B SETOK 07070000 ********************************************************************** 07080000 * SET RECFM * 07090000 ********************************************************************** 07100000 NOQ CLC =C'RE',0(R6) 07110000 BNE NOREC 07120000 BXH R7,R8,SETNFM MORE OPERANDS? 07130000 L R6,0(R7) PICK UP RECORD FORMAT 07140000 CLI 0(R6),C'?' 07150000 BNE CHKFM 07160000 WRTERM 'F OR V (DEFAULT OF V)' 07170000 B SETOK 07180000 CHKFM CLI 0(R6),C'V' REDUNDANT 07190000 BE FMSET 07200000 CLI 0(R6),C'F' FIXED FORMAT? 07210000 BNE RECERR 07220000 FMSET MVC RFM(1),0(R6) PICK UP RECFM 07230000 B SETOK 07240000 RECERR WRTERM 'FIXED AND VARIABLE FILES ONLY' 07250000 B SETERR 07260000 ********************************************************************** 07270000 * SET QUOTE * 07280000 ********************************************************************** 07290000 NOREC CLC =C'QU',0(R6) QUOTE CHARACTER 07300000 BNE NOQUO 07310000 BXH R7,R8,SETNFM ANY MORE OPERANDS 07320000 L R6,0(R7) GET NEXT TOKEN 07330000 CLI 0(R6),C' ' VALUE NOT SUPPLIED? 07340000 BNE GIVQ 07350000 SETNFM WRTERM '?NOT CONFIRMED' 07360000 B SETERR 07370000 GIVQ CLC =C'? ',0(R6) 07380000 BNE GETQUO 07390000 WRTERM 'A SINGLE CHARACTER' 07400000 B SETOK 07410000 GETQUO MVC QUOCHAR(1),0(R6) SET NEW QUOTE CHAR 07420000 TR QUOCHAR(1),ETOA GET ASCII FORM 07430000 CLI 1(R6),C' ' IS IT ONLY ONE CHAR? 07440000 BE ISQOK 07450000 WRTERM 'ONE CHARACTER ONLY' 07460000 B BADQUO 07470000 ISQOK CLI QUOCHAR,X'21' CAN'T BE LESS THAN 32 07480000 BL BADQUO 07490000 CLI QUOCHAR,X'7E' CAN'T BE LARGER THAN 126 07500000 BH BADQUO 07510000 CLI QUOCHAR,X'3E' HAS TO BE BETWEEN 32-62 07520000 BNH SETOK 07530000 CLI QUOCHAR,X'60' OR BETWEEN 96-126 07540000 BNL SETOK 07550000 BADQUO WRTERM 'MUST FALL BETWEEN 41-76,140,OR 173-176 (OCTAL).' 07560000 MVC QUOCHAR(1),DQUOTE RESET VALUE, JUST IN CASE 07570000 B SETERR 07580000 ********************************************************************** 07590000 * SET LRECL * 07600000 ********************************************************************** 07610000 NOQUO CLC =C'LR',0(R6) LRECL SIZE 07620000 BNE SETBLK 07630000 BXH R7,R8,SETNFM ANY MORE OPERANDS 07640000 L R6,0(R7) GET NEXT TOKEN 07650000 CLI 0(R6),C'?' HELP ? 07660000 BNE GETREC 07670000 WRTERM 'LOGICAL RECORD LENGTH (DEFAULT OF 80).' 07680000 B SETOK 07690000 GETREC CLI 0(R6),C' ' NO VALUE GIVEN 07700000 BNE CALC 07710000 WRTERM '?NOT CONFIRMED' 07720000 B SETERR 07730000 CALC CLI 0(R6),X'F0' MUST BE >= TO 0 07740000 BL BADREC 07750000 CLI 0(R6),X'F9' MUST BE <= TO 9 07760000 BH BADREC 07770000 XC PKVAR,PKVAR EMPTY IT OUT 07780000 SR R4,R4 LENGTH OF NUMBER 07790000 CLI 1(R6),C' ' TWO DIGITS? 07800000 BNE CALC2 07810000 EX R4,PCK 07820000 B TST 07830000 CALC2 LA R4,1(R4) ADD ONE 07840000 CLI 2(R6),C' ' THREE DIGITS? 07850000 BNE CALC3 07860000 EX R4,PCK 07870000 B TST 07880000 CALC3 LA R4,1(R4) IS THERE AN ERROR? 07890000 CLI 3(R6),C' ' 07900000 BNE BADREC 07910000 EX R4,PCK 07920000 TST CVB R7,PKVAR 07930000 C R7,=F'255' MAX OF 255 FOR LRECL 07940000 BH BADREC 07950000 STC R7,LRECL SET THE LRECL VALUE 07960000 B SETOK 07970000 BADREC WRTERM 'A NUMBER WITH A MAXIMUM OF 255.' 07980000 B SETERR 07990000 ********************************************************************** 08000000 * SET BLKSIZE * 08010000 ********************************************************************** 08020000 SETBLK CLC =C'BL',0(R6) BLOCK SIZE 08030000 BNE SETSPACE 08040000 BXH R7,R8,SETNFM ANY MORE OPERANDS 08050000 L R6,0(R7) GET NEXT TOKEN 08060000 CLI 0(R6),C'?' HELP ? 08070000 BNE GETBLK 08080000 WRTERM 'BLOCKSIZE (DEFAULT OF 80).' 08090000 B SETOK 08100000 GETBLK CLI 0(R6),C' ' NO VALUE GIVEN 08110000 BNE BLKCALC 08120000 WRTERM '?NOT CONFIRMED' 08130000 B SETERR 08140000 BLKCALC XC PKVAR,PKVAR EMPTY IT OUT 08150000 SR R4,R4 LENGTH OF NUMBER 08160000 LA R7,5 MAX LENGTH OF NUMBER 08170000 LR R5,R6 SAVE START OF STRING 08180000 BLKCALC1 CLI 0(R6),X'F0' MUST BE >= TO 0 08190000 BL BADBLK 08200000 CLI 0(R6),X'F9' MUST BE <= TO 9 08210000 BH BADBLK 08220000 CLI 1(R6),C' ' FOUND LAST DIGIT? 08230000 BE BLKCALC2 08240000 LA R4,1(R4) COUNT NUMBER OF DIGITS 08250000 LA R6,1(R6) POINT TO NEXT DIGIT 08260000 BCT R7,BLKCALC1 KEEP CHECKING 08270000 B BADBLK 08280000 BLKCALC2 EX R4,BLKPCK 08290000 B BLKTST 08300000 BLKTST CVB R7,PKVAR 08310000 C R7,=F'32767' MAX OF 32767 FOR BLKSIZE 08320000 BH BADBLK 08330000 STH R7,BLKSIZE SET THE BLKSIZE 08340000 B SETOK 08350000 BADBLK WRTERM 'A NUMBER WITH A MAXIMUM OF 32767' 08360000 B SETERR 08370000 ********************************************************************** 08380000 * SET TRACK ALLOCATION * 08390000 ********************************************************************** 08400000 SETSPACE CLC =C'SP',0(R6) BLOCK SIZE 08410000 BNE SETEOL 08420000 BXH R7,R8,SETNFM ANY MORE OPERANDS 08430000 L R6,0(R7) GET NEXT TOKEN 08440000 CLI 0(R6),C'?' HELP ? 08450000 BNE GETSPC 08460000 WRTERM 'DATASET SPACE ALLOCATION (DEFAULT OF 5 TRACKS).' 08470000 B SETOK 08480000 GETSPC CLI 0(R6),C' ' NO VALUE GIVEN 08490000 BNE SPCCALC 08500000 WRTERM '?NOT CONFIRMED' 08510000 B SETERR 08520000 SPCCALC XC PKVAR,PKVAR EMPTY IT OUT 08530000 SR R4,R4 LENGTH OF NUMBER 08540000 LA R7,5 MAX LENGTH OF NUMBER 08550000 LR R5,R6 SAVE START OF STRING 08560000 SPCCALC1 CLI 0(R6),X'F0' MUST BE >= TO 0 08570000 BL BADSPC 08580000 CLI 0(R6),X'F9' MUST BE <= TO 9 08590000 BH BADSPC 08600000 CLI 1(R6),C' ' FOUND LAST DIGIT? 08610000 BE SPCCALC2 08620000 LA R4,1(R4) COUNT NUMBER OF DIGITS 08630000 LA R6,1(R6) POINT TO NEXT DIGIT 08640000 BCT R7,SPCCALC1 KEEP CHECKING 08650000 B BADSPC 08660000 SPCCALC2 EX R4,SPCPCK 08670000 B SPCTST 08680000 SPCTST CVB R7,PKVAR 08690000 C R7,=F'99999' MAX OF 99999 FOR SPACE 08700000 BH BADSPC 08710000 ST R7,TRACK SET THE ALLOCATION 08720000 B SETOK 08730000 BADSPC WRTERM 'A NUMBER WITH A MAXIMUM OF 99999' 08740000 B SETERR 08750000 ********************************************************************** 08760000 * SET END-OF-LINE CHARACTER * 08770000 ********************************************************************** 08780000 SETEOL CLC =C'EN',0(R6) EOL CHARACTER 08790000 BNE NOEND 08800000 BXH R7,R8,SETNFM ANY MORE OPERANDS 08810000 L R6,0(R7) GET NEXT TOKEN 08820000 CLI 0(R6),C' ' NOT DATA 08830000 BNE EOLCHAR 08840000 WRTERM '?NOT CONFIRMED' 08850000 B SETERR 08860000 EOLCHAR CLI 0(R6),C'?' NEED HELP? 08870000 BNE GETEOL 08880000 WRTERM 'A TWO DIGIT NUMBER BETWEEN 00 AND 31 (DEC).' 08890000 B SETOK 08900000 GETEOL CLI 0(R6),X'F0' MUST BE >= TO 0 08910000 BL BADEOL 08920000 CLI 0(R6),X'F9' MUST BE <= TO 9 08930000 BH BADEOL 08940000 XC PKVAR,PKVAR USE TO CONVERT VALUE 08950000 CLI 1(R6),C' ' INPUT MUST BE TWO CHARS 08960000 BE BADEOL 08970000 CLI 2(R6),C' ' TWO CHARS, AT MAX 08980000 BNE BADEOL 08990000 PACK PKVAR(8),0(2,R6) PICK UP TWO CHARACTERS 09000000 CVB R7,PKVAR PUT PACKED DECIMAL INTO REG 09010000 C R7,=F'31' MAX OF 31 DECIMAL 09020000 BH BADEOL 09030000 STC R7,SEOL SET SEND EOL VALUE 09040000 B SETOK 09050000 BADEOL WRTERM 'MUST BE A TWO DIGIT VALUE LESS THAN 31 (DEC).' 09060000 B SETERR 09070000 ********************************************************************** 09080000 * SET PACKET-SIZE * 09090000 ********************************************************************** 09100000 NOEND CLC =C'PA',0(R6) CHANGE RECEIVE PACKET SIZE 09110000 BNE NOPAC 09120000 BXH R7,R8,SETNFM ANY MORE OPERANDS 09130000 L R6,0(R7) GET NEXT TOKEN 09140000 CLI 0(R6),C' ' NO DATA 09150000 BNE GETPAC 09160000 WRTERM '?NOT CONFIRMED' 09170000 B SETERR 09180000 GETPAC CLI 0(R6),C'?' NEED HELP? 09190000 BNE CALC4 09200000 WRTERM 'RECEIVE PACKET SIZE (RANGE: 26-94 DECIMAL).' 09210000 B SETOK 09220000 CALC4 CLI 0(R6),X'F0' MUST BE >= TO 0 09230000 BL BADPAC 09240000 CLI 0(R6),X'F9' MUST BE <= TO 9 09250000 BH BADPAC 09260000 XC PKVAR,PKVAR USE TO CONVERT VALUE 09270000 CLI 1(R6),C' ' INPUT MUST BE TWO CHARS 09280000 BE BADPAC 09290000 CLI 2(R6),C' ' TWO CHARS, AT MAX 09300000 BNE BADPAC 09310000 PACK PKVAR(8),0(2,R6) PICK UP TWO CHARS 09320000 CVB R7,PKVAR PUT PACKED DECIMAL INTO REG 09330000 C R7,=F'26' THIS IS MIN 09340000 BL BADPAC 09350000 C R7,MAXPACK THIS IS THE MAX 09360000 BH BADPAC 09370000 ST R7,RPSIZ USE THIS VALUE NOW 09380000 B SETOK 09390000 BADPAC WRTERM 'MUST BE BETWEEN 26-94 (DECIMAL).' 09400000 B SETERR 09410000 ********************************************************************** 09420000 * SET DEBUG ON\OFF * 09430000 ********************************************************************** 09440000 NOPAC CLC =C'DEB',0(R6) IS THIS DEBUG? 09450000 BNE SETSOH NO, THEN SEE IF SET SOH 09460000 BXH R7,R8,SETNFM ANY MORE OPERANDS 09470000 L R6,0(R7) GET NEXT TOKEN 09480000 CLI 0(R6),C' ' IS THERE AN OPERAND? 09490000 BE DEBERR NO, THEN ASK FOR ONE. 09500000 CLC =C'ON',0(R6) IS IT TIME TO TURN ON 09510000 BE DEBON YES, OPEN FILE 09520000 CLC =C'OF',0(R6) IS IT TIME TO TURN OFF 09530000 BE DEBOFF YES, CLOSE FILE 09540000 B DEBERR YES, GIVE MESSAGE 09550000 DEBERR WRTERM 'COMMAND IS SET DEBUG ON \ OFF' 09560000 B SETERR 09570000 DEBON OPEN (DEBUG,(OUTPUT)) 09580000 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 09590000 BO SETOK 09600000 WRTERM 'UNABLE TO OPEN DEBUG FILE, DEBUG DISABLED.' 09610000 B SETERR 09620000 DEBOFF CLOSE DEBUG 09630000 B SETOK 09640000 ********************************************************************** 09650000 * SET START-OF-HEADER CHARACTER * 09660000 ********************************************************************** 09670000 SETSOH B NOSOH SOH CHARACTER J 09680000 CLC =C'ST',0(R6) SOH CHARACTER 09690000 BNE NOSOH NO, THEN TRY DELAY 09700000 BXH R7,R8,SETNFM ANY MORE OPERANDS 09710000 L R6,0(R7) GET NEXT TOKEN 09720000 CLI 0(R6),C' ' NOT DATA 09730000 BNE SOHCHAR 09740000 WRTERM '?NOT CONFIRMED' 09750000 B SETERR 09760000 SOHCHAR CLI 0(R6),C'?' NEED HELP? 09770000 BNE GETSOH 09780000 WRTERM 'A TWO DIGIT NUMBER BETWEEN 00 AND 31 (DEC).' 09790000 B SETOK 09800000 GETSOH CLI 0(R6),X'F0' MUST BE >= TO 0 09810000 BL BADSOH 09820000 CLI 0(R6),X'F9' MUST BE <= TO 9 09830000 BH BADSOH 09840000 XC PKVAR,PKVAR USE TO CONVERT VALUE 09850000 CLI 1(R6),C' ' INPUT MUST BE TWO CHARS 09860000 BE BADSOH 09870000 CLI 2(R6),C' ' TWO CHARS, AT MAX 09880000 BNE BADSOH 09890000 PACK PKVAR(8),0(2,R6) PICK UP TWO CHARACTERS 09900000 CVB R7,PKVAR PUT PACKED DECIMAL INTO REG 09910000 C R7,=F'31' MAX OF 31 DECIMAL 09920000 BH BADSOH ERROR, TOO BIG 09930000 STC R7,SSOH SET SEND SOH VALUE 09940000 STC R7,RSOH SET RECEIVE SOH VALUE 09950000 B SETOK 09960000 BADSOH WRTERM 'MUST BE A TWO DIGIT VALUE LESS THAN 31 (DEC).' 09970000 B SETERR 09980000 ********************************************************************** 09990000 * SET DELAY VALUE * 10000000 ********************************************************************** 10010000 NOSOH CLC =C'DEL',0(R6) CHANGE RECEIVE PACKET SIZE 10020000 BNE SETFILE J 10030000 BXH R7,R8,SETNFM ANY MORE OPERANDS 10040000 L R6,0(R7) GET NEXT TOKEN 10050000 CLI 0(R6),C' ' NO DATA 10060000 BNE GETDELAY 10070000 WRTERM '?NOT CONFIRMED' 10080000 B SETERR 10090000 GETDELAY CLI 0(R6),C'?' NEED HELP? 10100000 BNE DLYCALC 10110000 WRTERM 'RECEIVE PACKET SIZE (RANGE: 26-94 DECIMAL).' 10120000 B SETOK 10130000 DLYCALC XC PKVAR,PKVAR EMPTY IT OUT 10140000 SR R4,R4 LENGTH OF NUMBER 10150000 LA R7,5 MAX LENGTH OF NUMBER 10160000 LR R5,R6 SAVE START OF STRING 10170000 DLYCALC1 CLI 0(R6),X'F0' MUST BE >= TO 0 10180000 BL BADDELAY 10190000 CLI 0(R6),X'F9' MUST BE <= TO 9 10200000 BH BADDELAY 10210000 CLI 1(R6),C' ' FOUND LAST DIGIT? 10220000 BE DLYCALC2 10230000 LA R4,1(R4) COUNT NUMBER OF DIGITS 10240000 LA R6,1(R6) POINT TO NEXT DIGIT 10250000 BCT R7,DLYCALC1 KEEP CHECKING 10260000 B BADDELAY 10270000 DLYCALC2 EX R4,DLYPCK 10280000 B DLYTST 10290000 DLYTST CVB R7,PKVAR 10300000 LTR R7,R7 THIS IS MIN 10310000 BNP BADDELAY 10320000 C R7,=F'99999' THIS IS THE MAX 10330000 BH BADDELAY 10340000 MH R7,=H'100' MAKE IT 100THS OF SECONDS 10350000 ST R7,DELAY USE THIS VALUE NOW 10360000 B SETOK 10370000 BADDELAY WRTERM 'MUST BE BETWEEN 1-99999 (DECIMAL).' 10380000 B SETERR 10390000 ********************************************************************** 10400000 * SET FILE TYPE * 10410000 ********************************************************************** 10420000 SETFILE CLC =C'FI',0(R6) J (BEGIN) 10430000 BNE SETTRT 10440000 BXH R7,R8,SETNFM 10450000 L R6,0(R7) 10460000 CLI 0(R6),C'?' 10470000 BNE FICONT 10480000 WRTERM 'BINARY OR TEXT (DEFAULT IS TEXT)' 10490000 B SETOK 10500000 FICONT CLI 0(R6),C' ' 10510000 BE FIERR 10520000 CLC =C'BI',0(R6) 10530000 BNE FITEX 10540000 OI FLAGS,BINF 10550000 B SETOK 10560000 FITEX NI FLAGS,X'FF'-BINF 10570000 B SETOK 10580000 FIERR WRTERM 'COMMAND IZ SET FILE BINARY / TEXT' 10590000 B SETERR J (END) 10600000 ********************************************************************** 10610000 * SET TRT TABLE NAME * 10620000 ********************************************************************** 10630000 SETTRT CLC =C'TRT',0(R6) J (BEGIN) 10640000 BNE SETERR 10650000 BXH R7,R8,SETNFM 10660000 L R6,0(R7) 10670000 CLI 0(R6),C'?' 10680000 BNE TRTCONT 10690000 WRTERM 'ONE SYMBOL AS A LAST CHAR OF NAME CTRT? OR S FOR STANDA*10700000 RT TABLE' 10710000 B SETOK 10720000 TRTCONT CLI 0(R6),C' ' 10730000 BE SETERR 10740000 CLI 0(R6),C'S' 10750000 BNE TRTCLC 10760000 TRTSST MVC TRTNAME,=CL8'STANDARD' 10770000 LA R15,ATOE8 10780000 ST R15,TRTADDR 10790000 B SETOK 10800000 TRTCLC CLC TRTNAME,=CL8'STANDARD' 10810000 BE TRTMVC 10820000 DELETE EPLOC=TRTNAME 10830000 TRTMVC MVC TRTNAME,=CL8'CTRT' 10840000 MVC TRTNAME+4(1),0(R6) 10850000 BLDL 0,TRTBLDL 10860000 LTR R15,R15 10870000 BZ TRTLOAD 10880000 MVC WRKBUFF(41),=CL41'TABLE XXXXXXXX NOT FOUND, STANDARD IS *10890000 SET' 10900000 MVC WRKBUFF+6(8),TRTNAME 10910000 TPUT WRKBUFF,41 10920000 B TRTSST 10930000 TRTLOAD LOAD EPLOC=TRTNAME 10940000 ST R0,TRTADDR 10950000 B SETOK END J 10960000 ********************************************************************** 10970000 SETERR LA R15,4 SET A NON-ZERO RETCODE 10980000 B SETRET 10990000 SETOK SR R15,R15 RETCODE OF 0 11000000 * 11010000 SETRET L R13,4(R13) 11020000 L R14,12(R13) 11030000 LM R0,R12,20(R13) 11040000 BR R14 11050000 SETSAVE DS 18F 11060000 PCK PACK PKVAR(8),0(0,R6) 11070000 BLKPCK PACK PKVAR(8),0(0,R5) 11080000 SPCPCK PACK PKVAR(8),0(0,R5) 11090000 DLYPCK PACK PKVAR(8),0(0,R5) 11100000 LTORG 11110000 DROP R11 11120000 DROP R12 11130000 EJECT 11140000 ********************************************************************** 11150000 * * 11160000 * ROUTINE TO PROCESS SHOW COMMAND * 11170000 * * 11180000 ********************************************************************** 11190000 SHOW DS 0H 11200000 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 11210000 BALR R12,0 ESTABLISH ADDRESSABILITY 11220000 USING *,R12 11230000 LA R14,SHOWSAVE ADDRESS OF MY SAVE AREA 11240000 ST R13,4(R14) SAVE CALLER'S 11250000 ST R14,8(R13) 11260000 LR R13,R14 11270000 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 11280000 L R11,=A(PARMS) 11290000 USING PARMS,R11 ESTABLISH ADDRESSABILITY 11300000 BXH R7,R8,SHONFM ANY MORE OPERANDS 11310000 L R6,0(R7) GET NEXT TOKEN 11320000 CLI 0(R6),C'?' NEED HELP ? 11330000 BNE SHOREC 11340000 WRTERM 'STATE' 11350000 B SHOWOK 11360000 SHONFM WRTERM '?NOT CONFIRMED' 11370000 B SHOWERR 11380000 SHOREC CLI 0(R6),C'S' IS THIS SHOW STATE 11390000 BNE SHOWERR 11400000 TM FLAGS,BINF 11410000 BZ TEXTF 11420000 WRTERM 'FILE IS BINARY' J (BEGIN) 11430000 B S#1 11440000 TEXTF WRTERM 'FILE IS TEXT' 11450000 S#1 DS 0H J (END) 11460000 MVC WRKBUFF(18),=C'RECORD FORMAT IS .' 11470000 MVC WRKBUFF+17(1),RFM 11480000 TPUT WRKBUFF,18 11490000 TR QUOCHAR(1),ATOE GET EBCDIC VERSION 11500000 MVC WRKBUFF(20),=C'QUOTE CHARACTER IS .' 11510000 MVC WRKBUFF+19(1),QUOCHAR 11520000 TPUT WRKBUFF,20 11530000 MVC WRKBUFF(26),=C'8-BIT QUOTE CHARACTER IS X' J 11540000 MVC WRKBUFF+25(1),EBQUOT J 11550000 TR WRKBUFF+25(1),ATOE TRANSLATE TO EBCDIC J 11560000 TPUT WRKBUFF,26 J 11570000 TR QUOCHAR(1),ETOA KEEP THE ASCII FORM AROUND 11580000 SR R4,R4 ZERO IT OUT 11590000 IC R4,LRECL 11600000 MVC WRKBUFF(8),=C'LRECL IS' 11610000 BINCVRT R4,WRKBUFF+8,DBLWRK 11620000 TPUT WRKBUFF,14 11630000 LH R4,BLKSIZE 11640000 MVC WRKBUFF(10),=C'BLKSIZE IS' 11650000 BINCVRT R4,WRKBUFF+10,DBLWRK 11660000 TPUT WRKBUFF,16 11670000 L R4,TRACK 11680000 MVC WRKBUFF(32),=C'SPACE ALLOCATION IS ..... TRACKS' 11690000 BINCVRT R4,WRKBUFF+19,DBLWRK 11700000 TPUT WRKBUFF,32 11710000 SR R4,R4 ZERO IT OUT 11720000 IC R4,SSOH 11730000 MVC WRKBUFF(44),=C'START-OF-HEADER CHARACTER IS ..... (DECIMAL)' 11740000 BINCVRT R4,WRKBUFF+28,DBLWRK 11750000 ****** TPUT WRKBUFF,44 J 11760000 SR R4,R4 ZERO IT OUT 11770000 IC R4,SEOL 11780000 MVC WRKBUFF(40),=C'END-OF-LINE CHARACTER IS ..... (DECIMAL)' 11790000 BINCVRT R4,WRKBUFF+24,DBLWRK 11800000 ***** TPUT WRKBUFF,40 J 11810000 MVC WRKBUFF(38),=C'RECEIVE PACKET SIZE IS ..... (DECIMAL)' 11820000 L R1,RPSIZ 11830000 BINCVRT R1,WRKBUFF+22,DBLWRK 11840000 TPUT WRKBUFF,38 11850000 MVC WRKBUFF(28),=C'DELAY VALUE IS ..... SECONDS' 11860000 L R1,DELAY 11870000 SR R0,R0 11880000 D R0,=F'100' 11890000 BINCVRT R1,WRKBUFF+14,DBLWRK 11900000 TPUT WRKBUFF,28 11910000 MVC WRKBUFF(9),=C'DEBUG IS ' 11920000 MVC WRKBUFF+9(3),=C'OFF' 11930000 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 11940000 BZ SHOWDBG 11950000 MVC WRKBUFF+9(3),=C'ON ' 11960000 SHOWDBG TPUT WRKBUFF,12 11970000 MVC WRKBUFF(27),=CL27'TRANSLATE TABLE IS XXXXXXXX' 11980000 MVC WRKBUFF+19(8),TRTNAME 11990000 TPUT WRKBUFF,27 12000000 B SHOWOK 12010000 SHOWERR LA R15,4 SET A NON-ZERO RETCODE 12020000 B SHOWRET 12030000 SHOWOK SR R15,R15 ZERO RETCODE 12040000 * 12050000 SHOWRET L R13,4(R13) 12060000 L R14,12(R13) 12070000 LM R0,R12,20(R13) 12080000 BR R14 12090000 SHOWSAVE DS 18F 12100000 LTORG 12110000 DROP R11 12120000 DROP R12 12130000 * 12140000 EJECT 12150000 ********************************************************************** 12160000 * * 12170000 * ROUTINE TO INITIALIZE PARAMETER AREA * 12180000 * * 12190000 ********************************************************************** 12200000 INIT DS 0H 12210000 STM R14,R12,12(R13) 12220000 BALR R12,0 12230000 USING *,R12 12240000 LA R14,ISAVE 12250000 ST R13,4(R14) 12260000 ST R14,8(R13) 12270000 LR R13,R14 12280000 * 12290000 * INITIALIZE VARIABLES THAT GET CHANGED DURING EXECUTION 12300000 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA LIST 12310000 L R11,=A(PARMS) 12320000 USING PARMS,R11 12330000 XC SNDPKT,SNDPKT CLEAR OUT THESE BUFFERS 12340000 XC RECPKT,RECPKT 12350000 XC INPUT,INPUT 12360000 LA R0,BUF 12370000 LA R1,L'BUF ; CLEAR OUT THE BUFFER. 12380000 SR R15,R15 12390000 MVCL R0,R14 12400000 LA R0,RBUF 12410000 LA R1,L'RBUF 12420000 SR R15,R15 12430000 MVCL R0,R14 12440000 XC SDAT,SDAT 12450000 XC RDAT,RDAT 12460000 XC N,N SET VARIABLES TO ZERO 12470000 XC NUM,NUM 12480000 XC LSDAT,LSDAT 12490000 XC LRDAT,LRDAT 12500000 MVI FLAGS,X'00' CLEAR ALL FLAGS 12510000 XC SAVPL,SAVPL 12520000 XC RSAVPL,RSAVPL 12530000 XC NUMTRY,NUMTRY 12540000 MVC FILNAM,=18X'20' BLANK OUT FILNAM & NAME 12550000 MVC NAME,=18X'20' 12560000 MVI PREV,X'00' 12570000 MVI ERRNUM,X'FF' SET TO NO ERROR FOR NOW 12580000 MVI OLDERR,X'FF' SAME HERE 12590000 XC PKVAR,PKVAR ZERO IT OUT 12600000 XC OLDTRY,OLDTRY 12610000 XC SPSIZ,SPSIZ 12620000 XC SIZE,SIZE 12630000 XC TEMP,TEMP 12640000 XC STORLOC,STORLOC 12650000 MVC DELAY,DDELAY SET DEFAULT DELAY 12660000 MVC LRECL(1),DLRECL SET DEFAULTS, JUST IN CASE 12670000 MVC BLKSIZE(2),DBLKSIZE SET DEFAULTS, JUST IN CASE 12680000 MVC TRACK,DTRACK DEFAULT SPACE OF 5 TRACKS 12690000 MVC RFM(1),DRECFM 12700000 MVC QUOCHAR(1),DQUOTE 12710000 MVC RQUO(1),DQUOTE 12720000 MVC REOL(1),DEOL 12730000 MVC SEOL(1),DEOL 12740000 MVC SSOH(1),DSOH 12750000 MVC RSOH(1),DSOH 12760000 MVI EBQUOT,D8QUO 8-BIT QUOT J 12770000 MVI ORIG8Q,D8QUO 8-BIT QUOT J 12780000 MVI STATE,C' ' 12790000 MVI STYPE,C' ' 12800000 MVI RTYPE,C' ' 12810000 * 12820000 INITRET L R13,4(R13) 12830000 L R14,12(R13) 12840000 LM R0,R12,20(R13) 12850000 BR R14 12860000 ISAVE DS 18F 12870000 LTORG 12880000 DROP R11 12890000 DROP R12 12900000 EJECT 12910000 ********************************************************************** 12920000 * * 12930000 * ROUTINE TO PROCESS SEND COMMAND * 12940000 * * 12950000 ********************************************************************** 12960000 SEND DS 0H 12970000 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 12980000 BALR R12,0 ESTABLISH ADDRESSABILITY 12990000 USING *,R12 13000000 LA R14,SENDSAVE ADDRESS OF MY SAVE AREA 13010000 ST R13,4(R14) SAVE CALLER'S 13020000 ST R14,8(R13) 13030000 LR R13,R14 13040000 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 13050000 L R11,=A(PARMS) 13060000 USING PARMS,R11 ESTABLISH ADDRESSABILITY 13070000 MVC EBQUOT(1),ORIG8Q IF CHANGED IN LAST X-FER J 13080000 MVI STATE,C'S' 13090000 SR R3,R3 13100000 ST R3,N 13110000 ST R3,NUMTRY 13120000 OKSND TM FLAGS,FLG1 IS THIS THE FIRST FILE? 13130000 BNO SLOOP 13140000 NI FLAGS,X'FF'-FLG1 TURN OFF FIRST FILE FLAG 13150000 ********************************************************************** 13160000 * MAIN SEND LOOP * 13170000 ********************************************************************** 13180000 SLOOP CLI STATE,C'D' SEND DATA STATE 13190000 BE SDATA 13200000 CLI STATE,C'F' SEND FILE STATE 13210000 BE SFILE 13220000 CLI STATE,C'S' SEND INIT STATE 13230000 BE SINIT 13240000 CLI STATE,C'Z' END OF FILE STATE 13250000 BE SEOF 13260000 CLI STATE,C'B' SEND BREAK STATE 13270000 BE SBREAK 13280000 CLI STATE,C'C' COMPLETE STATE 13290000 BE COMPLETE 13300000 CLI STATE,C'A' ABORT STATE 13310000 BE ABORT ERROR - GO TO ABORT STATE 13320000 MVI ERRNUM,X'02' UNRECOGNIZED STATE 13330000 B ABORT OTHERWISE, DIE 13340000 ********************************************************************** 13350000 * CREATE AND SEND INITIALIZATION PACKET * 13360000 ********************************************************************** 13370000 SINIT CLC NUMTRY,IMXTRY SEE IF CAN SEND 13380000 BL OK1 YES WE CAN 13390000 MVI STATE,C'A' NOPE, GO INTO ABORT STATE 13400000 B SLOOP 13410000 OK1 L R5,SPACE MAKE CHARACTER PRINTABLE 13420000 A R5,RPSIZ ADD REC PACKET SIZE 13430000 STC R5,SDAT ADD SIZE INFO TO BUFFER 13440000 L R5,SPACE 13450000 A R5,=F'10' 10 FOR TIMEOUT 13460000 STC R5,SDAT+1 13470000 * L R5,SPACE SEND ZERO + " " FOR NPAD Z 13480000 MVI SDAT+2,X'21' SEND ONE (!) FOR NPAD Z 13490000 * SR R5,R5 PAD WITH NULLS Z 13500000 * L R3,O1H Z 13510000 * XR R5,R3 CTL FUNCTION (XOR WITH 64)Z 13520000 MVI SDAT+3,X'42' SEND CTL B FOR PADCHAR Z 13530000 SR R5,R5 ZERO IT OUT FOR NEXT TWO GUYS 13540000 IC R5,REOL EOL CHAR I NEED 13550000 A R5,SPACE MAKE PRINTABLE 13560000 STC R5,SDAT+4 13570000 IC R5,QUOCHAR MY QUOTE CHAR 13580000 STC R5,SDAT+5 13590000 IC R5,EBQUOT 8-BIT QUOTE CHAR J 13600000 STC R5,SDAT+6 J 13610000 L R3,NUMTRY 13620000 LA R3,1(R3) INCREMENT TRIAL COUNTER 13630000 ST R3,NUMTRY 13640000 MVI STYPE,AS PACKET TYPE = SEND INITIATE 13650000 MVC LSDAT(4),=F'7' BUFFER SIZE FOR THIS SEND J 13660000 L R4,DSSIZ GET DEFAULT SPSIZ 13670000 S R4,FIVE FOR NOW, USE DEFAULT SPSIZ.... 13680000 ST R4,SIZE ....TO SET VALUE OF SIZE 13690000 L R15,=A(SPACK) GET ADDRESS OF ROUTINE 'SPACK' 13700000 BALR 14,15 SAVE * AND GO TO SPACK 13710000 CLI STATE,C'A' 13720000 BE ABORT 13730000 L 15,=A(RPACK) GET ADDRESS OF 'RPACK' 13740000 BALR 14,15 SAVE * AND GO TO RPACK 13750000 CLI RTYPE,AE ERROR PACKET? 13760000 BNE Y1 NO, THEN MAYBE AN ACK 13770000 MVI ERRNUM,X'0A' MICRO DIED 13780000 MVI STATE,C'A' AND DIE 13790000 B SLOOP 13800000 Y1 CLI RTYPE,AY SEE IF GOT ACK 13810000 BNE N1 MAYBE IT'S 'N' 13820000 CLC N,NUM CHECK MESSAGE NUMBERS 13830000 BE AOK1 13840000 MVI ERRNUM,X'08' PACKET LOST 13850000 B SLOOP 13860000 AOK1 SR R4,R4 ZERO OUT REGISTER 13870000 IC R4,RDAT USE SPSIZ THE MICRO WANTS 13880000 S R4,SPACE SUBTRACT THE ' ' 13890000 C R4,=F'26' BUFFER HAS TO BE >= 26 13900000 BNL CH1 SO FAR, SO GOOD 13910000 MVI STATE,C'A' ABORT THEN 13920000 MVI ERRNUM,X'00' INVALID DATA-PACKET-SIZE ERROR 13930000 B SLOOP 13940000 CH1 C R4,MAXPACK MAX PACKET SIZE 13950000 BNH CH2 CONTINUE IF <= TO MAX 13960000 MVI STATE,C'A' DIE 13970000 MVI ERRNUM,X'00' INVALID DATA-PACKET-SIZE ERROR 13980000 B SLOOP 13990000 CH2 STC R4,SPSIZ+3 USE SPSIZ THE MICRO WANTS 14000000 S R4,FIVE 14010000 ST R4,SIZE SET SIZE TO SPSIZ-5 14020000 CLC LRDAT(4),=F'4' USING DEFAULTS? 14030000 BNH NOCHG YUP 14040000 LA R5,RDAT POINTER TO THE BUFFER 14050000 SR R7,R7 14060000 IC R7,4(R5) SEOL MICRO WANTS 14070000 S R7,SPACE UNCHAR (IE - SUBTRACT SPACE) 14080000 STC R7,SEOL 14090000 NOCHG MVI STATE,C'F' PUT INTO SEND FILE STATE 14100000 XC NUMTRY,NUMTRY RESET TO ZERO 14110000 L R3,N 14120000 LA R3,1(R3) ADD ONE 14130000 ST R3,N STORE VALUE INCREMENTED BY 1 14140000 NC N(4),=X'0000003F' MASK TO GET MOD 64 14150000 B SLOOP 14160000 N1 CLI RTYPE,AN SEE IF IT'S 'N' 14170000 BNE AB1 IF NOT, DIE 14180000 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 14190000 BO SLOOP LEAVE ERR MSG AS IS IF I DID 14200000 MVI ERRNUM,X'09' MICRO NAK'ED 14210000 B SLOOP 14220000 AB1 MVI STATE,C'A' ELSE, ABORT 14230000 MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 14240000 B SLOOP 14250000 ********************************************************************** 14260000 * CREATE AND SEND FILE PACKET * 14270000 ********************************************************************** 14280000 SFILE CLC NUMTRY,MAXTRY EXCEEDED NO. OF TRIES ALLOWED? 14290000 BL OK2 NOPE, STILL OK 14300000 MVI STATE,C'A' ABORT IF YES 14310000 B SLOOP 14320000 OK2 DS 0H 14330000 TR FILNAM,ETOA 14340000 LH R5,FILNAML GET LENGTH OF FILENAME - 1 14350000 MVC SDAT(*-*),FILNAM USE FOR EXECUTE 14360000 EX R5,*-6 GO MOVE FILENAME TO BUFFER 14370000 LA R5,1(,R5) UP THE FILE LENGTH TO BE EXACT 14380000 L R3,NUMTRY 14390000 LA R3,1(R3) INCREMENT TRIAL COUNTER 14400000 ST R3,NUMTRY 14410000 MVI STYPE,AF PACKET TYPE = FILE HEADER 14420000 ST R5,LSDAT SET BUFFER SIZE 14430000 TR FILNAM,ATOE 14440000 SNDFIL L R15,=A(SPACK) GET ADDRESS OF 'SPACK' 14450000 BALR 14,15 SAVE * AND GO TO SPACK 14460000 CLI STATE,C'A' 14470000 BE ABORT 14480000 L 15,=A(RPACK) GET ADDRESS OF 'RPACK' 14490000 BALR 14,15 SAVE * AND GO TO RPACK 14500000 CLI RTYPE,AE ERROR PACKET? 14510000 BNE Y2 MAYBE AN ACK 14520000 MVI ERRNUM,X'0A' MICRO DIED 14530000 MVI STATE,C'A' SO WE DO TOO 14540000 B SLOOP 14550000 Y2 CLI RTYPE,AY SEE IF GOT ACK 14560000 BNE N2 MAYBE GOT AN 'N' 14570000 CLC N,NUM DO WE HAVE THE CORRECT ACK? 14580000 BE AOK2 14590000 MVI ERRNUM,X'08' MISSING A PACKET SOMEWHERE 14600000 B SLOOP 14610000 AOK2 MVI STATE,C'D' PREPARE FOR SEND-DATA STATE 14620000 XC NUMTRY,NUMTRY RESET COUNTER 14630000 L R3,N 14640000 LA R3,1(R3) ADD ONE 14650000 ST R3,N STORE INCREMENTED VALUE 14660000 NC N(4),=X'0000003F' MASK TO GET MOD 64 14670000 L 15,=A(GTCHR) 14680000 BALR 14,15 DO GET-CHAR AND COME BACK 14690000 B SLOOP 14700000 N2 CLI RTYPE,AN 14710000 BNE AB2 ELSE, DIE 14720000 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 14730000 BO SLOOP LEAVE ERR MSG AS IS IF I DID 14740000 MVI ERRNUM,X'09' MICRO NAK'ED 14750000 B SLOOP 14760000 AB2 MVI STATE,C'A' ELSE, ABORT 14770000 MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 14780000 B SLOOP 14790000 ********************************************************************** 14800000 * CREATE AND SEND DATA PACKETS * 14810000 ********************************************************************** 14820000 SDATA CLC NUMTRY,MAXTRY CAN WE DO IT? 14830000 BL OK4 YES 14840000 MVI STATE,C'A' ELSE ABORT 14850000 B SLOOP 14860000 OK4 L R3,NUMTRY 14870000 LA R3,1(R3) INCREMENT COUNTER 14880000 ST R3,NUMTRY 14890000 MVI STYPE,AD PACKET TYPE = DATA 14900000 L R15,=A(SPACK) 14910000 BALR 14,15 GO TO SPACK AND RETURN 14920000 CLI STATE,C'A' 14930000 BE ABORT 14940000 L 15,=A(RPACK) 14950000 BALR 14,15 SAME FOR RPACK 14960000 CLI RTYPE,AE ERROR PACKET? 14970000 BNE Y4 MAYBE AN ACK 14980000 MVI ERRNUM,X'0A' MICRO DIED 14990000 MVI STATE,C'A' SO WE DO TOO 15000000 B SLOOP 15010000 Y4 CLI RTYPE,AY SEE IF GOT 'ACK' 15020000 BNE N4 SEE IF IT'S AN 'N' 15030000 CLC N,NUM DO WE HAVE THE CORRECT ACK? 15040000 BE AOK4 15050000 MVI ERRNUM,X'08' MISSING A PACKET 15060000 B SLOOP 15070000 AOK4 XC NUMTRY,NUMTRY RESET COUNTER 15080000 L R3,N 15090000 LA R3,1(R3) INCREMENT COUNTER 15100000 ST R3,N 15110000 NC N(4),=X'0000003F' MASK TO GET MOD 64 15120000 L 15,=A(GTCHR) 15130000 BALR 14,15 DO GET-CHAR AND RETURN 15140000 B SLOOP 15150000 N4 CLI RTYPE,AN 15160000 BNE AB4 15170000 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 15180000 BO SLOOP LEAVE ERR MSG AS IS IF I DID 15190000 MVI ERRNUM,X'09' MICRO NAK'ED 15200000 B SLOOP 15210000 AB4 MVI STATE,C'A' 15220000 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 15230000 B SLOOP 15240000 ********************************************************************** 15250000 * CREATE AND SEND EOF PACKET * 15260000 ********************************************************************** 15270000 SEOF CLC NUMTRY,MAXTRY CAN WE DO IT? 15280000 BL OK5 BRANCH IF YES 15290000 MVI STATE,C'A' ABORT IF NO 15300000 B SLOOP 15310000 OK5 L R3,NUMTRY 15320000 LA R3,1(R3) ADD ONE 15330000 ST R3,NUMTRY STORE INCREMENTED COUNTER 15340000 MVI STYPE,AZ PACKET TYPE = EOF 15350000 XC LSDAT,LSDAT LENGTH OF ZERO 15360000 L R15,=A(SPACK) 15370000 BALR 14,15 SAVE * AND GO TO SPACK 15380000 CLI STATE,C'A' 15390000 BE ABORT 15400000 L 15,=A(RPACK) 15410000 BALR 14,15 SAME FOR RPACK 15420000 CLI RTYPE,AE ERROR PACKET? 15430000 BNE Y5 MAYBE AN ACK 15440000 MVI ERRNUM,X'0A' MICRO DIED 15450000 MVI STATE,C'A' SO WE DO TOO 15460000 B SLOOP 15470000 Y5 CLI RTYPE,AY CHECK FOR 'ACK' 15480000 BNE N5 MAYBE WAS A 'NAK' 15490000 CLC N,NUM CORRECT ACK? 15500000 BE AOK5 15510000 MVI ERRNUM,X'08' LOST A PACKET 15520000 B SLOOP 15530000 AOK5 L R3,N 15540000 LA R3,1(R3) ADD ONE 15550000 ST R3,N STORE VALUE INCREMENTED BY 1 15560000 NC N(4),=X'0000003F' MASK TO GET MOD 64 15570000 MVI STATE,C'F' SET TO SEND FILE FOR NOW 15580000 * 15590000 * 15600000 * WE JUST PROCESS ONE FILE FOR NOW. 15610000 * 15620000 DIEOK MVI STATE,C'B' BREAK CONNECTION 15630000 B SLOOP 15640000 N5 CLI RTYPE,AN 15650000 BNE AB5 DIE IF NOT A NAK 15660000 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 15670000 BO SLOOP LEAVE ERR MSG AS IS IF I DID 15680000 MVI ERRNUM,X'09' MICRO NAK'ED 15690000 B SLOOP 15700000 AB5 MVI STATE,C'A' ELSE, ABORT 15710000 MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 15720000 B SLOOP 15730000 ********************************************************************** 15740000 * CREATE AND SEND BREAK PACKET * 15750000 ********************************************************************** 15760000 SBREAK CLC NUMTRY,MAXTRY OVER OUR LIMIT? 15770000 BL OK6 BRANCH IF NO 15780000 MVI STATE,C'A' ABORT IF YES 15790000 B SLOOP 15800000 OK6 L R3,NUMTRY 15810000 LA R3,1(R3) ADD ONE 15820000 ST R3,NUMTRY INCREMEMTED TRIAL COUNTER 15830000 MVI STYPE,AB PACKET TYPE = BREAK 15840000 XC LSDAT,LSDAT LENGTH = ZERO 15850000 L R15,=A(SPACK) 15860000 BALR 14,15 SAVE * AND GO TO SPACK 15870000 CLI STATE,C'A' 15880000 BE ABORT 15890000 L 15,=A(RPACK) 15900000 BALR 14,15 SAVE * AND GO TO RPACK 15910000 CLI RTYPE,AE ERROR PACKET? 15920000 BNE Y6 MAYBE AN ACK 15930000 MVI ERRNUM,X'0A' MICRO DIED 15940000 MVI STATE,C'A' THEN WE DO TOO 15950000 B SLOOP 15960000 Y6 CLI RTYPE,AY CHECK FOR ACK 15970000 BNE N6 CHECK FOR 'N' 15980000 CLC N,NUM CORRECT ACK? 15990000 BE AOK6 16000000 MVI ERRNUM,X'08' LOST A PACKET 16010000 B SLOOP 16020000 AOK6 MVI STATE,C'C' COMPLETED STATE 16030000 B SLOOP 16040000 N6 CLI RTYPE,AN CHECK FOR 'N' 16050000 BNE AB6 DIE IF NOT A NAK 16060000 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 16070000 BO SLOOP LEAVE ERR MSG AS IS IF I DID 16080000 MVI ERRNUM,X'09' MICRO NAK'ED 16090000 B SLOOP 16100000 AB6 MVI STATE,C'A' ELSE,ABORT 16110000 MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 16120000 B SLOOP 16130000 ********************************************************************** 16140000 * CREATE AND SEND ABORT PACKET * 16150000 ********************************************************************** 16160000 ABORT DS 0H 16170000 TM FLAGS,FLG1 DYING ON FILE-NOT-FOUND? 16180000 BO NOERRP IF SO, THEN NO ERROR PACKET 16190000 CLI ERRNUM,X'0A' DID THE MICRO DIE? 16200000 BE NOERRP NO ERROR PACKET IF SO 16210000 MVI STYPE,AE ERROR PACKET 16220000 MVC LSDAT(4),=F'20' ALL MSGS ARE THIS LONG 16230000 MVC N(4),NUM SYNCH PACKET NUMBERS 16240000 SR R5,R5 16250000 IC R5,ERRNUM GET RIGHT MESSAGE NUMBER 16260000 M R4,=F'20' OFFSET := ERRNUM * 20 16270000 LA R5,ERRTAB(R5) 16280000 MVC SDAT(20),0(R5) SPACK NEEDS THE DATA HERE 16290000 TR SDAT(20),ETOA 16300000 L R15,=A(SPACK) 16310000 BALR R14,R15 SEND ERROR PACKET & DIE 16320000 NOERRP LA R15,4 SET NON-ZERO RETCODE 16330000 B SENDRET PREPARE TO LEAVE 16340000 ********************************************************************** 16350000 * PROCESS COMPLETE * 16360000 ********************************************************************** 16370000 COMPLETE SR R15,R15 ZERO WILL BE RETCODE 16380000 SENDRET L R13,4(R13) 16390000 L R14,12(R13) 16400000 LM R0,R12,20(R13) 16410000 BR R14 16420000 EJECT 16430000 ********************************************************************** 16440000 * * 16450000 * ROUTINE TO GET A CHARACTER FROM INPUT BUFFER WILL READ DISK TO * 16460000 * FILL THE BUFFER. * 16470000 * * 16480000 ********************************************************************** 16490000 GTCHR DS 0H 16500000 TM FLAGS,FLG3 SEE IF THERE'S STUFF IN BUF 16510000 BO STUFF ONES -> STUFF'S THERE 16520000 * 16530000 * GO TO COMMON ROUTINE TO READ SOME BYTES 16540000 * 16550000 LA R15,READX 16560000 BALR R15,R15 16570000 * 16580000 LTR R4,R1 PUT RESULT OF READ IN R4 16590000 BZ OK8 16600000 C R4,=A(ERCOD) RETCODE OF 12 MEANS EOF 16610000 BNE ERR1 TRY IT AGAIN 16620000 MVI STATE,C'Z' MAKE TO EOF STATE 16630000 BR R14 16640000 ERR1 MVI STATE,C'A' ABORT ON FILE SYSTEM ERROR 16650000 MVI ERRNUM,X'0C' INVALID RECORD LENGTH 16660000 C R4,=F'8' WAS OUR GUESS RIGHT? 16670000 BER R14 IF YES, RETURN 16680000 MVI ERRNUM,X'0D' ELSE, GOT AN I/O ERROR 16690000 BR R14 16700000 OK8 LR R5,R0 GET NUMBER OF BYTES READ IN 16710000 LR R4,R5 SAVE ALSO IN R4 16720000 BCTR R4,0 SUBTRACT 1 FOR EX COMMAND 16730000 TM FLAGS,BINF IZ FLILE BINARY? J 16740000 BNZ SAMETRAN YES - NO TRANSLATE J 16750000 L R15,TRTADDR CURRENT TRT TAB ADDR J 16760000 EX R4,TRANS EBCDIC TO ASCII TRANSLATION 16770000 SAMETRAN LA R8,BUF GET LOCATION OF BUFFER INPUT 16780000 LA R9,BUF(R4) LAST POSITION IN THAT BUFFER 16790000 TM FLAGS,BINF IS FILE BINARY ? J 16800000 BZ X4 NO,CONTINUE J 16810000 B ST5R SKEEP BLANKS ADD J 16820000 X4 CLI 0(R9),X'20' IS THIS A BLANK? 16830000 BNE X5 NO, FOUND LAST CHAR OF LINE 16840000 BCTR R9,0 16850000 CR R9,R8 16860000 BNL X4 FIND LAST CHAR 16870000 SR R5,R5 ALL BLANKS 16880000 B FOO 16890000 X5 SR R9,R8 16900000 LR R5,R9 LENGTH OF LINE 16910000 LA R5,1(R5) ADD ONE 16920000 FOO LA R9,BUF(R5) FIRST BLANK SPACE AFTER DATA 16930000 MVC 0(1,R9),=X'0D' ADD ASCII CR 16940000 LA R9,1(R9) INCREMENT POINTER 16950000 MVC 0(1,R9),=X'0A' AND ADD ASCII LF 16960000 LA R5,2(R5) TWO EXTRA BYTES OF DATA NOW 16970000 ST5R ST R5,RECL LRECL + 2 (FOR CRLF) 16980000 SR R8,R8 ZERO OUT INDEX FOR BUF 16990000 STUFF SR R9,R9 SAME FOR INDEX FOR SDAT 17000000 SR R10,R10 CHARACTER COUNTER 17010000 SR R5,R5 WILL HOLD QUOCHAR 17020000 IC R5,QUOCHAR 17030000 L R8,SAVPL WHERE WE LEFT OFF 17040000 C R8,RECL SEE IF ARE AT LIMIT 17050000 BNL FULL2 LEAVE IF REACHED OR EXCEEDED 17060000 SR R7,R7 17070000 LOOP IC R7,BUF(R8) PICK UP BYTE 17080000 CLI EBQUOT,AN DOING 8-BIT QUOTING ? **BEGIN J 17090000 BE TESTSPE 17100000 CLI EBQUOT,AY CAN DO IT BUT AREN'T 17110000 BE TESTSPE 17120000 LR R1,R7 17130000 N R1,=X'00000080' 17140000 LTR R1,R1 17150000 BZ TESTSPE 17160000 N R7,=X'0000007F' 17170000 L R4,SIZE 17180000 SR R4,R10 17190000 C R4,=F'3' J 17200000 BL SAMEEND 17210000 LA R4,SDAT(R9) 17220000 MVC 0(1,R4),EBQUOT 17230000 LA R9,1(R9) 17240000 LA R10,1(R10) 17250000 TESTSPE SR R1,R1 17260000 CLI EBQUOT,AN 17270000 BE TESTSPC 17280000 CLI EBQUOT,AY 17290000 BE TESTSPC 17300000 IC R1,EBQUOT 17310000 CR R7,R1 17320000 BE SPECIAL 17330000 TESTSPC CR R7,R5 IS IT THE QUOTE CHARACTER? ENDJ 17340000 BE SPECIAL 17350000 C R7,DEL IS IT THE CHARDEL? 17360000 BE SPECIAL 17370000 C R7,SPACE IS IT A CONTROL CHARACTER? 17380000 BL SPECIAL 17390000 B ADDIT 17400000 SPECIAL L R4,SIZE MUNGE VALUE WHILE IN R4 17410000 SR R4,R10 FIND DIF BETWWEN THE TWO 17420000 C R4,=F'2' SEE IF HAVE AT LEAST 2 BYTES =R= 17430000 BNL ROOM YES,CAN ADD 17440000 SAMEEND STC R10,LSDAT+3 SET LSDAT TO VAL OF COUNTER J 17450000 OI FLAGS,FLG3 SET FLAG TO SHOW STUFF'S THERE 17460000 ST R8,SAVPL SAVE PLACE IN BUF 17470000 BR 14 LEAVE THIS ROUTINE 17480000 ROOM LA R4,SDAT(R9) WHERE IT'S GOING 17490000 MVC 0(1,R4),QUOCHAR MOVE QUOTE CHAR THERE 17500000 LA R9,1(R9) INCREMENT SDAT COUNTER 17510000 LA R10,1(R10) INCREMENT CHARACTER COUNTER 17520000 CR R7,R5 DON'T ADD O100 TO THIS 17530000 BE ADDIT IT'S ALREADY PRINTABLE 17540000 LTR R1,R1 J 17550000 BZ AR7 J 17560000 CR R1,R7 J 17570000 BE ADDIT J 17580000 AR7 A R7,O1H ADD 0100 TO CHAR J 17590000 N R7,=X'0000007F' GET MOD O200 17600000 ADDIT STC R7,SDAT(R9) ADD THE CHARACTER 17610000 LA R9,1(R9) INCREMENT SDAT COUNTER 17620000 LA R8,1(R8) INCREMENT BUF COUNTER 17630000 LA R10,1(R10) INCREMENT CHARACTER COUNTER 17640000 C R8,RECL SEE IF REACHED LIMIT 17650000 BNL FULL2 17660000 C R9,SIZE SEE IF REACHED LIMIT 17670000 BNL FULL 17680000 B LOOP 17690000 FULL EQU * 17700000 STC R10,LSDAT+3 THIS ONE TOO 17710000 ST R8,SAVPL HERE TOO 17720000 OI FLAGS,FLG3 TURN ON FLAG - STUFF IN BUF 17730000 BR 14 17740000 FULL2 EQU * 17750000 STC R10,LSDAT+3 THIS ONE TOO 17760000 XC SAVPL,SAVPL RESET THIS 17770000 NI FLAGS,X'FF'-FLG3 TURN OFF LEFTOVER DATA FLAG 17780000 BR 14 17790000 SENDSAVE DS 18F 17800000 TRANS TR BUF(0),256(R15) EBCDIC TO ASCII TRANSLATION 17810000 PARSE DC 32X'00' 17820000 DC X'01' STOP ON A SPACE 17830000 DC 223X'00' 17840000 FIRST MVC SDAT(0),FILNAM PICK UP THE FN 17850000 SECOND MVC 0(0,R7),FILNAM+8 PICK UP FT 17860000 LTORG 17870000 DROP R11 17880000 DROP R12 DON'T NEED THEM ANYMORE 17890000 EJECT 17900000 ********************************************************************** 17910000 * * 17920000 * ROUTINE TO PROCESS SEND PACKET REQUEST * 17930000 * * 17940000 ********************************************************************** 17950000 SPACK DS 0H CSECT 17960000 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 17970000 BALR R12,0 ESTABLISH ADDRESSABILITY 17980000 USING *,R12 17990000 LA R14,SPSAVE ADDRESS OF MY SAVE AREA 18000000 ST R13,4(R14) SAVE CALLER'S 18010000 ST R14,8(R13) 18020000 LR R13,R14 18030000 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 18040000 L R11,=A(PARMS) 18050000 USING PARMS,R11 ESTABLISH ADDRESSABILITY 18060000 SR R9,R9 18070000 * MVC PHDR,SSOH ADD SOH TO PACKET Z 18080000 CLC LSDAT,SIZE NEED DATA SIZE <= SPSIZ-5 18090000 BNH FINE 18100000 MVI ERRNUM,X'00' DATA SIZE EXCEEDS MAX LIMIT 18110000 MVI STATE,C'A' ABORT ON THIS 18120000 B SPRET 18130000 FINE L R4,=F'35' USE O43 TO OFFSET DATA 18140000 A R4,LSDAT ADD IT TO LSDAT 18150000 STC R4,PLEN 18160000 AR R9,R4 AND THEN ADD IT TO CHECKSUM 18170000 CLC N,ZERO CHECK IF N IS VALID 18180000 BNL T1 OK IF >= TO 0 18190000 MVI ERRNUM,X'01' ILLEGAL MESSAGE NUMBER 18200000 MVI STATE,C'A' 18210000 B SPRET 18220000 T1 CLC N,O1H SEE IF IS <= OCTAL 100 18230000 BNH T2 18240000 MVI ERRNUM,X'01' ILLEGAL MESSAGE NUMBER 18250000 MVI STATE,C'A' 18260000 B SPRET 18270000 T2 L R4,SPACE OFFSET THIS VALUE TOO 18280000 A R4,N ADD IT TO N 18290000 ST R4,TEMP 18300000 MVC PNUM(1),TEMP+3 18310000 A R9,TEMP AND ADD TO CHECKSUM 18320000 CLI STYPE,X'41' ASCII 'A' 18330000 BL T3 CAN'T BE LESS THAN THIS 18340000 CLI STYPE,X'5A' ASCII 'Z' 18350000 BNH T4 CAN'T BE GREATER 18360000 T3 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 18370000 MVI STATE,C'A' DIE ON THIS 18380000 B SPRET 18390000 T4 MVC PTYPE(1),STYPE ADD MESSAGE TYPE 18400000 SR R2,R2 ZERO IT OUT 18410000 IC R2,STYPE 18420000 AR R9,R2 ADD TO CHECKSUM 18430000 L R6,LSDAT HOW MUCH DATA 18440000 LTR R6,R6 TEST IT OUT 18450000 BZ NODAT 18460000 SR R5,R5 USE TO GET DATA 18470000 SR R3,R3 USE TO HOLD DATA 18480000 DATCHK IC R3,SDAT(R5) PICK UP CHAR 18490000 AR R9,R3 ADD TO CHECKSUM 18500000 LA R5,1(R5) BUMP POINTER 18510000 BCTR R6,0 18520000 LTR R6,R6 MORE DATA? 18530000 BNZ DATCHK 18540000 NODAT L R6,LSDAT WILL NEED THIS LATER 18550000 LR R7,R6 MUNGE WHILE IN R7 18560000 BCTR R7,0 SUBTRACT 1 FOR EX FUNCTION 18570000 EX R7,MOVE MOVE THE DATA TO SNDPKT 18580000 ST R9,TEMP WE'LL NEED THIS SOON 18590000 N R9,=X'000000C0' GET MOD 192 18600000 M R8,ONE CARRY OVER THE SIGN BIT 18610000 D R8,O1H GET MOD 64 18620000 A R9,TEMP ADD THE TWO VALUES 18630000 N R9,=X'0000003F' GET MOD 64 OF CHECKSUM 18640000 A R9,SPACE ADD OFFSET 18650000 STC R9,PDATA(R6) ADD CHECKSUM AFTER DATA 18660000 LA R6,1(R6) MOVE POINTER 18670000 * IC R9,SEOL ADD SEND END OF PACKET CHAR Z 18680000 * STC R9,PDATA(R6) Z 18690000 LA R6,3(R6) VALUE OF LSDAT+3 -SOH-EOL Z 18700000 *** ZINOVIEV IS SHURE NEXT COMAND IS RIGHT J 18710000 TR SNDPKT(130),ATOE SEND IN EBCDIC 18720000 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 18730000 BZ SPNODEB 18740000 MVC WRKBUFF(2),=H'20' 18750000 XC WRKBUFF+2(2),WRKBUFF+2 18760000 MVC WRKBUFF+4(16),=CL16'TPUT SEND PACKET' 18770000 PUT DEBUG,WRKBUFF 18780000 LA R1,4(,R6) ADJUST LENGTH 18790000 STH R1,WRKBUFF SET RDW 18800000 EX R6,DBGMVC1 MOVE IN DATA 18810000 PUT DEBUG,WRKBUFF 18820000 SPNODEB TPUT SNDPKT,(R6),FULLSCR âùìO CONTROL J 18830000 LTR R15,R15 WAS THERE ANY ERROR? 18840000 BZ SPRET NO, THEN JUST RETURN 18850000 MVI ERRNUM,10 SET MICRO DIED 18860000 MVI STATE,C'A' ABORT ON THIS 18870000 SPRET L R13,4(R13) 18880000 L R14,12(R13) 18890000 LM R0,R12,20(R13) 18900000 BR 14 18910000 SPSAVE DS 18F 18920000 MOVE MVC PDATA(0),SDAT 18930000 DBGMVC1 MVC WRKBUFF+4(*-*),SNDPKT 18940000 LTORG 18950000 DROP R11 18960000 DROP R12 DON'T NEED THEM ANYMORE 18970000 EJECT 18980000 ********************************************************************** 18990000 * * 19000000 * ROUTINE TO PROCESS RECEIVE PACKET REQUEST * 19010000 * * 19020000 ********************************************************************** 19030000 RPACK DS 0H 19040000 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 19050000 BALR R12,0 ESTABLISH ADDRESSABILITY 19060000 USING *,R12 19070000 LA R14,RPSAVE ADDRESS OF MY SAVE AREA 19080000 ST R13,4(R14) SAVE CALLER'S 19090000 ST R14,8(R13) 19100000 LR R13,R14 19110000 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 19120000 L R11,=A(PARMS) 19130000 USING PARMS,R11 ESTABLISH ADDRESSABILITY 19140000 TGET RECPKT,130,ASIS 19150000 LTR R15,R15 WAS THERE AN ERROR? 19160000 BZ RPTSTDB NO, THEN TEST FOR DEBUG 19170000 MVI RTYPE,AE SET AN ERROR 19180000 B RPRET 19190000 RPTSTDB TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 19200000 BZ RDNODEB 19210000 LA R8,4(,R1) SAVE LENGTH 19220000 MVC WRKBUFF(2),=H'19' 19230000 XC WRKBUFF+2(2),WRKBUFF+2 19240000 MVC WRKBUFF+4(15),=CL15'TGET REC PACKET' 19250000 PUT DEBUG,WRKBUFF 19260000 STH R8,WRKBUFF SET RDW 19270000 EX R8,DBGMVC2 MOVE IN DATA 19280000 PUT DEBUG,WRKBUFF 19290000 *** ZINOVIEV IS SHURE NEXT COMAND IS RIGHT J 19300000 RDNODEB TR RECPKT(130),ETOA 19310000 NI FLAGS,X'FF'-FLG4 ASSUME MICRO'LL NAK-NOT RPACK 19320000 SR R8,R8 INDEX REG FOR RECPKT 19330000 SR R5,R5 CHECKSUM REGISTER 19340000 TRY LA R7,RECPKT(R8) ADDRESS OF CHARACTER 19350000 * CLC RSOH,0(R7) IS IT START OF HEADER Z 19360000 SR R9,R9 ZERO OUT INDEX REG FOR RDAT Z 19370000 B READIS GOTO CONTINUE Z 19380000 * BE READIN YES; SO FAR, SO GOOD Z 19390000 LA R8,1(R8) TRY NEXT CHARACTER 19400000 C R8,=F'130' SEE IF EXCEED BUFFER 19410000 BL TRY 19420000 MVI ERRNUM,X'03' NO "SOH" ERROR 19430000 B BADP 19440000 READIN SR R9,R9 ZERO OUT INDEX REG FOR RDAT 19450000 LA R8,1(R8) INCREMENT COUNTER 19460000 LA R7,RECPKT(R8) PICK UP LOC OF CHAR COUNT 19470000 CLC RSOH,0(R7) IS IT START OF HEADER? 19480000 BE READIN START OVER 19490000 READIS CLC 0(1,R7),DQUOTE COUNT+' '+3 AND D35 Z 19500000 BNL CONT CONTINUE IF >= 19510000 MVI ERRNUM,X'04' BAD LENGTH ATTRIBUTE 19520000 B BADP 19530000 CONT IC R5,0(R7) START CHECKSUM 19540000 LR R7,R5 MUNGE IN R7 TO GET LRDAT 19550000 S R7,=F'35' LENGTH OF DATA 19560000 STC R7,LRDAT+3 19570000 LA R8,1(R8) INCREMENT 19580000 SR R7,R7 ZERO IT OUT 19590000 IC R7,RECPKT(R8) PICK UP PACKET NUMBER 19600000 CLM R7,B'0001',RSOH IS IT START OF HEADER 19610000 BE READIN 19620000 AR R5,R7 ADD TO CHECKSUM 19630000 S R7,SPACE SUBTRACT THE ' ' 19640000 STC R7,NUM+3 NUM := RECEIVED PACKET NO. 19650000 LA R8,1(R8) INCREMENT COUNTER 19660000 IC R7,RECPKT(R8) PICK UP MESSAGE TYPE 19670000 CLM R7,B'0001',RSOH IS IT START OF HEADER? 19680000 BE READIN 19690000 AR R5,R7 ADD TO CHECKSUM 19700000 STC R7,RTYPE PUT INTO RTYPE 19710000 LA R8,1(R8) GO TO NEXT BYTE 19720000 L R4,LRDAT COUNTER TO GET ALL DATA 19730000 LUP C R4,ZERO SEE IF PICKED UP ALL DATA 19740000 BE FIN 19750000 XC TEMP,TEMP ZERO IT OUT 19760000 LA R7,RECPKT(R8) NEXT LOCATION IN BUFFER 19770000 MVC TEMP+3(1),0(R7) PICK UP NEXT BYTE 19780000 CLC RSOH,TEMP+3 IS IT START OF HEADER 19790000 BE READIN 19800000 LA R7,RDAT(R9) WHERE THE DATA'S GOING 19810000 MVC 0(1,R7),TEMP+3 AND MOVE IT 19820000 A R5,TEMP ADD TO CHECKSUM 19830000 LA R8,1(R8) ADD ONE 19840000 LA R9,1(R9) ADD ONE 19850000 BCTR R4,0 DECREMENT COUNTER 19860000 B LUP 19870000 FIN SR R7,R7 ZERO OUT REGISTER 19880000 IC R7,RECPKT(R8) GET CHECKSUM 19890000 CLM R7,B'0001',RSOH IS IT START OF HEADER 19900000 BE READIN 19910000 ST R5,TEMP WE'LL NEED THIS SOON 19920000 N R5,=X'000000C0' GET MOD 192 19930000 M R4,ONE CARRY OVER THE SIGN BIT 19940000 D R4,O1H GET MOD 64 19950000 A R5,TEMP ADD THE TWO VALUES 19960000 N R5,=X'0000003F' GET MOD 64 19970000 A R5,SPACE ADD OFFSET 19980000 CR R5,R7 COMPUTED VS RECEIVED CHECKSUM 19990000 BE RPRET 20000000 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN 20010000 BZ NODEBG2 20020000 MVC WRKBUFF(2),=H'18' 20030000 XC WRKBUFF+2(2),WRKBUFF+2 20040000 MVC WRKBUFF+4(14),=CL14'CHECKSUM ERROR' 20050000 PUT DEBUG,WRKBUFF 20060000 NODEBG2 MVI ERRNUM,X'05' BAD CHECKSUM ERROR 20070000 BADP MVI RTYPE,AN RETURN A NAK 20080000 OI FLAGS,FLG4 RPACK NAK'ED THE PACKET 20090000 RPRET L R13,4(R13) 20100000 L R14,12(R13) 20110000 LM R0,R12,20(R13) 20120000 BR 14 20130000 DBGMVC2 MVC WRKBUFF+4(*-*),RECPKT 20140000 RPSAVE DS 18F 20150000 LTORG 20160000 DROP R11 20170000 DROP R12 DON'T NEED THEM ANYMORE 20180000 EJECT 20190000 ********************************************************************** 20200000 * * 20210000 * DISK FILE READ ROUTE WITH DEBUGGING CODE * 20220000 * * 20230000 ********************************************************************** 20240000 READX DS 0H 20250000 USING PARMS,R11 ESTABLISH ADDRESSABILITY 20260000 STM R12,R15,READSAVE 20270000 BALR R12,0 20280000 USING *,R12 20290000 TM KERIN+(DCBRECFM-IHADCB),DCBRECV VARIABLE? 20300000 BO RDVAR 20310000 GET KERIN,BUF 20320000 B RDTSTDB 20330000 RDVAR GET KERIN,BUF-4 20340000 RDTSTDB TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 20350000 BZ RDNODBG 20360000 MVC WRKBUFF(2),=H'12' 20370000 XC WRKBUFF+2(2),WRKBUFF+2 20380000 MVC WRKBUFF+4(8),=CL8'QSAM GET' 20390000 PUT DEBUG,WRKBUFF 20400000 LH R1,KERIN+(DCBLRECL-IHADCB) 20410000 STH R1,WRKBUFF 20420000 EX R1,DBGMVC3 20430000 PUT DEBUG,WRKBUFF 20440000 RDNODBG XR R1,R1 SET RETURN CODE 20450000 LH R0,KERIN+(DCBLRECL-IHADCB) GET RECORD LENGTH 20460000 TM KERIN+(DCBRECFM-IHADCB),DCBRECV VARIABLE? 20470000 BZ *+12 NO, THEN SKIP 20480000 LH R0,BUF-4 GET LENGTH FROM RDW 20490000 SH R0,=H'4' REMOVE RDW LENGTH 20500000 LM R12,R15,READSAVE 20510000 BR R15 20520000 DBGMVC3 MVC WRKBUFF+4(*-*),KERIN 20530000 * 20540000 INEOF DS 0H 20550000 LA R1,12 20560000 XR R0,R0 20570000 LM R12,R15,READSAVE 20580000 BR R15 20590000 LTORG 20600000 DROP R11 20610000 DROP R12 20620000 EJECT 20630000 ********************************************************************** 20640000 * * 20650000 * ROUTINE TO PROCESS RECEIVE COMMAND * 20660000 * * 20670000 ********************************************************************** 20680000 RECEIVE DS 0H 20690000 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 20700000 BALR R12,0 ESTABLISH ADDRESSABILITY 20710000 USING *,R12 20720000 LA R14,RECSAVE ADDRESS OF MY SAVE AREA 20730000 ST R13,4(R14) SAVE CALLER'S 20740000 ST R14,8(R13) 20750000 LR R13,R14 20760000 * USE R11 AS BASE REGISTER FOR THE GLOBAL DATA AREA, 'PARMS' 20770000 L R11,=A(PARMS) 20780000 USING PARMS,R11 20790000 MVC EBQUOT(1),ORIG8Q J 20800000 SR R6,R6 GET ZERO 20810000 ST R6,NUMTRY ZERO THIS OUT 20820000 ST R6,N HERE TOO 20830000 MVI STATE,C'R' SET TO RECEIVE STATE 20840000 ********************************************************************** 20850000 * MAIN RECEIVE PROCESSING LOOP * 20860000 ********************************************************************** 20870000 RLOOP CLI STATE,C'D' RECEIVE DATA STATE 20880000 BE RDATA 20890000 CLI STATE,C'F' RECEIVE FILE STATE 20900000 BE RFILE 20910000 CLI STATE,C'R' RECEIVE INIT STATE 20920000 BE RINIT 20930000 CLI STATE,C'C' COMPLETE STATE 20940000 BE RCOMP 20950000 CLI STATE,C'A' ABORT STATE 20960000 BE RABORT 20970000 MVI ERRNUM,X'02' UNRECOGNIZED STATE 20980000 B RABORT ELSE, DIE 20990000 ********************************************************************** 21000000 * PROCESS INITIALIZATION PACKET * 21010000 ********************************************************************** 21020000 RINIT CLC NUMTRY,IMXTRY SEE IF CAN RECEIVE 21030000 BL ROK1 YES, WE CAN 21040000 MVI STATE,C'A' NOPE, GO INTO ABORT STATE 21050000 B RLOOP 21060000 ROK1 L R3,NUMTRY 21070000 LA R3,1(R3) INCREMENT TRIAL COUNTER 21080000 ST R3,NUMTRY 21090000 L R4,DSSIZ DEFAULT SEND PACKET SIZE 21100000 S R4,FIVE USE DEFAULT TO SET "SIZE" 21110000 ST R4,SIZE IN CASE WE DIE BEFORE IT'S SET 21120000 L R15,=A(RPACK) GET INIT INFORMATION 21130000 BALR R14,R15 21140000 CLI RTYPE,AE ERROR PACKET? 21150000 BNE RY1 ALL OK 21160000 MVI ERRNUM,X'0A' MICRO DIED 21170000 MVI STATE,C'A' SO WE DO TOO 21180000 B RLOOP 21190000 RY1 CLI RTYPE,AS IS IT A SEND-INIT PACKET 21200000 BNE RN1 MAYBE IT GOT CLOBBERED 21210000 SR R4,R4 ZERO OUT REGISTER 21220000 IC R4,RDAT GET FIRST CHARACTER 21230000 S R4,SPACE SUBTRACT THE ' ' 21240000 C R4,=F'26' MIN SPACK SIZE 21250000 BNL RCH1 SO FAR, SO GOOD 21260000 L R4,=F'80' ELSE, USE DEFAULT J 21270000 B RCH2 J 21280000 RCH1 C R4,MAXPACK MAX PACKET SIZE 21290000 BNH RCH2 21300000 MVI STATE,C'A' ABORT IF SIZE IS ILLEGAL 21310000 MVI ERRNUM,X'00' BAD SEND DATA LENGTH 21320000 B RLOOP 21330000 RCH2 STC R4,SPSIZ+3 USE THE VALUE AS SEND SIZE 21340000 S R4,FIVE 21350000 ST R4,SIZE SET IT TO SPSIZ-5 21360000 CLC LRDAT(4),=F'4' USING ALL DEFAULTS ? 21370000 BNH NOCH YUP 21380000 LA R5,RDAT POINT TO THE BUFFER 21390000 SR R7,R7 21400000 IC R7,4(R5) SEOL THE MICRO WANTS 21410000 S R7,SPACE UNCHAR (SUBTRACT ' ') 21420000 STC R7,SEOL 21430000 CLC LRDAT(4),FIVE ANY MORE DATA? 21440000 BNH NOCH JUST USE DEFAULTS 21450000 MVC RQUO(1),5(R5) SET NEW QUOCHAR VALUE 21460000 NOCH CLC LRDAT(4),=F'6' J (BEGIN) 21470000 BL NOCH 21480000 L R15,=A(DOQUO) 21490000 BALR R14,R15 SET 8-BIT QUOTE CHAR J (END) 21500000 MVC N(4),NUM SYNCH PACKET NUMBERS 21510000 MVI STYPE,AY SET MESSAGE TYPE TO ACK 21520000 MVC LSDAT(4),=F'7' SET LENGTH OF DATA SENDING J 21530000 L R5,SPACE MAKE CHARACTER PRINTABLE 21540000 A R5,RPSIZ ADD REC PACKET SIZE 21550000 STC R5,SDAT ADD SIZE INFO TO BUFFER 21560000 L R5,SPACE 21570000 A R5,=F'10' 10 FOR TIMEOUT 21580000 STC R5,SDAT+1 21590000 * L R5,SPACE SEND ZERO + " " FOR NPAD 21600000 MVI SDAT+2,X'21' SEND ONE (!) FOR NPAD Z 21610000 * SR R5,R5 PAD WITH NULLS Z 21620000 * L R3,O1H Z 21630000 * XR R5,R3 CTL FUNCTION (XOR WITH 64) Z 21640000 MVI SDAT+3,X'42' SEND CTL B FOR PADCHAR Z 21650000 SR R5,R5 ZERO IT OUT FOR NEXT TWO GUYS 21660000 IC R5,REOL EOL CHAR I NEED 21670000 A R5,SPACE MAKE PRINTABLE 21680000 STC R5,SDAT+4 21690000 IC R5,QUOCHAR MY QUOTE CHAR 21700000 STC R5,SDAT+5 21710000 IC R5,EBQUOT 8-BIT QUOTE CHAR J 21720000 STC R5,SDAT+6 TO PACKET J 21730000 L R15,=A(SPACK) ADDRESS OF SPACK 21740000 BALR R14,R15 SAVE * AND GO TO SPACK 21750000 CLI STATE,C'A' 21760000 BE RABORT 21770000 MVI STATE,C'F' SET TO RECEIVE FILE STATE 21780000 MVC OLDTRY(4),NUMTRY SAVE TRIAL COUNTER 21790000 XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 21800000 L R3,N 21810000 LA R3,1(R3) ADD ONE 21820000 ST R3,N STORE VALUE INCREMENTED BY 1 21830000 NC N(4),=X'0000003F' MASK TO GET MOD 64 21840000 B RLOOP 21850000 RN1 CLI RTYPE,AN MAYBE IT'S A NAK 21860000 BNE RSELSE 21870000 MVI STYPE,AN SEND A NAK PACKET 21880000 XC LSDAT,LSDAT NO DATA 21890000 L R15,=A(SPACK) 21900000 BALR R14,R15 21910000 B RLOOP 21920000 RSELSE MVI STATE,C'A' ELSE,ABORT 21930000 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 21940000 B RLOOP 21950000 ********************************************************************** 21960000 * PROCESS FILE PACKET * 21970000 ********************************************************************** 21980000 RFILE CLC NUMTRY,MAXTRY EXCEEDED NO. OF TRIALS ALLOWED 21990000 BL ROK2 NOPE, STILL OK 22000000 MVI STATE,C'A' ABORT IF YES 22010000 B RLOOP 22020000 ROK2 L R3,NUMTRY 22030000 LA R3,1(R3) INCREMENT TRIAL COUNTER 22040000 ST R3,NUMTRY 22050000 L R15,=A(RPACK) GET ADDRESS OF RPACK 22060000 BALR R14,R15 GO THERE AND RETURN WHEN DONE 22070000 CLI RTYPE,AE ERROR PACKET? 22080000 BNE RY2 MAYBE AN ACK 22090000 MVI ERRNUM,X'0A' MICRO DIED 22100000 MVI STATE,C'A' SO WE DO TOO 22110000 B RLOOP 22120000 RY2 CLI RTYPE,AS STILL IN INIT STATE? 22130000 BNE RNZ TRY FOR AN EOF 22140000 CLC OLDTRY,MAXTRY CAN WE TRY AGAIN? 22150000 BL ROLD 22160000 MVI STATE,C'A' ELSE, ABORT 22170000 B RLOOP 22180000 ROLD L R3,OLDTRY 22190000 LA R3,1(R3) INCREMENT COUNTER 22200000 ST R3,OLDTRY 22210000 L R3,N GET PACKET NUMBER SENT 22220000 BCTR R3,0 SUBTRACT ONE FROM IT 22230000 C R3,NUM NUM MUST EQUAL N-1 22240000 BE RNUM 22250000 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 22260000 B RNAK SEND A NAK 22270000 RNUM MVI STYPE,AY ACK PACKET 22280000 ST R3,N MAKE SEND SEQ NO. = N-1 22290000 MVC LSDAT(4),=F'6' SET DATA LENGTH VARIABLE 22300000 L R15,=A(SPACK) 22310000 BALR R14,R15 GO TO SPACK AND RETURN 22320000 CLI STATE,C'A' 22330000 BE RABORT 22340000 L R4,N 22350000 LA R4,1(R4) ADD ONE 22360000 ST R4,N RESTORE N TO PROPER VALUE 22370000 XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 22380000 B RLOOP 22390000 RNZ CLI RTYPE,AZ 22400000 BNE RNF MAYBE IT'S AN 'F' 22410000 CLC OLDTRY,MAXTRY CAN WE TRY AGAIN? 22420000 BL ROLD2 22430000 MVI STATE,C'A' ELSE,ABORT 22440000 B RLOOP 22450000 ROLD2 L R3,OLDTRY 22460000 LA R3,1(R3) INCREMENT COUNTER 22470000 ST R3,OLDTRY 22480000 L R3,N GET PACKET NUMBER SENT 22490000 BCTR R3,0 SUBTRACT ONE FROM IT 22500000 C R3,NUM NUM MUST EQUAL N-1 22510000 BE RNUM2 22520000 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 22530000 B RNAK SEND A NAK 22540000 RNUM2 MVI STYPE,AY ACK PACKET 22550000 ST R3,N SEND SEQ := N-1 22560000 XC LSDAT,LSDAT NO DATA 22570000 L R15,=A(SPACK) 22580000 BALR R14,R15 22590000 CLI STATE,C'A' 22600000 BE RABORT 22610000 L R4,N 22620000 LA R4,1(R4) ADD ONE 22630000 ST R4,N RESTORE N TO PROPER VALUE 22640000 XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 22650000 B RLOOP 22660000 RNF CLI RTYPE,AF 22670000 BNE RNB WELL, IT'S NOT A FNAME 22680000 CLC NUM,N THEY HAVE TO BE EQUAL 22690000 BE RNUM3 22700000 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 22710000 B RNAK SEND A NAK 22720000 RNUM3 MVI STYPE,AY ACK PACKET 22730000 XC LSDAT,LSDAT NO DATA 22740000 OVER L R15,=A(SPACK) 22750000 BALR R14,R15 SEND ACK 22760000 CLI STATE,C'A' 22770000 BE RABORT 22780000 MVC OLDTRY(4),NUMTRY KEEP NUMTRY FOR LATER 22790000 XC NUMTRY,NUMTRY RESET TO ZERO 22800000 L R3,N 22810000 LA R3,1(R3) ADD ONE 22820000 ST R3,N INCREMENT COUNTER 22830000 NC N(4),=X'0000003F' MASK TO GET MOD 64 22840000 MVI STATE,C'D' DATA RECEIVE STATE 22850000 B RLOOP 22860000 RNB CLI RTYPE,AB SEE IF IT'S A BREAK 22870000 BNE RNN MAYBE GOT A NAK 22880000 CLC NUM,N 22890000 BE RNUM4 22900000 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 22910000 B RNAK SEND A NAK 22920000 RNUM4 MVI STYPE,AY ACK PACKET 22930000 XC LSDAT,LSDAT NO DATA 22940000 L R15,=A(SPACK) 22950000 BALR R14,R15 22960000 CLI STATE,C'A' 22970000 BE RABORT 22980000 MVI STATE,C'C' COMPLETE STATE 22990000 B RLOOP 23000000 RNN CLI RTYPE,AN SEE IF GOT A NAK 23010000 BNE RNELSE 23020000 RNAK MVI STYPE,AN SEND A NAK PACKET 23030000 XC LSDAT,LSDAT NO DATA 23040000 L R15,=A(SPACK) 23050000 BALR R14,R15 23060000 B RLOOP DO NOTHING ON A NAK 23070000 RNELSE MVI STATE,C'A' ABORT OTHERWISE 23080000 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 23090000 B RLOOP 23100000 ********************************************************************** 23110000 * RECEIVE DATA PACKETS * 23120000 ********************************************************************** 23130000 RDATA CLC NUMTRY,MAXTRY HAVE WE EXCEEDED OUR LIMIT? 23140000 BL ROK3 23150000 MVI STATE,C'A' ELSE, ABORT 23160000 B RLOOP 23170000 ROK3 L R4,NUMTRY 23180000 LA R4,1(R4) INCREMENT 23190000 ST R4,NUMTRY SAVE INCREMENTED COUNTER 23200000 L R15,=A(RPACK) 23210000 BALR R14,R15 CALL RPACK 23220000 CLI RTYPE,AE ERROR PACKET? 23230000 BNE RY3 MAYBE AN ACK 23240000 MVI ERRNUM,X'0A' MICRO DIED 23250000 MVI STATE,C'A' WE ABORT TOO 23260000 B RLOOP 23270000 RY3 CLI RTYPE,AD IS THIS A DATA PACKET? 23280000 BNE RDF MAYBE IT'S AN FNAME PACKET 23290000 CLC N,NUM CHECK FOR RIGHT PACKET 23300000 BNE DIF 23310000 L R15,=A(PTCHR) 23320000 BALR R14,R15 PUT CHARACTERS INTO FILE 23330000 LTR R7,R7 CHECK FOR NO ERROR 23340000 BZ OKWR NO ERROR 23350000 MVI STATE,C'A' ABORT ON FILE SYSTEM ERROR 23360000 B RLOOP 23370000 OKWR MVI STYPE,AY ACK PACKET 23380000 XC LSDAT,LSDAT NO DATA 23390000 L R15,=A(SPACK) 23400000 BALR R14,R15 23410000 CLI STATE,C'A' 23420000 BE RABORT 23430000 MVC OLDTRY(4),NUMTRY SAVE NUMTRY'S VALUE IN OLDTRY 23440000 XC NUMTRY,NUMTRY RESET NUMTRY 23450000 L R3,N 23460000 LA R3,1(R3) 23470000 ST R3,N INCREMENT COUNTER 23480000 NC N(4),=X'0000003F' MASK TO GET MOD 64 23490000 B RLOOP 23500000 DIF CLC OLDTRY,MAXTRY CAN WE DO IT? 23510000 BL DIFNUM 23520000 MVI STATE,C'A' AND ABORT 23530000 B RLOOP 23540000 DIFNUM L R4,OLDTRY 23550000 LA R4,1(R4) 23560000 ST R4,OLDTRY INCREMENT THIS COUNTER 23570000 L R4,N 23580000 BCTR R4,0 23590000 C R4,NUM NUM MUST EQUAL N-1 23600000 BE DIFOK 23610000 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 23620000 B RDN1 SEND A NAK 23630000 DIFOK XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 23640000 MVI STYPE,AY ACK PACKET 23650000 XC LSDAT,LSDAT NO DATA 23660000 ST R4,N SET N TO N-1 TO RESEND PACKET 23670000 L R15,=A(SPACK) 23680000 BALR R14,R15 SEND THE PACKET 23690000 CLI STATE,C'A' 23700000 BE RABORT 23710000 L R4,N 23720000 LA R4,1(R4) ADD ONE 23730000 ST R4,N RESTORE N TO PROPER VALUE 23740000 B RLOOP AND RETURN 23750000 RDF CLI RTYPE,AF SENDING FILENAME AGAIN? 23760000 BNE RDZ 23770000 CLC OLDTRY,MAXTRY CAN WE DO IT? 23780000 BL FILOVER TRYING IT AGAIN 23790000 MVI STATE,C'A' IF NO, ABORT 23800000 B RLOOP 23810000 FILOVER L R4,OLDTRY 23820000 LA R4,1(R4) 23830000 ST R4,OLDTRY SAVE INCREMENTED VALUE 23840000 L R4,N 23850000 BCTR R4,0 NEED VALUE OF N-1 23860000 C R4,NUM N-1 MUST EQUAL NUM 23870000 BE FILOK 23880000 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 23890000 B RDN1 SEND A NAK 23900000 FILOK XC NUMTRY,NUMTRY RESET TO ZERO 23910000 XC LSDAT,LSDAT NO DATA 23920000 MVI STYPE,AY ACK PACKET AGAIN 23930000 ST R4,N SET N TO N-1 FOR NOW 23940000 OVRWRT L R15,=A(SPACK) 23950000 BALR R14,R15 23960000 CLI STATE,C'A' 23970000 BE RABORT 23980000 L R4,N 23990000 LA R4,1(R4) ADD ONE 24000000 ST R4,N RESTORE N TO PROPER VALUE 24010000 B RLOOP AND RETURN 24020000 RDZ CLI RTYPE,AZ IS THIS AN EOF PACKET? 24030000 BNE RDN 24040000 CLC N,NUM ARE THEY EQUAL 24050000 BE RDOK 24060000 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 24070000 B RDN1 SEND A NAK 24080000 RDOK MVI STYPE,AY ACK THE PACKET 24090000 XC LSDAT,LSDAT NO DATA 24100000 L R15,=A(SPACK) 24110000 BALR R14,R15 24120000 MVC OLDTRY(4),NUMTRY SAVE NUMTRY'S VALUE HERE 24130000 XC NUMTRY,NUMTRY AND RESET COUNTER 24140000 L R3,N 24150000 LA R3,1(R3) 24160000 ST R3,N STORE VALUE INCREMENTED BY 1 24170000 NC N(4),=X'0000003F' MASK TO GET MOD 64 24180000 MVI STATE,C'F' TRY FOR ANOTHER FILE 24190000 B RLOOP 24200000 RDN CLI RTYPE,AN DO WE NEED TO SEND A NAK? 24210000 BNE RDELSE 24220000 RDN1 MVI STYPE,AN SEND A NAK 24230000 XC LSDAT,LSDAT NO DATA 24240000 L R15,=A(SPACK) 24250000 BALR R14,R15 24260000 B RLOOP 24270000 RDELSE MVI STATE,C'A' UNRECOGNIZED PACKET - ABORT 24280000 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 24290000 B RLOOP 24300000 SAYNO MVI STYPE,AN SEND A NAK PACKET 24310000 XC LSDAT,LSDAT NO DATA 24320000 MVI ERRNUM,X'0B' ILLEGAL FILENAME ERROR 24330000 L R15,=A(SPACK) 24340000 BALR R14,R15 24350000 B RLOOP 24360000 ********************************************************************** 24370000 * RECEIVE ABORT PROCESS * 24380000 ********************************************************************** 24390000 RABORT DS 0H 24400000 CLI ERRNUM,X'0A' DID THE MICRO DIE? 24410000 BE RNOERRP NO ERROR PACKET IF SO 24420000 MVI STYPE,AE ERROR PACKET 24430000 MVC LSDAT(4),=F'20' ALL MSGS ARE THIS LONG 24440000 MVC N(4),NUM SYNCH PACKET NUMBERS 24450000 SR R5,R5 24460000 IC R5,ERRNUM 24470000 M R4,=F'20' OFFSET := ERRNUM * 20 24480000 LA R5,ERRTAB(R5) 24490000 MVC SDAT(20),0(R5) SPACK NEEDS THE DATA HERE 24500000 TR SDAT(20),ETOA 24510000 L R15,=A(SPACK) 24520000 BALR R14,R15 SEND ERROR PACKET & DIE 24530000 RNOERRP LA R15,4 SET A NON-ZERO RETCODE 24540000 B RECRET PREPARE TO LEAVE 24550000 ********************************************************************** 24560000 * RECEIVE COMPLETE PROCESS * 24570000 ********************************************************************** 24580000 RCOMP SR R15,R15 RETCODE OF ZERO 24590000 RECRET L R13,4(R13) 24600000 L R14,12(R13) 24610000 LM R0,R12,20(R13) 24620000 BR 14 24630000 EJECT 24640000 ********************************************************************** 24650000 * * 24660000 * ROUTINE TO PUT A CHARACTER IN OUTPUT BUFFER AND DUMP WHEN FULL * 24670000 * * 24680000 ********************************************************************** 24690000 PTCHR SR R4,R4 COXPAHñEM QUOTE 24700000 SR R6,R6 COXPAHñEM LRECL 24710000 SR R8,R8 õKAúATEìø B RDAT 24720000 L R9,RSAVPL õKAúATEìø B RBUF 24730000 IC R4,RQUO 24740000 IC R6,LRECL 24750000 L R5,LRDAT COUNTER TO GET ALL DATA 24760000 RLUP SR R7,R7 USE TO PICK UP CHAR 24770000 LTR R5,R5 MORE DATA LEFT? 24780000 BNZ MOR LEAVE IF ALL DONE 24790000 TM FLAGS,BINF FILE BINARY ? J 24800000 BE ST9RS YES - SKEEP EOREC. PROC. J 24810000 CLI PREV,X'4D' ARE WE IN MIDDLE OF LINE? 24820000 BER R14 LEAVE IF NOT 24830000 ST9RS ST R9,RSAVPL SAVE OUR PLACE 24840000 SR R7,R7 ZERO RETCODE 24850000 BR R14 24860000 MOR BCTR R5,0 DECREMENT CHAR COUNTER 24870000 XC PADD(4),PADD FOR 8-BIT QUO J 24880001 SR R1,R1 WORK REGISTER J 24890000 IC R7,RDAT(R8) âEPEM CéMBOì 24900000 * ****** J BEGIN ******** 24910000 CLI EBQUOT,AN COçìACOBAHA PAâOTA C 8-âéT ? 24920000 BE TESTCQ HET 24930000 CLI EBQUOT,AY COçìACOBAHA PAâOTA C 8-âéT ? 24940000 BE TESTCQ HET 24950000 SR R1,R1 8-BIT QUOTING IS POSSIBLE 24960000 IC R1,EBQUOT úAçPõöAEM PREF 8 âéTA 24970000 CR R7,R1 ðOìõþEH PREF ? 24980000 BNE TESTCQ HET 24990000 * ****** R BEGIN ******** 25000001 OI PADD+3,X'80' úAðOMHéM, þTO âùì PREF 25010001 BCTR R5,0 ELSE - SKEEP QUOTE 25020000 LA R8,1(R8) AäPEC CìEä. CéMBOìA 25030000 IC R7,RDAT(R8) âEPEM CìEä. CéMBOì 25040000 TESTCQ CR R7,R4 ðOìõþEH QUOTE ? 25050001 BNE REGULAR HET 25060001 BCTR R5,0 DECREMENT CHAR COUNT 25070000 LA R8,1(R8) MOVE POINTER 25080000 IC R7,RDAT(R8) âEPEM CéMBOì ðOCìE QUOTE 25090001 **** ðPOBEPKA CR LF B TEKCTOBOM æAêìE 25100001 TM FLAGS,BINF IS FILE BINARY J 25110000 BNZ NOLF YES - SKEEP CR & LF PROC. J 25120000 TM PADD+3,X'80' ðEPEä QUOTE âùì PREF ? R 25130001 BO NOLF äA R 25140001 C R7,=X'0000004D' IS IT A CR? (CHAR(CR)) 25150000 BNE NOCR WRITE OUT RECORD IF YES 25160000 MVI PREV,X'4D' JUST HAD A CR 25170000 LA R8,1(R8) IGNORE CONTROL CHAR 25180000 B RFIN 25190000 NOCR C R7,=X'0000004A' HOW ABOUT A LF? (CHAR(LF)) 25200000 BNE NOLF IF YES, WRITE OUT RECORD 25210000 LA R8,1(R8) IGNORE CONTROL CHAR 25220000 CLI PREV,X'4D' WAS LAST THING CR? 25230000 BNE RFIN NOPE, THEN KEEP ON 25240000 B RLUP IGNORE LF IF PREV=CR 25250000 **** 25260001 NOLF CR R7,R4 QUOTE ? 25270001 BE REGULAR äA, BùBOäéM QUOTE 25280001 LTR R1,R1 ECTø ðPEæéKCAãéñ 8 âéTA ? J 25290001 BZ AR7O1H HET J 25300001 CR R7,R1 üTO PREF 8 âéTA ? J 25310001 BE REGULAR äA, BùBOäéM PREF J 25320001 AR7O1H A R7,O1H FUNCTION CTL(X) 25330001 N R7,=X'0000007F' çACéM BCE, KPOME CEMé âéT 25340001 REGULAR O R7,PADD ADD 8 BIT IF IT'S NEED ***J END 25350000 STC R7,RBUF(R9) STORE CHAR IN RBUF 25360000 LA R9,1(R9) MOVE RBUF COUNTER 25370000 LA R8,1(R8) MOVE RDAT COUNTER 25380000 MVI PREV,X'00' BLANK OUT CR IF WAS THERE 25390000 C R9,=F'255' ONLY 256 CHARS ALLOWED 25400000 BNH RLUP AND CONTINUE 25410000 LR R10,R9 USE MAX LENGTH OF 256 25420000 B WRFIL AND WRITE TO FILE 25430000 RFIN LTR R10,R9 GET DATA SIZE 25440000 BZ FUDGE GOTTA FAKE A BLANK LINE 25450000 C R7,=X'0000004D' IS IT A CR? (CHAR(CR)) 25460000 BE WRFIL 25470000 C R7,=X'0000004A' HOW ABOUT A LF? (CHAR(LF)) 25480000 BE WRFIL 25490000 ST R10,RSAVPL SAVE DATA RECEIVED SO FAR 25500000 SR R7,R7 ZERO RETCODE 25510000 BR 14 25520000 FUDGE MVI RBUF,X'20' MAKE FIRST CHAR A SPACE 25530000 LA R10,1(R10) LENGTH OF ONE 25540000 WRFIL XC RSAVPL,RSAVPL RESET THE POINTER 25550000 TM FLAGS,BINF IZ FILE BINARY ? J 25560000 BNZ CRR10 YES - NO TRANSLATE J 25570000 L R15,TRTADDR CURRENT TRAN TABLE ADDR J 25580000 TR RBUF(256),0(R15) MAKE EBCDIC AGAIN J 25590000 B WRCONT SAME CONT J 25600000 CRR10 CR R10,R6 PART LT BLKSIZE J 25610000 BL STR10 NOW SKIP WRITE J 25620000 WRTRY ST R10,SAVR10 TEMPORARY SAVE J 25630000 LR R10,R6 LENGHTH = BLKSIZE J 25640000 LA R15,WRITEX J 25650000 BALR R15,R15 WRITE RECORD J 25660000 L R10,SAVR10 RETURN R10 J 25670000 SR R10,R6 J 25680000 BE STR10 J 25690000 BCTR R10,0 FOR EX COM. J 25700000 LA R15,RBUF(R6) J 25710000 MVC RBUF(*-*),0(R15) TO BEGIN OF BUF. J 25720000 EX R10,*-6 J 25730000 LA R10,1(R10) RETURN LEN J 25740000 CR R10,R6 GRATER THEN LRECL ? J 25750000 BNL WRTRY YES,NEXT WRITE J 25760000 STR10 ST R10,RSAVPL SHORT PART - CONTINUE J 25770000 LR R9,R10 RESTORE BUF. POINTER (!!) J 25780000 B RLUP J 25790000 WRCONT CLI RFM,C'V' IS IT VARIABLE FORMAT ? J 25800000 BE VAR 25810000 CR R10,R6 PAD OUT TO LRECL SIZE ? 25820000 BE VAR NOPE, IT'S OK. 25830000 BNL PUR J 25840000 LR R2,R6 GET LRECL SIZE 25850000 SR R2,R10 PAD WITH THIS MANY SPACES 25860000 BCTR R2,0 MINUS ONE FOR THE 'EX' 25870000 LA R9,RBUF(R10) START PADDING HERE 25880000 MVI 0(R9),C' ' PUT IN THE FIRST SPACE 25890000 LTR R2,R2 25900000 BZ PUR DON'T PAD IF SIZE DIF WAS ONE 25910000 BCTR R2,0 SUBRTRACT SPACE WE JUST ADDED 25920000 EX R2,PAD PAD OUT BUFFER 25930000 PUR LR R10,R6 LENGTH HAS TO BE THIS SIZE 25940000 VAR DS 0H RJR 25950000 LA R15,WRITEX 25960000 BALR R15,R15 25970000 SR R9,R9 START AT BEGINNING OF RBUF 25980000 B RLUP GET NEXT LINE IF OK 25990000 RECSAVE DS 18F 26000000 PAD MVC 1(0,R9),0(R9) PAD OUT WITH SPACES 26010000 LTORG 26020000 * 26030000 EJECT 26040000 ********************************************************************** 26050000 * * 26060000 * DISK FILE WRITE ROUTE WITH DEBUGGING CODE * 26070000 * * 26080000 ********************************************************************** 26090000 WRITEX DS 0H 26100000 USING PARMS,R11 26110000 STM R12,R15,WRITSAVE 26120000 BALR R12,0 26130000 USING *,R12 26140000 LA R0,RBUF POINT TO RBUF 26150000 TM KEROUT+(DCBRECFM-IHADCB),DCBRECV VARIABLE? 26160000 BZ WRITEX2 NO, THEN DON'T ADJUST 26170000 LA R0,RBUF-4 POINT TO RDW 26180000 LR R15,R10 GET THE LENGTH 26190000 AH R15,=H'4' INCLUDE LENGTH OF RDW 26200000 SR R1,R1 26210000 STH R1,RBUF-2 CLEAR RDW 26220000 IC R1,LRECL GET LRECL 26230000 CR R15,R1 IS THE RECORD GT MAX LRECL? 26240000 BNH *+6 NO, THEN IT'S OK 26250000 LR R15,R1 ELSE SET TO MAX 26260000 STH R15,RBUF-4 26270000 WRITEX2 DS 0H 26280000 PUT KEROUT,(R0) 26290000 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 26300000 BZ WRNODBG 26310000 MVC WRKBUFF(2),=H'12' 26320000 XC WRKBUFF+2(2),WRKBUFF+2 26330000 MVC WRKBUFF+4(8),=CL8'QSAM PUT' 26340000 PUT DEBUG,WRKBUFF 26350000 EX R10,DBGMVC4 26360000 LA R1,4(,R10) 26370000 STH R1,WRKBUFF 26380000 PUT DEBUG,WRKBUFF 26390000 WRNODBG LM R12,R15,WRITSAVE 26400000 BR R15 26410000 DBGMVC4 MVC WRKBUFF+4(*-*),RBUF 26420000 DROP R11 26430000 DROP R12 26440000 LTORG 26450000 EJECT 26460000 ********************************************************************** 26470000 * J (BEGIN) * 26480000 * ROUTINE TO SET 8 - BIT QUOTE CHARACTER DEPENDING ON MY * 26490000 * OUN CAPABILITIES AND THE OT HER KERMIT'S REQUEST * 26500003 * * 26510000 ********************************************************************** 26520000 DOQUO DS 0H 26530000 STM R14,R12,12(R13) 26540000 BALR R12,0 26550000 USING *,R12 26560000 LA R14,DQSAVE 26570000 ST R13,4(R14) 26580000 ST R14,8(R13) 26590000 LR R13,R14 26600000 L R11,=A(PARMS) GET ADDRESS OF WORKAREAS 26610000 USING PARMS,R11 26620000 LA R7,RDAT POINT TO DATA BUFFER 26630000 CLI EBQUOT,AN CAN I DO 8-BIT QUOTING ? 26640000 BE DQRET NO - SO FORGET IT 26650000 CLI EBQUOT,AY CAN I DO IT IF REQUIRED ? 26660000 BNE DQ0 NO - I MUST QUOTE 26670000 MVC EBQUOT(1),6(R7) SET NEW BIT QUOTE CHAR 26680000 SR R3,R3 26690000 IC R3,EBQUOT 26700000 * QUOT CHAR CHECKING 26710000 C R3,=F'33' 26720000 BNL PREC0 26730000 B DQ1 26740000 PREC0 C R3,=F'62' 26750000 BH PREC1 26760000 B PREC5 26770000 PREC1 C R3,=F'96' 26780000 BNL PREC2 26790000 B DQ1 26800000 PREC2 C R3,=F'126' 26810000 BNH PREC5 26820000 PREC5 DS 0H CHAR IS GOOD 26830000 CLC EBQUOT(1),QUOCHAR SAME ? 26840000 BE DQ1 26850000 * CLC EBQUOT(1),SQUOTE 26860000 * BE DQ1 26870000 B DQRET 26880000 DQ0 CLI 6(R7),AY I NEED QUOT, CAN HI DO IT ? 26890000 BE DQRET 26900000 CLI 6(R7),AN HE CANT DO IT, DON'T QUOTE 26910000 BE DQ1 26920000 CLC EBQUOT(1),6(R7) QUOT CHARS MAST MATCH 26930000 BE DQRET 26940000 DQ1 MVI EBQUOT,AN ELSE, FORGET THE QUOTING 26950000 DQRET L R13,4(R13) 26960000 L R14,12(R13) 26970000 LM R0,R12,20(R13) 26980000 BR 14 26990000 DQSAVE DS 18F SAVE AREA J (END) 27000000 DROP R11 27010000 DROP R12 27020000 LTORG 27030000 EJECT 27040000 ********************************************************************** 27050000 * * 27060000 * ROUTINE TO PARSE COMMANDS AND CREATE PARSE TABLE * 27070000 * * 27080000 ********************************************************************** 27090000 PARSER STM R14,R12,12(R13) SAVE REGISTERS 27100000 LR R12,R15 MOVE THE BASE REGISTER 27110000 USING PARSER,R12 ## 27120000 L R11,=A(PARMS) GET ADDRESS OF WORKAREAS 27130000 USING PARMS,R11 27140000 LR R3,R0 R3 = TEXT LENGTH 27150000 BCTR R1,0 R1 ==> BYTE BEFORE PARM 27160000 LA R3,0(R1,R3) R3 ==> END OF LINE 27170000 LA R2,1 R2 = PARSING INCREMENT 27180000 LA R5,PTRTBL R5 ==> TARGET AREA 27190000 LA R6,4 R6 = POINTER INCREMENT 27200000 STM R5,R6,PARSELST SAVE FOR PARSING 27210000 LA R7,PTRTBL+PTRTBLL-4 R7 ==> END OF TARGET 27220000 * 27230000 SCNTOKEN BXH R1,R2,SCNFINIS SCAN FOR PARM START 27240000 CLI 0(R1),C' ' FOUND A BLANK? 27250000 BE SCNTOKEN YES, THEN KEEP LOOKING 27260000 ST R1,0(,R5) SAVE PTR TO OPERAND 27270000 BXH R5,R6,SCNFINIS BR ON END OF TARGET AREA 27280000 SCNLASTC BXH R1,R2,SCNFINIS SCAN TO END OF OPERAND 27290000 CLI 0(R1),C' ' IS THIS BLANK AT END OF OPERAND 27300000 BNE SCNLASTC IF SO, MOVE TOKEN 27310000 LR R9,R1 REMEMBER JUST AFTER OPERAND 27320000 B SCNTOKEN FIND START OF NEXT OPERAND 27330000 SCNFINIS MVI 0(R9),C' ' MARK THE END OF OPERANDS 27340000 ST R9,0(R5) SAVE POINTER TO END 27350000 ST R5,PARSELST+8 SAVE END TARGET 27360000 LM R14,R12,12(R13) RESTORE THE REGISTERS 27370000 BR R14 RETURN TO CALLER 27380000 LTORG 27390000 DROP R11 27400000 DROP R12 DON'T NEED THEM ANYMORE 27410000 EJECT 27420000 PARMS DS 0H GLOBAL DATA LIST 27430000 USING PARMS,R11 27440000 SNDPKT DS CL130 SEND THIS TO MICRO 27450000 ORG SNDPKT 27460000 *HDR DS X WAS PHDR Z 27470000 PLEN DS X 27480000 PNUM DS X 27490000 PTYPE DS X 27500000 PDATA DS 0C 27510000 ORG , 27520000 RECPKT DS CL130 RECEIVE THIS FROM MICRO 27530000 LSDAT DS F SEND PACKET SIZE 27540000 LRDAT DS F RECEIVE PACKET SIZE 27550000 FLAGS DC X'00' USE TO TEST OUR FLAGS 27560000 NAME DC 18X'20' NAME OF FILE(S) TO SEND 27570000 DS 0F 27580000 DS 0F 27590000 INPUT DS CL130 INPUT BUFFER 27600000 DS 0F 27610000 DS F RDW FOR VARIABLE RECORDS 27620000 BUF DS CL260 DISK READ INTO HERE 27630000 DS F RDW FOR VARIABLE RECORDS 27640000 RBUF DS CL260 DISK WRITE FROM HERE 27650000 N DC F'0' SEND PACKET NUMBER 27660000 NUM DC F'0' RECEIVE PACKET NUMBER 27670000 NUMTRY DC F'0' TRIAL COUNTER FOR TRANSFERS 27680000 OLDTRY DS F COUNTER FOR PREVIOUS PACKET 27690000 STORLOC DS F POINTER TO EXTRA STORAGE 27700000 MAXPACK DC F'94' MAX PACKET SIZE 27710000 RECL DS F RECORD LEN (IF RECFM = V) 27720000 RPSIZ DC F'94' MAX RECEIVE PACKET SIZE 27730000 DSSIZ DC F'40' DEFAULT MAX SEND PACKET SIZE 27740000 SPSIZ DS F SEND PACKET SIZE 27750000 MAXTRY DC F'5' NO. OF TIMES TO RETRY PACKET 27760000 IMXTRY DC F'16' NO. OF INITIAL TRIALS ALLOWED 27770000 SIZE DS F MAX SIZE FOR SEND DATA 27780000 DEL DC F'127' OCTAL 177 (DELETE CHAR) 27790000 ZERO DC F'0' 27800000 ONE DC F'1' 27810000 FIVE DC F'5' 27820000 TWO DC F'2' 27830000 SPACE DC F'32' ASCII SPACE 27840000 O1H DC F'64' OCTAL 100 27850000 O2H DC F'128' OCTAL 200 27860000 SAVPL DC F'0' POINTER WITHIN BUF,INIT=0 27870000 RSAVPL DC F'0' POINTER IN 'PTCHR',INIT=0 27880000 DQUOTE DC X'23' DEFAULT QUOTE CHARACTER = # 27890000 QUOCHAR DS X QOUTE CHAR WE'LL SEND 27900000 RQUO DS X MICRO'S QUOTE CHAR 27910000 EBQUOT DS X 8-BIT QUOTING CHAR J 27920000 ORIG8Q DS X ORIGINAL 8-BIT QUOTING CHAR J 27930000 TEMP DS F TEMPORARY SPACE 27940000 DS 0D 27950000 PKVAR DS D USE FOR PICKING UP INTEGER 27960000 SDAT DS CL130 TEMP PLACE FOR SEND DATA 27970000 RDAT DS CL130 TEMP PLACE FOR RECEIVE DATA 27980000 FILNAML DS H LENGTH OF FILENAME 27990000 FILNAM DS CL18 SEND/REC FILENAME 28000000 STATE DS C OUR CURRENT STATE 28010000 DEOL DC X'04' DEFAULT END OF PACKET (EOT) Z 28020000 REOL DS X EOL CHAR I NEED (CR) 28030000 SEOL DS X EOL I'LL SEND 28040000 DSOH DC X'01' DEFAULT START OF HEADER (CTL A) 28050000 RSOH DS X RECEIVE START OF HEADER 28060000 SSOH DS X SEND START OF HEADER 28070000 DLRECL DC X'50' DEFAULT LRECL SIZE OF 80 28080000 LRECL DS X LRECL PROGRAM WILL USE 28090000 DBLKSIZE DC H'80' DEFAULT BLKSIZE OF 80 28100000 BLKSIZE DS H BLKSIZE PROGRAM WILL USE 28110000 DTRACK DC F'5' DEFAULT SPACE ALLOCATION 28120000 DRECFM DC C'F' DEFAULT WITH FIXED RECFM 28130000 RFM DS C RECFM PROGRAM WILL USE 28140000 PREV DS C PREVIOUS CHAR REC (IN PTCHR) 28150000 BLIP DS X SAVE USER'S BLIP CHAR 28160000 LINSIZ DS F SAVE USER'S CONSOLE LINESIZE 28170000 ERRNUM DS X ERROR NUMBER,IN CASE WE DIE 28180000 OLDERR DS X ERROR OF PREVIOUS EXECUTION 28190000 STYPE DS C TYPE OF PACKET SENT 28200000 RTYPE DS C TYPE OF PACKET RECEIVED 28210000 * 28220000 READSAVE DS 4F 28230000 WRITSAVE DS 4F 28240000 SAVR6 DS F J 28250000 SAVR10 DS F FOR TEMPORARY SAVE OF R10 J 28260000 PADD DS F PAD FOR 8-BIT QUOT AT READ J 28270000 TRTBLDL DC H'1,12' 28280000 TRTNAME DC CL8'STANDARD',CL4' ' 28290000 TRTADDR DC A(ATOE8) 28300000 PARSELST DS 3F PTRS TO OPERAND STACK 28310000 PTRTBL DS 15F OPERAND STACK 28320000 PTRTBLL EQU *-PTRTBL LENGTH OF PTRTBL 28330000 DBLWRK DS D 28340000 IDSYS DC F'2' MVS TSO 28350000 DDNAME DC CL8' ' DDNAME TO ALLOCATE 28360000 DSNAME DC CL80' ' DSNAME TO ALLOCATE 28370000 DSNAMEX DC CL80' ' WRKBUFFER 28380000 MEMBER DC CL8' ' MEMBER NAME FOR PDS ALLOC 28390000 CMSXXX DC CL8' ' USED IN CMS ONLY 28400000 CMSYYY DC CL8' ' 28410000 CMSZZZ DC CL2' ' 28420000 DISP1 DC F'2' DISP (0=NEW,1=OLD,2=SHR) 28430000 DISP2 DC F'3' DISP (0=UNCAT,1=CAT,3=KEEP) 28440000 INOUT DC F'2' 0=INPUT,1=OUTPUT,2=INOUT) 28450000 RECFMX DC F'1' 1=FB,2=VBS 28460000 BLKSIZEX DC F'3600' FOR NEW DATA SETS ONLY 28470000 LRECLX DC F'80' .... 28480000 DEV DC CL8'SYSDA' DEVICE 28490000 TRACK DC F'20' # TRACKS TO ALLOC FOR NEW DSETS 28500000 DYNALCRC DC F'0' RETURN CODE FROM FUNCTION 28510000 WRKBUFF DS CL280 28520000 PREFIX DC CL8' ' USERS DSET PREFIX FROM UPT 28530000 PREFIXL DC F'0' PREFIX LENGTH-1 28540000 DDELAY DC F'2000' DEFAULT DELAY TIME 28550000 DELAY DS F DELAY TIME 28560000 PUTGET PUTGET OUTPUT=(OLD,SINGLE,MODE),TERMPUT=ASIS,MF=L J 28570000 ECBPTGT DC F'0' ECB FOR IOPL J 28580000 OLD DC A(1,*+4),H'17,0',CL13' KERMIT-TSO>' OUTPUT STRING J 28590003 IOPLL DC 4F'0' IOPL J 28600000 * 28610000 * THIS IS THE DYNALC PARM LIST USED FOR BOTH ALLOCATION AND 28620000 * CREATION OF DATA SETS. 28630000 * 28640000 DYNAPARM DS 0F 28650000 DC A(IDSYS,DDNAME,DSNAME,MEMBER,CMSXXX,CMSYYY,CMSZZZ,DISP1,DISP2) 28660000 DC A(INOUT,RECFMX,BLKSIZEX,LRECLX,DEV,TRACK) 28670000 DC X'80',AL3(DYNALCRC) 28680000 * 28690000 * TABLE TO TRANSLATE TO UPPER CASE 28700000 * 28710000 UPPER DC 256AL1(*-UPPER) 28720000 ORG UPPER+X'81' 28730000 DC C'ABCDEFGHI' 28740000 ORG UPPER+X'91' 28750000 DC C'JKLMNOPQR' 28760000 ORG UPPER+X'A2' 28770000 DC C'STUVWXYZ' 28780000 ORG 28790000 * THIS IS THE ASCII TO EBCDIC TABLE TRUNCATED (RUSSIAN DKOI) Z 28800000 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 28810000 ATOE DC X'00010203372D2E2F1605250B0C0D0E0F' 0 28820000 DC X'101112133C3D322618193F271C1D1E1F' 1 28830000 DC X'404F7F7B5B6C507D4D5D5C4E6B604B61' 2 28840000 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 3 28850000 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 4 28860000 DC X'D7D8D9E2E3E4E5E6E7E8E94AE05A5F6D' 5 28870000 DC X'B8B9BABBBCBDBEBFCACBCCCDCECFDADB' 6 28880000 DC X'DCDDDEDFEAEBECEDEEEFFAFBFCFDFEFF' 7 28890000 *THIS IS THE EBCDIC TO ASCII CONVERSION TABLE 28900000 *CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL 28910000 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 28920000 ETOA DC X'00010203905C867F0000000B0C0D0E0F' 0 Z 28930000 DC X'101112139D0A0000181992001C1D1E1F' 1 28940000 DC X'80818200840A171B00008A0000050607' 2 28950000 DC X'0000160094959604000000001415001A' 3 28960000 DC X'200000000000000000005B2E3C282B21' 4 28970000 DC X'260000000000000000005D242A293B5E' 5 28980000 DC X'2D2F00000000000000007C2C255F3E3F' 6 28990000 DC X'000000000027606162203A2340273D22' 7 29000000 DC X'63414243444546474849646566676869' 8 29010000 DC X'6A4A4B4C4D4E4F5051526B6C6D6E6F70' 9 29020000 DC X'7100535455565758595A727374757677' A 29030000 DC X'78797A7B7C7D7E276061626364656667' B 29040000 DC X'2841424344454647484968696A6B6C6D' C 29050000 DC X'294A4B4C4D4E4F5051526E6F70717273' D 29060000 DC X'5C00535455565758595A747576777879' E 29070000 DC X'303132333435363738397A7B7C7D7E7F' F 29080000 * ASCII TO EBCDIC TEXT FILE TABLE 29090000 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 29100000 ATOE8 DC X'00010203372D2E2F1605250B0C0D0E0F' 0 29110000 DC X'101112133C3D322618193F271C1D1E1F' 1 29120000 DC X'404F7F7B5B6C507D4D5D5C4E6B604B61' 2 29130000 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 3 29140000 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 4 29150000 DC X'D7D8D9E2E3E4E5E6E7E8E94AE05A5F6D' 5 29160000 DC X'B8B9BABBBCBDBEBFCACBCCCDCECFDADB' 6 29170000 DC X'DCDDDEDFEAEBECEDEEEFFAFBFCFDFEFF' 7 29180000 DC X'3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F' 8 29190000 DC X'3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F' 9 29200000 DC X'3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F' A 29210000 DC X'3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F' B 29220000 DC X'3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F' C 29230000 DC X'3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F' D 29240000 DC X'3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F' E 29250000 DC X'3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F3F' F 29260000 * EBCDIC TO ASCII TEXT FILE TABLE 29270000 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 29280000 ETOA8 DC X'000102039009867F0000000B0C0D0E0F' 0 Z 29290000 DC X'101112139D0A0000181992001C1D1E1F' 1 29300000 DC X'80818200840A171B00008A0000050607' 2 29310000 DC X'0000160094959604000000001415001A' 3 29320000 DC X'200000000000000000005B2E3C282B21' 4 29330000 DC X'260000000000000000005D242A293B5E' 5 29340000 DC X'2D2F00000000000000007C2C255F3E3F' 6 29350000 DC X'000000000027606162203A2340273D22' 7 29360000 DC X'63414243444546474849646566676869' 8 29370000 DC X'6A4A4B4C4D4E4F5051526B6C6D6E6F70' 9 29380000 DC X'7100535455565758595A727374757677' A 29390000 DC X'78797A7B7C7D7E276061626364656667' B 29400000 DC X'2841424344454647484968696A6B6C6D' C 29410000 DC X'294A4B4C4D4E4F5051526E6F70717273' D 29420000 DC X'5C00535455565758595A747576777879' E 29430000 DC X'303132333435363738397A7B7C7D7E7F' F 29440000 * 29450000 * TABLE OF ERROR MESSAGES (IN CASE WE ABORT) 29460000 ERRTAB DC CL20'BAD SEND-PACKET SIZE' ERR MSG #0 29470000 DC CL20'BAD MESSAGE NUMBER' ERR MSG #1 29480000 DC CL20'UNRECOGNIZED STATE' ERR MSG #2 29490000 DC CL20'NO SOH ENCOUNTERED' ERR MSG #3 29500000 DC CL20'BAD CHARACTER COUNT' ERR MSG #4 29510000 DC CL20'BAD CHECKSUM' ERR MSG #5 29520000 DC CL20'DISK IS FULL' ERR MSG #6 29530000 DC CL20'ILLEGAL PACKET TYPE' ERR MSG #7 29540000 DC CL20'LOST A PACKET' ERR MSG #8 29550000 DC CL20'MICRO SENT A NAK' ERR MSG #9 29560000 DC CL20'MICRO ABORTED' ERR MSG #10 29570000 DC CL20'ILLEGAL FILE NAME' ERR MSG #11 29580000 DC CL20'INVALID LRECL' ERR MSG #12 29590000 DC CL20'PERMANENT I/O ERROR' ERR MSG #13 29600000 DC CL20'DISK IS READ-ONLY' ERR MSG #14 29610000 DC CL20'RECFM CONFLICT' ERR MSG #15 29620000 DC CL20'ERR ALLOCATING SPACE' ERR MSG #16 29630000 DATASET CAMLST NAME,DSNAME,,WRKBUFF 29640000 KERIN DCB DDNAME=KERIN,DSORG=PS,MACRF=(GM), X29650000 EODAD=INEOF 29660000 KEROUT DCB DDNAME=KEROUT,DSORG=PS,MACRF=(PM),LRECL=80,BLKSIZE=84, X29670000 RECFM=VB 29680000 DEBUG DCB DDNAME=DEBUG,DSORG=PS,MACRF=(PM),LRECL=260,BLKSIZE=2048, X29690000 RECFM=VB 29700000 MODDCBF DCB DDNAME=KEROUT,DSORG=PS,MACRF=(PM),LRECL=80,BLKSIZE=80, X29710000 RECFM=FB 29720000 MODDCBFL EQU *-MODDCBF 29730000 MODDCBV DCB DDNAME=KEROUT,DSORG=PS,MACRF=(PM),LRECL=80,BLKSIZE=84, X29740000 RECFM=VB 29750000 MODDCBVL EQU *-MODDCBV 29760000 END KERMIT 29770003