home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
guts.tar.gz
/
guts.tar
/
guts.asm
next >
Wrap
Assembly Source File
|
1988-08-16
|
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