Columbia Kermit

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

/ Columbia Kermit / kermit.zip / guts / guts.asm next >

Wrap

Assembly Source File | 2020-01-01 | 218KB | 2,693 lines

KERMIT TITLE 'KERMIT-IBM' 00000010 MACRO 00000020 REGISTER 00000030 LCLA &N 00000040 SPACE 00000050 ***********************************************************************00000060 * GENERAL REGISTER EQUATES *00000070 ***********************************************************************00000080 SPACE 00000090 &N SETA 0 00000100 .LOOP ANOP 00000110 R&N EQU &N 00000120 AIF (&N EQ 15).OUT 00000130 &N SETA &N+1 00000140 AGO .LOOP 00000150 .OUT ANOP 00000160 SPACE 00000170 MEND 00000180 MACRO 00000190 &LABEL BINCVRT ®,&AREA,&DBLWRK 00000200 .* 00000210 .* CONVERT THE CONTENTS OF ® TO DECIMAL AND EDIT INTO &AREA. 00000220 .* &AREA IS A FIELD OF LENGTH SIX THAT WILL CONTAIN THE INTEGER 00000230 .* STRING WITH LEADING BLANKS SUPRESSED. &DBLWRK IS A DOUBLE 00000240 .* WORK SPACE. 00000250 .* 00000260 &LABEL CVD ®,&DBLWRK 00000270 MVC &AREA.(6),=X'402020202120' 00000280 ED &AREA.(6),&DBLWRK+5 00000290 MEND 00000300 MACRO 00000310 &LAB WRTERM &MSG 00000320 LCLC &MS 00000330 LCLA &LN 00000340 &MS SETC '&MSG' 00000350 &LN SETA K'&MS 00000360 &LN SETA &LN-2 00000370 &LAB TPUT =C&MS,&LN 00000380 MEND 00000390 MACRO 00000400 &LAB PROMPT &MSG 00000410 LCLC &MS 00000420 LCLA &LN 00000430 &MS SETC '&MSG' 00000440 &LN SETA K'&MS 00000450 &LN SETA &LN-2 00000460 &LAB TPUT =C&MS,&LN,ASIS 00000470 MEND 00000480 MACRO 00000490 RDTERM &BUFF 00000500 TGET &BUFF,130 00000510 MEND 00000520 KERMIT CSECT 00000530 ***********************************************************************00000540 * ---------------------------------------- *00000550 * *00000560 * KERMIT/GUTS - *00000570 * *00000580 * Kermit - KL10 Error-free Reciprocol Micro Interface Transfer *00000590 * IBM Version 1.0 *00000600 * *00000610 * This program is the IBM MVS/GUTS side of a file transfer system. *00000620 * It can be used to transfer files between a micro and a system *00000630 * running under MVS/GUTS. *00000640 * See the KERMIT manual for the complete program specifications *00000650 * to which this program and any other component of the system *00000660 * must adhere. *00000670 * *00000680 * Stefan Lundberg, *00000681 * Gothenburg Universities' Computing Centre, *00000682 * Box 19070, *00000683 * S-400 12 Gothenburg, *00000684 * SWEDEN *00000685 * Tel: +46-31810720 *00000686 * ARPA forwarding address: *00000687 * STEFAN_LUNDBERG_GD%QZCOM1MIT-MULTICS.ARPA *00000688 * October 1984 *00000690 * *00000691 * This GUTS version is a modification of the MVS/TSO version *00000692 * written by: *00000693 * Ronald J. Rusnak, University of Chicago Computation Center *00000694 * BITNET address, SYSRONR at UCHIVM1 *00000700 * MAILNET address, SYSTEMS.RON@UCHICAGO.MAILNET *00000710 * ARPA forwarding address, SYSTEMS.RON%UCHICAGO1MIT-MULTICS.ARPA *00000720 * May 1984 *00000730 * *00000740 * Developed by the modification of the IBM CMS version written by *00000750 * Daphne Tzoar, Columbia University Center for Computing Activities *00000760 * March 1982 *00000770 * *00000780 * Copyright (C) 1984 University of Chicago *00000790 * *00000800 * Permission is granted to any individual or institution to copy *00000810 * or use this program, except for explicitly commercial purposes. *00000820 * *00000830 * *00000840 * The following external subroutines are required: *00000850 * -DYNALC - MVS dynamic allocation interface. *00000860 * *00000870 * *00000880 * ---------------------------------------- *00000890 * *00000900 * Note that this is an experimental version; all changes should *00000910 * be forwarded to the author. *00000920 ***********************************************************************00000930 EJECT 00000940 * REGISTER USAGE - 00000950 * R1 - 00000960 * R2 - 00000970 * R3 - 00000980 * R4 - 00000990 * R5 - 00001000 * R6 - 00001010 * R7 - 00001020 * R8 - 00001030 * R9 - 00001040 * R10 - 00001050 * R11 - BASE REGISTER FOR GLOBAL DATA AREA 00001060 * R12 - PROGRAM BASE 00001070 * R13 - SAVE AREA 00001080 * R14 - SUBROUTINE LINKAGE 00001090 * R15 - SUBROUTINE LINKAGE 00001100 * 00001110 SPACE 00001120 PRINT NOGEN 00001130 REGISTER 00001140 IKJCPPL 00001150 IKJUPT 00001160 SPACE 00001170 AD EQU 68 DATA PACKET (ASCII 'D') 00001180 AN EQU 78 NAK 00001190 AZ EQU 90 EOF PACKET 00001200 AS EQU 83 INIT PACKET 00001210 AY EQU 89 ACK 00001220 AF EQU 70 FILE PACKET 00001230 AB EQU 66 BREAK PACKET 00001240 AE EQU 69 ERROR PACKET 00001250 ERCOD EQU 12 MEANS EOF WITH 'FSREAD' 00001260 FLG1 EQU X'80' IS FILE THE FIRST OR NOT 00001270 FLG2 EQU X'40' OVERWRITE SENT FILENAME? 00001280 FLG3 EQU X'20' ONE = SENT ONLY PARTIAL RECORD 00001290 FLG4 EQU X'10' NAK FROM MICRO(0) OR RPACK(1)? 00001300 FLG5 EQU X'08' ALLOCATED MORE SPACE (DMSFREE) 00001310 EJECT 00001320 DCBD DSORG=(PS) 00001330 PSCB PSCB SYS=MVS GET PSCB LAYOUT GUC00001331 EJECT 00001340 ********************************************************************** 00001350 * * 00001360 * KERMIT-GUTS PROGRAM * 00001370 * * 00001380 ********************************************************************** 00001390 KERMIT CSECT 00001400 STM R14,R12,12(R13) 00001410 BALR R12,0 00001420 USING *,R12 00001430 LA R14,KSAVE 00001440 ST R13,4(R14) 00001450 ST R14,8(R13) 00001460 LR R13,R14 00001470 * USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 00001480 L R11,=A(PARMS) 00001490 USING PARMS,R11 00001500 * 00001530 * COLLECT USERS MVS-GUTS PREFIX. 00001540 * AT GUC WE HAVE AN EXIT IN THE DYNALLOC SVC THAT WILL CHANGE 00001541 * THE PREFIX TO WHAT THE GUTS USER HAS SET WITH THE /SET INDEX=... 00001542 * COMMAND. IF YOUR GUTS INSTALLATION DOES'NT HAVE THIS EXIT 00001543 * OR ANY OTHER SOLUTION, THE OSFILE WILL BE CALLED &USERID.filename 00001544 * THIS EXIT WILL BE SUPPLIED WITH VERSION 3.8 OF GUTS. 00001545 * 00001550 L R2,CPPLUPT-CPPL(,R1) GET TO UPT 00001560 XR R3,R3 CLEAR R3 00001570 IC R3,UPTPREFL-UPT(,R2) GET LENGTH 00001580 BCTR R3,0 00001590 ST R3,PREFIXL SAVE FOR LATER 00001600 MVC PREFIX(*-*),UPTPREFX-UPT(R2) MOVE PREFIX 00001610 EX R3,*-6 00001620 * GUC00001621 * GET DEFAULT UNIT FROM PSCB GUC00001622 * GUC00001623 LPSCBP R1,USING GUC00001624 LTR R1,R1 ANY POINTER PRESENT? GUC00001625 BZ NOPSCBP NO, USE SYSDA VALUE GUC00001626 MVC DEV,PSCBGPNM GET WANTED UNIT GUC00001627 DROP R1 GUC00001628 NOPSCBP DS 0H DUMMY LABEL GUC00001630 * THE NEXT THREE LINES WILL CHECK IF THE TERMINAL IS A TTY TERMINAL * 00001631 * THE TTY TERMINAL MUST HAVE SET LC=0 FIRST * 00001632 * DEACTIVATE THE NEXT TREE LINES IF YOU WANT TO TEST WITH A 3270 * 00001633 GTSIZE , GET TERMINAL INFO 00001660 LTR R0,R0 IS THIS A GRAPHICS DEVICE? 00001670 BNZ BADDEV YES, THEN REFUSE USER 00001680 L R15,=A(INIT) 00001690 BALR R14,R15 CALL THE INITIALIZATION 00001700 WRTERM 'KERMIT-GUTS Version 1.00.' 00001710 WRTERM ' ' 00001720 ********************************************************************** 00001730 * * 00001740 * MAIN COMMAND PROCESSING ROUTINE * 00001750 * * 00001760 ********************************************************************** 00001770 PROMPT PROMPT 'KERMIT-GUTS> ' 00001780 RDTERM INPUT 00001790 * 00001800 TR INPUT,UPPER UPPERCASE INPUT 00001810 LA R1,INPUT R1 GETS ADDRESS OF STRING 00001820 L R0,=F'130' R0 GETS THE LENGTH 00001830 L R15,=A(PARSER) 00001840 BALR R14,R15 DO TOKENIZING 00001850 * 00001860 LM R7,R9,PARSELST SAVE ADDR OF TOKENIZED LIST 00001870 L R6,0(,R7) GET THE PTR TO FIRST OPERAND 00001880 NOPRO MVI ERRNUM,X'FF' RESET ERROR FOR THIS TIME 00001890 CLI 0(R6),C' ' BARE CARRIAGE RETURN? 00001900 BE PROMPT IGNORE IT 00001910 CLI 0(R6),C'E' CHECK FOR 'EXIT' COMMAND 00001920 BE LEAVE 00001930 CLI 0(R6),C'Q' CHECK FOR 'QUIT' COMMAND 00001940 BE LEAVE 00001950 CLI 0(R6),C'?' NEED HELP ? 00001960 BNE SETCHK 00001970 WRTERM 'Legal Commands are: ' 00001980 WRTERM 'Receive, Send, Help, Exit, Quit, Set, Status, Show .' 00001990 B PROMPT 00002000 SETCHK CLC =C'SET',0(R6) IS IT THE SET COMMAND ? 00002010 BE STSWITCH 00002020 CLC =C'ST',0(R6) IS IT THE STATUS COMMAND? 00002030 BE STATSW 00002040 CLC =C'SH',0(R6) IS IT THE SHOW COMMAND? 00002050 BE SHOSW 00002060 CLC =C'HE',0(R6) NEED HELP ? 00002070 BE HELPSW 00002080 OI FLAGS,FLG1 SET FLG1 - IT'S THE FIRST FILE 00002090 NI FLAGS,X'FF'-FLG2 TURN OFF OVERWRITE FLAG (INIT) 00002100 CLC =C'RE',0(R6) 00002110 BNE SS MAYBE IT'S A SEND COMMAND 00002120 ********************************************************************** 00002130 * PROCESS RECEIVE COMMAND * 00002140 ********************************************************************** 00002150 BXH R7,R8,RR3 GET NEXT OPERAND 00002160 L R6,0(,R7) GET POINTER TO NEXT OPERAND 00002170 CLI 0(R6),C'?' NEED HELP? 00002180 BNE RR2 00002190 WRTERM 'Specify dsname to be created for RECEIVE.' 00002200 B PROMPT 00002210 RR2 CLI 0(R6),C' ' MORE WORDS ? 00002220 BE RR3 NO, THEN PROMPT 00002230 MVC DSNAMEX(80),=CL80' ' BLANK DSNAME 00002240 LA R1,DSNAMEX POINT TO DSNAME BUFFER 00002250 LA R2,44 MAX LENGTH OF DSNAME 00002260 SR R5,R5 ZERO THE LENGTH 00002270 RR4 CLI 0(R6),C' ' IS THIS END OF FIELD 00002280 BE RR5 YES, THEN PROCESS DSNAME 00002290 MVC 0(1,R1),0(R6) MOVE A CHARACTER 00002300 LA R6,1(,R6) MOVE ALONG INPUT BUFFER 00002310 LA R1,1(,R1) MOVE ALONG DSNAME BUFFER 00002320 LA R5,1(,R5) UP THE LENGTH COUNT 00002330 BCT R2,RR4 KEEP LOOKING FOR END 00002340 WRTERM 'Dsname too long' 00002350 * 00002360 * allocate a new data set for receive 00002370 * dynaloc will not prefix - so we have to do this by hand. 00002380 * 00002390 RR3 WRTERM 'Enter data set name for RECEIVE.' 00002400 MVC DSNAMEX(80),=CL80' ' BLANK FIELD 00002410 TGET DSNAMEX,44 GET DSNAME 00002420 TR DSNAMEX(80),UPPER MAKE UPPER CASE DSN 00002430 LA R5,0 GUC00002431 CR R5,R1 WAS DSN BLANK? GUC00002432 BE NODSN YES I WAS| GUC00002433 LR R5,R1 SAVE TGET LENGTH 00002440 RR5 LA R6,DSNAMEX SOURCE 00002450 MVC DSNAME(44),=CL44' ' BLANK FIELD 00002460 LA R2,DSNAME PLACE TO STUFF DSNAME 00002470 CLI DSNAMEX,C'''' TEST IF QUOTED 00002480 BE GBDSNQ1 BR IF SO 00002490 * 00002500 * we'll prefix the dsname "by hand". 00002510 * 00002520 L R3,PREFIXL ELSE GET EX LEN 00002530 MVC 0(*-*,R2),PREFIX MOVE PREFIX TO BUFFER 00002540 EX R3,*-6 MOVE IT 00002550 LA R2,1(R3,R2) NEXT POS IN BUFFER 00002560 MVI 0(R2),C'.' PUT A DOT IN THERE 00002570 LA R2,1(,R2) PLACE FOR REST OF DSNAME 00002580 B GBDSNQ2 CONTINUE 00002590 GBDSNQ1 DS 0H X 00002600 LA R6,1(,R6) PAST QUOTE 00002610 S R5,=F'2' REDUCE LENGTH BY 2 00002620 * 00002630 * build the parm list to the MVS dynalc routine. 00002640 * 00002650 GBDSNQ2 DS 0H 00002660 BCTR R5,0 DEC LEN FOR EX 00002670 MVC 0(*-*,R2),0(R6) COMPLETE DSNAME 00002680 EX R5,*-6 00002690 MVC DDNAME(8),=CL8'KEROUT' 00002700 MVC DISP1(4),=F'0' A NEW DATA SET 00002710 MVC DISP2(4),=F'1' CATLG 00002720 MVC INOUT(4),=F'1' OUTPUT 00002730 MVC RECFMX(4),=F'1' FB DATA SET 00002740 MVC TRACK(4),=F'5' 5 TRACK ALLOC 00002750 * 00002760 * select a model dcb. either f or v 00002770 * 00002780 MVC KEROUT(MODDCBFL),MODDCBF 00002790 CLI RFM,C'F' DOES USER WANT FB 00002800 BE MAKDCB YES 00002810 MVC KEROUT(MODDCBVL),MODDCBV USE V MODEL 00002820 MAKDCB DS 0H 00002830 * GUC00002831 * GET DEFAULT UNIT FROM PSCB GUC00002832 * THE CREATED DSN WILL SHOW UP ON THE VOLUME INDICATED BY GUC00002833 * THE /SET UNIT= COMMAND IN GUTS. GUC00002834 * GUC00002835 LPSCBP R1,USING GUC00002836 LTR R1,R1 ANY POINTER PRESENT? GUC00002837 BZ NOPSCBP NO, USE SYSDA VALUE GUC00002838 MVC DEV,PSCBGPNM GET WANTED UNIT GUC00002839 DROP R1 GUC00002840 NOPSCB1 DS 0H 00002841 * 00002842 * NOW CHECK THE LRECL AND BLKSIZE BEFORE OPEN 00002850 * 00002860 SR R1,R1 CLEAR R1 00002870 IC R1,LRECL GET LRECL 00002880 SR R2,R2 CLEAR R2 00002890 LH R3,BLKSIZE GET BLKSIZE 00002900 CLI RFM,C'V' IS THIS VARIABLE 00002910 BE CHKFIXD NO, THEN CHECK AS IF FIXED 00002920 DR R2,R1 SEE IF BLKSIZE IS A MULTIPLE 00002930 LTR R2,R2 OF THE LRECL 00002940 BNZ CHKBLKER YES, THEN SET LRECL AND BLKSIZE 00002950 LH R3,BLKSIZE GET BLKSIZE 00002960 B SETLB 00002970 CHKBLKER WRTERM 'BLKSIZE not multiple of LRECL for RECFM=F' 00002980 B PROMPT 00002990 CHKFIXD SH R3,=H'4' ADJUST BLKSIZE 00003000 CR R1,R3 IS LRECL =< BLKSIZE - 4 00003010 BNH CHKFIXD2 YES, THEN SET LRECL AND BLKSIZE 00003020 WRTERM 'LRECL not less than BLKSIZE - 4 FOR RECFM=V' 00003030 B PROMPT 00003040 CHKFIXD2 AH R3,=H'4' READJUST BLKSIZE 00003050 SETLB DS 0H 00003060 STH R1,KEROUT+(DCBLRECL-IHADCB) STUFF IN DCB 00003070 STH R3,KEROUT+(DCBBLKSI-IHADCB) 00003080 ST R3,BLKSIZEX BLKSIZE 00003090 ST R1,LRECLX LRECL 00003100 LOCATE DATASET 00003110 LTR R15,R15 DOES DATASET EXIST? 00003120 BNZ RRALOC NO, THEN ALLOC A NEW ONE 00003130 PROMPT 'Dataset exists, reply "OK" to overwrite: ' 00003140 TGET WRKBUFF,3 00003150 OC WRKBUFF(3),=CL80' ' UPPER CASE REPLY 00003160 CLC =C'OK',WRKBUFF 00003170 BNE PROMPT BR, IF NOT OK 00003180 MVC DISP1,=F'1' MAKE DISP OLD 00003190 MVC DISP2,=F'3' KEEP 00003200 RRALOC L R15,=V(DYNALC) -> ENTRY POINT 00003210 LA R1,DYNAPARM PARMS FOR ALLOC 00003220 BALR R14,R15 DO IT 00003230 * 00003240 ICM R1,B'1111',DYNALCRC GET RETURN OCDE 00003250 BNZ PROMPT BR IF FAILURE 00003260 * 00003270 * ... then we'll merge in these dcb attributes 00003280 * 00003290 MAKDCBX DS 0H 00003300 OPEN (KEROUT,(OUTPUT)) 00003310 TM KEROUT+(DCBOFLGS-IHADCB),DCBOFOPN 00003320 BO GBOPNA 00003330 WRTERM 'Open for dataset failed.' 00003340 B PROMPT 00003350 * 00003360 * a breeze... 00003370 * 00003380 GBOPNA DS 0H 00003390 WRTERM 'Receive waiting...' 00003400 L R15,=A(RECEIVE) 00003410 BALR R14,R15 CALL RECEIVE PORTION 00003420 LTR R5,R15 CHECK RETURN CODE 00003430 BNZ LNON 00003440 MVI ERRNUM,X'FF' 00003450 LNON DS 0H 00003460 * 00003470 * close any open data sets. 00003480 * 00003490 CLOSE (KERIN,,KEROUT) 00003500 MVC OLDERR(1),ERRNUM ERROR SETTING OF THIS RUN 00003510 LTR R5,R5 CHECK THE RETCODE 00003520 BZ PROMPT ALL OKAY 00003530 WRTERM 'Error in receiving file. Try again.' 00003540 B PROMPT ERROR - TRY AGAIN 00003550 SS CLC =C'SEN',0(R6) 00003560 BNE ERR UNRECOGNIZED COMMAND 00003570 ********************************************************************** 00003580 * PROCESS SEND COMMAND * 00003590 ********************************************************************** 00003600 BXH R7,R8,SS3 NO MORE LEFT 00003610 L R6,0(R7) PICK UP NEXT OPERAND 00003620 CLI 0(R6),C'?' NEED HELP? 00003630 BNE SS2 00003640 WRTERM 'Specify dataset name.' # $ 00003650 B PROMPT 00003660 SS2 CLI 0(R6),C' ' MORE DATA ? 00003670 * 00003680 * User wants to send a data set - well... 00003690 * 00003700 BE SS3 NO, THEN PROMPT 00003710 MVC DSNAMEX(80),=CL80' ' BLANK DSNAME 00003720 LA R1,DSNAMEX POINT TO DSNAME BUFFER 00003730 LA R2,44 MAX LENGTH OF DSNAME 00003740 SR R5,R5 CLEAR LENGTH 00003750 SS4 CLI 0(R6),C' ' IS THIS END OF FIELD 00003760 BE SS5 YES, THEN PROCESS DSNAME 00003770 MVC 0(1,R1),0(R6) MOVE A CHARACTER 00003780 LA R6,1(,R6) MOVE ALONG INPUT BUFFER 00003790 LA R1,1(,R1) MOVE ALONG DSNAME BUFFER 00003800 LA R5,1(,R5) UP THE LENGTH COUNT 00003810 BCT R2,SS4 KEEP LOOKING FOR END 00003820 WRTERM 'Dsname too long' 00003830 B PROMPT 00003840 SS3 WRTERM 'Enter dataset name to send.' 00003850 MVC DSNAMEX(80),=CL80' ' BLANK FIELD 00003860 TGET DSNAMEX,44 GET DSNAME 00003870 TR DSNAMEX(80),UPPER MAKE UPPER CASE DSN 00003880 LR R5,R1 SAVE TGET LENGTH 00003890 SS5 LA R6,DSNAMEX SOURCE 00003900 MVC DSNAME(44),=CL44' ' BLANK FIELD 00003910 LA R2,DSNAME PLACE TO STUFF DSNAME 00003920 CLI DSNAMEX,C'''' TEST IF QUOTED 00003930 BE GBDSNQ3 BR IF SO 00003940 * 00003950 * user tests if i know how to prefix a dsname. 00003960 * 00003970 L R3,PREFIXL ELSE GET EX LEN 00003980 MVC 0(*-*,R2),PREFIX MOVE PREFIX TO BUFFER 00003990 EX R3,*-6 MOVE IT 00004000 LA R2,1(R3,R2) NEXT POS IN BUFFER 00004010 MVI 0(R2),C'.' PUT A DOT IN THERE 00004020 LA R2,1(,R2) PLACE FOR REST OF DSNAME 00004030 B GBDSNQ4 CONTINUE 00004040 GBDSNQ3 DS 0H X 00004050 LA R6,1(,R6) PAST QUOTE 00004060 S R5,=F'2' REDUCE LENGTH BY 2 00004070 * 00004080 * build a "control block" 00004090 * 00004100 GBDSNQ4 DS 0H 00004110 * GUC00004111 * GET DEFAULT UNIT FROM PSCB GUC00004112 * GUC00004113 LPSCBP R1,USING GUC00004114 LTR R1,R1 ANY POINTER PRESENT? GUC00004115 BZ NOPSCBP2 NO, USE SYSDA VALUE GUC00004116 MVC DEV,SENDDEV GET WANTED UNIT GUC00004117 DROP R1 GUC00004118 NOPSCBP2 DS 0H 00004119 BCTR R5,0 DEC LEN FOR EX 00004120 MVC 0(*-*,R2),0(R6) COMPLETE DSNAME 00004130 EX R5,*-6 00004140 LA R5,DSNAME+43 POINT TO END OF DSNAME 00004150 LA R4,44 LENGTH OF DSNAME 00004160 SSFINDL1 CLI 0(R5),C' ' IS IT BLANK? 00004170 BNE SSFINDL2 NO, THEN FOUND END OF DSN 00004180 BCTR R5,0 DECREMENT PTR 00004190 BCT R4,SSFINDL1 LOOP TILL FOUND 00004200 NODSN WRTERM 'Dsname cannot be entirely blank' 00004210 B PROMPT 00004220 SSFINDL2 LR R3,R5 REMEMBER END OF DSN 00004230 LA R2,2 TRY TO FIND 2 LEVELS 00004240 SSFINDL3 CLI 0(R5),C'.' IS IT A DOT? 00004250 BE SSFINDL4 YES, THEN HANDLE IT 00004260 SSFINDL5 BCTR R5,0 DECREMENT PTR 00004270 BCT R4,SSFINDL3 LOOP TILL FOUND 00004280 B SSFINDE BR IF FRONT OF DSN 00004290 SSFINDL4 BCT R2,SSFINDL5 FIND ANOTHER LEVEL 00004300 SSFINDE MVC FILNAM,=CL80' ' BLANK FILNAM 00004310 LA R5,1(,R5) MOVE TO FRONT OF LEVEL 00004320 SR R3,R5 FIND LENGTH TO MOVE 00004330 CH R3,=H'17' TRUNC IF TOO LONG 00004340 BNH *+8 NOT TOO LONG 00004350 LA R3,=H'17' FORCE MAX LENGTH 00004360 MVC FILNAM(*-*),0(R5) MOVE INSTRUCTION FOR EXECUTE 00004370 EX R3,*-6 GO MOVE THE DATA 00004380 STH R3,FILNAML SAVE LENGTH - 1 00004390 MVC DDNAME(8),=CL8'KERIN' 00004400 MVC DISP1(4),=F'2' DISP=SHR 00004410 MVC DISP2(4),=F'3' KEEP 00004420 MVC INOUT(4),=F'0' INPUT 00004430 LA R1,DYNAPARM 00004440 L R15,=V(DYNALC) GET EMTRY POINT 00004450 BALR R14,R15 DO IT 00004460 ICM R1,B'1111',DYNALCRC GET RETURN CODE 00004470 BNZ PROMPT 00004480 * 00004490 * open the users data set 00004500 * 00004510 OPEN (KERIN,(INPUT)) 00004520 TM KERIN+(DCBOFLGS-IHADCB),DCBOFOPN 00004530 BO GBOPNB 00004540 WRTERM 'Open for dataset failed.' 00004550 B PROMPT 00004560 GBOPNB DS 0H 00004570 TM KERIN+(DCBRECFM-IHADCB),DCBRECV IS RECFM=V 00004580 BO SSDELAY YES, THEN WAIT 00004590 TM KERIN+(DCBRECFM-IHADCB),DCBRECF IS RECFM=F 00004600 BO SSDELAY YES, THEN WAIT 00004610 WRTERM 'Invalid RECFM, only fixed and variable supported' 00004620 CLOSE KERIN 00004630 B PROMPT 00004640 SSDELAY DS 0H 00004650 MVC WRKBUFF(37),=C'Waiting ..... seconds before sending.' 00004660 L R1,DELAY 00004670 SR R0,R0 00004680 D R0,=F'100' 00004690 BINCVRT R1,WRKBUFF+7,DBLWRK 00004700 TPUT WRKBUFF,37 00004710 STIMER WAIT,BINTVL=DELAY 00004720 B SSWITCH 00004730 ERR WRTERM 'Invalid command' 00004740 B PROMPT INVALID COMMAND - TRY AGAIN 00004750 SPACE 3 00004760 SSWITCH EQU * 00004770 L R15,=A(SEND) 00004780 BALR R14,R15 CALL SEND PORTION 00004790 LTR R5,R15 CHECK RETURN CODE 00004800 BNZ LINON 00004810 MVI ERRNUM,X'FF' WORKED OK 00004820 LINON DS 0H 00004830 * 00004840 * close any open data sets. 00004850 * 00004860 CLOSE (KERIN,,KEROUT) 00004870 MVC OLDERR(1),ERRNUM ERROR SETTING OF THIS RUN 00004880 LTR R5,R5 CHECK THE RETCODE 00004890 BZ PROMPT ALL OKAY 00004900 WRTERM 'Error in sending file. Try again.' 00004910 B PROMPT ERROR - TRY AGAIN 00004920 ********************************************************************** 00004930 * PROCESS SET COMMAND * 00004940 ********************************************************************** 00004950 STSWITCH EQU * 00004960 L R15,=A(SET) 00004970 BALR R14,R15 CALL "SET" SUBROUTINE 00004980 LTR R15,R15 CHECK RETCODE 00004990 BZ PROMPT 00005000 WRTERM 'Illegal Set Command' 00005010 B PROMPT 00005020 ********************************************************************** 00005030 * PROCESS SHOW COMMAND * 00005040 ********************************************************************** 00005050 SHOSW EQU * 00005060 L R15,=A(SHOW) 00005070 BALR R14,R15 CALL "SHOW" SUBROUTINE 00005080 LTR R15,R15 CHECK RETCODE 00005090 BZ PROMPT 00005100 WRTERM 'Illegal Show Command' 00005110 B PROMPT 00005120 ********************************************************************** 00005130 * PROCESS STATUS COMMAND * 00005140 ********************************************************************** 00005150 STATSW EQU * 00005160 BXH R7,R8,GIVSTAT NO MORE LEFT 00005170 L R6,0(R7) PICK UP NEXT OPERAND 00005180 CLI 0(R6),C'?' NEED HELP? 00005190 BNE GIVSTAT 00005200 WRTERM 'Confirm with a carriage return' 00005210 B PROMPT 00005220 GIVSTAT CLI OLDERR,X'FF' WAS THERE AN ERROR LAST TIME? 00005230 BNE FAIL 00005240 WRTERM 'Kermit completed successfully' 00005250 B PROMPT 00005260 FAIL SR R5,R5 00005270 IC R5,OLDERR GET OFFSET INTO ERROR TABLE 00005280 M R4,=F'20' OFFSET := ERRNUM * 20 00005290 LA R5,ERRTAB(R5) 00005300 *G WRTERM (R5),20 PRINT ERROR MSG ON SCREEN 00005310 TPUT (R5),20 00005320 B PROMPT AND LEAVE 00005330 ********************************************************************** 00005340 * PROCESS HELP COMMAND * 00005350 ********************************************************************** 00005360 HELPSW BXH R7,R8,GIVHLP NO MORE LEFT 00005370 L R6,0(R7) PICK UP NEXT OPERAND 00005380 CLI 0(R6),C'?' NEED HELP? 00005390 BNE GIVHLP 00005400 WRTERM 'Confirm with a carriage return' 00005410 B PROMPT 00005420 GIVHLP DS 0H 00005430 WRTERM 'Enter ? at prompt to receive list of commands.' 00005440 WRTERM 'Enter ? after a command to receive list of operands' 00005450 B PROMPT 00005460 ********************************************************************** 00005470 * PROCESS EXIT COMMAND * 00005480 ********************************************************************** 00005490 LEAVE BXH R7,R8,KRET ANY MORE OPERANDS? 00005500 L R6,0(,R7) GET ADDRESS OF OPERAND 00005510 CLI 0(R6),C'?' NEED HELP? 00005520 BNE KRET NO, JUST LEAVE 00005530 WRTERM 'Confirm with a carriage return' 00005540 B PROMPT 00005550 BADDEV WRTERM 'An Ascii terminal must be used.' 00005560 B RET 00005570 NOTCP WRTERM 'KERMIT-TSO must be running as a command processor' 00005580 WRTERM 'Contact your local systems programmer' 00005590 B RET 00005600 KRET EQU * 00005610 RET EQU * 00005620 * 00005630 * close any open data sets. 00005640 * dynalc has a free=close so..... 00005650 * 00005660 TM KERIN+(DCBOFLGS-IHADCB),DCBOFOPN 00005670 BNO RETGB1 00005680 CLOSE KERIN 00005690 RETGB1 DS 0H 00005700 TM KEROUT+(DCBOFLGS-IHADCB),DCBOFOPN 00005710 BNO RETGB2 00005720 CLOSE KEROUT 00005730 RETGB2 DS 0H 00005740 CLOSE DEBUG 00005750 L R13,4(R13) 00005760 L R14,12(R13) 00005770 LM R0,R12,20(R13) 00005780 BR R14 00005790 KSAVE DS 18F KERMIT'S SAVE AREA 00005800 LTORG 00005810 DROP R11 00005820 DROP R12 NO LONGER NEED THEM 00005830 EJECT 00005840 ********************************************************************** 00005850 * * 00005860 * ROUTINE TO PROCESS SET COMMAND * 00005870 * * 00005880 ********************************************************************** 00005890 SET DS 0H 00005900 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 00005910 BALR R12,0 ESTABLISH ADDRESSABILITY 00005920 USING *,R12 00005930 LA R14,SETSAVE ADDRESS OF MY SAVE AREA 00005940 ST R13,4(R14) SAVE CALLER'S 00005950 ST R14,8(R13) 00005960 LR R13,R14 00005970 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 00005980 L R11,=A(PARMS) 00005990 USING PARMS,R11 ESTABLISH ADDRESSABILITY 00006000 BXH R7,R8,SETHLP 00006010 L R6,0(R7) PICK UP NEXT OPERAND 00006020 CLI 0(R6),C'?' NEED HELP ? 00006030 BNE NOQ 00006040 SETHLP WRTERM 'Blksize, Debug, Delay, End-of-line, Lrecl,' 00006050 WRTERM 'Quote, Packet-size, Recfm, Space, Start-of-line' 00006060 B SETOK 00006070 ********************************************************************** 00006080 * SET RECFM * 00006090 ********************************************************************** 00006100 NOQ CLC =C'RE',0(R6) 00006110 BNE NOREC 00006120 BXH R7,R8,SETNFM MORE OPERANDS? 00006130 L R6,0(R7) PICK UP RECORD FORMAT 00006140 CLI 0(R6),C'?' 00006150 BNE CHKFM 00006160 WRTERM 'f or v (default of v)' 00006170 B SETOK 00006180 CHKFM CLI 0(R6),C'V' REDUNDANT 00006190 BE FMSET 00006200 CLI 0(R6),C'F' FIXED FORMAT? 00006210 BNE RECERR 00006220 FMSET MVC RFM(1),0(R6) PICK UP RECFM 00006230 B SETOK 00006240 RECERR WRTERM 'Fixed and variable files only' 00006250 B SETERR 00006260 ********************************************************************** 00006270 * SET QUOTE * 00006280 ********************************************************************** 00006290 NOREC CLC =C'QU',0(R6) QUOTE CHARACTER 00006300 BNE NOQUO 00006310 BXH R7,R8,SETNFM ANY MORE OPERANDS 00006320 L R6,0(R7) GET NEXT TOKEN 00006330 CLI 0(R6),C' ' VALUE NOT SUPPLIED? 00006340 BNE GIVQ 00006350 SETNFM WRTERM '?NOT CONFIRMED' 00006360 B SETERR 00006370 GIVQ CLC =C'? ',0(R6) 00006380 BNE GETQUO 00006390 WRTERM 'a single character' 00006400 B SETOK 00006410 GETQUO MVC QUOCHAR(1),0(R6) SET NEW QUOTE CHAR 00006420 TR QUOCHAR(1),ETOA GET ASCII FORM 00006430 CLI 1(R6),C' ' IS IT ONLY ONE CHAR? 00006440 BE ISQOK 00006450 WRTERM 'one character only' 00006460 B BADQUO 00006470 ISQOK CLI QUOCHAR,X'21' CAN'T BE LESS THAN 32 00006480 BL BADQUO 00006490 CLI QUOCHAR,X'7E' CAN'T BE LARGER THAN 126 00006500 BH BADQUO 00006510 CLI QUOCHAR,X'3E' HAS TO BE BETWEEN 32-62 00006520 BNH SETOK 00006530 CLI QUOCHAR,X'60' OR BETWEEN 96-126 00006540 BNL SETOK 00006550 BADQUO WRTERM 'Must fall between 41-76,140,or 173-176 (octal).' 00006560 MVC QUOCHAR(1),DQUOTE RESET VALUE, JUST IN CASE 00006570 B SETERR 00006580 ********************************************************************** 00006590 * SET LRECL * 00006600 ********************************************************************** 00006610 NOQUO CLC =C'LR',0(R6) LRECL SIZE 00006620 BNE SETBLK 00006630 BXH R7,R8,SETNFM ANY MORE OPERANDS 00006640 L R6,0(R7) GET NEXT TOKEN 00006650 CLI 0(R6),C'?' HELP ? 00006660 BNE GETREC 00006670 WRTERM 'Logical Record Length (default of 80).' 00006680 B SETOK 00006690 GETREC CLI 0(R6),C' ' NO VALUE GIVEN 00006700 BNE CALC 00006710 WRTERM '?not confirmed' 00006720 B SETERR 00006730 CALC CLI 0(R6),X'F0' MUST BE >= TO 0 00006740 BL BADREC 00006750 CLI 0(R6),X'F9' MUST BE <= TO 9 00006760 BH BADREC 00006770 XC PKVAR,PKVAR EMPTY IT OUT 00006780 SR R4,R4 LENGTH OF NUMBER 00006790 CLI 1(R6),C' ' TWO DIGITS? 00006800 BNE CALC2 00006810 EX R4,PCK 00006820 B TST 00006830 CALC2 LA R4,1(R4) ADD ONE 00006840 CLI 2(R6),C' ' THREE DIGITS? 00006850 BNE CALC3 00006860 EX R4,PCK 00006870 B TST 00006880 CALC3 LA R4,1(R4) IS THERE AN ERROR? 00006890 CLI 3(R6),C' ' 00006900 BNE BADREC 00006910 EX R4,PCK 00006920 TST CVB R7,PKVAR 00006930 C R7,=F'255' MAX OF 255 FOR LRECL 00006940 BH BADREC 00006950 STC R7,LRECL SET THE LRECL VALUE 00006960 B SETOK 00006970 BADREC WRTERM 'A number with a maximum of 255.' 00006980 B SETERR 00006990 ********************************************************************** 00007000 * SET BLKSIZE * 00007010 ********************************************************************** 00007020 SETBLK CLC =C'BL',0(R6) BLOCK SIZE 00007030 BNE SETSPACE 00007040 BXH R7,R8,SETNFM ANY MORE OPERANDS 00007050 L R6,0(R7) GET NEXT TOKEN 00007060 CLI 0(R6),C'?' HELP ? 00007070 BNE GETBLK 00007080 WRTERM 'Blocksize (default of 3600).' 00007090 B SETOK 00007100 GETBLK CLI 0(R6),C' ' NO VALUE GIVEN 00007110 BNE BLKCALC 00007120 WRTERM '?not confirmed' 00007130 B SETERR 00007140 BLKCALC XC PKVAR,PKVAR EMPTY IT OUT 00007150 SR R4,R4 LENGTH OF NUMBER 00007160 LA R7,5 MAX LENGTH OF NUMBER 00007170 LR R5,R6 SAVE START OF STRING 00007180 BLKCALC1 CLI 0(R6),X'F0' MUST BE >= TO 0 00007190 BL BADBLK 00007200 CLI 0(R6),X'F9' MUST BE <= TO 9 00007210 BH BADBLK 00007220 CLI 1(R6),C' ' FOUND LAST DIGIT? 00007230 BE BLKCALC2 00007240 LA R4,1(R4) COUNT NUMBER OF DIGITS 00007250 LA R6,1(R6) POINT TO NEXT DIGIT 00007260 BCT R7,BLKCALC1 KEEP CHECKING 00007270 B BADBLK 00007280 BLKCALC2 EX R4,BLKPCK 00007290 B BLKTST 00007300 BLKTST CVB R7,PKVAR 00007310 C R7,=F'32767' MAX OF 32767 FOR BLKSIZE 00007320 BH BADBLK 00007330 STH R7,BLKSIZE SET THE BLKSIZE 00007340 B SETOK 00007350 BADBLK WRTERM 'A number with a maximum of 32767' 00007360 B SETERR 00007370 ********************************************************************** 00007380 * SET TRACK ALLOCATION * 00007390 ********************************************************************** 00007400 SETSPACE CLC =C'SP',0(R6) BLOCK SIZE 00007410 BNE SETEOL 00007420 BXH R7,R8,SETNFM ANY MORE OPERANDS 00007430 L R6,0(R7) GET NEXT TOKEN 00007440 CLI 0(R6),C'?' HELP ? 00007450 BNE GETSPC 00007460 WRTERM 'Dataset space allocation (default of 5 tracks).' 00007470 B SETOK 00007480 GETSPC CLI 0(R6),C' ' NO VALUE GIVEN 00007490 BNE SPCCALC 00007500 WRTERM '?not confirmed' 00007510 B SETERR 00007520 SPCCALC XC PKVAR,PKVAR EMPTY IT OUT 00007530 SR R4,R4 LENGTH OF NUMBER 00007540 LA R7,5 MAX LENGTH OF NUMBER 00007550 LR R5,R6 SAVE START OF STRING 00007560 SPCCALC1 CLI 0(R6),X'F0' MUST BE >= TO 0 00007570 BL BADSPC 00007580 CLI 0(R6),X'F9' MUST BE <= TO 9 00007590 BH BADSPC 00007600 CLI 1(R6),C' ' FOUND LAST DIGIT? 00007610 BE SPCCALC2 00007620 LA R4,1(R4) COUNT NUMBER OF DIGITS 00007630 LA R6,1(R6) POINT TO NEXT DIGIT 00007640 BCT R7,SPCCALC1 KEEP CHECKING 00007650 B BADSPC 00007660 SPCCALC2 EX R4,SPCPCK 00007670 B SPCTST 00007680 SPCTST CVB R7,PKVAR 00007690 C R7,=F'99999' MAX OF 99999 FOR SPACE 00007700 BH BADSPC 00007710 ST R7,TRACK SET THE ALLOCATION 00007720 B SETOK 00007730 BADSPC WRTERM 'A number with a maximum of 99999' 00007740 B SETERR 00007750 ********************************************************************** 00007760 * SET END-OF-LINE CHARACTER * 00007770 ********************************************************************** 00007780 SETEOL CLC =C'EN',0(R6) EOL CHARACTER 00007790 BNE NOEND 00007800 BXH R7,R8,SETNFM ANY MORE OPERANDS 00007810 L R6,0(R7) GET NEXT TOKEN 00007820 CLI 0(R6),C' ' NOT DATA 00007830 BNE EOLCHAR 00007840 WRTERM '?not confirmed' 00007850 B SETERR 00007860 EOLCHAR CLI 0(R6),C'?' NEED HELP? 00007870 BNE GETEOL 00007880 WRTERM 'A two digit number between 00 and 31 (dec).' 00007890 B SETOK 00007900 GETEOL CLI 0(R6),X'F0' MUST BE >= TO 0 00007910 BL BADEOL 00007920 CLI 0(R6),X'F9' MUST BE <= TO 9 00007930 BH BADEOL 00007940 XC PKVAR,PKVAR USE TO CONVERT VALUE 00007950 CLI 1(R6),C' ' INPUT MUST BE TWO CHARS 00007960 BE BADEOL 00007970 CLI 2(R6),C' ' TWO CHARS, AT MAX 00007980 BNE BADEOL 00007990 PACK PKVAR(8),0(2,R6) PICK UP TWO CHARACTERS 00008000 CVB R7,PKVAR PUT PACKED DECIMAL INTO REG 00008010 C R7,=F'31' MAX OF 31 DECIMAL 00008020 BH BADEOL 00008030 STC R7,SEOL SET SEND EOL VALUE 00008040 B SETOK 00008050 BADEOL WRTERM 'Must be a two digit value less than 31 (dec).' 00008060 B SETERR 00008070 ********************************************************************** 00008080 * SET PACKET-SIZE * 00008090 ********************************************************************** 00008100 NOEND CLC =C'PA',0(R6) CHANGE RECEIVE PACKET SIZE 00008110 BNE NOPAC 00008120 BXH R7,R8,SETNFM ANY MORE OPERANDS 00008130 L R6,0(R7) GET NEXT TOKEN 00008140 CLI 0(R6),C' ' NO DATA 00008150 BNE GETPAC 00008160 WRTERM '?not confirmed' 00008170 B SETERR 00008180 GETPAC CLI 0(R6),C'?' NEED HELP? 00008190 BNE CALC4 00008200 WRTERM 'Receive packet size (range: 26-94 decimal).' 00008210 B SETOK 00008220 CALC4 CLI 0(R6),X'F0' MUST BE >= TO 0 00008230 BL BADPAC 00008240 CLI 0(R6),X'F9' MUST BE <= TO 9 00008250 BH BADPAC 00008260 XC PKVAR,PKVAR USE TO CONVERT VALUE 00008270 CLI 1(R6),C' ' INPUT MUST BE TWO CHARS 00008280 BE BADPAC 00008290 CLI 2(R6),C' ' TWO CHARS, AT MAX 00008300 BNE BADPAC 00008310 PACK PKVAR(8),0(2,R6) PICK UP TWO CHARS 00008320 CVB R7,PKVAR PUT PACKED DECIMAL INTO REG 00008330 C R7,=F'26' THIS IS MIN 00008340 BL BADPAC 00008350 C R7,MAXPACK THIS IS THE MAX 00008360 BH BADPAC 00008370 ST R7,RPSIZ USE THIS VALUE NOW 00008380 B SETOK 00008390 BADPAC WRTERM 'Must be between 26-94 (decimal).' 00008400 B SETERR 00008410 ********************************************************************** 00008420 * SET DEBUG ON:OFF * 00008430 ********************************************************************** 00008440 NOPAC CLC =C'DEB',0(R6) IS THIS DEBUG? 00008450 BNE SETSOH NO, THEN SEE IF SET SOH 00008460 BXH R7,R8,SETNFM ANY MORE OPERANDS 00008470 L R6,0(R7) GET NEXT TOKEN 00008480 CLI 0(R6),C' ' IS THERE AN OPERAND? 00008490 BE DEBERR NO, THEN ASK FOR ONE. 00008500 CLC =C'ON',0(R6) IS IT TIME TO TURN ON 00008510 BE DEBON YES, OPEN FILE 00008520 CLC =C'OF',0(R6) IS IT TIME TO TURN OFF 00008530 BE DEBOFF YES, CLOSE FILE 00008540 B DEBERR YES, GIVE MESSAGE 00008550 DEBERR WRTERM 'Command is SET DEBUG ON : OFF' 00008560 B SETERR 00008570 DEBON OPEN (DEBUG,(OUTPUT)) 00008580 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 00008590 BO SETOK 00008600 WRTERM 'Unable to open debug file, debug disabled.' 00008610 B SETERR 00008620 DEBOFF CLOSE DEBUG 00008630 B SETOK 00008640 ********************************************************************** 00008650 * SET START-OF-HEADER CHARACTER * 00008660 ********************************************************************** 00008670 SETSOH CLC =C'ST',0(R6) SOH CHARACTER 00008680 BNE NOSOH NO, THEN TRY DELAY 00008690 BXH R7,R8,SETNFM ANY MORE OPERANDS 00008700 L R6,0(R7) GET NEXT TOKEN 00008710 CLI 0(R6),C' ' NOT DATA 00008720 BNE SOHCHAR 00008730 WRTERM '?not confirmed' 00008740 B SETERR 00008750 SOHCHAR CLI 0(R6),C'?' NEED HELP? 00008760 BNE GETSOH 00008770 WRTERM 'A two digit number between 00 and 31 (dec).' 00008780 B SETOK 00008790 GETSOH CLI 0(R6),X'F0' MUST BE >= TO 0 00008800 BL BADSOH 00008810 CLI 0(R6),X'F9' MUST BE <= TO 9 00008820 BH BADSOH 00008830 XC PKVAR,PKVAR USE TO CONVERT VALUE 00008840 CLI 1(R6),C' ' INPUT MUST BE TWO CHARS 00008850 BE BADSOH 00008860 CLI 2(R6),C' ' TWO CHARS, AT MAX 00008870 BNE BADSOH 00008880 PACK PKVAR(8),0(2,R6) PICK UP TWO CHARACTERS 00008890 CVB R7,PKVAR PUT PACKED DECIMAL INTO REG 00008900 C R7,=F'31' MAX OF 31 DECIMAL 00008910 BH BADSOH ERROR, TOO BIG 00008920 STC R7,SSOH SET SEND SOH VALUE 00008930 STC R7,RSOH SET RECEIVE SOH VALUE 00008940 B SETOK 00008950 BADSOH WRTERM 'Must be a two digit value less than 31 (dec).' 00008960 B SETERR 00008970 ********************************************************************** 00008980 * SET DELAY VALUE * 00008990 ********************************************************************** 00009000 NOSOH CLC =C'DEL',0(R6) CHANGE RECEIVE PACKET SIZE 00009010 BNE SETERR 00009020 BXH R7,R8,SETNFM ANY MORE OPERANDS 00009030 L R6,0(R7) GET NEXT TOKEN 00009040 CLI 0(R6),C' ' NO DATA 00009050 BNE GETDELAY 00009060 WRTERM '?not confirmed' 00009070 B SETERR 00009080 GETDELAY CLI 0(R6),C'?' NEED HELP? 00009090 BNE DLYCALC 00009100 WRTERM 'Receive packet size (range: 26-94 decimal).' 00009110 B SETOK 00009120 DLYCALC XC PKVAR,PKVAR EMPTY IT OUT 00009130 SR R4,R4 LENGTH OF NUMBER 00009140 LA R7,5 MAX LENGTH OF NUMBER 00009150 LR R5,R6 SAVE START OF STRING 00009160 DLYCALC1 CLI 0(R6),X'F0' MUST BE >= TO 0 00009170 BL BADDELAY 00009180 CLI 0(R6),X'F9' MUST BE <= TO 9 00009190 BH BADDELAY 00009200 CLI 1(R6),C' ' FOUND LAST DIGIT? 00009210 BE DLYCALC2 00009220 LA R4,1(R4) COUNT NUMBER OF DIGITS 00009230 LA R6,1(R6) POINT TO NEXT DIGIT 00009240 BCT R7,DLYCALC1 KEEP CHECKING 00009250 B BADDELAY 00009260 DLYCALC2 EX R4,DLYPCK 00009270 B DLYTST 00009280 DLYTST CVB R7,PKVAR 00009290 LTR R7,R7 THIS IS MIN 00009300 BNP BADDELAY 00009310 C R7,=F'99999' THIS IS THE MAX 00009320 BH BADDELAY 00009330 MH R7,=H'100' MAKE IT 100THS OF SECONDS 00009340 ST R7,DELAY USE THIS VALUE NOW 00009350 B SETOK 00009360 BADDELAY WRTERM 'Must be between 1-99999 (DECIMAL).' 00009370 B SETERR 00009380 SETERR LA R15,4 SET A NON-ZERO RETCODE 00009390 B SETRET 00009400 SETOK SR R15,R15 RETCODE OF 0 00009410 * 00009420 SETRET L R13,4(R13) 00009430 L R14,12(R13) 00009440 LM R0,R12,20(R13) 00009450 BR R14 00009460 SETSAVE DS 18F 00009470 PCK PACK PKVAR(8),0(0,R6) 00009480 BLKPCK PACK PKVAR(8),0(0,R5) 00009490 SPCPCK PACK PKVAR(8),0(0,R5) 00009500 DLYPCK PACK PKVAR(8),0(0,R5) 00009510 LTORG 00009520 DROP R11 00009530 DROP R12 00009540 EJECT 00009550 ********************************************************************** 00009560 * * 00009570 * ROUTINE TO PROCESS SHOW COMMAND * 00009580 * * 00009590 ********************************************************************** 00009600 SHOW DS 0H 00009610 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 00009620 BALR R12,0 ESTABLISH ADDRESSABILITY 00009630 USING *,R12 00009640 LA R14,SHOWSAVE ADDRESS OF MY SAVE AREA 00009650 ST R13,4(R14) SAVE CALLER'S 00009660 ST R14,8(R13) 00009670 LR R13,R14 00009680 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 00009690 L R11,=A(PARMS) 00009700 USING PARMS,R11 ESTABLISH ADDRESSABILITY 00009710 BXH R7,R8,SHONFM ANY MORE OPERANDS 00009720 L R6,0(R7) GET NEXT TOKEN 00009730 CLC =C'AU',0(R6) WANT THE AUTHORS NAME? 00009731 BE SHOAUTH 00009732 CLI 0(R6),C'?' NEED HELP ? 00009740 BNE SHOREC 00009750 WRTERM 'State' 00009760 B SHOWOK 00009770 SHONFM WRTERM '?NOT CONFIRMED' 00009780 B SHOWERR 00009790 SHOREC CLI 0(R6),C'S' IS THIS SHOW STATE 00009800 BNE SHOWERR 00009810 MVC WRKBUFF(18),=C'Record format is .' 00009820 MVC WRKBUFF+17(1),RFM 00009830 TPUT WRKBUFF,18 00009840 TR QUOCHAR(1),ATOE GET EBCDIC VERSION 00009850 MVC WRKBUFF(20),=C'Quote character is .' 00009860 MVC WRKBUFF+19(1),QUOCHAR 00009870 TPUT WRKBUFF,20 00009880 TR QUOCHAR(1),ETOA KEEP THE ASCII FORM AROUND 00009890 SR R4,R4 ZERO IT OUT 00009900 IC R4,LRECL 00009910 MVC WRKBUFF(8),=C'Lrecl is' 00009920 BINCVRT R4,WRKBUFF+8,DBLWRK 00009930 TPUT WRKBUFF,14 00009940 LH R4,BLKSIZE 00009950 MVC WRKBUFF(10),=C'Blksize is' 00009960 BINCVRT R4,WRKBUFF+10,DBLWRK 00009970 TPUT WRKBUFF,16 00009980 L R4,TRACK 00009990 MVC WRKBUFF(32),=C'Space allocation is ..... tracks' 00010000 BINCVRT R4,WRKBUFF+19,DBLWRK 00010010 TPUT WRKBUFF,32 00010020 SR R4,R4 ZERO IT OUT 00010030 IC R4,SSOH 00010040 MVC WRKBUFF(44),=C'Start-of-header character is ..... (decimal)'00010050 BINCVRT R4,WRKBUFF+28,DBLWRK 00010060 TPUT WRKBUFF,44 00010070 SR R4,R4 ZERO IT OUT 00010080 IC R4,SEOL 00010090 MVC WRKBUFF(40),=C'End-of-line character is ..... (decimal)' 00010100 BINCVRT R4,WRKBUFF+24,DBLWRK 00010110 TPUT WRKBUFF,40 00010120 MVC WRKBUFF(38),=C'Receive packet size is ..... (decimal)' 00010130 L R1,RPSIZ 00010140 BINCVRT R1,WRKBUFF+22,DBLWRK 00010150 TPUT WRKBUFF,38 00010160 MVC WRKBUFF(28),=C'Delay value is ..... seconds' 00010170 L R1,DELAY 00010180 SR R0,R0 00010190 D R0,=F'100' 00010200 BINCVRT R1,WRKBUFF+14,DBLWRK 00010210 TPUT WRKBUFF,28 00010220 MVC WRKBUFF(9),=C'Debug is ' 00010230 MVC WRKBUFF+9(3),=C'off' 00010240 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 00010250 BZ SHOWDBG 00010260 MVC WRKBUFF+9(3),=C'on ' 00010270 SHOWDBG TPUT WRKBUFF,12 00010280 B SHOWOK 00010290 SHOAUTH WRTERM 'Written for CMS by Daphne Tzoar Columbia University00010291 NY, NY.' 00010292 WRTERM 'Modified for TSO by Ronald J. Rusnak, University of00010293 Chicago.' 00010294 WRTERM 'Modified for GUTS by Stefan Lundberg, Gothenburg Un00010295 iversities'' Computing Centre' 00010296 B SHOWOK 00010297 SHOWERR LA R15,4 SET A NON-ZERO RETCODE 00010300 B SHOWRET 00010310 SHOWOK SR R15,R15 ZERO RETCODE 00010320 * 00010330 SHOWRET L R13,4(R13) 00010340 L R14,12(R13) 00010350 LM R0,R12,20(R13) 00010360 BR R14 00010370 SHOWSAVE DS 18F 00010380 LTORG 00010390 DROP R11 00010400 DROP R12 00010410 * 00010420 EJECT 00010430 ********************************************************************** 00010440 * * 00010450 * ROUTINE TO INITIALIZE PARAMETER AREA * 00010460 * * 00010470 ********************************************************************** 00010480 INIT DS 0H 00010490 STM R14,R12,12(R13) 00010500 BALR R12,0 00010510 USING *,R12 00010520 LA R14,ISAVE 00010530 ST R13,4(R14) 00010540 ST R14,8(R13) 00010550 LR R13,R14 00010560 * 00010570 * INITIALIZE VARIABLES THAT GET CHANGED DURING EXECUTION 00010580 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA LIST 00010590 L R11,=A(PARMS) 00010600 USING PARMS,R11 00010610 XC SNDPKT,SNDPKT CLEAR OUT THESE BUFFERS 00010620 XC RECPKT,RECPKT 00010630 XC INPUT,INPUT 00010640 LA R0,BUF 00010650 LA R1,L'BUF ; CLEAR OUT THE BUFFER. 00010660 SR R15,R15 00010670 MVCL R0,R14 00010680 LA R0,RBUF 00010690 LA R1,L'RBUF 00010700 SR R15,R15 00010710 MVCL R0,R14 00010720 XC SDAT,SDAT 00010730 XC RDAT,RDAT 00010740 XC N,N SET VARIABLES TO ZERO 00010750 XC NUM,NUM 00010760 XC LSDAT,LSDAT 00010770 XC LRDAT,LRDAT 00010780 MVI FLAGS,X'00' CLEAR ALL FLAGS 00010790 XC SAVPL,SAVPL 00010800 XC RSAVPL,RSAVPL 00010810 XC NUMTRY,NUMTRY 00010820 MVC FILNAM,=18X'20' BLANK OUT FILNAM & NAME 00010830 MVC NAME,=18X'20' 00010840 MVI PREV,X'00' 00010850 MVI ERRNUM,X'FF' SET TO NO ERROR FOR NOW 00010860 MVI OLDERR,X'FF' SAME HERE 00010870 XC PKVAR,PKVAR ZERO IT OUT 00010880 XC OLDTRY,OLDTRY 00010890 XC SPSIZ,SPSIZ 00010900 XC SIZE,SIZE 00010910 XC TEMP,TEMP 00010920 XC STORLOC,STORLOC 00010930 MVC DELAY,DDELAY SET DEFAULT DELAY 00010940 MVC LRECL(1),DLRECL SET DEFAULTS, JUST IN CASE 00010950 MVC BLKSIZE(2),DBLKSIZE SET DEFAULTS, JUST IN CASE 00010960 MVC TRACK,DTRACK DEFAULT SPACE OF 5 TRACKS 00010970 MVC RFM(1),DRECFM 00010980 MVC QUOCHAR(1),DQUOTE 00010990 MVC RQUO(1),DQUOTE 00011000 MVC REOL(1),DEOL 00011010 MVC SEOL(1),DEOL 00011020 MVC SSOH(1),DSOH 00011030 MVC RSOH(1),DSOH 00011040 MVI STATE,C' ' 00011050 MVI STYPE,C' ' 00011060 MVI RTYPE,C' ' 00011070 * 00011080 INITRET L R13,4(R13) 00011090 L R14,12(R13) 00011100 LM R0,R12,20(R13) 00011110 BR R14 00011120 ISAVE DS 18F 00011130 LTORG 00011140 DROP R11 00011150 DROP R12 00011160 EJECT 00011170 ********************************************************************** 00011180 * * 00011190 * ROUTINE TO PROCESS SEND COMMAND * 00011200 * * 00011210 ********************************************************************** 00011220 SEND DS 0H 00011230 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 00011240 BALR R12,0 ESTABLISH ADDRESSABILITY 00011250 USING *,R12 00011260 LA R14,SENDSAVE ADDRESS OF MY SAVE AREA 00011270 ST R13,4(R14) SAVE CALLER'S 00011280 ST R14,8(R13) 00011290 LR R13,R14 00011300 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 00011310 L R11,=A(PARMS) 00011320 USING PARMS,R11 ESTABLISH ADDRESSABILITY 00011330 MVI STATE,C'S' 00011340 SR R3,R3 00011350 ST R3,N 00011360 ST R3,NUMTRY 00011370 OKSND TM FLAGS,FLG1 IS THIS THE FIRST FILE? 00011380 BNO SLOOP 00011390 NI FLAGS,X'FF'-FLG1 TURN OFF FIRST FILE FLAG 00011400 ********************************************************************** 00011410 * MAIN SEND LOOP * 00011420 ********************************************************************** 00011430 SLOOP CLI STATE,C'D' SEND DATA STATE 00011440 BE SDATA 00011450 CLI STATE,C'F' SEND FILE STATE 00011460 BE SFILE 00011470 CLI STATE,C'S' SEND INIT STATE 00011480 BE SINIT 00011490 CLI STATE,C'Z' END OF FILE STATE 00011500 BE SEOF 00011510 CLI STATE,C'B' SEND BREAK STATE 00011520 BE SBREAK 00011530 CLI STATE,C'C' COMPLETE STATE 00011540 BE COMPLETE 00011550 CLI STATE,C'A' ABORT STATE 00011560 BE ABORT ERROR - GO TO ABORT STATE 00011570 MVI ERRNUM,X'02' UNRECOGNIZED STATE 00011580 B ABORT OTHERWISE, DIE 00011590 ********************************************************************** 00011600 * CREATE AND SEND INITIALIZATION PACKET * 00011610 ********************************************************************** 00011620 SINIT CLC NUMTRY,IMXTRY SEE IF CAN SEND 00011630 BL OK1 YES WE CAN 00011640 MVI STATE,C'A' NOPE, GO INTO ABORT STATE 00011650 B SLOOP 00011660 OK1 L R5,SPACE MAKE CHARACTER PRINTABLE 00011670 A R5,RPSIZ ADD REC PACKET SIZE 00011680 STC R5,SDAT ADD SIZE INFO TO BUFFER 00011690 L R5,SPACE 00011700 A R5,=F'8' 8 FOR TIMEOUT 00011710 STC R5,SDAT+1 00011720 L R5,SPACE SEND ZERO + " " FOR NPAD 00011730 STC R5,SDAT+2 WE'RE THE SLOW GUYS 00011740 SR R5,R5 PAD WITH NULLS 00011750 L R3,O1H 00011760 XR R5,R3 CTL FUNCTION (XOR WITH 64) 00011770 STC R5,SDAT+3 DON'T NEED PADCHAR EITHER 00011780 SR R5,R5 ZERO IT OUT FOR NEXT TWO GUYS 00011790 IC R5,REOL EOL CHAR I NEED 00011800 A R5,SPACE MAKE PRINTABLE 00011810 STC R5,SDAT+4 00011820 IC R5,QUOCHAR MY QUOTE CHAR 00011830 STC R5,SDAT+5 00011840 L R3,NUMTRY 00011850 LA R3,1(R3) INCREMENT TRIAL COUNTER 00011860 ST R3,NUMTRY 00011870 MVI STYPE,AS PACKET TYPE = SEND INITIATE 00011880 MVC LSDAT(4),=F'6' BUFFER SIZE FOR THIS SEND 00011890 L R4,DSSIZ GET DEFAULT SPSIZ 00011900 S R4,FIVE FOR NOW, USE DEFAULT SPSIZ.... 00011910 ST R4,SIZE ....TO SET VALUE OF SIZE 00011920 L R15,=A(SPACK) GET ADDRESS OF ROUTINE 'SPACK' 00011930 BALR 14,15 SAVE * AND GO TO SPACK 00011940 CLI STATE,C'A' 00011950 BE ABORT 00011960 L 15,=A(RPACK) GET ADDRESS OF 'RPACK' 00011970 BALR 14,15 SAVE * AND GO TO RPACK 00011980 CLI RTYPE,AE ERROR PACKET? 00011990 BNE Y1 NO, THEN MAYBE AN ACK 00012000 MVI ERRNUM,X'0A' MICRO DIED 00012010 MVI STATE,C'A' AND DIE 00012020 B SLOOP 00012030 Y1 CLI RTYPE,AY SEE IF GOT ACK 00012040 BNE N1 MAYBE IT'S 'N' 00012050 CLC N,NUM CHECK MESSAGE NUMBERS 00012060 BE AOK1 00012070 MVI ERRNUM,X'08' PACKET LOST 00012080 B SLOOP 00012090 AOK1 SR R4,R4 ZERO OUT REGISTER 00012100 IC R4,RDAT USE SPSIZ THE MICRO WANTS 00012110 S R4,SPACE SUBTRACT THE ' ' 00012120 C R4,=F'26' BUFFER HAS TO BE >= 26 00012130 BNL CH1 SO FAR, SO GOOD 00012140 MVI STATE,C'A' ABORT THEN 00012150 MVI ERRNUM,X'00' INVALID DATA-PACKET-SIZE ERROR 00012160 B SLOOP 00012170 CH1 C R4,MAXPACK MAX PACKET SIZE 00012180 BNH CH2 CONTINUE IF <= TO MAX 00012190 MVI STATE,C'A' DIE 00012200 MVI ERRNUM,X'00' INVALID DATA-PACKET-SIZE ERROR 00012210 B SLOOP 00012220 CH2 STC R4,SPSIZ+3 USE SPSIZ THE MICRO WANTS 00012230 S R4,FIVE 00012240 ST R4,SIZE SET SIZE TO SPSIZ-5 00012250 CLC LRDAT(4),=F'4' USING DEFAULTS? 00012260 BNH NOCHG YUP 00012270 LA R5,RDAT POINTER TO THE BUFFER 00012280 SR R7,R7 00012290 IC R7,4(R5) SEOL MICRO WANTS 00012300 S R7,SPACE UNCHAR (IE - SUBTRACT SPACE) 00012310 STC R7,SEOL 00012320 NOCHG MVI STATE,C'F' PUT INTO SEND FILE STATE 00012330 XC NUMTRY,NUMTRY RESET TO ZERO 00012340 L R3,N 00012350 LA R3,1(R3) ADD ONE 00012360 ST R3,N STORE VALUE INCREMENTED BY 1 00012370 NC N(4),=X'0000003F' MASK TO GET MOD 64 00012380 B SLOOP 00012390 N1 CLI RTYPE,AN SEE IF IT'S 'N' 00012400 BNE AB1 IF NOT, DIE 00012410 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 00012420 BO SLOOP LEAVE ERR MSG AS IS IF I DID 00012430 MVI ERRNUM,X'09' MICRO NAK'ED 00012440 B SLOOP 00012450 AB1 MVI STATE,C'A' ELSE, ABORT 00012460 MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 00012470 B SLOOP 00012480 ********************************************************************** 00012490 * CREATE AND SEND FILE PACKET * 00012500 ********************************************************************** 00012510 SFILE CLC NUMTRY,MAXTRY EXCEEDED NO. OF TRIES ALLOWED? 00012520 BL OK2 NOPE, STILL OK 00012530 MVI STATE,C'A' ABORT IF YES 00012540 B SLOOP 00012550 OK2 DS 0H 00012560 TR FILNAM,ETOA 00012570 LH R5,FILNAML GET LENGTH OF FILENAME - 1 00012580 MVC SDAT(*-*),FILNAM USE FOR EXECUTE 00012590 EX R5,*-6 GO MOVE FILENAME TO BUFFER 00012600 LA R5,1(,R5) UP THE FILE LENGTH TO BE EXACT 00012610 L R3,NUMTRY 00012620 LA R3,1(R3) INCREMENT TRIAL COUNTER 00012630 ST R3,NUMTRY 00012640 MVI STYPE,AF PACKET TYPE = FILE HEADER 00012650 ST R5,LSDAT SET BUFFER SIZE 00012660 TR FILNAM,ATOE 00012670 SNDFIL L R15,=A(SPACK) GET ADDRESS OF 'SPACK' 00012680 BALR 14,15 SAVE * AND GO TO SPACK 00012690 CLI STATE,C'A' 00012700 BE ABORT 00012710 L 15,=A(RPACK) GET ADDRESS OF 'RPACK' 00012720 BALR 14,15 SAVE * AND GO TO RPACK 00012730 CLI RTYPE,AE ERROR PACKET? 00012740 BNE Y2 MAYBE AN ACK 00012750 MVI ERRNUM,X'0A' MICRO DIED 00012760 MVI STATE,C'A' SO WE DO TOO 00012770 B SLOOP 00012780 Y2 CLI RTYPE,AY SEE IF GOT ACK 00012790 BNE N2 MAYBE GOT AN 'N' 00012800 CLC N,NUM DO WE HAVE THE CORRECT ACK? 00012810 BE AOK2 00012820 MVI ERRNUM,X'08' MISSING A PACKET SOMEWHERE 00012830 B SLOOP 00012840 AOK2 MVI STATE,C'D' PREPARE FOR SEND-DATA STATE 00012850 XC NUMTRY,NUMTRY RESET COUNTER 00012860 L R3,N 00012870 LA R3,1(R3) ADD ONE 00012880 ST R3,N STORE INCREMENTED VALUE 00012890 NC N(4),=X'0000003F' MASK TO GET MOD 64 00012900 L 15,=A(GTCHR) 00012910 BALR 14,15 DO GET-CHAR AND COME BACK 00012920 B SLOOP 00012930 N2 CLI RTYPE,AN 00012940 BNE AB2 ELSE, DIE 00012950 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 00012960 BO SLOOP LEAVE ERR MSG AS IS IF I DID 00012970 MVI ERRNUM,X'09' MICRO NAK'ED 00012980 B SLOOP 00012990 AB2 MVI STATE,C'A' ELSE, ABORT 00013000 MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 00013010 B SLOOP 00013020 ********************************************************************** 00013030 * CREATE AND SEND DATA PACKETS * 00013040 ********************************************************************** 00013050 SDATA CLC NUMTRY,MAXTRY CAN WE DO IT? 00013060 BL OK4 YES 00013070 MVI STATE,C'A' ELSE ABORT 00013080 B SLOOP 00013090 OK4 L R3,NUMTRY 00013100 LA R3,1(R3) INCREMENT COUNTER 00013110 ST R3,NUMTRY 00013120 MVI STYPE,AD PACKET TYPE = DATA 00013130 L R15,=A(SPACK) 00013140 BALR 14,15 GO TO SPACK AND RETURN 00013150 CLI STATE,C'A' 00013160 BE ABORT 00013170 L 15,=A(RPACK) 00013180 BALR 14,15 SAME FOR RPACK 00013190 CLI RTYPE,AE ERROR PACKET? 00013200 BNE Y4 MAYBE AN ACK 00013210 MVI ERRNUM,X'0A' MICRO DIED 00013220 MVI STATE,C'A' SO WE DO TOO 00013230 B SLOOP 00013240 Y4 CLI RTYPE,AY SEE IF GOT 'ACK' 00013250 BNE N4 SEE IF IT'S AN 'N' 00013260 CLC N,NUM DO WE HAVE THE CORRECT ACK? 00013270 BE AOK4 00013280 MVI ERRNUM,X'08' MISSING A PACKET 00013290 B SLOOP 00013300 AOK4 XC NUMTRY,NUMTRY RESET COUNTER 00013310 L R3,N 00013320 LA R3,1(R3) INCREMENT COUNTER 00013330 ST R3,N 00013340 NC N(4),=X'0000003F' MASK TO GET MOD 64 00013350 L 15,=A(GTCHR) 00013360 BALR 14,15 DO GET-CHAR AND RETURN 00013370 B SLOOP 00013380 N4 CLI RTYPE,AN 00013390 BNE AB4 00013400 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 00013410 BO SLOOP LEAVE ERR MSG AS IS IF I DID 00013420 MVI ERRNUM,X'09' MICRO NAK'ED 00013430 B SLOOP 00013440 AB4 MVI STATE,C'A' 00013450 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 00013460 B SLOOP 00013470 ********************************************************************** 00013480 * CREATE AND SEND EOF PACKET * 00013490 ********************************************************************** 00013500 SEOF CLC NUMTRY,MAXTRY CAN WE DO IT? 00013510 BL OK5 BRANCH IF YES 00013520 MVI STATE,C'A' ABORT IF NO 00013530 B SLOOP 00013540 OK5 L R3,NUMTRY 00013550 LA R3,1(R3) ADD ONE 00013560 ST R3,NUMTRY STORE INCREMENTED COUNTER 00013570 MVI STYPE,AZ PACKET TYPE = EOF 00013580 XC LSDAT,LSDAT LENGTH OF ZERO 00013590 L R15,=A(SPACK) 00013600 BALR 14,15 SAVE * AND GO TO SPACK 00013610 CLI STATE,C'A' 00013620 BE ABORT 00013630 L 15,=A(RPACK) 00013640 BALR 14,15 SAME FOR RPACK 00013650 CLI RTYPE,AE ERROR PACKET? 00013660 BNE Y5 MAYBE AN ACK 00013670 MVI ERRNUM,X'0A' MICRO DIED 00013680 MVI STATE,C'A' SO WE DO TOO 00013690 B SLOOP 00013700 Y5 CLI RTYPE,AY CHECK FOR 'ACK' 00013710 BNE N5 MAYBE WAS A 'NAK' 00013720 CLC N,NUM CORRECT ACK? 00013730 BE AOK5 00013740 MVI ERRNUM,X'08' LOST A PACKET 00013750 B SLOOP 00013760 AOK5 L R3,N 00013770 LA R3,1(R3) ADD ONE 00013780 ST R3,N STORE VALUE INCREMENTED BY 1 00013790 NC N(4),=X'0000003F' MASK TO GET MOD 64 00013800 MVI STATE,C'F' SET TO SEND FILE FOR NOW 00013810 * 00013820 * 00013830 * WE JUST PROCESS ONE FILE FOR NOW. 00013840 * 00013850 DIEOK MVI STATE,C'B' BREAK CONNECTION 00013860 B SLOOP 00013870 N5 CLI RTYPE,AN 00013880 BNE AB5 DIE IF NOT A NAK 00013890 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 00013900 BO SLOOP LEAVE ERR MSG AS IS IF I DID 00013910 MVI ERRNUM,X'09' MICRO NAK'ED 00013920 B SLOOP 00013930 AB5 MVI STATE,C'A' ELSE, ABORT 00013940 MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 00013950 B SLOOP 00013960 ********************************************************************** 00013970 * CREATE AND SEND BREAK PACKET * 00013980 ********************************************************************** 00013990 SBREAK CLC NUMTRY,MAXTRY OVER OUR LIMIT? 00014000 BL OK6 BRANCH IF NO 00014010 MVI STATE,C'A' ABORT IF YES 00014020 B SLOOP 00014030 OK6 L R3,NUMTRY 00014040 LA R3,1(R3) ADD ONE 00014050 ST R3,NUMTRY INCREMEMTED TRIAL COUNTER 00014060 MVI STYPE,AB PACKET TYPE = BREAK 00014070 XC LSDAT,LSDAT LENGTH = ZERO 00014080 L R15,=A(SPACK) 00014090 BALR 14,15 SAVE * AND GO TO SPACK 00014100 CLI STATE,C'A' 00014110 BE ABORT 00014120 L 15,=A(RPACK) 00014130 BALR 14,15 SAVE * AND GO TO RPACK 00014140 CLI RTYPE,AE ERROR PACKET? 00014150 BNE Y6 MAYBE AN ACK 00014160 MVI ERRNUM,X'0A' MICRO DIED 00014170 MVI STATE,C'A' THEN WE DO TOO 00014180 B SLOOP 00014190 Y6 CLI RTYPE,AY CHECK FOR ACK 00014200 BNE N6 CHECK FOR 'N' 00014210 CLC N,NUM CORRECT ACK? 00014220 BE AOK6 00014230 MVI ERRNUM,X'08' LOST A PACKET 00014240 B SLOOP 00014250 AOK6 MVI STATE,C'C' COMPLETED STATE 00014260 B SLOOP 00014270 N6 CLI RTYPE,AN CHECK FOR 'N' 00014280 BNE AB6 DIE IF NOT A NAK 00014290 TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 00014300 BO SLOOP LEAVE ERR MSG AS IS IF I DID 00014310 MVI ERRNUM,X'09' MICRO NAK'ED 00014320 B SLOOP 00014330 AB6 MVI STATE,C'A' ELSE,ABORT 00014340 MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 00014350 B SLOOP 00014360 ********************************************************************** 00014370 * CREATE AND SEND ABORT PACKET * 00014380 ********************************************************************** 00014390 ABORT DS 0H 00014400 TM FLAGS,FLG1 DYING ON FILE-NOT-FOUND? 00014410 BO NOERRP IF SO, THEN NO ERROR PACKET 00014420 CLI ERRNUM,X'0A' DID THE MICRO DIE? 00014430 BE NOERRP NO ERROR PACKET IF SO 00014440 MVI STYPE,AE ERROR PACKET 00014450 MVC LSDAT(4),=F'20' ALL MSGS ARE THIS LONG 00014460 MVC N(4),NUM SYNCH PACKET NUMBERS 00014470 SR R5,R5 00014480 IC R5,ERRNUM GET RIGHT MESSAGE NUMBER 00014490 M R4,=F'20' OFFSET := ERRNUM * 20 00014500 LA R5,ERRTAB(R5) 00014510 MVC SDAT(20),0(R5) SPACK NEEDS THE DATA HERE 00014520 TR SDAT(20),ETOA 00014530 L R15,=A(SPACK) 00014540 BALR R14,R15 SEND ERROR PACKET & DIE 00014550 NOERRP LA R15,4 SET NON-ZERO RETCODE 00014560 B SENDRET PREPARE TO LEAVE 00014570 ********************************************************************** 00014580 * PROCESS COMPLETE * 00014590 ********************************************************************** 00014600 COMPLETE SR R15,R15 ZERO WILL BE RETCODE 00014610 SENDRET L R13,4(R13) 00014620 L R14,12(R13) 00014630 LM R0,R12,20(R13) 00014640 BR R14 00014650 EJECT 00014660 ********************************************************************** 00014670 * * 00014680 * ROUTINE TO GET A CHARACTER FROM INPUT BUFFER WILL READ DISK TO * 00014690 * FILL THE BUFFER. * 00014700 * * 00014710 ********************************************************************** 00014720 GTCHR DS 0H 00014730 TM FLAGS,FLG3 SEE IF THERE'S STUFF IN BUF 00014740 BO STUFF ONES -> STUFF'S THERE 00014750 * 00014760 * GO TO COMMON ROUTINE TO READ SOME BYTES 00014770 * 00014780 LA R15,READX 00014790 BALR R15,R15 00014800 * 00014810 LTR R4,R1 PUT RESULT OF READ IN R4 00014820 BZ OK8 00014830 C R4,=A(ERCOD) RETCODE OF 12 MEANS EOF 00014840 BNE ERR1 TRY IT AGAIN 00014850 MVI STATE,C'Z' MAKE TO EOF STATE 00014860 BR R14 00014870 ERR1 MVI STATE,C'A' ABORT ON FILE SYSTEM ERROR 00014880 MVI ERRNUM,X'0C' INVALID RECORD LENGTH 00014890 C R4,=F'8' WAS OUR GUESS RIGHT? 00014900 BER R14 IF YES, RETURN 00014910 MVI ERRNUM,X'0D' ELSE, GOT AN I/O ERROR 00014920 BR R14 00014930 OK8 LR R5,R0 GET NUMBER OF BYTES READ IN 00014940 LR R4,R5 SAVE ALSO IN R4 00014950 BCTR R4,0 SUBTRACT 1 FOR EX COMMAND 00014960 EX R4,TRANS EBCDIC TO ASCII TRANSLATION 00014970 LA R8,BUF GET LOCATION OF BUFFER INPUT 00014980 LA R9,BUF(R4) LAST POSITION IN THAT BUFFER 00014990 X4 CLI 0(R9),X'20' IS THIS A BLANK? 00015000 BNE X5 NO, FOUND LAST CHAR OF LINE 00015010 BCTR R9,0 00015020 CR R9,R8 00015030 BNL X4 FIND LAST CHAR 00015040 SR R5,R5 ALL BLANKS 00015050 B FOO 00015060 X5 SR R9,R8 00015070 LR R5,R9 LENGTH OF LINE 00015080 LA R5,1(R5) ADD ONE 00015090 FOO LA R9,BUF(R5) FIRST BLANK SPACE AFTER DATA 00015100 MVC 0(1,R9),=X'0D' ADD ASCII CR 00015110 LA R9,1(R9) INCREMENT POINTER 00015120 MVC 0(1,R9),=X'0A' AND ADD ASCII LF 00015130 LA R5,2(R5) TWO EXTRA BYTES OF DATA NOW 00015140 ST R5,RECL LRECL + 2 (FOR CRLF) 00015150 SR R8,R8 ZERO OUT INDEX FOR BUF 00015160 STUFF SR R9,R9 SAME FOR INDEX FOR SDAT 00015170 SR R10,R10 CHARACTER COUNTER 00015180 SR R5,R5 WILL HOLD QUOCHAR 00015190 IC R5,QUOCHAR 00015200 L R8,SAVPL WHERE WE LEFT OFF 00015210 C R8,RECL SEE IF ARE AT LIMIT 00015220 BNL FULL2 LEAVE IF REACHED OR EXCEEDED 00015230 SR R7,R7 00015240 LOOP IC R7,BUF(R8) PICK UP BYTE 00015250 CR R7,R5 IS IT THE QUOTE CHARACTER? 00015260 BE SPECIAL 00015270 C R7,DEL IS IT THE CHARDEL? 00015280 BE SPECIAL 00015290 C R7,SPACE IS IT A CONTROL CHARACTER? 00015300 BL SPECIAL 00015310 B ADDIT 00015320 SPECIAL L R4,SIZE MUNGE VALUE WHILE IN R4 00015330 SR R4,R10 FIND DIF BETWWEN THE TWO 00015340 C R4,TWO SEE IF HAVE AT LEAST 2 BYTES 00015350 BNL ROOM YES,CAN ADD 00015360 STC R10,LSDAT+3 SET LSDAT TO VAL OF COUNTER 00015370 OI FLAGS,FLG3 SET FLAG TO SHOW STUFF'S THERE 00015380 ST R8,SAVPL SAVE PLACE IN BUF 00015390 BR 14 LEAVE THIS ROUTINE 00015400 ROOM LA R4,SDAT(R9) WHERE IT'S GOING 00015410 MVC 0(1,R4),QUOCHAR MOVE QUOTE CHAR THERE 00015420 LA R9,1(R9) INCREMENT SDAT COUNTER 00015430 LA R10,1(R10) INCREMENT CHARACTER COUNTER 00015440 CR R7,R5 DON'T ADD ^O100 TO THIS 00015450 BE ADDIT IT'S ALREADY PRINTABLE 00015460 A R7,O1H ADD ^O100 TO CHAR 00015470 N R7,=X'0000007F' GET MOD ^O200 00015480 ADDIT STC R7,SDAT(R9) ADD THE CHARACTER 00015490 LA R9,1(R9) INCREMENT SDAT COUNTER 00015500 LA R8,1(R8) INCREMENT BUF COUNTER 00015510 LA R10,1(R10) INCREMENT CHARACTER COUNTER 00015520 C R8,RECL SEE IF REACHED LIMIT 00015530 BNL FULL2 00015540 C R9,SIZE SEE IF REACHED LIMIT 00015550 BNL FULL 00015560 B LOOP 00015570 FULL EQU * 00015580 STC R10,LSDAT+3 THIS ONE TOO 00015590 ST R8,SAVPL HERE TOO 00015600 OI FLAGS,FLG3 TURN ON FLAG - STUFF IN BUF 00015610 BR 14 00015620 FULL2 EQU * 00015630 STC R10,LSDAT+3 THIS ONE TOO 00015640 XC SAVPL,SAVPL RESET THIS 00015650 NI FLAGS,X'FF'-FLG3 TURN OFF LEFTOVER DATA FLAG 00015660 BR 14 00015670 SENDSAVE DS 18F 00015680 TRANS TR BUF(0),ETOA EBCDIC TO ASCII TRANSLATION 00015690 TRNS TR SNDPKT(0),ATOE BACK FROM ASCII TO EBCDIC 00015700 PARSE DC 32X'00' 00015710 DC X'01' STOP ON A SPACE 00015720 DC 223X'00' 00015730 FIRST MVC SDAT(0),FILNAM PICK UP THE FN 00015740 SECOND MVC 0(0,R7),FILNAM+8 PICK UP FT 00015750 LTORG 00015760 DROP R11 00015770 DROP R12 DON'T NEED THEM ANYMORE 00015780 EJECT 00015790 ********************************************************************** 00015800 * * 00015810 * ROUTINE TO PROCESS SEND PACKET REQUEST * 00015820 * * 00015830 ********************************************************************** 00015840 SPACK DS 0H CSECT 00015850 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 00015860 BALR R12,0 ESTABLISH ADDRESSABILITY 00015870 USING *,R12 00015880 LA R14,SPSAVE ADDRESS OF MY SAVE AREA 00015890 ST R13,4(R14) SAVE CALLER'S 00015900 ST R14,8(R13) 00015910 LR R13,R14 00015920 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 00015930 L R11,=A(PARMS) 00015940 USING PARMS,R11 ESTABLISH ADDRESSABILITY 00015950 SR R9,R9 00015960 MVC PHDR,SSOH ADD SOH TO PACKET 00015970 CLC LSDAT,SIZE NEED DATA SIZE <= SPSIZ-5 00015980 BNH FINE 00015990 MVI ERRNUM,X'00' DATA SIZE EXCEEDS MAX LIMIT 00016000 MVI STATE,C'A' ABORT ON THIS 00016010 B SPRET 00016020 FINE L R4,=F'35' USE ^o43 TO OFFSET DATA 00016030 A R4,LSDAT ADD IT TO LSDAT 00016040 STC R4,PLEN 00016050 AR R9,R4 AND THEN ADD IT TO CHECKSUM 00016060 CLC N,ZERO CHECK IF N IS VALID 00016070 BNL T1 OK IF >= TO 0 00016080 MVI ERRNUM,X'01' ILLEGAL MESSAGE NUMBER 00016090 MVI STATE,C'A' 00016100 B SPRET 00016110 T1 CLC N,O1H SEE IF IS <= OCTAL 100 00016120 BNH T2 00016130 MVI ERRNUM,X'01' ILLEGAL MESSAGE NUMBER 00016140 MVI STATE,C'A' 00016150 B SPRET 00016160 T2 L R4,SPACE OFFSET THIS VALUE TOO 00016170 A R4,N ADD IT TO N 00016180 ST R4,TEMP 00016190 MVC PNUM(1),TEMP+3 00016200 A R9,TEMP AND ADD TO CHECKSUM 00016210 CLI STYPE,X'41' ASCII 'A' 00016220 BL T3 CAN'T BE LESS THAN THIS 00016230 CLI STYPE,X'5A' ASCII 'Z' 00016240 BNH T4 CAN'T BE GREATER 00016250 T3 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 00016260 MVI STATE,C'A' DIE ON THIS 00016270 B SPRET 00016280 T4 MVC PTYPE(1),STYPE ADD MESSAGE TYPE 00016290 SR R2,R2 ZERO IT OUT 00016300 IC R2,STYPE 00016310 AR R9,R2 ADD TO CHECKSUM 00016320 L R6,LSDAT HOW MUCH DATA 00016330 LTR R6,R6 TEST IT OUT 00016340 BZ NODAT 00016350 SR R5,R5 USE TO GET DATA 00016360 SR R3,R3 USE TO HOLD DATA 00016370 DATCHK IC R3,SDAT(R5) PICK UP CHAR 00016380 AR R9,R3 ADD TO CHECKSUM 00016390 LA R5,1(R5) BUMP POINTER 00016400 BCTR R6,0 00016410 LTR R6,R6 MORE DATA? 00016420 BNZ DATCHK 00016430 NODAT L R6,LSDAT WILL NEED THIS LATER 00016440 LR R7,R6 MUNGE WHILE IN R7 00016450 BCTR R7,0 SUBTRACT 1 FOR EX FUNCTION 00016460 EX R7,MOVE MOVE THE DATA TO SNDPKT 00016470 ST R9,TEMP WE'LL NEED THIS SOON 00016480 N R9,=X'000000C0' GET MOD 192 00016490 M R8,ONE CARRY OVER THE SIGN BIT 00016500 D R8,O1H GET MOD 64 00016510 A R9,TEMP ADD THE TWO VALUES 00016520 N R9,=X'0000003F' GET MOD 64 OF CHECKSUM 00016530 A R9,SPACE ADD OFFSET 00016540 STC R9,PDATA(R6) ADD CHECKSUM AFTER DATA 00016550 LA R6,1(R6) MOVE POINTER 00016560 IC R9,SEOL ADD SEND END OF PACKET CHAR 00016570 STC R9,PDATA(R6) 00016580 LA R6,5(R6) VALUE OF LSDAT+5 00016590 TR SNDPKT(130),ATOE SEND IN EBCDIC 00016600 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 00016610 BZ SPNODEB 00016620 MVC WRKBUFF(2),=H'20' 00016630 XC WRKBUFF+2(2),WRKBUFF+2 00016640 MVC WRKBUFF+4(16),=CL16'TPUT SEND PACKET' 00016650 PUT DEBUG,WRKBUFF 00016660 LA R1,4(,R6) ADJUST LENGTH 00016670 STH R1,WRKBUFF SET RDW 00016680 EX R6,DBGMVC1 MOVE IN DATA 00016690 PUT DEBUG,WRKBUFF 00016700 SPNODEB TPUT SNDPKT,(R6),CONTROL 00016710 LTR R15,R15 WAS THERE ANY ERROR? 00016720 BZ SPRET NO, THEN JUST RETURN 00016730 MVI ERRNUM,10 SET MICRO DIED 00016740 MVI STATE,C'A' ABORT ON THIS 00016750 SPRET L R13,4(R13) 00016760 L R14,12(R13) 00016770 LM R0,R12,20(R13) 00016780 BR 14 00016790 SPSAVE DS 18F 00016800 MOVE MVC PDATA(0),SDAT 00016810 DBGMVC1 MVC WRKBUFF+4(*-*),SNDPKT 00016820 LTORG 00016830 DROP R11 00016840 DROP R12 DON'T NEED THEM ANYMORE 00016850 EJECT 00016860 ********************************************************************** 00016870 * * 00016880 * ROUTINE TO PROCESS RECEIVE PACKET REQUEST * 00016890 * * 00016900 ********************************************************************** 00016910 RPACK DS 0H 00016920 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 00016930 BALR R12,0 ESTABLISH ADDRESSABILITY 00016940 USING *,R12 00016950 LA R14,RPSAVE ADDRESS OF MY SAVE AREA 00016960 ST R13,4(R14) SAVE CALLER'S 00016970 ST R14,8(R13) 00016980 LR R13,R14 00016990 * USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 00017000 L R11,=A(PARMS) 00017010 USING PARMS,R11 ESTABLISH ADDRESSABILITY 00017020 MVI RECPKT,C' ' CLEAR OUT THE INPUT AREA GUCSL 00017021 MVC RECPKT+1(L'RECPKT-1),RECPKT GUCSL 00017022 TGET RECPKT,130,ASIS 00017030 LTR R15,R15 WAS THERE AN ERROR? 00017040 BZ RPTSTDB NO, THEN TEST FOR DEBUG 00017050 MVI RTYPE,AE SET AN ERROR 00017060 B RPRET 00017070 RPTSTDB TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 00017082 BZ RDNODEB 00017090 LA R8,4(,R1) SAVE LENGTH 00017100 MVC WRKBUFF(2),=H'19' 00017110 XC WRKBUFF+2(2),WRKBUFF+2 00017120 MVC WRKBUFF+4(15),=CL15'TGET REC PACKET' 00017130 PUT DEBUG,WRKBUFF 00017140 STH R8,WRKBUFF SET RDW 00017150 EX R8,DBGMVC2 MOVE IN DATA 00017160 PUT DEBUG,WRKBUFF 00017170 RDNODEB TR RECPKT(130),ETOA 00017180 NI FLAGS,X'FF'-FLG4 ASSUME MICRO'LL NAK-NOT RPACK 00017190 SR R8,R8 INDEX REG FOR RECPKT 00017200 SR R5,R5 CHECKSUM REGISTER 00017210 TRY LA R7,RECPKT(R8) ADDRESS OF CHARACTER 00017220 CLC RSOH,0(R7) IS IT START OF HEADER 00017230 BE READIN YES; SO FAR, SO GOOD 00017240 LA R8,1(R8) TRY NEXT CHARACTER 00017250 C R8,=F'130' SEE IF EXCEED BUFFER 00017260 BL TRY 00017270 MVI ERRNUM,X'03' NO "SOH" ERROR 00017280 B BADP 00017290 READIN SR R9,R9 ZERO OUT INDEX REG FOR RDAT 00017300 LA R8,1(R8) INCREMENT COUNTER 00017310 LA R7,RECPKT(R8) PICK UP LOC OF CHAR COUNT 00017320 CLC RSOH,0(R7) IS IT START OF HEADER? 00017330 BE READIN START OVER 00017340 CLC 0(1,R7),DQUOTE COUNT+' '+3 AND ^d35 00017350 BNL CONT CONTINUE IF >= 00017360 MVI ERRNUM,X'04' BAD LENGTH ATTRIBUTE 00017370 B BADP 00017380 CONT IC R5,0(R7) START CHECKSUM 00017390 LR R7,R5 MUNGE IN R7 TO GET LRDAT 00017400 S R7,=F'35' LENGTH OF DATA 00017410 STC R7,LRDAT+3 00017420 LA R8,1(R8) INCREMENT 00017430 SR R7,R7 ZERO IT OUT 00017440 IC R7,RECPKT(R8) PICK UP PACKET NUMBER 00017450 CLM R7,B'0001',RSOH IS IT START OF HEADER 00017460 BE READIN 00017470 AR R5,R7 ADD TO CHECKSUM 00017480 S R7,SPACE SUBTRACT THE ' ' 00017490 STC R7,NUM+3 NUM := RECEIVED PACKET NO. 00017500 LA R8,1(R8) INCREMENT COUNTER 00017510 IC R7,RECPKT(R8) PICK UP MESSAGE TYPE 00017520 CLM R7,B'0001',RSOH IS IT START OF HEADER? 00017530 BE READIN 00017540 AR R5,R7 ADD TO CHECKSUM 00017550 STC R7,RTYPE PUT INTO RTYPE 00017560 LA R8,1(R8) GO TO NEXT BYTE 00017570 L R4,LRDAT COUNTER TO GET ALL DATA 00017580 LUP C R4,ZERO SEE IF PICKED UP ALL DATA 00017590 BE FIN 00017600 XC TEMP,TEMP ZERO IT OUT 00017610 LA R7,RECPKT(R8) NEXT LOCATION IN BUFFER 00017620 MVC TEMP+3(1),0(R7) PICK UP NEXT BYTE 00017630 CLC RSOH,TEMP+3 IS IT START OF HEADER 00017640 BE READIN 00017650 LA R7,RDAT(R9) WHERE THE DATA'S GOING 00017660 MVC 0(1,R7),TEMP+3 AND MOVE IT 00017670 A R5,TEMP ADD TO CHECKSUM 00017680 LA R8,1(R8) ADD ONE 00017690 LA R9,1(R9) ADD ONE 00017700 BCTR R4,0 DECREMENT COUNTER 00017710 B LUP 00017720 FIN SR R7,R7 ZERO OUT REGISTER 00017730 IC R7,RECPKT(R8) GET CHECKSUM 00017740 CLM R7,B'0001',RSOH IS IT START OF HEADER 00017750 BE READIN 00017760 ST R5,TEMP WE'LL NEED THIS SOON 00017770 N R5,=X'000000C0' GET MOD 192 00017780 M R4,ONE CARRY OVER THE SIGN BIT 00017790 D R4,O1H GET MOD 64 00017800 A R5,TEMP ADD THE TWO VALUES 00017810 N R5,=X'0000003F' GET MOD 64 00017820 A R5,SPACE ADD OFFSET 00017830 CR R5,R7 COMPUTED VS RECEIVED CHECKSUM 00017840 BE RPRET 00017850 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN 00017860 BZ NODEBG2 00017870 MVC WRKBUFF(2),=H'18' 00017880 XC WRKBUFF+2(2),WRKBUFF+2 00017890 MVC WRKBUFF+4(14),=CL14'CHECKSUM ERROR' 00017900 PUT DEBUG,WRKBUFF 00017910 NODEBG2 MVI ERRNUM,X'05' BAD CHECKSUM ERROR 00017920 BADP MVI RTYPE,AN RETURN A NAK 00017930 OI FLAGS,FLG4 RPACK NAK'ED THE PACKET 00017940 RPRET L R13,4(R13) 00017950 L R14,12(R13) 00017960 LM R0,R12,20(R13) 00017970 BR 14 00017980 DBGMVC2 MVC WRKBUFF+4(*-*),RECPKT 00017990 RPSAVE DS 18F 00018000 LTORG 00018010 DROP R11 00018020 DROP R12 DON'T NEED THEM ANYMORE 00018030 EJECT 00018040 ********************************************************************** 00018050 * * 00018060 * DISK FILE READ ROUTE WITH DEBUGGING CODE * 00018070 * * 00018080 ********************************************************************** 00018090 READX DS 0H 00018100 USING PARMS,R11 ESTABLISH ADDRESSABILITY 00018110 STM R12,R15,READSAVE 00018120 BALR R12,0 00018130 USING *,R12 00018140 TM KERIN+(DCBRECFM-IHADCB),DCBRECV VARIABLE? 00018150 BO RDVAR 00018160 GET KERIN,BUF 00018170 B RDTSTDB 00018180 RDVAR GET KERIN,BUF-4 00018190 RDTSTDB TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 00018200 BZ RDNODBG 00018210 MVC WRKBUFF(2),=H'12' 00018220 XC WRKBUFF+2(2),WRKBUFF+2 00018230 MVC WRKBUFF+4(8),=CL8'QSAM GET' 00018240 PUT DEBUG,WRKBUFF 00018250 LH R1,KERIN+(DCBLRECL-IHADCB) 00018260 STH R1,WRKBUFF 00018270 EX R1,DBGMVC3 00018280 PUT DEBUG,WRKBUFF 00018290 RDNODBG XR R1,R1 SET RETURN CODE 00018300 LH R0,KERIN+(DCBLRECL-IHADCB) GET RECORD LENGTH 00018310 TM KERIN+(DCBRECFM-IHADCB),DCBRECV VARIABLE? 00018320 BZ *+12 NO, THEN SKIP 00018330 LH R0,BUF-4 GET LENGTH FROM RDW 00018340 SH R0,=H'4' REMOVE RDW LENGTH 00018350 LM R12,R15,READSAVE 00018360 BR R15 00018370 DBGMVC3 MVC WRKBUFF+4(*-*),KERIN 00018380 * 00018390 INEOF DS 0H 00018400 LA R1,12 00018410 XR R0,R0 00018420 LM R12,R15,READSAVE 00018430 BR R15 00018440 LTORG 00018450 DROP R11 00018460 DROP R12 00018470 EJECT 00018480 ********************************************************************** 00018490 * * 00018500 * ROUTINE TO PROCESS RECEIVE COMMAND * 00018510 * * 00018520 ********************************************************************** 00018530 RECEIVE DS 0H 00018540 STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 00018550 BALR R12,0 ESTABLISH ADDRESSABILITY 00018560 USING *,R12 00018570 LA R14,RECSAVE ADDRESS OF MY SAVE AREA 00018580 ST R13,4(R14) SAVE CALLER'S 00018590 ST R14,8(R13) 00018600 LR R13,R14 00018610 * USE R11 AS BASE REGISTER FOR THE GLOBAL DATA AREA, 'PARMS' 00018620 L R11,=A(PARMS) 00018630 USING PARMS,R11 00018640 SR R6,R6 GET ZERO 00018650 ST R6,NUMTRY ZERO THIS OUT 00018660 ST R6,N HERE TOO 00018670 MVI STATE,C'R' SET TO RECEIVE STATE 00018680 ********************************************************************** 00018690 * MAIN RECEIVE PROCESSING LOOP * 00018700 ********************************************************************** 00018710 RLOOP CLI STATE,C'D' RECEIVE DATA STATE 00018720 BE RDATA 00018730 CLI STATE,C'F' RECEIVE FILE STATE 00018740 BE RFILE 00018750 CLI STATE,C'R' RECEIVE INIT STATE 00018760 BE RINIT 00018770 CLI STATE,C'C' COMPLETE STATE 00018780 BE RCOMP 00018790 CLI STATE,C'A' ABORT STATE 00018800 BE RABORT 00018810 MVI ERRNUM,X'02' UNRECOGNIZED STATE 00018820 B RABORT ELSE, DIE 00018830 ********************************************************************** 00018840 * PROCESS INITIALIZATION PACKET * 00018850 ********************************************************************** 00018860 RINIT CLC NUMTRY,IMXTRY SEE IF CAN RECEIVE 00018870 BL ROK1 YES, WE CAN 00018880 MVI STATE,C'A' NOPE, GO INTO ABORT STATE 00018890 B RLOOP 00018900 ROK1 L R3,NUMTRY 00018910 LA R3,1(R3) INCREMENT TRIAL COUNTER 00018920 ST R3,NUMTRY 00018930 L R4,DSSIZ DEFAULT SEND PACKET SIZE 00018940 S R4,FIVE USE DEFAULT TO SET "SIZE" 00018950 ST R4,SIZE IN CASE WE DIE BEFORE IT'S SET 00018960 L R15,=A(RPACK) GET INIT INFORMATION 00018970 BALR R14,R15 00018980 CLI RTYPE,AE ERROR PACKET? 00018990 BNE RY1 ALL OK 00019000 MVI ERRNUM,X'0A' MICRO DIED 00019010 MVI STATE,C'A' SO WE DO TOO 00019020 B RLOOP 00019030 RY1 CLI RTYPE,AS IS IT A SEND-INIT PACKET 00019040 BNE RN1 MAYBE IT GOT CLOBBERED 00019050 SR R4,R4 ZERO OUT REGISTER 00019060 IC R4,RDAT GET FIRST CHARACTER 00019070 S R4,SPACE SUBTRACT THE ' ' 00019080 C R4,=F'26' MIN SPACK SIZE 00019090 BNL RCH1 SO FAR, SO GOOD 00019100 MVI STATE,C'A' ELSE, ABORT 00019110 MVI ERRNUM,X'00' INVALID DATA-PACKET-SIZE ERROR 00019120 B RLOOP 00019130 RCH1 C R4,MAXPACK MAX PACKET SIZE 00019140 BNH RCH2 00019150 MVI STATE,C'A' ABORT IF SIZE IS ILLEGAL 00019160 MVI ERRNUM,X'00' BAD SEND DATA LENGTH 00019170 B RLOOP 00019180 RCH2 STC R4,SPSIZ+3 USE THE VALUE AS SEND SIZE 00019190 S R4,FIVE 00019200 ST R4,SIZE SET IT TO SPSIZ-5 00019210 CLC LRDAT(4),=F'4' USING ALL DEFAULTS ? 00019220 BNH NOCH YUP 00019230 LA R5,RDAT POINT TO THE BUFFER 00019240 SR R7,R7 00019250 IC R7,4(R5) SEOL THE MICRO WANTS 00019260 S R7,SPACE UNCHAR (SUBTRACT ' ') 00019270 STC R7,SEOL 00019280 CLC LRDAT(4),FIVE ANY MORE DATA? 00019290 BNH NOCH JUST USE DEFAULTS 00019300 MVC RQUO(1),5(R5) SET NEW QUOCHAR VALUE 00019310 NOCH MVC N(4),NUM SYNCH PACKET NUMBERS 00019320 MVI STYPE,AY SET MESSAGE TYPE TO ACK 00019330 MVC LSDAT(4),=F'6' SET LENGTH OF DATA SENDING 00019340 L R5,SPACE MAKE CHARACTER PRINTABLE 00019350 A R5,RPSIZ ADD REC PACKET SIZE 00019360 STC R5,SDAT ADD SIZE INFO TO BUFFER 00019370 L R5,SPACE 00019380 A R5,=F'8' 8 FOR TIMEOUT 00019390 STC R5,SDAT+1 00019400 L R5,SPACE SEND ZERO + " " FOR NPAD 00019410 STC R5,SDAT+2 WE'RE THE SLOW GUYS 00019420 SR R5,R5 PAD WITH NULLS 00019430 L R3,O1H 00019440 XR R5,R3 CTL FUNCTION (XOR WITH 64) 00019450 STC R5,SDAT+3 DON'T NEED PADCHAR EITHER 00019460 SR R5,R5 ZERO IT OUT FOR NEXT TWO GUYS 00019470 IC R5,REOL EOL CHAR I NEED 00019480 A R5,SPACE MAKE PRINTABLE 00019490 STC R5,SDAT+4 00019500 IC R5,QUOCHAR MY QUOTE CHAR 00019510 STC R5,SDAT+5 00019520 L R15,=A(SPACK) ADDRESS OF SPACK 00019530 BALR R14,R15 SAVE * AND GO TO SPACK 00019540 CLI STATE,C'A' 00019550 BE RABORT 00019560 MVI STATE,C'F' SET TO RECEIVE FILE STATE 00019570 MVC OLDTRY(4),NUMTRY SAVE TRIAL COUNTER 00019580 XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 00019590 L R3,N 00019600 LA R3,1(R3) ADD ONE 00019610 ST R3,N STORE VALUE INCREMENTED BY 1 00019620 NC N(4),=X'0000003F' MASK TO GET MOD 64 00019630 B RLOOP 00019640 RN1 CLI RTYPE,AN MAYBE IT'S A NAK 00019650 BNE RSELSE 00019660 MVI STYPE,AN SEND A NAK PACKET 00019670 XC LSDAT,LSDAT NO DATA 00019680 L R15,=A(SPACK) 00019690 BALR R14,R15 00019700 B RLOOP 00019710 RSELSE MVI STATE,C'A' ELSE,ABORT 00019720 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 00019730 B RLOOP 00019740 ********************************************************************** 00019750 * PROCESS FILE PACKET * 00019760 ********************************************************************** 00019770 RFILE CLC NUMTRY,MAXTRY EXCEEDED NO. OF TRIALS ALLOWED 00019780 BL ROK2 NOPE, STILL OK 00019790 MVI STATE,C'A' ABORT IF YES 00019800 B RLOOP 00019810 ROK2 L R3,NUMTRY 00019820 LA R3,1(R3) INCREMENT TRIAL COUNTER 00019830 ST R3,NUMTRY 00019840 L R15,=A(RPACK) GET ADDRESS OF RPACK 00019850 BALR R14,R15 GO THERE AND RETURN WHEN DONE 00019860 CLI RTYPE,AE ERROR PACKET? 00019870 BNE RY2 MAYBE AN ACK 00019880 MVI ERRNUM,X'0A' MICRO DIED 00019890 MVI STATE,C'A' SO WE DO TOO 00019900 B RLOOP 00019910 RY2 CLI RTYPE,AS STILL IN INIT STATE? 00019920 BNE RNZ TRY FOR AN EOF 00019930 CLC OLDTRY,MAXTRY CAN WE TRY AGAIN? 00019940 BL ROLD 00019950 MVI STATE,C'A' ELSE, ABORT 00019960 B RLOOP 00019970 ROLD L R3,OLDTRY 00019980 LA R3,1(R3) INCREMENT COUNTER 00019990 ST R3,OLDTRY 00020000 L R3,N GET PACKET NUMBER SENT 00020010 BCTR R3,0 SUBTRACT ONE FROM IT 00020020 C R3,NUM NUM MUST EQUAL N-1 00020030 BE RNUM 00020040 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 00020050 B RNAK SEND A NAK 00020060 RNUM MVI STYPE,AY ACK PACKET 00020070 ST R3,N MAKE SEND SEQ NO. = N-1 00020080 MVC LSDAT(4),=F'6' SET DATA LENGTH VARIABLE 00020090 L R15,=A(SPACK) 00020100 BALR R14,R15 GO TO SPACK AND RETURN 00020110 CLI STATE,C'A' 00020120 BE RABORT 00020130 L R4,N 00020140 LA R4,1(R4) ADD ONE 00020150 ST R4,N RESTORE N TO PROPER VALUE 00020160 XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 00020170 B RLOOP 00020180 RNZ CLI RTYPE,AZ 00020190 BNE RNF MAYBE IT'S AN 'F' 00020200 CLC OLDTRY,MAXTRY CAN WE TRY AGAIN? 00020210 BL ROLD2 00020220 MVI STATE,C'A' ELSE,ABORT 00020230 B RLOOP 00020240 ROLD2 L R3,OLDTRY 00020250 LA R3,1(R3) INCREMENT COUNTER 00020260 ST R3,OLDTRY 00020270 L R3,N GET PACKET NUMBER SENT 00020280 BCTR R3,0 SUBTRACT ONE FROM IT 00020290 C R3,NUM NUM MUST EQUAL N-1 00020300 BE RNUM2 00020310 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 00020320 B RNAK SEND A NAK 00020330 RNUM2 MVI STYPE,AY ACK PACKET 00020340 ST R3,N SEND SEQ := N-1 00020350 XC LSDAT,LSDAT NO DATA 00020360 L R15,=A(SPACK) 00020370 BALR R14,R15 00020380 CLI STATE,C'A' 00020390 BE RABORT 00020400 L R4,N 00020410 LA R4,1(R4) ADD ONE 00020420 ST R4,N RESTORE N TO PROPER VALUE 00020430 XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 00020440 B RLOOP 00020450 RNF CLI RTYPE,AF 00020460 BNE RNB WELL, IT'S NOT A FNAME 00020470 CLC NUM,N THEY HAVE TO BE EQUAL 00020480 BE RNUM3 00020490 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 00020500 B RNAK SEND A NAK 00020510 RNUM3 MVI STYPE,AY ACK PACKET 00020520 XC LSDAT,LSDAT NO DATA 00020530 OVER L R15,=A(SPACK) 00020540 BALR R14,R15 SEND ACK 00020550 CLI STATE,C'A' 00020560 BE RABORT 00020570 MVC OLDTRY(4),NUMTRY KEEP NUMTRY FOR LATER 00020580 XC NUMTRY,NUMTRY RESET TO ZERO 00020590 L R3,N 00020600 LA R3,1(R3) ADD ONE 00020610 ST R3,N INCREMENT COUNTER 00020620 NC N(4),=X'0000003F' MASK TO GET MOD 64 00020630 MVI STATE,C'D' DATA RECEIVE STATE 00020640 B RLOOP 00020650 RNB CLI RTYPE,AB SEE IF IT'S A BREAK 00020660 BNE RNN MAYBE GOT A NAK 00020670 CLC NUM,N 00020680 BE RNUM4 00020690 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 00020700 B RNAK SEND A NAK 00020710 RNUM4 MVI STYPE,AY ACK PACKET 00020720 XC LSDAT,LSDAT NO DATA 00020730 L R15,=A(SPACK) 00020740 BALR R14,R15 00020750 CLI STATE,C'A' 00020760 BE RABORT 00020770 MVI STATE,C'C' COMPLETE STATE 00020780 B RLOOP 00020790 RNN CLI RTYPE,AN SEE IF GOT A NAK 00020800 BNE RNELSE 00020810 RNAK MVI STYPE,AN SEND A NAK PACKET 00020820 XC LSDAT,LSDAT NO DATA 00020830 L R15,=A(SPACK) 00020840 BALR R14,R15 00020850 B RLOOP DO NOTHING ON A NAK 00020860 RNELSE MVI STATE,C'A' ABORT OTHERWISE 00020870 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 00020880 B RLOOP 00020890 ********************************************************************** 00020900 * RECEIVE DATA PACKETS * 00020910 ********************************************************************** 00020920 RDATA CLC NUMTRY,MAXTRY HAVE WE EXCEEDED OUR LIMIT? 00020930 BL ROK3 00020940 MVI STATE,C'A' ELSE, ABORT 00020950 B RLOOP 00020960 ROK3 L R4,NUMTRY 00020970 LA R4,1(R4) INCREMENT 00020980 ST R4,NUMTRY SAVE INCREMENTED COUNTER 00020990 L R15,=A(RPACK) 00021000 BALR R14,R15 CALL RPACK 00021010 CLI RTYPE,AE ERROR PACKET? 00021020 BNE RY3 MAYBE AN ACK 00021030 MVI ERRNUM,X'0A' MICRO DIED 00021040 MVI STATE,C'A' WE ABORT TOO 00021050 B RLOOP 00021060 RY3 CLI RTYPE,AD IS THIS A DATA PACKET? 00021070 BNE RDF MAYBE IT'S AN FNAME PACKET 00021080 CLC N,NUM CHECK FOR RIGHT PACKET 00021090 BNE DIF 00021100 L R15,=A(PTCHR) 00021110 BALR R14,R15 PUT CHARACTERS INTO FILE 00021120 LTR R7,R7 CHECK FOR NO ERROR 00021130 BZ OKWR NO ERROR 00021140 MVI STATE,C'A' ABORT ON FILE SYSTEM ERROR 00021150 B RLOOP 00021160 OKWR MVI STYPE,AY ACK PACKET 00021170 XC LSDAT,LSDAT NO DATA 00021180 L R15,=A(SPACK) 00021190 BALR R14,R15 00021200 CLI STATE,C'A' 00021210 BE RABORT 00021220 MVC OLDTRY(4),NUMTRY SAVE NUMTRY'S VALUE IN OLDTRY 00021230 XC NUMTRY,NUMTRY RESET NUMTRY 00021240 L R3,N 00021250 LA R3,1(R3) 00021260 ST R3,N INCREMENT COUNTER 00021270 NC N(4),=X'0000003F' MASK TO GET MOD 64 00021280 B RLOOP 00021290 DIF CLC OLDTRY,MAXTRY CAN WE DO IT? 00021300 BL DIFNUM 00021310 MVI STATE,C'A' AND ABORT 00021320 B RLOOP 00021330 DIFNUM L R4,OLDTRY 00021340 LA R4,1(R4) 00021350 ST R4,OLDTRY INCREMENT THIS COUNTER 00021360 L R4,N 00021370 BCTR R4,0 00021380 C R4,NUM NUM MUST EQUAL N-1 00021390 BE DIFOK 00021400 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 00021410 B RDN1 SEND A NAK 00021420 DIFOK XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 00021430 MVI STYPE,AY ACK PACKET 00021440 XC LSDAT,LSDAT NO DATA 00021450 ST R4,N SET N TO N-1 TO RESEND PACKET 00021460 L R15,=A(SPACK) 00021470 BALR R14,R15 SEND THE PACKET 00021480 CLI STATE,C'A' 00021490 BE RABORT 00021500 L R4,N 00021510 LA R4,1(R4) ADD ONE 00021520 ST R4,N RESTORE N TO PROPER VALUE 00021530 B RLOOP AND RETURN 00021540 RDF CLI RTYPE,AF SENDING FILENAME AGAIN? 00021550 BNE RDZ 00021560 CLC OLDTRY,MAXTRY CAN WE DO IT? 00021570 BL FILOVER TRYING IT AGAIN 00021580 MVI STATE,C'A' IF NO, ABORT 00021590 B RLOOP 00021600 FILOVER L R4,OLDTRY 00021610 LA R4,1(R4) 00021620 ST R4,OLDTRY SAVE INCREMENTED VALUE 00021630 L R4,N 00021640 BCTR R4,0 NEED VALUE OF N-1 00021650 C R4,NUM N-1 MUST EQUAL NUM 00021660 BE FILOK 00021670 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 00021680 B RDN1 SEND A NAK 00021690 FILOK XC NUMTRY,NUMTRY RESET TO ZERO 00021700 XC LSDAT,LSDAT NO DATA 00021710 MVI STYPE,AY ACK PACKET AGAIN 00021720 ST R4,N SET N TO N-1 FOR NOW 00021730 OVRWRT L R15,=A(SPACK) 00021740 BALR R14,R15 00021750 CLI STATE,C'A' 00021760 BE RABORT 00021770 L R4,N 00021780 LA R4,1(R4) ADD ONE 00021790 ST R4,N RESTORE N TO PROPER VALUE 00021800 B RLOOP AND RETURN 00021810 RDZ CLI RTYPE,AZ IS THIS AN EOF PACKET? 00021820 BNE RDN 00021830 CLC N,NUM ARE THEY EQUAL 00021840 BE RDOK 00021850 MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 00021860 B RDN1 SEND A NAK 00021870 RDOK MVI STYPE,AY ACK THE PACKET 00021880 XC LSDAT,LSDAT NO DATA 00021890 L R15,=A(SPACK) 00021900 BALR R14,R15 00021910 MVC OLDTRY(4),NUMTRY SAVE NUMTRY'S VALUE HERE 00021920 XC NUMTRY,NUMTRY AND RESET COUNTER 00021930 L R3,N 00021940 LA R3,1(R3) 00021950 ST R3,N STORE VALUE INCREMENTED BY 1 00021960 NC N(4),=X'0000003F' MASK TO GET MOD 64 00021970 MVI STATE,C'F' TRY FOR ANOTHER FILE 00021980 B RLOOP 00021990 RDN CLI RTYPE,AN DO WE NEED TO SEND A NAK? 00022000 BNE RDELSE 00022010 RDN1 MVI STYPE,AN SEND A NAK 00022020 XC LSDAT,LSDAT NO DATA 00022030 L R15,=A(SPACK) 00022040 BALR R14,R15 00022050 B RLOOP 00022060 RDELSE MVI STATE,C'A' UNRECOGNIZED PACKET - ABORT 00022070 MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 00022080 B RLOOP 00022090 SAYNO MVI STYPE,AN SEND A NAK PACKET 00022100 XC LSDAT,LSDAT NO DATA 00022110 MVI ERRNUM,X'0B' ILLEGAL FILENAME ERROR 00022120 L R15,=A(SPACK) 00022130 BALR R14,R15 00022140 B RLOOP 00022150 ********************************************************************** 00022160 * RECEIVE ABORT PROCESS * 00022170 ********************************************************************** 00022180 RABORT DS 0H 00022190 CLI ERRNUM,X'0A' DID THE MICRO DIE? 00022200 BE RNOERRP NO ERROR PACKET IF SO 00022210 MVI STYPE,AE ERROR PACKET 00022220 MVC LSDAT(4),=F'20' ALL MSGS ARE THIS LONG 00022230 MVC N(4),NUM SYNCH PACKET NUMBERS 00022240 SR R5,R5 00022250 IC R5,ERRNUM 00022260 M R4,=F'20' OFFSET := ERRNUM * 20 00022270 LA R5,ERRTAB(R5) 00022280 MVC SDAT(20),0(R5) SPACK NEEDS THE DATA HERE 00022290 TR SDAT(20),ETOA 00022300 L R15,=A(SPACK) 00022310 BALR R14,R15 SEND ERROR PACKET & DIE 00022320 RNOERRP LA R15,4 SET A NON-ZERO RETCODE 00022330 B RECRET PREPARE TO LEAVE 00022340 ********************************************************************** 00022350 * RECEIVE COMPLETE PROCESS * 00022360 ********************************************************************** 00022370 RCOMP SR R15,R15 RETCODE OF ZERO 00022380 RECRET L R13,4(R13) 00022390 L R14,12(R13) 00022400 LM R0,R12,20(R13) 00022410 BR 14 00022420 EJECT 00022430 ********************************************************************** 00022440 * * 00022450 * ROUTINE TO PUT A CHARACTER IN OUTPUT BUFFER AND DUMP WHEN FULL * 00022460 * * 00022470 ********************************************************************** 00022480 PTCHR SR R4,R4 USE TO HOLD QUOCHAR 00022490 SR R6,R6 USE TO HOLD LRECL 00022500 SR R8,R8 COUNTER WITHIN RDAT 00022510 L R9,RSAVPL COUNTER WITHIN RBUF 00022520 IC R4,RQUO 00022530 IC R6,LRECL 00022540 L R5,LRDAT COUNTER TO GET ALL DATA 00022550 RLUP SR R7,R7 USE TO PICK UP CHAR 00022560 LTR R5,R5 MORE DATA LEFT? 00022570 BNZ MOR LEAVE IF ALL DONE 00022580 CLI PREV,X'4D' ARE WE IN MIDDLE OF LINE? 00022590 BER R14 LEAVE IF NOT 00022600 ST R9,RSAVPL SAVE OUR PLACE 00022610 SR R7,R7 ZERO RETCODE 00022620 BR R14 00022630 MOR BCTR R5,0 DECREMENT CHAR COUNTER 00022640 IC R7,RDAT(R8) GET DATA FROM RDAT 00022650 CR R7,R4 IS IT THE QUOTE CHARACTER? 00022660 BNE REGULAR 00022670 BCTR R5,0 DECREMENT CHAR COUNT 00022680 LA R8,1(R8) MOVE POINTER 00022690 IC R7,RDAT(R8) PICK UP SPECIAL CHAR 00022700 C R7,=X'0000004D' IS IT A CR? (CHAR(CR)) 00022710 BNE NOCR WRITE OUT RECORD IF YES 00022720 MVI PREV,X'4D' JUST HAD A CR 00022730 LA R8,1(R8) IGNORE CONTROL CHAR 00022740 B RFIN 00022750 NOCR C R7,=X'0000004A' HOW ABOUT A LF? (CHAR(LF)) 00022760 BNE NOLF IF YES, WRITE OUT RECORD 00022770 LA R8,1(R8) IGNORE CONTROL CHAR 00022780 CLI PREV,X'4D' WAS LAST THING CR? 00022790 BNE RFIN NOPE, THEN KEEP ON 00022800 B RLUP IGNORE LF IF PREV=CR 00022810 NOLF CR R7,R4 IS IT THE QUOCHAR 00022820 BE REGULAR DON'T CONVERT IF IT IS 00022830 A R7,O1H ADD ^O100 00022840 N R7,=X'0000007F' GET MOD ^O200 00022850 REGULAR STC R7,RBUF(R9) STORE CHAR IN RBUF 00022860 LA R9,1(R9) MOVE RBUF COUNTER 00022870 LA R8,1(R8) MOVE RDAT COUNTER 00022880 MVI PREV,X'00' BLANK OUT CR IF WAS THERE 00022890 C R9,=F'255' ONLY 256 CHARS ALLOWED 00022900 BNH RLUP AND CONTINUE 00022910 LR R10,R9 USE MAX LENGTH OF 256 00022920 B WRFIL AND WRITE TO FILE 00022930 RFIN LTR R10,R9 GET DATA SIZE 00022940 BZ FUDGE GOTTA FAKE A BLANK LINE 00022950 C R7,=X'0000004D' IS IT A CR? (CHAR(CR)) 00022960 BE WRFIL 00022970 C R7,=X'0000004A' HOW ABOUT A LF? (CHAR(LF)) 00022980 BE WRFIL 00022990 ST R10,RSAVPL SAVE DATA RECEIVED SO FAR 00023000 SR R7,R7 ZERO RETCODE 00023010 BR 14 00023020 FUDGE MVI RBUF,X'20' MAKE FIRST CHAR A SPACE 00023030 LA R10,1(R10) LENGTH OF ONE 00023040 WRFIL XC RSAVPL,RSAVPL RESET THE POINTER 00023050 TR RBUF(256),ATOE MAKE EBCDIC AGAIN 00023060 CLI RFM,C'V' IS IT VARIABLE FORMAT? 00023070 BE VAR 00023080 CR R10,R6 00023090 BH PUR IGNORE DATA AFTER LRECL VALUE 00023100 CR R10,R6 PAD OUT TO LRECL SIZE ? 00023110 BE VAR NOPE, IT'S OK. 00023120 LR R2,R6 GET LRECL SIZE 00023130 SR R2,R10 PAD WITH THIS MANY SPACES 00023140 BCTR R2,0 MINUS ONE FOR THE 'EX' 00023150 LA R9,RBUF(R10) START PADDING HERE 00023160 MVI 0(R9),C' ' PUT IN THE FIRST SPACE 00023170 LTR R2,R2 00023180 BZ PUR DON'T PAD IF SIZE DIF WAS ONE 00023190 BCTR R2,0 SUBRTRACT SPACE WE JUST ADDED 00023200 EX R2,PAD PAD OUT BUFFER 00023210 PUR LR R10,R6 LENGTH HAS TO BE THIS SIZE 00023220 VAR DS 0H RJR 00023230 LA R15,WRITEX 00023240 BALR R15,R15 00023250 SR R9,R9 START AT BEGINNING OF RBUF 00023260 B RLUP GET NEXT LINE IF OK 00023270 RECSAVE DS 18F 00023280 PAD MVC 1(0,R9),0(R9) PAD OUT WITH SPACES 00023290 LTORG 00023300 * 00023310 EJECT 00023320 ********************************************************************** 00023330 * * 00023340 * DISK FILE WRITE ROUTE WITH DEBUGGING CODE * 00023350 * * 00023360 ********************************************************************** 00023370 WRITEX DS 0H 00023380 USING PARMS,R11 00023390 STM R12,R15,WRITSAVE 00023400 BALR R12,0 00023410 USING *,R12 00023420 LA R0,RBUF POINT TO RBUF 00023430 TM KEROUT+(DCBRECFM-IHADCB),DCBRECV VARIABLE? 00023440 BZ WRITEX2 NO, THEN DON'T ADJUST 00023450 LA R0,RBUF-4 POINT TO RDW 00023460 LR R15,R10 GET THE LENGTH 00023470 AH R15,=H'4' INCLUDE LENGTH OF RDW 00023480 SR R1,R1 00023490 STH R1,RBUF-2 CLEAR RDW 00023500 IC R1,LRECL GET LRECL 00023510 CR R15,R1 IS THE RECORD GT MAX LRECL? 00023520 BNH *+6 NO, THEN IT'S OK 00023530 LR R15,R1 ELSE SET TO MAX 00023540 STH R15,RBUF-4 00023550 WRITEX2 DS 0H 00023560 PUT KEROUT,(R0) 00023570 TM DEBUG+(DCBOFLGS-IHADCB),DCBOFOPN IS IT OPEN? 00023580 BZ WRNODBG 00023590 MVC WRKBUFF(2),=H'12' 00023600 XC WRKBUFF+2(2),WRKBUFF+2 00023610 MVC WRKBUFF+4(8),=CL8'QSAM PUT' 00023620 PUT DEBUG,WRKBUFF 00023630 EX R10,DBGMVC4 00023640 LA R1,4(,R10) 00023650 STH R1,WRKBUFF 00023660 PUT DEBUG,WRKBUFF 00023670 WRNODBG LM R12,R15,WRITSAVE 00023680 BR R15 00023690 DBGMVC4 MVC WRKBUFF+4(*-*),RBUF 00023700 DROP R11 00023710 DROP R12 00023720 LTORG 00023730 EJECT 00023740 ********************************************************************** 00023750 * * 00023760 * ROUTINE TO PARSE COMMANDS AND CREATE PARSE TABLE * 00023770 * * 00023780 ********************************************************************** 00023790 PARSER STM R14,R12,12(R13) SAVE REGISTERS 00023800 LR R12,R15 MOVE THE BASE REGISTER 00023810 USING PARSER,R12 ## 00023820 L R11,=A(PARMS) GET ADDRESS OF WORKAREAS 00023830 USING PARMS,R11 00023840 LR R3,R0 R3 = TEXT LENGTH 00023850 BCTR R1,0 R1 ==> BYTE BEFORE PARM 00023860 LA R3,0(R1,R3) R3 ==> END OF LINE 00023870 LA R2,1 R2 = PARSING INCREMENT 00023880 LA R5,PTRTBL R5 ==> TARGET AREA 00023890 LA R6,4 R6 = POINTER INCREMENT 00023900 STM R5,R6,PARSELST SAVE FOR PARSING 00023910 LA R7,PTRTBL+PTRTBLL-4 R7 ==> END OF TARGET 00023920 * 00023930 SCNTOKEN BXH R1,R2,SCNFINIS SCAN FOR PARM START 00023940 CLI 0(R1),C' ' FOUND A BLANK? 00023950 LR R9,R1 SAVE POINTER IF NOOP GUCSL 00023960 BE SCNTOKEN YES, THEN KEEP LOOKING 00023970 ST R1,0(,R5) SAVE PTR TO OPERAND 00023980 BXH R5,R6,SCNFINIS BR ON END OF TARGET AREA 00023990 SCNLASTC BXH R1,R2,SCNFINIS SCAN TO END OF OPERAND 00024000 CLI 0(R1),C' ' IS THIS BLANK AT END OF OPERAND 00024010 BNE SCNLASTC IF SO, MOVE TOKEN 00024020 LR R9,R1 REMEMBER JUST AFTER OPERAND 00024030 B SCNTOKEN FIND START OF NEXT OPERAND 00024040 SCNFINIS MVI 0(R9),C' ' MARK THE END OF OPERANDS 00024050 ST R9,0(R5) SAVE POINTER TO END 00024060 ST R5,PARSELST+8 SAVE END TARGET 00024070 LM R14,R12,12(R13) RESTORE THE REGISTERS 00024080 BR R14 RETURN TO CALLER 00024090 LTORG 00024100 DROP R11 00024110 DROP R12 DON'T NEED THEM ANYMORE 00024120 EJECT 00024130 PARMS DS 0H GLOBAL DATA LIST 00024140 USING PARMS,R11 00024150 SNDPKT DS CL130 SEND THIS TO MICRO 00024160 ORG SNDPKT 00024170 PHDR DS X 00024180 PLEN DS X 00024190 PNUM DS X 00024200 PTYPE DS X 00024210 PDATA DS 0C 00024220 ORG , 00024230 RECPKT DS CL130 RECEIVE THIS FROM MICRO 00024240 LSDAT DS F SEND PACKET SIZE 00024250 LRDAT DS F RECEIVE PACKET SIZE 00024260 FLAGS DC X'00' USE TO TEST OUR FLAGS 00024270 NAME DC 18X'20' NAME OF FILE(S) TO SEND 00024280 DS 0F 00024290 DS 0F 00024300 INPUT DS CL130 INPUT BUFFER 00024310 DS 0F 00024320 DS F RDW FOR VARIABLE RECORDS 00024330 BUF DS CL260 DISK READ INTO HERE 00024340 DS F RDW FOR VARIABLE RECORDS 00024350 RBUF DS CL260 DISK WRITE FROM HERE 00024360 N DC F'0' SEND PACKET NUMBER 00024370 NUM DC F'0' RECEIVE PACKET NUMBER 00024380 NUMTRY DC F'0' TRIAL COUNTER FOR TRANSFERS 00024390 OLDTRY DS F COUNTER FOR PREVIOUS PACKET 00024400 STORLOC DS F POINTER TO EXTRA STORAGE 00024410 MAXPACK DC F'94' MAX PACKET SIZE 00024420 RECL DS F RECORD LEN (IF RECFM = V) 00024430 RPSIZ DC F'94' MAX RECEIVE PACKET SIZE 00024440 DSSIZ DC F'40' DEFAULT MAX SEND PACKET SIZE 00024450 SPSIZ DS F SEND PACKET SIZE 00024460 MAXTRY DC F'5' NO. OF TIMES TO RETRY PACKET 00024470 IMXTRY DC F'16' NO. OF INITIAL TRIALS ALLOWED 00024480 SIZE DS F MAX SIZE FOR SEND DATA 00024490 DEL DC F'127' OCTAL 177 (DELETE CHAR) 00024500 ZERO DC F'0' 00024510 ONE DC F'1' 00024520 FIVE DC F'5' 00024530 TWO DC F'2' 00024540 SPACE DC F'32' ASCII SPACE 00024550 O1H DC F'64' OCTAL 100 00024560 O2H DC F'128' OCTAL 200 00024570 SAVPL DC F'0' POINTER WITHIN BUF,INIT=0 00024580 RSAVPL DC F'0' POINTER IN 'PTCHR',INIT=0 00024590 DQUOTE DC X'23' DEFAULT QUOTE CHARACTER = # 00024600 QUOCHAR DS X QOUTE CHAR WE'LL SEND 00024610 RQUO DS X MICRO'S QUOTE CHAR 00024620 TEMP DS F TEMPORARY SPACE 00024630 DS 0D 00024640 PKVAR DS D USE FOR PICKING UP INTEGER 00024650 SDAT DS CL130 TEMP PLACE FOR SEND DATA 00024660 RDAT DS CL130 TEMP PLACE FOR RECEIVE DATA 00024670 FILNAML DS H LENGTH OF FILENAME 00024680 FILNAM DS CL18 SEND/REC FILENAME 00024690 STATE DS C OUR CURRENT STATE 00024700 DEOL DC X'0D' DEFAULT END OF PACKET (CR) 00024710 REOL DS X EOL CHAR I NEED (CR) 00024720 SEOL DS X EOL I'LL SEND 00024730 DSOH DC X'01' DEFAULT START OF HEADER (CTL A) 00024740 RSOH DS X RECEIVE START OF HEADER 00024750 SSOH DS X SEND START OF HEADER 00024760 DLRECL DC X'50' DEFAULT LRECL SIZE OF 80 00024770 LRECL DS X LRECL PROGRAM WILL USE 00024780 DBLKSIZE DC H'3600' DEFAULT BLKSIZE OF 3600 00024790 BLKSIZE DS H BLKSIZE PROGRAM WILL USE 00024800 DTRACK DC F'5' DEFAULT SPACE ALLOCATION 00024810 DRECFM DC C'F' DEFAULT WITH FIXED RECFM 00024820 RFM DS C RECFM PROGRAM WILL USE 00024830 PREV DS C PREVIOUS CHAR REC (IN PTCHR) 00024840 BLIP DS X SAVE USER'S BLIP CHAR 00024850 LINSIZ DS F SAVE USER'S CONSOLE LINESIZE 00024860 ERRNUM DS X ERROR NUMBER,IN CASE WE DIE 00024870 OLDERR DS X ERROR OF PREVIOUS EXECUTION 00024880 STYPE DS C TYPE OF PACKET SENT 00024890 RTYPE DS C TYPE OF PACKET RECEIVED 00024900 * 00024910 READSAVE DS 4F 00024920 WRITSAVE DS 4F 00024930 PARSELST DS 3F PTRS TO OPERAND STACK 00024940 PTRTBL DS 15F OPERAND STACK 00024950 PTRTBLL EQU *-PTRTBL LENGTH OF PTRTBL 00024960 DBLWRK DS D 00024970 IDSYS DC F'2' MVS TSO 00024980 DDNAME DC CL8' ' DDNAME TO ALLOCATE 00024990 DSNAME DC CL80' ' DSNAME TO ALLOCATE 00025000 DSNAMEX DC CL80' ' WRKBUFFER 00025010 MEMBER DC CL8' ' MEMBER NAME FOR PDS ALLOC 00025020 CMSXXX DC CL8' ' USED IN CMS ONLY 00025030 CMSYYY DC CL8' ' 00025040 CMSZZZ DC CL2' ' 00025050 DISP1 DC F'2' DISP (0=NEW,1=OLD,2=SHR) 00025060 DISP2 DC F'3' DISP (0=UNCAT,1=CAT,3=KEEP) 00025070 INOUT DC F'2' 0=INPUT,1=OUTPUT,2=INOUT) 00025080 RECFMX DC F'1' 1=FB,2=VBS 00025090 BLKSIZEX DC F'3600' FOR NEW DATA SETS ONLY 00025100 LRECLX DC F'80' .... 00025110 DEV DC CL8'SYSDA' DEVICE FOR RECEIVE 00025120 SENDDEV DC CL8'SYSDA' DEVICE FOR SEND COMMAND *GUC00025121 TRACK DC F'20' # TRACKS TO ALLOC FOR NEW DSETS 00025130 DYNALCRC DC F'0' RETURN CODE FROM FUNCTION 00025140 WRKBUFF DS CL280 00025150 PREFIX DC CL8' ' USERS DSET PREFIX FROM UPT 00025160 PREFIXL DC F'0' PREFIX LENGTH-1 00025170 DDELAY DC F'2000' DEFAULT DELAY TIME 00025180 DELAY DS F DELAY TIME 00025190 * 00025200 * THIS IS THE DYNALC PARM LIST USED FOR BOTH ALLOCATION AND 00025210 * CREATION OF DATA SETS. 00025220 * 00025230 DYNAPARM DS 0F 00025240 DC A(IDSYS,DDNAME,DSNAME,MEMBER,CMSXXX,CMSYYY,CMSZZZ,DISP1,DISP2) 00025250 DC A(INOUT,RECFMX,BLKSIZEX,LRECLX,DEV,TRACK) 00025260 DC X'80',AL3(DYNALCRC) 00025270 * 00025280 * TABLE TO TRANSLATE TO UPPER CASE 00025290 * 00025300 UPPER DC 256AL1(*-UPPER) 00025310 ORG UPPER+X'81' 00025320 DC C'ABCDEFGHI' 00025330 ORG UPPER+X'91' 00025340 DC C'JKLMNOPQR' 00025350 ORG UPPER+X'A2' 00025360 DC C'STUVWXYZ' 00025370 ORG 00025380 * THIS IS THE ASCII TO EBCDIC TABLE (THE STANDARD AMERICAN TSO VERSION)00025390 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 00025400 ATOE DC X'00010203372D2E2F1605250B0C0D0E0F' 0 00025410 DC X'101112133C3D322618193F271C1D1E1F' 1 00025420 DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' 2 00025430 DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 3 00025440 DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 4 00025450 DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' 5 00025460 DC X'79818283848586878889919293949596' 6 00025470 DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' 7 00025480 * THIS IS THE ASCII TO EBCDIC TABLE (THE SWEDISH GUTS VERSION) 00025490 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 00025500 *TOE DC X'00010203372D2E2F1605250B0C0D0E0F' 0 00025510 * DC X'101112133C3D322618193F27221D351F' 1 00025520 * DC X'404F7F73536C507D4D5D5C4E6B604B61' 2 00025530 * DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 3 00025540 * DC X'74C1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 4 00025550 * DC X'D7D8D9E2E3E4E5E6E7E8E97B7C5B5F6D' 5 00025560 * DC X'79818283848586878889919293949596' 6 00025570 * DC X'979899A2A3A4A5A6A7A8A9C06AD0A107' 7 00025580 *THIS IS THE EBCDIC TO ASCII CONVERSION TABLE (AMERICAN TSO VERSION) 00025590 *CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL 00025600 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 00025610 ETOA DC X'000102030009007F0000000B0C0D0E0F' 0 00025620 *G DC X'1011121300000800181900001C1D1E1F' 00025630 DC X'10111213000D0800181900001C1D1E1F' 1 00025640 DC X'00000000000A171B0000000000050607' 2 00025650 DC X'0000160000000004000000001415001A' 3 00025660 DC X'20000000000000000000002E3C282B7C' 4 00025670 DC X'2600000000000000000021242A293B5E' 5 00025680 DC X'2D2F00000000000000007C2C255F3E3F' 6 00025690 DC X'000000000000000000603A2340273D22' 7 00025700 DC X'00616263646566676869007B00000000' 8 00025710 DC X'006A6B6C6D6E6F707172007D00000000' 9 00025720 DC X'007E737475767778797A0000005B0000' A 00025730 DC X'000000000000000000000000005D0000' B 00025740 DC X'7B414243444546474849000000000000' C 00025750 DC X'7D4A4B4C4D4E4F505152000000000000' D 00025760 DC X'5C00535455565758595A000000000000' E 00025770 DC X'303132333435363738397C0000000000' F 00025780 *THIS IS THE EBCDIC TO ASCII CONVERSION TABLE (SWEDISH GUTS VERSION) 00025790 *CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL 00025800 * 0 1 2 3 4 5 6 7 8 9 A B C D E F 00025810 *TOA DC X'000102030009007F0000000B0C0D0E0F' 0 00025820 * DC X'10111213000D0800181900001C1D1E1F' 1 00025830 * DC X'00001C00000A171B0000000000050607' 2 00025840 * DC X'00001600001E0004000000001415001A' 3 00025850 * DC X'20000000000000000000002E3C282B21' 4 00025860 * DC X'26000024000000000000215D2A293B5E' 5 00025870 * DC X'2D2F00000000000000007C2C255F3E3F' 6 00025880 * DC X'000000234000000000603A5B5C273D22' 7 00025890 * DC X'00616263646566676869007B00000000' 8 00025900 * DC X'006A6B6C6D6E6F707172007D00000000' 9 00025910 * DC X'007E737475767778797A0000005B0000' A 00025920 * DC X'000000000000000000000000005D0000' B 00025930 * DC X'7B414243444546474849000000000000' C 00025940 * DC X'7D4A4B4C4D4E4F505152000000000000' D 00025950 * DC X'5C00535455565758595A000000000000' E 00025960 * DC X'303132333435363738397C0000000000' F 00025970 * 00025980 * TABLE OF ERROR MESSAGES (IN CASE WE ABORT) 00025990 ERRTAB DC CL20'Bad send-packet size' ERR MSG #0 00026000 DC CL20'Bad message number' ERR MSG #1 00026010 DC CL20'Unrecognized state' ERR MSG #2 00026020 DC CL20'No SOH encountered' ERR MSG #3 00026030 DC CL20'Bad character count' ERR MSG #4 00026040 DC CL20'Bad checksum' ERR MSG #5 00026050 DC CL20'Disk is full' ERR MSG #6 00026060 DC CL20'Illegal packet type' ERR MSG #7 00026070 DC CL20'Lost a packet' ERR MSG #8 00026080 DC CL20'Micro sent a NAK' ERR MSG #9 00026090 DC CL20'Micro aborted' ERR MSG #10 00026100 DC CL20'Illegal file name' ERR MSG #11 00026110 DC CL20'Invalid lrecl' ERR MSG #12 00026120 DC CL20'Permanent I/O error' ERR MSG #13 00026130 DC CL20'Disk is read-only' ERR MSG #14 00026140 DC CL20'Recfm conflict' ERR MSG #15 00026150 DC CL20'Err allocating space' ERR MSG #16 00026160 DATASET CAMLST NAME,DSNAME,,WRKBUFF 00026170 KERIN DCB DDNAME=KERIN,DSORG=PS,MACRF=(GM), 00026180 EODAD=INEOF 00026190 KEROUT DCB DDNAME=KEROUT,DSORG=PS,MACRF=(PM),LRECL=80,BLKSIZE=84, 00026200 RECFM=VB 00026210 DEBUG DCB DDNAME=DEBUG,DSORG=PS,MACRF=(PM),LRECL=260,BLKSIZE=2048, 00026220 RECFM=VB 00026230 MODDCBF DCB DDNAME=KEROUT,DSORG=PS,MACRF=(PM),LRECL=80,BLKSIZE=80, 00026240 RECFM=FB 00026250 MODDCBFL EQU *-MODDCBF 00026260 MODDCBV DCB DDNAME=KEROUT,DSORG=PS,MACRF=(PM),LRECL=80,BLKSIZE=84, 00026270 RECFM=VB 00026280 MODDCBVL EQU *-MODDCBV 00026290 END KERMIT 00026300 00026310 00026320