home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
cmsoriginal
/
cmsv2.asm
next >
Wrap
Assembly Source File
|
1985-04-14
|
343KB
|
4,230 lines
KERMIT TITLE 'KERMIT-CMS' 00001000
KERMIT CSECT 00002000
* KERMIT - 00003000
* 00004000
* Kermit CMS Version 2.01 00005000
* May 20, 1985 00006000
* 00007000
* This program is the IBM VM/CMS side of a file transfer system. 00008000
* It can be used to transfer files between a micro and a system 00009000
* running under VM/CMS. 00010000
* See the KERMIT User's Guide and Protocol manual for the complete 00011000
* program specifications to which this program and any other 00012000
* component of the system must adhere. 00013000
* 00014000
* Daphne Tzoar, Columbia University Center for Computing Activities 00015000
* March 1982 00016000
* 00016100
* Version 2.01 00016150
* 00016200
* [23] May 85: If virtual console is not a TTY, assume 3270. 00016250
* [24] May 85: If no repeat prefixing, reset all variables. 00016300
* [25] May 85: Fix problem of repeat prefixing of CR or LF. 00016350
* 00017000
* Version 2.0 00018000
* [1] Sept 83: Add 8-bit quoting to allow transfer of fixed format 00019000
* binary files. 00020000
* [2] Sept 83: Don't restrict incoming/outgoing record size to 256. 00021000
* [3] Aug 84: Print a version number upon startup. Improve handling 00022000
* of keywords. Maybe by the next release. 00023000
* [4] Aug 84: Pack as much data into a packet as possible. Clean 00024000
* things up a bit. 00025000
* [5] Aug 84: Use common routines SPAR and RPAR for init packets. 00026000
* [6] Aug 84: Re-write decoding routine. 00027000
* [7] Sept 84: Add repeat count prefixing. 00028000
* [8] Sept 84: Add support for two character checksum and three 00029000
* character CRC. 00030000
* [9] Oct 84: If no filetype supplied on incoming file, use "X" 00031000
* rather than fail. Default filemode to "*" on send. 00032000
* Remove redundant filename handling code from RDATA. 00033000
* Replace invalid letter in filename with "X". 00034000
* [10] Oct 84: Add SET/SHOW DEBUG mode. If OFF, ignore atten- 00035000
* tion if user types a BREAK. Don't ignore if ON. 00036000
* [11] Dec 84: If input supplied on command line, execute command 00037000
* and return to CMS (not to Kermit prompt mode). 00038000
* Allow several commands, separated by pound signs. 00039000
* [12] Feb 85: Add support for Series/1 front end. Bob Shields 00040000
* Temporarily turn off MSG, WNG, IMSG (if S/1 or TTY). 00041000
* [13] Mar 85: Add server support including only basic functions. Put 00042000
* send-error-packet code in one place only. Make packet 00043000
* numbers more meaningful (n -> spknum, num -> rpknum). 00044000
* [14] Mar 85: If debugging is on, log packets in a file. 00045000
* [15] Mar 85: Upon startup, read commands from two init files: SYSTEM 00046000
* KERMINI and (USERID) KERMINI. Lines with asterisk as 00047000
* the first character are comments. Add TAKE command. 00048000
* Lrecl for these files must be 130 or less. 00049000
* [16] Mar 85: Implement skip file or file group when sending. Ditto 00050000
* for receiving (discard incoming file). 00051000
* [17] Apr 85: Add a SHOW ALL command. 00052000
* [18] Apr 85: Add SET WARNING ON/OFF in case incoming file has the 00053000
* same name as an existing one. If ON, rename incoming 00054000
* file. If OFF, overwrite existing file. 00055000
* [19] Apr 85: Make ATOE table 256 characters long, as it should be. 00056000
* Modify SPACK and RPACK cosole I/O to use plists with 00057000
* flags to bypass user translate tables. Bob Shields 00058000
* Use prompt of XON. 00059000
* [20] Apr 85: Add SET ETOA and SET ATOE to allow user to modify 00060000
* the translate tables so they conform to his system. 00061000
* Display tables with new command: TDUMP. Have SET 00062000
* routines use common code to get decimal input. 00063000
* [21] Apr 85: Moved some code to different base register, 4K limit. 00064000
* [22] Apr 85: Encode outgoing filename, decode incoming one. Need 00065000
* a general routine to setup for encode/decode routines. 00066000
* 00067000
* Version 1.0 Updates: 00068000
* June 82:Only allow Kermit to run on an ASCII terminal. Else, stop 00069000
* execution. Also, check padding when receiving file in 00070000
* fixed format. If only pad one character, pad the balance 00071000
* via the "EX" option, else skip that command. 00072000
* Aug 82: Change "FSREAD" when sending to allow a maximum of 133, not 00073000
* the full buffer size since need two spaces for CRLF. 00074000
* Apr 83: Fix maximum number of tries on init (to 16), set timeout 00075000
* value to 8, and do "CTL" function to padding character 00076000
* in SINIT (not CHAR). 00077000
* Feb 84: Add fix so that when receive a file with RECFM = F, program 00078000
* does not abort with DISK FULL error. Changes are indicated 00079000
* by the phrase '[edit]' in the comment. Fix: Bill Small. 00080000
* 00081000
* Please address all comments and questions to: 00082000
* 716 Watson 00083000
* 612 W. 115th St. 00084000
* NY,NY, 10025 00085000
* (212) 280-3703 00086000
* 00087000
* Copyright (C) 1982,1983 Columbia University 00088000
* 00089000
* Permission is granted to any individual or institution to copy 00090000
* or use this program, except for explicitly commercial purposes. 00091000
* 00092000
* Note: If you find and correct problems in the program, please 00093000
* forward all changes to the author. 00094000
* 00095000
EJECT 00096000
* REGISTER USAGE - 00097000
* R1 - 00098000
* R2 - 00099000
* R3 - 00100000
* R4 - 00101000
* R5 - 00102000
* R6 - 00103000
* R7 - 00104000
* R8 - 00105000
* R9 - 00106000
* R10 - 00107000
* R11 - BASE REGISTER FOR GLOBAL DATA AREA 00108000
* R12 - PROGRAM BASE 00109000
* R13 - SAVE AREA 00110000
* R14 - SUBROUTINE LINKAGE 00111000
* R15 - SUBROUTINE LINKAGE 00112000
* 00113000
* EXTERNAL MACROS/MODULES CALLED - 00114000
* The following MACLIBs should be GLOBAL'd: 00115000
* DMSSP, CMSLIB, TSOMAC 00116000
* 00117000
* The following external routines are called: 00118000
* NEXTFST ASSEMBLE 00119000
* WILD ASSEMBLE 00120000
* 00121000
* 00122000
SPACE 00123000
PRINT NOGEN 00124000
REGEQU 00125000
FSTD DSECT WILL NEED FOR NEXTFST ROUTINE 00126000
ADT DSECT 00127000
NUCON DSECT USE IN TOKENIZER ROUTINE 00128000
EXTSECT DSECT USE WHEN TURNING BLIP OFF 00129000
SPACE 00130000
SOH EQU X'01' ^a FOR START OF HEADER CHAR 00131000
XON EQU X'11' XON [13] 00132000
AD EQU 68 DATA PACKET (ASCII 'D') 00133000
AN EQU 78 NAK 00134000
AZ EQU 90 EOF packet, skip file group [16] 00135000
AS EQU 83 INIT PACKET 00136000
AY EQU 89 ACK 00137000
AF EQU 70 FILE PACKET 00138000
AB EQU 66 BREAK PACKET 00139000
AE EQU 69 ERROR PACKET 00140000
AR EQU 82 Get packet "R" [13] 00141000
AG EQU 71 Generic server packet "G" [13] 00142000
AL EQU 76 Logout packet "L" [13] 00143000
AI EQU 73 Parameter init packet "I" [13] 00144000
AX EQU 88 Skip file when sending [16] 00145000
ACR EQU 13 Ascii CR [25] 00145100
ALF EQU 10 Ascii LF [25] 00145200
ERCOD EQU 12 MEANS EOF WITH 'FSREAD' 00146000
MAXTXT EQU 64536 Max output buffer is 64K [6] 00147000
MAXBIN EQU 80 Max output for binary files [1] 00148000
* Fields of variable FLAGS: 00149000
FLG1 EQU X'80' IS FILE THE FIRST OR NOT 00150000
FLG2 EQU X'40' OVERWRITE SENT FILENAME? 00151000
FLG3 EQU X'20' ONE = SENT ONLY PARTIAL RECORD 00152000
FLG4 EQU X'10' NAK FROM MICRO(0) OR RPACK(1)? 00153000
FLG5 EQU X'08' ALLOCATED MORE SPACE (DMSFREE) 00154000
BINF EQU X'04' ONE := BINARY DATA [1] 00155000
FLG7 EQU X'02' One := End-of-file [4] 00156000
DEBUG EQU X'01' Debug mode ON/OFF [10] 00157000
* Fields of variable LFLAGS: 00158000
FMSGON EQU X'80' CP SET MSG was ON [12] 00159000
FWNGON EQU X'40' CP SET WNG was ON [12] 00160000
FIMSGON EQU X'20' CP SET IMSG was ON [12] 00161000
SERVON EQU X'10' In SERVER mode [13] 00162000
TAKON EQU X'08' TAKE command [15] 00163000
ALLFL EQU X'04' SHOW ALL requested [17] 00164000
WARFL EQU X'02' Rename incoming file [18] 00165000
CMDL EQU X'01' Data on cmd line [11] 00166000
* 00167000
DSSIZ EQU X'50' Default send packet size [4] 00168000
DQUOTE EQU X'23' Default quote character = # [4] 00169000
D8QUO EQU X'26' Default 8-bit quochar=& [1][4] 00170000
DCHKLEN EQU X'01' Default checksum length [4] 00171000
DRPT EQU X'7E' Default repeat prefix TILDE [4] 00172000
DEOL EQU X'0D' Default end of packet (CR) [4] 00173000
DLRECL EQU X'50' Default lrecl size = 80 [4] 00174000
DRECFM EQU X'E5' Default is variable recfm [4] 00175000
DSTIM EQU X'08' Default send time out [4] 00176000
DRTIM EQU X'0D' Default receive time out [4] 00177000
DSPAD EQU X'00' Default send padding. [4] 00178000
DRPAD EQU X'00' Default receive padding. [4] 00179000
DSPADC EQU X'00' Default send padding char. [4] 00180000
DRPADC EQU X'00' Default rec padding char. [4] 00181000
SPMIN EQU X'14' Min send packet size (20) [5] 00182000
SPMAX EQU X'5E' Max send packet size (94) [5] 00183000
RPTMIN EQU X'03' Min repeats for quoting [7] 00184000
TAKMAX EQU 10 Max TAKE nesting level [15] 00185000
* 00186000
* For Series/1 [12 start] 00187000
ASCXON EQU X'91' X-ON (DC1) with hi order bit on 00188000
* Fields of variable S1FLAGS 00189000
S1INIT EQU X'80' Init for S/1 already done [13] 00190000
ISS1 EQU X'01' Console is S/1 00191000
* CCW flags: 00192000
CC EQU X'40' Chained CCW follows 00193000
SLI EQU X'20' Suppress Incorr Len Ind 00194000
* WCC flag bits and 3270 orders: 00195000
ALARM EQU X'04' ring alarm 00196000
UNLKKB EQU X'02' unlock keyboard 00197000
SBA EQU X'11' Set Buffer Address (3270) 00198000
IC EQU X'13' Insert Cursor (3270) 00199000
* CSW flag bits: 00200000
ATTN EQU X'80' attention 00201000
STATMOD EQU X'40' status modifier 00202000
CUEND EQU X'20' control unit end 00203000
BUSY EQU X'10' busy 00204000
CHEND EQU X'08' channel end 00205000
DEVEND EQU X'04' device end 00206000
UNCHK EQU X'02' unit check 00207000
UNXCPT EQU X'01' unit exception 00208000
CPBRK EQU ATTN+CHEND+DEVEND+UNCHK CP break-in [12 end] 00209000
* 00210000
EJECT 00211000
KERMIT CSECT 00212000
STM R14,R12,12(R13) 00213000
BALR R12,0 00214000
USING *,R12 00215000
LA R14,KSAVE 00216000
ST R13,4(R14) 00217000
ST R14,8(R13) 00218000
LR R13,R14 00219000
* 00220000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 00221000
L R11,=A(PARMS) 00222000
USING PARMS,R11 00223000
LR R6,R1 HOLD ON TO CONSOLE BUFFER 00224000
SR R2,R2 00225000
BCTR R2,0 Get info by using addr -1 00226000
DC X'83230024' GET LINESIZE DATA - DIAG 24 00227000
STH R2,CONSADDR Save console addr (CUU) [12] 00228000
XC LINSIZ,LINSIZ 00229000
STC R4,LINSIZ+3 SAVE THE LINESIZE 00230000
ST R4,TEMP Put here for compare [12] 00231000
MVI S1FLAGS,X'00' Clear S/1 flags [12] 00232000
CLC CONSTTY,TEMP Is console Ascii TTY? [12] 00233000
BE OKDEV Yes it's OK [12] 00234000
* CLC CONS772,TEMP Is console 3277 mod 2? [12][23] 00235000
* BNE BADDEV No fail [12] [23] 00236000
OI S1FLAGS,ISS1 Remember going via S/1 [12] 00237000
OKDEV LA R7,=C'TERM LINES 130' 00238000
LA R8,14 00239000
DIAG 7,8,8 SET TO HIGHEST POSSIBLE VALUE 00240000
USING NUCON,0 FOR TOKENIZER 00241000
L R7,AEXTSECT LOC OF CMS ROUTINE EXTSECT 00242000
USING EXTSECT,R7 00243000
MVC BLIP(1),TIMCHAR SAVE USER'S BLIP CHAR 00244000
DMSEXS MVI,TIMCHAR,X'00' TURN OFF BLIP FOR NOW 00245000
DROP R7 00246000
L R15,=A(INIT) 00247000
BALR R14,R15 CALL THE INITIALIZATION 00248000
L R15,=A(PACKLEN) 00249000
BALR R14,R15 Get max send packet size [4] 00250000
LA R1,1 Set flags for next call [12] 00251000
L R15,=A(SETMSGS) Turn off MSG, WNG, IMSG [12] 00252000
BALR R14,R15 [12] 00253000
* Get two 64K buffers for reading from and writing to files. [2] 00254000
* Should really be 64K+2 for the possible CRLF added to end of the 00255000
* send buffer. The overrun will go into the receive buffer which 00256000
* is OK since only one of send or receive is active at any time. 00257000
L R0,=F'16384' REQUEST 128K TOTAL [2 START] 00258000
DMSFREE DWORDS=(0),ERR=ERRBUF,MSG=NO 00259000
ST R1,ABUF ADDR OF FIRST BUFFER 00260000
A R1,=F'64536' SECOND BUFFER IS 64K ... 00261000
ST R1,ARBUF AWAY FROM FIRST [2 END] 00262000
MVI TAKLEV,X'00' TAKE file nesting [15 start] 00263000
LA R2,INFOBUF Put diag result here 00264000
L R3,=F'32' Get this much info 00265000
DC X'83230000' Issue the diagnose 00266000
LA R2,INFOBUF 00267000
MVC UNAME(8),16(R2) Move to our buffer 00268000
LA R2,UNAME Point to init filename 00269000
FSOPEN (R2) Look for init file 00270000
LTR R15,R15 Is it there 00271000
BNZ INIF0 Didn't find one 00272000
MVI TAKLEV,X'01' Increment to one 00273000
MVC TAKTAB(18),0(R2) Add to TAKE table 00274000
OI LFLAGS,TAKON Commands are from file 00275000
INIF0 LA R2,SYSTAK Now look for SYSTEM KERMINI 00276000
FSOPEN (R2) 00277000
LTR R15,R15 Is it there 00278000
BNZ INIF2 No 00279000
SR R5,R5 Clear to pick up byte 00280000
SR R4,R4 Offset into TAKE table 00281000
IC R5,TAKLEV Get current TAKE level 00282000
LTR R5,R5 Any levels so far 00283000
BZ INIF1 No so offset is OK 00284000
LA R4,18(R4) Bump to next spot in table 00285000
INIF1 LA R4,TAKTAB(R4) Where to add file 00286000
MVC 0(18,R4),0(R2) Add to TAKE table 00287000
LA R5,1(R5) Increment it 00288000
STC R5,TAKLEV 00289000
OI LFLAGS,TAKON Commands are from file [15 end] 00290000
INIF2 SR R15,R15 ZERO RC INITIALLY (IF EXIT) 00291000
MVI EXTFLG,X'00' Don't exit yet [11] 00292000
OI LFLAGS,CMDL Set if info on cmd line [11] 00293000
LA R6,8(R6) 00294000
CLC 0(8,R6),=8X'FF' ALL COMMAND ON ONE LINE? 00295000
BNE NOPRO NO PROMPT IF YES 00296000
NI LFLAGS,X'FF'-CMDL Nothing at command line [11] 00297000
LA R5,PROMSG Address of prompt string [3] 00298000
LA R4,L'PROMSG And it's length [3] 00299000
WRTERM (R5),(R4) Print it [3] 00300000
LA R5,HELPM Address of help string [3] 00301000
LA R4,L'HELPM And it's length [3] 00302000
WRTERM (R5),(R4) Print it [3] 00303000
WRTERM ' ' And leave a blank line [3] 00304000
PROMPT CLI EXTFLG,X'FF' Time to exit? [11] 00305000
BE LV2 Yup [11] 00306000
TM LFLAGS,CMDL Data on cmd line? [11] 00307000
BO PRO4 Yes go check [11] 00308000
TM LFLAGS,TAKON Using TAKE file? [15 start] 00309000
BNO PRO1 No go prompt 00310000
XC INPUT,INPUT Should be clear 00311000
SR R3,R3 00312000
IC R3,TAKLEV Get current TAKE level 00313000
BCTR R3,0 00314000
M R2,=F'18' Get offset into table 00315000
LA R2,TAKTAB(R3) Point to TAKE file name 00316000
FSREAD (R2),BUFFER=INPUT,BSIZE=130,FORM=E 00317000
TR INPUT(130),UPC Upcase the input 00318000
LTR R15,R15 Read in OK? 00319000
BZ PRO2 Yes go parse 00320000
C R15,=A(ERCOD) End of file 00321000
BE PRO3 00322000
WRTERM 'Error reading command from TAKE or INIT file' 00323000
PRO3 SR R2,R2 00324000
IC R2,TAKLEV Get TAKE level 00325000
BCTR R2,0 And decrement it 00326000
STC R2,TAKLEV 00327000
LTR R2,R2 Test level 00328000
BNZ PROMPT Not done with TAKE yet 00329000
NI LFLAGS,X'FF'-TAKON 00330000
B PROMPT Done with init/TAKE [15 end] 00331000
PRO1 WRTERM 'KERMIT-CMS>',EDIT=NO 00332000
PRO4 RDTERM INPUT No prompt [11] 00333000
PRO2 DMSKEY NUCLEUS 00334000
LA R1,INPUT R1 GETS ADDRESS OF STRING 00335000
* RDTERM and FSREAD return amount actually read in R0. 00336000
* L R0,=F'130' R0 GETS THE LENGTH 00337000
L R15,ASCANN 00338000
BALR R14,R15 DO TOKENIZING 00339000
LR R6,R1 SAVE ADDR OF TOKENIZED LIST 00340000
DMSKEY RESET 00341000
NOPRO MVI ERRNUM,X'FF' RESET ERROR FOR THIS TIME 00342000
MVC CHKLEN(1),CHKSET Reset checksum length 00343000
CLI 0(R6),C'E' CHECK FOR 'EXIT' COMMAND 00344000
BE LEAVE 00345000
CLI 0(R6),C'Q' CHECK FOR 'QUIT' COMMAND 00346000
BE LEAVE 00347000
CLC 0(8,R6),=8X'FF' No more input? [11] 00348000
BE NOPRO2 Go check [11] 00349000
CLI 0(R6),C'?' NEED HELP ? 00350000
BNE SETCHK 00351000
WRTERM 'Receive, Send, Help, Exit, Quit, Status, Set, Show' 00352000
WRTERM 'Server, Take, Tdump, CMS, CP' 00353000
B PROMPT 00354000
NOPRO2 TM LFLAGS,CMDL No more info on cmd line [11] 00355000
BO LV2 Yes so just exit [11] 00356000
B PROMPT No, blank line at prompt [11] 00357000
SETCHK CLC 0(3,R6),=CL3'SET' IS IT THE SET COMMAND ? 00358000
BE STSWITCH 00359000
CLC 0(6,R6),=C'STATUS' IS IT THE STATUS COMMAND? 00360000
BE STATSW 00361000
CLC 0(3,R6),=C'SHO' IS IT THE SHOW COMMAND? 00362000
BE SHOSW 00363000
CLC 0(5,R6),=C'TDUMP' Dump a table? [20] 00364000
BE TDSW [20] 00365000
CLC 0(4,R6),=C'HELP' NEED HELP ? 00366000
BE HELPSW 00367000
CLC 0(4,R6),=C'SERV' Server command [13] 00368000
BE SERVSW Yup [13] 00369000
CLC 0(4,R6),=C'TAKE' Take a command file? [15] 00370000
BE TAKSW [15] 00371000
CLI 0(R6),C'*' Is this a comment? [15] 00372000
BE PROMPT Yes ignore [15] 00373000
CLC 0(3,R6),=C'CMS' CMS COMMAND? 00374000
BE SYSCMD 00375000
CLC 0(2,R6),=C'CP' CP COMMAND? 00376000
BE SYSCMD 00377000
OI FLAGS,FLG1 SET FLG1 - IT'S THE FIRST FILE 00378000
NI FLAGS,X'FF'-FLG2 TURN OFF OVERWRITE FLAG (INIT) 00379000
XC NFSENT,NFSENT NUMBER OF FILES SENT (= 0) 00380000
CLC 0(3,R6),=C'REC' 00381000
BNE SS MAYBE IT'S A SEND COMMAND 00382000
L R15,=A(PRSFN) Parse filename [21] 00383000
BALR R14,R15 [21] 00384000
LTR R15,R15 Check retcode [21] 00385000
BNE PROMPT Bad so don't accept cmd [21] 00386000
L R15,=A(VERLET) Verify letters of fn [9] 00387000
BALR R14,R15 [9] 00388000
B RSWITCH Else go receive [21] 00389000
SS CLC 0(3,R6),=C'SEN' 00390000
BNE ERR UNRECOGNIZED COMMAND 00391000
LA R6,8(R6) PICK UP NEXT WORD 00392000
CLI 0(R6),C'?' NEED HELP? 00393000
BNE SS2 00394000
WRTERM 'Specify filename(s) with format: fn ft [fm]' 00395000
B PROMPT 00396000
SS2 CLC 0(8,R6),=8X'FF' NO MORE DATA ? 00397000
BNE SNAM 00398000
WRTERM 'Specify File Name' 00399000
B PROMPT TRY AGAIN 00400000
SNAM MVC NAME,=18X'20' BLANK IT OUT 00401000
MVC FILNAM,=18X'20' BLANK IT OUT TOO 00402000
MVC NAME(8),0(R6) PICK UP THE FNAME 00403000
LA R6,8(R6) MOVE TO NEXT TOKEN 00404000
CLC 0(8,R6),=8X'FF' NO MORE DATA ? 00405000
BNE STYP 00406000
WRTERM 'Specify File Type' 00407000
B PROMPT 00408000
STYP MVC NAME+8(8),0(R6) Pick up the ftype 00409000
MVC NAME+16(2),=C'* ' Default file mode [9] 00410000
LA R6,8(R6) Look for fmode 00411000
CLC 0(8,R6),=8X'FF' Is it there? 00412000
BE SSWITCH No use default 00413000
MVC NAME+16(2),0(R6) Get fmode user wants 00414000
B SSWITCH 00415000
ERR WRTERM 'Invalid command' 00416000
B PROMPT INVALID COMMAND - TRY AGAIN 00417000
SPACE 3 00418000
SSWITCH EQU * 00419000
LA 1,=C'SET LINEDIT OFF' 00420000
LA 0,15 15 CHAR COMMAND 00421000
DIAG 1,0,8 SHOW IT'S A CP COMMAND 00422000
TM FLAGS,DEBUG In DEBUG mode? [10] 00423000
BO SCALL Yes, then don't ignore attn [10] 00424000
STAX IGNATTN Else ignore attention [10] 00425000
SCALL L R15,=A(SEND) 00426000
BALR R14,R15 CALL SEND PORTION 00427000
LTR R5,R15 CHECK RETURN CODE 00428000
BNZ LINON 00429000
MVI ERRNUM,X'FF' WORKED OK 00430000
LINON LA 1,=C'SET LINEDIT ON' 00431000
LA 0,14 00432000
DIAG 1,0,8 00433000
STAX , Reset attn address [10] 00434000
MVC OLDERR(1),ERRNUM ERROR SETTING OF THIS RUN 00435000
TM FLAGS,FLG5 GOT EXTRA SPACE? 00436000
BNO SSW1 NOPE, JUST LEAVE 00437000
LA R0,4096/8 AMOUNT OF SPACE WE GOT 00438000
L R1,STORLOC FIND IT & FREE IT 00439000
DMSFRET DWORDS=(0),LOC=(1),ERR=*,MSG=NO 00440000
NI FLAGS,X'FF'-FLG5 TURN OFF EXTRA SPACE FLAG 00441000
SSW1 LTR R5,R5 CHECK THE RETCODE 00442000
BZ PROMPT ALL OKAY 00443000
WRTERM 'Error in sending file. Try again.' 00444000
B PROMPT ERROR - TRY AGAIN 00445000
RSWITCH EQU * 00446000
LA 1,=C'SET LINEDIT OFF' 00447000
LA 0,15 15 CHAR COMMAND 00448000
DIAG 1,0,8 SHOW IT'S A CP COMMAND 00449000
TM FLAGS,DEBUG In DEBUG mode? [10] 00450000
BO RCALL Yes, then don't ignore attn [10] 00451000
STAX IGNATTN Else ignore attention [10] 00452000
RCALL L R15,=A(RECEIVE) 00453000
BALR R14,R15 CALL RECEIVE PORTION 00454000
LTR R5,R15 CHECK RETURN CODE 00455000
BNZ LNON 00456000
MVI ERRNUM,X'FF' 00457000
LNON LA 1,=C'SET LINEDIT ON' 00458000
LA 0,14 00459000
DIAG 1,0,8 00460000
STAX , Reset attn address [10] 00461000
MVC OLDERR(1),ERRNUM ERROR SETTING OF THIS RUN 00462000
LTR R5,R5 CHECK THE RETCODE 00463000
BZ PROMPT ALL OKAY 00464000
WRTERM 'Error in receiving file. Try again.' 00465000
B PROMPT ERROR - TRY AGAIN 00466000
STSWITCH EQU * 00467000
L R15,=A(SET) 00468000
BALR R14,R15 CALL "SET" SUBROUTINE 00469000
LTR R15,R15 CHECK RETCODE 00470000
BZ PROMPT 00471000
WRTERM 'Invalid Set Command' 00472000
B PROMPT 00473000
SHOSW EQU * 00474000
L R15,=A(SHOW) 00475000
BALR R14,R15 CALL "SHOW" SUBROUTINE 00476000
LTR R15,R15 CHECK RETCODE 00477000
BZ PROMPT 00478000
WRTERM 'Invalid Show Command' 00479000
B PROMPT 00480000
SERVSW EQU * [13 start] 00481000
CLI 8(R6),C'?' Need help? 00482000
BNE SERVS0 No call server 00483000
WRTERM 'Confirm with a carriage return' 00484000
B PROMPT 00485000
SERVS0 L R15,=A(SERVER) 00486000
BALR R14,R15 Call server routine 00487000
B PROMPT Return to normal mode [13 end] 00488000
TAKSW EQU * Take a command file [15 start] 00489000
CLI 8(R6),C'?' Need help? 00490000
BNE TAKS0 00491000
WRTERM 'Specify filename with format: fn ft [fm]' 00492000
B PROMPT 00493000
TAKS0 CLI TAKLEV,TAKMAX At our max level? 00494000
BNH TAKS1 Below so we're OK 00495000
WRTERM 'Past maximum nesting level for TAKE command' 00496000
B PROMPT 00497000
TAKS1 LA R6,8(R6) Point to filename 00498000
CLC 0(8,R6),=8X'FF' File name given? 00499000
BNE TAKS2 Yes OK 00500000
WRTERM 'File name must be specified' 00501000
B PROMPT 00502000
TAKS2 SR R3,R3 00503000
IC R3,TAKLEV Get current TAKE level 00504000
M R2,=F'18' Offset for next file name 00505000
LA R2,TAKTAB(R3) 00506000
MVC 0(18,R2),=18X'40' Blank area for file name 00507000
MVC 0(8,R2),0(R6) Pick up file name 00508000
LA R6,8(R6) Point to file type 00509000
CLC 0(8,R6),=8X'FF' File type given? 00510000
BNE TAKS3 Yes OK 00511000
WRTERM 'File type must be specified' 00512000
B PROMPT 00513000
TAKS3 MVC 8(8,R2),0(R6) Pick up file type 00514000
LA R6,8(R6) Check for file mode 00515000
MVC 16(2,R2),=C'* ' Use any mode 00516000
CLC 0(8,R6),=8X'FF' File mode given? 00517000
BE TAKS4 No use default 00518000
MVC 16(2,R2),0(R6) Use what user typed 00519000
TAKS4 FSOPEN (R2) Does file exist? 00520000
LTR R15,R15 00521000
BZ TAKS5 Bad return code 00522000
WRTERM 'TAKE file not found' 00523000
B PROMPT 00524000
TAKS5 SR R3,R3 00525000
IC R3,TAKLEV Get current take level 00526000
LA R3,1(R3) And increment 00527000
STC R3,TAKLEV 00528000
OI LFLAGS,TAKON Say we're in TAKE mode 00529000
B PROMPT [15 end] 00530000
STATSW EQU * 00531000
CLI 8(R6),C'?' NEED HELP? 00532000
BNE GIVSTAT 00533000
WRTERM 'Confirm with a carriage return' 00534000
B PROMPT 00535000
GIVSTAT CLI OLDERR,X'FF' WAS THERE AN ERROR LAST TIME? 00536000
BNE FAIL 00537000
WRTERM 'Kermit completed successfully' 00538000
B PROMPT 00539000
FAIL SR R5,R5 00540000
IC R5,OLDERR GET OFFSET INTO ERROR TABLE 00541000
M R4,=F'20' OFFSET := ERRNUM * 20 00542000
LA R5,ERRTAB(R5) 00543000
WRTERM (R5),20 PRINT ERROR MSG ON SCREEN 00544000
B PROMPT AND LEAVE 00545000
IGNATTN BR R14 Ignore attention [10] 00546000
HELPSW CLI 8(R6),C'?' NEED HELP? 00547000
BNE GIVHLP 00548000
WRTERM 'Confirm with a carriage return' 00549000
B PROMPT 00550000
GIVHLP LA R1,HLPMSG GET LOCATION OF HELP MESSAGE 00551000
SVC 202 SUPERVISOR CALL 00552000
DC AL4(*+8) PRINT ERR MSG IF FAILED 00553000
B PROMPT RETURN IF NO 00554000
WRTERM 'No help available' 00555000
B PROMPT 00556000
TDSW L R15,=A(SHOW) Dump tables [20] 00557000
BALR R14,R15 Use the SHOW routine [20] 00558000
B PROMPT 00559000
SYSCMD CLI 8(R6),C'?' NEED HELP? 00560000
BNE GIVSYS 00561000
WRTERM 'Issue a CMS/CP command' 00562000
B PROMPT 00563000
GIVSYS CLC 8(8,R6),=8X'FF' ANY COMMAND? 00564000
BE SYSERR DIE IF NO 00565000
LA R1,0(R6) REST OF THE CMS COMMAND 00566000
CLC 0(3,R6),=C'CMS' CMS OR CP COMMAND? 00567000
BNE GIVSVC 00568000
LA R1,8(R6) IGNORE THE "CMS" PART 00569000
GIVSVC SVC 202 ISSUE THE COMMAND 00570000
DC AL4(*+8) PRINT ERR MSG IF FAILED 00571000
B PROMPT 00572000
LR R5,R15 GET RETCODE 00573000
LINEDIT TEXT='Command return code is ...',SUB=(DEC,(R5)) 00574000
B PROMPT 00575000
SYSERR WRTERM 'No command supplied' 00576000
B PROMPT 00577000
LEAVE CLI 8(R6),C'?' NEED HELP? 00578000
BNE LV2 00579000
WRTERM 'Confirm with a carriage return' 00580000
B PROMPT 00581000
* Return the two 64K buffers used for reading/writing. [2] 00582000
LV2 L R0,=F'16384' RETURN 128K [2] 00583000
L R1,ABUF STARTING ADDR [2] 00584000
DMSFRET DWORDS=(0),LOC=(1),ERR=*,MSG=NO [2] 00585000
SR R1,R1 Clear flags back to how [12] 00586000
L R15,=A(SETMSGS) the user had them set [12] 00587000
BALR R14,R15 [12] 00588000
FSCLOSE 'KER LOG A1' Close and ignore errors [14] 00589000
B KRET AND LEAVE [2] 00590000
BADDEV WRTERM 'Connection must be via a TTY line or the Series/1 *00591000
emulation controller.' [12] 00592000
B RET 00593000
ERRBUF WRTERM 'Unable to allocate read/write buffers' [2] 00594000
KRET EQU * 00595000
USING NUCON,0 USE TO RESET BLIP 00596000
L R7,AEXTSECT ADDR OF EXTSECT 00597000
USING EXTSECT,R7 RESTORE USER'S BLIP CHAR 00598000
DMSEXS MVC,TIMCHAR(1),BLIP 00599000
DROP R7 00600000
* RESTORE USER'S TERMINAL LINESIZE 00601000
LINEDIT TEXT='TERM LINES ........',SUB=(DECA,LINSIZ), *00602000
DOT=NO,DISP=CPCOMM 00603000
RET EQU * 00604000
L R13,4(R13) 00605000
L R14,12(R13) 00606000
LM R0,R12,20(R13) 00607000
BR R14 00608000
* 00609000
KSAVE DS 18F KERMIT'S SAVE AREA 00610000
LTORG 00611000
DROP R11 00612000
DROP R12 NO LONGER NEED THEM 00613000
EJECT 00614000
* Moved code because base register ran out on us. [21] 00615000
PRSFN BALR R7,0 New base register 00616000
USING *,R7 00617000
L R11,=A(PARMS) Point to data area 00618000
USING PARMS,R11 00619000
SR R15,R15 Retcode 00620000
LA R6,8(R6) Pick up next token 00621000
CLI 0(R6),C'?' Need help? 00622000
BNE PRSF0 00623000
WRTERM 'Specify filename with format: [fn ft [fm]]' 00624000
BCTR R15,0 00625000
B PRSRET 00626000
PRSF0 CLC 0(8,R6),=8X'FF' No more words? 00627000
BE PRSRET No so go receive 00628000
CLI 0(R6),C'=' Is it " = = FM" ? 00629000
BNE PRSF1 00630000
CLI 8(R6),C'=' Is FT also '=' ? 00631000
BNE PRSF3 Must be an '=' 00632000
CLI 16(R6),X'FF' No FM given - assume A1 00633000
BE PRSRET 00634000
MVC FM(2),16(R6) Use FM they specified 00635000
B PRSRET 00636000
PRSF1 CLI 0(R6),C'*' No wildcards here 00637000
BNE PRSF2 00638000
WRTERM 'Invalid file name' 00639000
BCTR R15,0 00640000
B PRSRET 00641000
PRSF2 MVC FILNAM,=18X'20' Blank it out 00642000
MVC FILNAM(8),0(R6) Get fn 00643000
LA R6,8(R6) Get next token 00644000
CLI 0(R6),C'*' Not allowed 00645000
BE PRSF3 00646000
CLI 0(R6),C'=' Not allowed 00647000
BE PRSF3 00648000
CLC 0(8,R6),=8X'FF' No more? 00649000
BNE PRSF4 00650000
PRSF3 WRTERM 'Invalid File Type' 00651000
BCTR R15,0 00652000
B PRSRET 00653000
PRSF4 MVC FILNAM+8(8),0(R6) Get ftype 00654000
OI FLAGS,FLG2 Overwrite received fname 00655000
MVC FILNAM+16(2),DFM Default fmode,just in case 00656000
LA R6,8(R6) Look for fmode 00657000
CLC 0(8,R6),=8X'FF' Is it there? 00658000
BE PRSRET No use default 00659000
CLI 0(R6),C'*' Not allowed in FM 00660000
BE PRSF5 00661000
MVC FILNAM+16(2),0(R6) Get fmode 00662000
B PRSRET Go to read portion 00663000
PRSF5 WRTERM 'Invalid file mode' 00664000
BCTR R15,0 00665000
PRSRET EQU * 00666000
DROP R7 Go back to old base 00667000
BR R14 Return to caller 00668000
LTORG 00669000
* 00670000
* Set the maximum data packet size. [4] 00671000
PACKLEN CSECT 00672000
STM R14,R12,12(R13) 00673000
BALR R12,0 00674000
USING *,R12 00675000
LA R14,PKSAV 00676000
ST R13,4(R14) 00677000
ST R14,8(R13) 00678000
LR R13,R14 00679000
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA LIST 00680000
L R11,=A(PARMS) 00681000
USING PARMS,R11 00682000
L R5,SPSIZ Maximum send packet size 00683000
S R5,=F'4' Minus control information 00684000
SR R7,R7 00685000
IC R7,CHKLEN 00686000
SR R5,R7 Minus checksum length 00687000
BCTR R5,0 00688000
BCTR R5,0 Minus two for possible #X 00689000
CLI EBQUOT,AN Doing 8-bit quoting? 00690000
BE PACK0 Nope 00691000
CLI EBQUOT,AY Not doing it in this case either 00692000
BE PACK0 00693000
BCTR R5,0 Another one for 8-bit quoting 00694000
PACK0 CLI RPTQ,X'00' Doing repeat char quoting 00695000
BE PACK1 Nope, so that's all for now 00696000
BCTR R5,0 00697000
BCTR R5,0 Minus two for repeat prefix 00698000
PACK1 ST R5,MAXDAT Save max length for data field 00699000
* Do standard linkage and return. 00700000
L R13,4(R13) 00701000
L R14,12(R13) 00702000
LM R0,R12,20(R13) 00703000
BR R14 00704000
PKSAV DS 18F 00705000
LTORG 00706000
DROP R11 00707000
DROP R12 00708000
EJECT 00709000
* 00710000
* Verify characters of FILNAM. [9] 00711000
VERLET CSECT 00712000
STM R14,R12,12(R13) 00713000
BALR R12,0 00714000
USING *,R12 00715000
LA R14,VRLSAV 00716000
ST R13,4(R14) 00717000
ST R14,8(R13) 00718000
LR R13,R14 00719000
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA LIST 00720000
L R11,=A(PARMS) 00721000
USING PARMS,R11 00722000
VER0 SR R1,R1 00723000
TRT FILNAM(18),VALLET Valid letters only 00724000
BZ VERRET 00725000
MVI 0(R1),C'X' Replace invalid char 00726000
B VER0 00727000
VERRET L R13,4(R13) 00728000
L R14,12(R13) 00729000
LM R0,R12,20(R13) 00730000
BR R14 00731000
VRLSAV DS 18F 00732000
VALLET DC 64X'01' 00733000
DC X'00' For 40 (space) 00734000
DC 13X'01' 00735000
DC X'00' For 4E (plus) 00736000
DC 12X'01' 00737000
DC X'00' For 5B (dollar sign) 00738000
DC 4X'01' 00739000
DC X'00' For 60 (dash) 00740000
DC 12X'01' 00741000
DC X'00' For 6D (underscore) 00742000
DC 12X'01' 00743000
DC 3X'00' For 7A-7C (colon ... 00744000
DC 68X'01' ... pound sign, at sign) 00745000
DC 9X'00' For C1-C9 (A-I) 00746000
DC 7X'01' 00747000
DC 9X'00' For D1-D9 (J-R) 00748000
DC 8X'01' 00749000
DC 8X'00' For E2-E9 (S-Z) 00750000
DC 6X'01' 00751000
DC 10X'00' For F0-F9 (0-9) 00752000
DC 6X'01' 00753000
LTORG 00754000
DROP R11 00755000
DROP R12 00756000
EJECT 00757000
* 00758000
INIT CSECT 00759000
STM R14,R12,12(R13) 00760000
BALR R12,0 00761000
USING *,R12 00762000
LA R14,ISAVE 00763000
ST R13,4(R14) 00764000
ST R14,8(R13) 00765000
LR R13,R14 00766000
* 00767000
* INITIALIZE VARIABLES THAT GET CHANGED DURING EXECUTION 00768000
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA LIST 00769000
L R11,=A(PARMS) 00770000
USING PARMS,R11 00771000
XC SNDPKT,SNDPKT CLEAR OUT THESE BUFFERS 00772000
XC RECPKT,RECPKT 00773000
XC INPUT,INPUT 00774000
XC ABUF,ABUF ADDR OF READ BUFFER [2] 00775000
XC ARBUF,ARBUF ADDR OF WRITE BUFFER [2] 00776000
XC QSBUF,QSBUF For QUERY SET cmd [12] 00777000
XC FSENT,FSENT 00778000
XC SDAT,SDAT 00779000
XC RDAT,RDAT 00780000
XC SPKNUM,SPKNUM SET VARIABLES TO ZERO 00781000
XC RPKNUM,RPKNUM 00782000
XC LSDAT,LSDAT 00783000
XC LRDAT,LRDAT 00784000
MVI FLAGS,X'00' CLEAR ALL FLAGS 00785000
MVI LFLAGS,X'00' Local settings flags [12] 00786000
XC INBFPT,INBFPT 00787000
XC OUTBFPT,OUTBFPT 00788000
XC NUMTRY,NUMTRY 00789000
MVC FILNAM,=18X'20' BLANK OUT FILNAM & NAME 00790000
MVC NAME,=18X'20' 00791000
MVI PREV,X'00' 00792000
MVI ERRNUM,X'FF' SET TO NO ERROR FOR NOW 00793000
MVI OLDERR,X'FF' SAME HERE 00794000
MVC FST(4),=X'FF000000' 00795000
MVC ADT(4),=X'FF000000' 00796000
XC PKVAR,PKVAR ZERO IT OUT 00797000
XC OLDTRY,OLDTRY 00798000
XC TEMP,TEMP 00799000
XC NFSENT,NFSENT ZERO FILES SENT,INITIALLY 00800000
XC STORLOC,STORLOC 00801000
MVC LRECL,=A(DLRECL) Use default [2] [4] 00802000
MVI RFM,DRECFM 00803000
MVC FM(2),DFM 00804000
MVC MAXOUT,=A(MAXTXT) Max output buffer size [6] 00805000
MVI RQUOTE,DQUOTE Use default quote char [4] 00806000
MVI SQUOTE,DQUOTE Ditto [4] 00807000
MVI EBQUOT,D8QUO For 8-bit quoting [1][4] 00808000
MVI ORIG8Q,D8QUO For 8-bit quoting [1][4] 00809000
MVI REOL,DEOL Use default for now [4] 00810000
MVI SEOL,DEOL Ditto [4] 00811000
MVI STIME,DSTIM 00812000
MVI RTIME,DRTIM 00813000
MVI SPAD,DSPAD 00814000
MVI RPAD,DRPAD 00815000
MVI SPADCH,DSPADC 00816000
MVI RPADCH,DRPADC 00817000
MVI CHKLEN,DCHKLEN Checksum length [4] 00818000
MVI CHKSET,DCHKLEN Checksum length [4] 00819000
MVI RPTQ,DRPT Repeat char prefix [4] 00820000
MVI ORIGQ,DRPT Repeat char prefix [4] 00821000
MVI CXZ,X'00' Abort sending file(s) [16] 00822000
MVI STATE,C' ' 00823000
MVI STYPE,C' ' 00824000
MVI RTYPE,C' ' 00825000
* 00826000
INITRET L R13,4(R13) 00827000
L R14,12(R13) 00828000
LM R0,R12,20(R13) 00829000
BR R14 00830000
ISAVE DS 18F 00831000
LTORG 00832000
DROP R11 00833000
DROP R12 00834000
EJECT 00835000
PARMS CSECT GLOBAL DATA LIST 00836000
S1ORDS DS 0D Transparent R/W [12 start] 00837000
DC X'40',AL1(SBA),X'5D7F',AL1(SBA),X'0001' 00838000
S1ORDSL EQU *-S1ORDS [12 end] 00839000
SNDPKT DS CL130 SEND THIS TO MICRO 00840000
ORG SNDPKT 00841000
PHDR DS X 00842000
PLEN DS X 00843000
PNUM DS X 00844000
PTYPE DS X 00845000
PDATA DS 0C 00846000
ORG , 00847000
RECPKT DS CL130 RECEIVE THIS FROM MICRO 00848000
S1SCCW DS 0D CCW to write to S/1 [12 start] 00849000
DC X'29',AL3(S1ORDS),AL1(SLI),X'00' 00850000
S1SDATL DC H'0' Length of data to send 00851000
S1RCCW DS 0D CCW to read S/1 00852000
DC X'2A',AL3(RECPKT),AL1(SLI),X'80',AL2(L'RECPKT) 00853000
* Data from console interrupts are saved here: 00854000
CONSCSW DS 0D 00855000
CONSKEY DC X'00' storage key + cond code 00856000
CONSCCW DC AL3(0) CCW addr 00857000
CONSUNIT DC X'00' unit status 00858000
CONSCHAN DC X'00' channel status 00859000
CONSBYTC DC H'0' byte count 00860000
ERRCSW DS 1D copy of CSW in error 00861000
* 00862000
S1RDBYTC DC F'-1' READ MOD byte count residue 00863000
CONSADDR DC H'9' console addr (CUU) 00864000
CONSTTY DC X'8020' Class=TERM,type=TTY 00865000
CONS772 DC X'400402' Class=GRAF,type=3277,mod=2 00866000
S1FLAGS DC X'00' S/1 flags [12 end] 00867000
* 00868000
LSDAT DS F SEND PACKET SIZE 00869000
LRDAT DS F RECEIVE PACKET SIZE 00870000
MORENC DS F Encode refill routine [22] 00871000
MORDEC DS F Deocde dump routine [22] 00872000
FLAGS DC X'00' USE TO TEST OUR FLAGS 00873000
LFLAGS DC X'00' For local settings [12] 00874000
FILINFO DC A(NAME) DATA FOR "NEXTFST" ROUTINE 00875000
DC A(ADT) 00876000
DC X'80',AL3(FST) 00877000
HLPMSG DC CL8'HELP' USE FOR CMS 'HELP' COMMAND 00878000
DC CL8'KERMIT' TOKENIZE TO 8 CHARACTERS 00879000
DC 8X'FF' NO MORE INFO 00880000
NAME DC 18X'20' NAME OF FILE(S) TO SEND 00881000
DS 0F 00882000
FST DC X'FF',AL3(0) USE FOR "NEXTFST" ROUTINE 00883000
ADT DC X'FF',AL3(0) THIS TOO 00884000
DS 0F 00885000
INPUT DS CL130 INPUT BUFFER 00886000
DS 0F 00887000
ABUF DS F ADDR OF FSREAD BUFFER [2] 00888000
ARBUF DS F ADDR OF FSWRITE BUFFER [2] 00889000
PROMSG DC C'Kermit CMS Version 2.01' [3] 00890000
HELPM DC C'Enter ? for a list of valid commands' [3] 00891000
FILMSG1 DC C'File type is text.' [17] 00892000
FILMSG2 DC C'File type is binary.' [17] 00893000
DEBMSG1 DC C'Debug mode is off.' [17] 00894000
DEBMSG2 DC C'Debug mode is on.' [17] 00895000
SERMSG1 DC C'Series/1 mode is off.' [17] 00896000
SERMSG2 DC C'Series/1 mode is on.' [17] 00897000
WARMSG1 DC C'Warning is off.' [18] 00898000
WARMSG2 DC C'Warning is on.' [18] 00899000
FSENT DS CL160 TABLE OF FILES SENT SO FAR 00900000
DS 0F 00901000
TAKTAB DS CL160 Table of TAKE files [15] 00902000
QSBUF DS CL256 For QUERY SET response [12] 00903000
SPKNUM DC F'0' SEND PACKET NUMBER [13] 00904000
RPKNUM DC F'0' RECEIVE PACKET NUMBER [13] 00905000
NUMTRY DC F'0' TRIAL COUNTER FOR TRANSFERS 00906000
OLDTRY DS F COUNTER FOR PREVIOUS PACKET 00907000
NFSENT DC F'0' NUMBER OF FILES SENT 00908000
STORLOC DS F POINTER TO EXTRA STORAGE 00909000
RECL DS F RECORD LEN (IF RECFM = V) 00910000
RPSIZ DC F'94' MAX RECEIVE PACKET SIZE 00911000
SPSIZ DC F'80' SEND PACKET SIZE 00912000
MAXTRY DC F'5' NO. OF TIMES TO RETRY PACKET 00913000
IMXTRY DC F'16' NO. OF INITIAL TRIALS ALLOWED 00914000
DEL DC F'127' OCTAL 177 (DELETE CHAR) 00915000
ZERO DC F'0' 00916000
ONE DC F'1' 00917000
FIVE DC F'5' 00918000
TWO DC F'2' 00919000
SPACE DC F'32' ASCII SPACE 00920000
O1H DC F'64' OCTAL 100 00921000
O2H DC F'128' OCTAL 200 00922000
INBFPT DC F'0' Input buffer pointer 00923000
OUTBFPT DC F'0' Output buffer pointer 00924000
PAR DS F PARITY OF INCOMING CHARACTER [1] 00925000
EXTFLG DS X Exit flag [11] 00926000
SQUOTE DS X Micro's quote char 00927000
RQUOTE DS X QUOTE CHAR WE'LL SEND 00928000
EBQUOT DS X 8-BIT QUOTING CHAR [1] 00929000
ORIG8Q DS X ORIG 8-BIT QUOTE CHAR [1] 00930000
STIME DS X Send timeout [5] 00931000
RTIME DS X Receive timeout [5] 00932000
SPAD DS X Send padding [5] 00933000
RPAD DS X Receive padding [5] 00934000
SPADCH DS X Send pad char [5] 00935000
RPADCH DS X Receive pad char [5] 00936000
CXZ DS X Abort send/rec file(s) [16] 00937000
TMP DS X 00938000
TEMP DS F TEMPORARY SPACE 00939000
DS 0D 00940000
PKVAR DS D USE FOR PICKING UP INTEGER 00941000
SDAT DS CL130 TEMP PLACE FOR SEND DATA 00942000
RDAT DS CL130 TEMP PLACE FOR RECEIVE DATA 00943000
DS 0D 00944000
INFOBUF DS 32X'00' For diagnose x'00' [15] 00945000
FILNAM DS CL18 SEND/REC FILENAME 00946000
UNAME DS CL8 User for init file [15] 00947000
DC CL8'KERMINI ' File type expected [15] 00948000
DC CL2'* ' File mode [15] 00949000
SYSTAK DC CL8'SYSTEM ' System init file [15] 00950000
DC CL8'KERMINI ' File type [15] 00951000
DC CL2'* ' File mode [15] 00952000
STATE DS C OUR CURRENT STATE 00953000
DFM DC CL2'A1' DEFAULT FILEMODE 00954000
FM DS CL2 FILEMODE USER WANTS 00955000
CHKLEN DS X Checksum length [4] 00956000
CURCHK DS X Store chksum length here [8] 00957000
CHKSET DS X SET by user [8] 00958000
RPTQ DS X Repeat prefix [4] 00959000
ORIGQ DS X Original repeat prefix [7] 00960000
RPTVAL DS X Character to be repeated [7] 00961000
RPTCT DS X No. of times is repeated [7] 00962000
TAKLEV DS X TAKE file level [15] 00963000
REOL DS X EOL CHAR I NEED (CR) 00964000
SEOL DS X EOL I'LL SEND 00965000
LRECL DS F LRECL PROGRAM WILL USE [2] 00966000
RFM DS C RECFM PROGRAM WILL USE 00967000
PREV DS C PREVIOUS CHAR REC (IN PTCHR) 00968000
BLIP DS X SAVE USER'S BLIP CHAR 00969000
LINSIZ DS F SAVE USER'S CONSOLE LINESIZE 00970000
MAXDAT DS F Max packet size for send [4] 00971000
MAXOUT DS F Max output buffer [6] 00972000
ERRNUM DS X ERROR NUMBER,IN CASE WE DIE 00973000
OLDERR DS X ERROR OF PREVIOUS EXECUTION 00974000
STYPE DS C TYPE OF PACKET SENT 00975000
RTYPE DS C TYPE OF PACKET RECEIVED 00976000
* THIS IS THE ASCII TO EBCDIC TABLE [19] 00977000
ATOE DC X'00010203372D2E2F1605250B0C0D0E0F' 00978000
DC X'101112133C3D322618193F271C1D1E1F' 00979000
DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' 00980000
DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 00981000
DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 00982000
DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' 00983000
DC X'79818283848586878889919293949596' 00984000
DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' 00985000
DC X'00010203372D2E2F1605250B0C0D0E0F' 00986000
DC X'101112133C3D322618193F271C1D1E1F' 00987000
DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' 00988000
DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' 00989000
DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' 00990000
DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' 00991000
DC X'79818283848586878889919293949596' 00992000
DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' 00993000
*THIS IS THE EBCDIC TO ASCII CONVERSION TABLE 00994000
*CHARACTERS NOT REPRESENTABLE IN ASCII ARE REPLACED BY A NULL 00995000
ETOA DC X'000102030009007F0000000B0C0D0E0F' 00996000
DC X'1011121300000800181900001C1D1E1F' 00997000
DC X'00000000000A171B0000000000050607' 00998000
DC X'0000160000000004000000001415001A' 00999000
DC X'20000000000000000000002E3C282B7C' 01000000
DC X'2600000000000000000021242A293B5E' 01001000
DC X'2D2F00000000000000007C2C255F3E3F' 01002000
DC X'000000000000000000603A2340273D22' 01003000
DC X'00616263646566676869007B00000000' 01004000
DC X'006A6B6C6D6E6F707172007D00000000' 01005000
DC X'007E737475767778797A0000005B0000' 01006000
DC X'000000000000000000000000005D0000' 01007000
DC X'7B414243444546474849000000000000' 01008000
DC X'7D4A4B4C4D4E4F505152000000000000' 01009000
DC X'5C00535455565758595A000000000000' 01010000
DC X'303132333435363738397C0000000000' 01011000
* Table to convert EBCDIC text to upper case. [15] 01012000
UPC DC X'000102030405060708090A0B0C0D0E0F' 01013000
DC X'101112131415161718191A1B1C1D1E1F' 01014000
DC X'202122232425262728292A2B2C2D2E2F' 01015000
DC X'303132333435363738393A3B3C3D3E3F' 01016000
DC X'404142434445464748494A4B4C4D4E4F' 01017000
DC X'505152535455565758595A5B5C5D5E5F' 01018000
DC X'606162636465666768696A6B6C6D6E6F' 01019000
DC X'707172737475767778797A7B7C7D7E7F' 01020000
DC X'80C1C2C3C4C5C6C7C8C98A8B8C8D8E8F' 01021000
DC X'90D1D2D3D4D5D6D7D8D99A9B9C9D9E9F' 01022000
DC X'A0A1E2E3E4E5E6E7E8E9AAABACADAEAF' 01023000
DC X'B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF' 01024000
DC X'C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF' 01025000
DC X'D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF' 01026000
DC X'E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF' 01027000
DC X'F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF' 01028000
* Table to use for CRC calculation 01029000
CRCTAB DC X'0000' 01030000
DC X'1081' 01031000
DC X'2102' 01032000
DC X'3183' 01033000
DC X'4204' 01034000
DC X'5285' 01035000
DC X'6306' 01036000
DC X'7387' 01037000
DC X'8408' 01038000
DC X'9489' 01039000
DC X'A50A' 01040000
DC X'B58B' 01041000
DC X'C60C' 01042000
DC X'D68D' 01043000
DC X'E70E' 01044000
DC X'F78F' 01045000
* 01046000
CRCTB2 DC X'0000' 01047000
DC X'1189' 01048000
DC X'2312' 01049000
DC X'329B' 01050000
DC X'4624' 01051000
DC X'57AD' 01052000
DC X'6536' 01053000
DC X'74BF' 01054000
DC X'8C48' 01055000
DC X'9DC1' 01056000
DC X'AF5A' 01057000
DC X'BED3' 01058000
DC X'CA6C' 01059000
DC X'DBE5' 01060000
DC X'E97E' 01061000
DC X'F8F7' 01062000
* 01063000
* TABLE OF ERROR MESSAGES (IN CASE WE ABORT) 01064000
ERRTAB DC CL20'Bad send-packet size' ERR MSG #0 01065000
DC CL20'Bad message number' ERR MSG #1 01066000
DC CL20'Unrecognized state' ERR MSG #2 01067000
DC CL20'No SOH encountered' ERR MSG #3 01068000
DC CL20'Bad character count' ERR MSG #4 01069000
DC CL20'Bad checksum' ERR MSG #5 01070000
DC CL20'Disk is full' ERR MSG #6 01071000
DC CL20'Invalid packet type' ERR MSG #7 01072000
DC CL20'Lost a packet' ERR MSG #8 01073000
DC CL20'Micro sent a NAK' ERR MSG #9 01074000
DC CL20'Micro aborted' ERR MSG #10 01075000
DC CL20'Invalid file name' ERR MSG #11 01076000
DC CL20'Invalid lrecl' ERR MSG #12 01077000
DC CL20'Permanent I/O error' ERR MSG #13 01078000
DC CL20'Disk is read-only' ERR MSG #14 01079000
DC CL20'Recfm conflict' ERR MSG #15 01080000
DC CL20'Err allocating space' ERR MSG #16 01081000
DC CL20'Series/1 I/O error' ERR MSG #17 [12] 01082000
DC CL20'Unknown generic cmd' ERR MSG #18 [13] 01083000
DC CL20'Unknown server cmd' ERR MSG #19 [13] 01084000
DC CL20'Cannot rename file' ERR MSG #20 [18] 01085000
DC CL20'File not found' ERR MSG #21 [13] 01086000
DC CL20'Send cancelled' ERR MSG #22 [16] 01087000
DC CL20'Receive cancelled' ERR MSG #23 [16] 01088000
DC CL20'Cannot create file' ERR MSG #24 [18] 01089000
DC CL20'Error writing file' ERR MSG #25 [4] 01090000
S1ERRNUM EQU 17 Makes life easier [12] 01091000
LTORG 01092000
EJECT 01093000
SET CSECT 01094000
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 01095000
BALR R12,0 ESTABLISH ADDRESSABILITY 01096000
USING *,R12 01097000
LA R14,SETSAVE ADDRESS OF MY SAVE AREA 01098000
ST R13,4(R14) SAVE CALLER'S 01099000
ST R14,8(R13) 01100000
LR R13,R14 01101000
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 01102000
L R11,=A(PARMS) 01103000
USING PARMS,R11 ESTABLISH ADDRESSABILITY 01104000
LA R6,8(R6) PICK UP NEXT TOKEN 01105000
CLI 0(R6),C'?' NEED HELP ? 01106000
BNE NOQ 01107000
WRTERM 'File, Debug, Block, Series1, Warning, Recfm, Quote' 01108000
WRTERM 'Lrecl, End-of-line, Packet-size, Etoa, Atoe' 01109000
B SETOK 01110000
NOQ CLC 0(7,R6),=CL7'SERIES1' Series/1 mode [12 start] 01111000
BNE NOSER 01112000
LA R6,8(R6) Pick up operand 01113000
CLI 0(R6),C'?' Need help? 01114000
BNE CHKSR 01115000
WRTERM 'ON or OFF' 01116000
B SETOK 01117000
CHKSR CLC 0(2,R6),=CL2'ON' Set series/1 mode on 01118000
BNE STSR0 01119000
OI S1FLAGS,ISS1 01120000
B SETOK 01121000
STSR0 CLC 0(3,R6),=CL3'OFF' Set series/1 mode off 01122000
BNE STSR1 01123000
NI S1FLAGS,X'FF'-ISS1 01124000
B SETOK 01125000
STSR1 WRTERM 'Operand must be ON or OFF' 01126000
B SETERR [12 end] 01127000
NOSER CLC 0(4,R6),=CL4'WARN' Set fn renaming [18 start] 01128000
BNE NOWAR 01129000
LA R6,8(R6) Pick up operand 01130000
CLI 0(R6),C'?' Need help? 01131000
BNE CHKWR 01132000
WRTERM 'ON or OFF' 01133000
B SETOK 01134000
CHKWR CLC 0(2,R6),=CL2'ON' Set warning on? 01135000
BNE STWR0 01136000
OI LFLAGS,WARFL Yes 01137000
B SETOK 01138000
STWR0 CLC 0(3,R6),=CL3'OFF' Set warning off? 01139000
BNE STWR1 01140000
NI LFLAGS,X'FF'-WARFL 01141000
B SETOK 01142000
STWR1 WRTERM 'Operand must be ON or OFF' 01143000
B SETERR [18 end] 01144000
NOWAR CLC 0(4,R6),=CL4'FILE' Set file mode [1 start] 01145000
BNE NOBIN 01146000
LA R6,8(R6) Pick up operand 01147000
CLI 0(R6),C'?' Need help? 01148000
BNE CHKBN 01149000
WRTERM 'BINARY or TEXT' 01150000
B SETOK 01151000
CHKBN CLC 0(6,R6),=CL6'BINARY' Setting to BINARY? 01152000
BNE STBN0 No maybe it's TEXT 01153000
OI FLAGS,BINF Set binary on 01154000
MVC MAXOUT,LRECL Max output buffer size 01155000
B SETOK 01156000
STBN0 CLC 0(4,R6),=CL4'TEXT' Setting it off? 01157000
BNE STBN1 No then it's wrong 01158000
NI FLAGS,X'FF'-BINF Set it OFF 01159000
MVC MAXOUT,=A(MAXTXT) Max output buffer size 01160000
B SETOK 01161000
STBN1 WRTERM 'Invalid operand' 01162000
B SETERR [1 end] 01163000
NOBIN CLC 0(5,R6),=CL5'DEBUG' Set debug mode [10 start] 01164000
BNE NODEB No check something else 01165000
LA R6,8(R6) Pick up operand 01166000
CLI 0(R6),C'?' Need help? 01167000
BNE CHKDB 01168000
WRTERM 'ON or OFF' 01169000
B SETOK 01170000
CHKDB CLC 0(2,R6),=CL2'ON' Setting it on? 01171000
BNE STDEB3 No maybe it's OFF 01172000
OI FLAGS,DEBUG Set it ON 01173000
FSERASE 'KER LOG A1' In case exists already [14] 01174000
FSOPEN 'KER LOG A1',RECFM=V,FORM=E Keep a log [14] 01175000
LTR R15,R15 Check the return code [14] 01176000
BZ SETOK No problem [14] 01177000
C R15,=F'28' File not found [14] 01178000
BE SETOK That's OK too [14] 01179000
WRTERM 'Error creating file, no logging of packets.' [14] 01180000
B SETOK 01181000
STDEB3 CLC 0(3,R6),=CL3'OFF' Setting if off? 01182000
BNE STDEB4 No then it's wrong 01183000
NI FLAGS,X'FF'-DEBUG Set it OFF 01184000
FSCLOSE 'KER LOG A1' Done logging [14] 01185000
B SETOK 01186000
STDEB4 WRTERM 'Invalid operand' 01187000
B SETERR [10 end] 01188000
NODEB CLC 0(5,R6),=CL5'BLOCK' Set checksum len [8 start] 01189000
BNE NOBL 01190000
LA R6,8(R6) Pick up chksum type 01191000
CLI 0(R6),C'?' Need help? 01192000
BNE CHKBL 01193000
WRTERM '1, 2, or 3' 01194000
B SETOK 01195000
CHKBL CLI 0(R6),X'F1' Must be 1, 2 or 3 01196000
BL BLKERR Error if below 1 01197000
CLI 0(R6),X'F3' 01198000
BH BLKERR Error if above 3 01199000
CLI 1(R6),C' ' Should be one char long [20] 01200000
BNE BLKERR Else fail [20] 01201000
SR R4,R4 01202000
IC R4,0(R6) Pick it up 01203000
S R4,=F'240' Shouldn't be printable 01204000
STC R4,CHKLEN Pick up block check 01205000
STC R4,CHKSET Store here too 01206000
B SETOK 01207000
BLKERR WRTERM 'Must be 1, 2, or 3' 01208000
B SETERR 01209000
NOBL CLC 0(5,R6),=CL5'RECFM' Set recfm [8 end] 01210000
BNE NOREC 01211000
LA R6,8(R6) PICK UP RECORD FORMAT 01212000
CLI 0(R6),C'?' 01213000
BNE CHKFM 01214000
WRTERM 'f or v (default of v)' 01215000
B SETOK 01216000
CHKFM CLI 0(R6),C'V' REDUNDANT 01217000
BE FMSET 01218000
CLI 0(R6),C'F' FIXED FORMAT? 01219000
BNE RECERR 01220000
FMSET MVC RFM(1),0(R6) PICK UP RECFM 01221000
B SETOK 01222000
RECERR WRTERM 'Fixed and variable files only' 01223000
B SETERR 01224000
NOREC CLC 0(5,R6),=C'QUOTE' QUOTE CHARACTER 01225000
BNE NOQUO 01226000
LA R6,8(R6) GET NEXT TOKEN 01227000
CLI 0(R6),X'FF' VALUE NOT SUPPLIED? 01228000
BNE GIVQ 01229000
WRTERM '?not confirmed' 01230000
B SETERR 01231000
GIVQ CLC 0(2,R6),=C'? ' 01232000
BNE GETQUO 01233000
WRTERM 'a single character' 01234000
B SETOK 01235000
GETQUO MVC RQUOTE(1),0(R6) SET NEW QUOTE CHAR 01236000
TR RQUOTE(1),ETOA GET ASCII FORM 01237000
CLI 1(R6),C' ' IS IT ONLY ONE CHAR? 01238000
BE ISQOK 01239000
WRTERM 'one character only' 01240000
B SETERR 01241000
ISQOK CLI RQUOTE,X'21' CAN'T BE LESS THAN 32 01242000
BL BADQUO 01243000
CLI RQUOTE,X'7E' CAN'T BE LARGER THAN 126 01244000
BH BADQUO 01245000
CLI RQUOTE,X'3E' HAS TO BE BETWEEN 32-62 01246000
BNH SETOK 01247000
CLI RQUOTE,X'60' OR BETWEEN 96-126 01248000
BNL SETOK 01249000
BADQUO WRTERM 'Must fall between 33-62,96,or 123-126 (decimal).' 01250000
B SETERR 01251000
NOQUO CLC 0(5,R6),=C'LRECL' LRECL SIZE 01252000
BNE NORCL 01253000
LA R6,8(R6) PICK UP NEXT TOKEN 01254000
CLI 0(R6),C'?' HELP ? 01255000
BNE GETREC 01256000
WRTERM 'Logical record length of 1-65536 (default of 80).' 01257000
B SETOK 01258000
GETREC L R15,=A(GETNUM) Get decimal number [20] 01259000
BALR R14,R15 Use common routine [20] 01260000
LTR R7,R7 Result put here [20] 01261000
BM BADREC Below zero or no input [20] 01262000
BZ BADREC Must be above zero [20] 01263000
C R7,=F'65536' Max of 64K for lrecl [2] 01264000
BH BADREC 01265000
ST R7,LRECL Set the lrecl value [2] 01266000
MVC MAXOUT,LRECL Max output buffer size 01267000
B SETOK 01268000
BADREC WRTERM 'A number between 1 and 65536 (decimal).' 01269000
B SETERR 01270000
NORCL CLC 0(3,R6),=C'END' EOL CHARACTER 01271000
BNE NOEND 01272000
LA R6,8(R6) NEXT TOKEN 01273000
CLI 0(R6),C'?' NEED HELP? 01274000
BNE GETEOL 01275000
WRTERM 'A decimal number between 0 and 31.' 01276000
B SETOK 01277000
GETEOL L R15,=A(GETNUM) Get decimal number [20] 01278000
BALR R14,R15 Use common routine [20] 01279000
LTR R7,R7 Result is here [20] 01280000
BM BADEOL Below zero or no input [20] 01281000
C R7,=X'0000001F' MAX OF 31 DECIMAL 01282000
BH BADEOL 01283000
STC R7,SEOL SET SEND EOL VALUE 01284000
B SETOK 01285000
BADEOL WRTERM 'Must be a two digit value less than 31 (dec).' 01286000
B SETERR 01287000
NOEND CLC 0(3,R6),=C'PAC' CHANGE RECEIVE PACKET SIZE 01288000
BNE NOPAC [20] 01289000
LA R6,8(R6) GET NEXT TOKEN 01290000
CLI 0(R6),C'?' NEED HELP? 01291000
BNE GETPAC 01292000
WRTERM 'Receive packet size (range: 26-94 decimal).' 01293000
B SETOK 01294000
GETPAC L R15,=A(GETNUM) Get decimal number [20] 01295000
BALR R14,R15 Use common routine [20] 01296000
LTR R7,R7 Result is here [20] 01297000
BM BADPAC Below zero or no input [20] 01298000
C R7,=F'26' THIS IS MIN 01299000
BL BADPAC 01300000
C R7,=A(SPMAX) This is the max [5] 01301000
BH BADPAC 01302000
ST R7,RPSIZ USE THIS VALUE NOW 01303000
B SETOK 01304000
BADPAC WRTERM 'Must be between 26-94 (decimal).' 01305000
B SETERR 01306000
* Use common code to change ATOE or ETOA. R9 points to table to edit. 01307000
NOPAC CLC 0(4,R6),=C'ETOA' Change ETOA table? [20 start] 01308000
BNE NOET 01309000
LA R9,ETOA Address of table to change 01310000
ET0 LA R6,8(R6) Bump pointer 01311000
CLI 0(R6),C'?' Help? 01312000
BNE ET1 01313000
WRTERM 'Offset to change and new value (decimal)' 01314000
B SETOK 01315000
ET1 L R15,=A(GETNUM) Get table offset 01316000
BALR R14,R15 Use common routine 01317000
LTR R7,R7 Result is here 01318000
BM BADTRT Below zero or no input 01319000
C R7,=F'255' Max is 255 01320000
BH BADTRT 01321000
LR R2,R7 Save table offset here 01322000
LA R6,8(R6) Pick up next field 01323000
L R15,=A(GETNUM) Get value to change it to 01324000
BALR R14,R15 01325000
LTR R7,R7 01326000
BM BADTRT 01327000
C R7,=F'255' 01328000
BH BADTRT 01329000
AR R9,R2 Location of byte to change 01330000
STC R7,0(R9) Change value 01331000
B SETOK All done 01332000
BADTRT WRTERM 'Both numbers must be between 0-255 (decimal).' 01333000
B SETERR 01334000
NOET CLC 0(4,R6),=C'ATOE' Change ATOE 01335000
BNE SETERR 01336000
LA R9,ATOE Addr of table to edit 01337000
B ET0 Use common routine 01338000
* R6 points to input. Read and convert to binary. Return value 01339000
* in R7. Indicate error by returning -1. Also uses R4 and R3. 01340000
GETNUM SR R7,R7 01341000
BCTR R7,0 Set to -1, error condition 01342000
CLI 0(R6),X'FF' Any input? 01343000
BE GETN5 No, return negative value 01344000
XC PKVAR,PKVAR Clear it out 01345000
SR R4,R4 Length of input 01346000
LR R3,R6 Don't lose pointer to input 01347000
GETN0 CLI 0(R3),C' ' Any more input 01348000
BE GETN1 No, pick it data 01349000
CLI 0(R3),X'F0' Must be between 0-9 01350000
BL GETN5 01351000
CLI 0(R3),X'F9' 01352000
BH GETN5 01353000
LA R3,1(R3) Bump input pointer 01354000
LA R4,1(R4) Bump counter 01355000
C R4,=F'8' At our limit? 01356000
BNE GETN0 No go for more 01357000
GETN1 BCTR R4,0 Decrement for next call 01358000
EX R4,PCK Get the input 01359000
CVB R7,PKVAR Convert to binary 01360000
GETN5 BR R14 Return to caller 01361000
* [20 end] 01362000
SETERR MVI RQUOTE,DQUOTE Reset value, just in case [4] 01363000
LA R15,4 SET A NON-ZERO RETCODE 01364000
B SETRET 01365000
SETOK SR R15,R15 RETCODE OF 0 01366000
* 01367000
SETRET L R13,4(R13) 01368000
L R14,12(R13) 01369000
LM R0,R12,20(R13) 01370000
BR R14 01371000
SETSAVE DS 18F 01372000
PCK PACK PKVAR(8),0(0,R6) 01373000
LTORG 01374000
DROP R11 01375000
DROP R12 01376000
EJECT 01377000
* Change to allow SHOW ALL. 01378000
SHOW CSECT 01379000
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 01380000
BALR R12,0 ESTABLISH ADDRESSABILITY 01381000
USING *,R12 01382000
LA R14,SHOWSAVE ADDRESS OF MY SAVE AREA 01383000
ST R13,4(R14) SAVE CALLER'S 01384000
ST R14,8(R13) 01385000
LR R13,R14 01386000
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 01387000
L R11,=A(PARMS) 01388000
USING PARMS,R11 ESTABLISH ADDRESSABILITY 01389000
CLC 0(5,R6),=C'TDUMP' Show or tdump [20] 01390000
BE TDUMP 01391000
LA R6,8(R6) PICK UP NEXT TOKEN 01392000
CLI 0(R6),C'?' NEED HELP ? 01393000
BNE SHOA No check options 01394000
WRTERM 'File, Debug, Block, Series1, Warning, Recfm, Quote' 01395000
WRTERM 'Lrecl, End-of-line, Packet-size, All' 01396000
B SHOWOK 01397000
SHOA NI LFLAGS,X'FF'-ALLFL Turn off just in case 01398000
CLC 0(3,R6),=CL3'ALL' Show all options? 01399000
BNE SHO0 No find specific one 01400000
OI LFLAGS,ALLFL SHOW ALL requested 01401000
B SHO00 Jump to middle 01402000
SHO0 CLC 0(4,R6),=CL4'FILE' Show file value [1 start] 01403000
BNE SHO1 01404000
SHO00 LA R3,FILMSG1 Assume text mode 01405000
LA R4,L'FILMSG1 Get msg length 01406000
TM FLAGS,BINF Is text mode on? 01407000
BNO SHO01 Yes. 01408000
LA R3,FILMSG2 Mode is binary 01409000
LA R4,L'FILMSG2 01410000
SHO01 WRTERM (R3),(R4) Print mode 01411000
TM LFLAGS,ALLFL Do they want it all 01412000
BO SHO10 Yes give more 01413000
B SHOWOK [1 end] 01414000
SHO1 CLC 0(5,R6),=CL5'DEBUG' Show debug value [10 start] 01415000
BNE SHO2 01416000
SHO10 LA R3,DEBMSG2 Assume debug mode is on 01417000
LA R4,L'DEBMSG2 Get length 01418000
TM FLAGS,DEBUG Is debug mode on? 01419000
BO SHO11 Yes. 01420000
LA R3,DEBMSG1 01421000
LA R4,L'DEBMSG1 01422000
SHO11 WRTERM (R3),(R4) 01423000
TM LFLAGS,ALLFL More to show 01424000
BO SHO20 Yes 01425000
B SHOWOK Else end [10 end] 01426000
SHO2 CLC 0(5,R6),=CL5'BLOCK' Show checksum len [8 start] 01427000
BNE SHO3 01428000
SHO20 MVC TMP(1),CHKLEN Munge it here 01429000
OI TMP,X'F0' Make it printable 01430000
LINEDIT TEXT='Block check is ..',SUB=(CHARA,(TMP,1)) 01431000
TM LFLAGS,ALLFL More to show 01432000
BO SHO30 Yes 01433000
B SHOWOK 01434000
SHO3 CLC 0(7,R6),=CL7'SERIES1' Show series/1 mode [12 start] 01435000
BNE SHO4 01436000
SHO30 LA R3,SERMSG1 Assume S/1 mode is off 01437000
LA R4,L'SERMSG1 01438000
TM S1FLAGS,ISS1 S/1 mode on? 01439000
BNO SHO31 No 01440000
LA R3,SERMSG2 01441000
LA R4,L'SERMSG2 01442000
SHO31 WRTERM (R3),(R4) 01443000
TM LFLAGS,ALLFL 01444000
BO SHO40 01445000
B SHOWOK [12 end] 01446000
SHO4 CLC 0(4,R6),=CL4'WARN' Show fn warning? [18 start] 01447000
BNE SHO5 01448000
SHO40 LA R3,WARMSG1 Assume warning is off 01449000
LA R4,L'WARMSG1 Get length 01450000
TM LFLAGS,WARFL Is warning off? 01451000
BNO SHO41 Yes. 01452000
LA R3,WARMSG2 01453000
LA R4,L'WARMSG2 01454000
SHO41 WRTERM (R3),(R4) 01455000
TM LFLAGS,ALLFL More to show 01456000
BO SHO50 Yes 01457000
B SHOWOK Else end [18 end] 01458000
SHO5 CLC 0(5,R6),=CL5'RECFM' Show recfm 01459000
BNE SHO6 01460000
SHO50 LINEDIT TEXT='The record format is ..',SUB=(CHARA,(RFM,1)) 01461000
TM LFLAGS,ALLFL 01462000
BO SHO60 01463000
B SHOWOK 01464000
SHO6 CLC 0(5,R6),=C'QUOTE' 01465000
BNE SHO7 01466000
SHO60 TR RQUOTE(1),ATOE GET EBCDIC VERSION 01467000
LINEDIT TEXT='The quote character is ..', *01468000
SUB=(CHARA,(RQUOTE,1)) 01469000
TR RQUOTE(1),ETOA KEEP THE ASCII FORM AROUND 01470000
TM LFLAGS,ALLFL 01471000
BO SHO70 01472000
B SHOWOK 01473000
SHO7 CLC 0(5,R6),=C'LRECL' 01474000
BNE SHO8 01475000
SHO70 L R4,LRECL 01476000
LINEDIT TEXT='Lrecl is ........',SUB=(DEC,(R4)) 01477000
TM LFLAGS,ALLFL 01478000
BO SHO80 01479000
B SHOWOK 01480000
SHO8 CLC 0(3,R6),=C'END' 01481000
BNE SHO9 01482000
SHO80 SR R4,R4 ZERO IT OUT 01483000
IC R4,SEOL 01484000
LINEDIT TEXT='End-of-Line character is ...... (decimal)', *01485000
SUB=(DEC,(R4)) 01486000
TM LFLAGS,ALLFL 01487000
BO SHO90 01488000
B SHOWOK 01489000
SHO9 CLC 0(3,R6),=C'PAC' PACKET LENGTH ? 01490000
BNE SHOWERR 01491000
SHO90 LINEDIT TEXT='Receive packet size is ........ (decimal)', *01492000
SUB=(DECA,RPSIZ) 01493000
B SHOWOK 01494000
* Table dump routine [20 start] 01495000
TDUMP LA R6,8(R6) Bump pointer 01496000
CLI 0(R6),C'?' Need help? 01497000
BNE TD0 01498000
WRTERM 'Name of table to dump (ETOA or ATOE)' 01499000
B SHOWOK 01500000
TD0 SR R4,R4 01501000
CLC 0(4,R6),=C'ETOA' 01502000
BNE TD2 01503000
LA R3,ETOA 01504000
TD1 C R4,=F'16' 01505000
BE SHOWOK All lines displayed 01506000
LINEDIT TEXT='....................................', *01507000
SUB=(HEX4A,(R3)),DOT=NO 01508000
LA R4,1(R4) Increment counter 01509000
LA R3,16(R3) Point to next line 01510000
B TD1 01511000
TD2 CLC 0(4,R6),=C'ATOE' 01512000
BNE TD3 01513000
LA R3,ATOE 01514000
B TD1 01515000
TD3 WRTERM 'Only the ETOA or ATOE tables are displayed' 01516000
B SHOWOK 01517000
* [20 end] 01518000
SHOWERR LA R15,4 SET A NON-ZERO RETCODE 01519000
B SHOWRET 01520000
SHOWOK SR R15,R15 ZERO RETCODE 01521000
* 01522000
SHOWRET L R13,4(R13) 01523000
L R14,12(R13) 01524000
LM R0,R12,20(R13) 01525000
BR R14 01526000
SHOWSAVE DS 18F 01527000
LTORG 01528000
DROP R11 01529000
DROP R12 01530000
EJECT 01531000
* 01532000
* Add server support. [13 start] 01533000
SERVER CSECT 01534000
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 01535000
BALR R12,0 ESTABLISH ADDRESSABILITY 01536000
USING *,R12 01537000
LA R14,SERVSAVE ADDRESS OF MY SAVE AREA 01538000
ST R13,4(R14) SAVE CALLER'S 01539000
ST R14,8(R13) 01540000
LR R13,R14 01541000
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 01542000
L R11,=A(PARMS) 01543000
USING PARMS,R11 ESTABLISH ADDRESSABILITY 01544000
LA 1,=C'SET LINEDIT OFF' 01545000
LA 0,15 Command length of 15 01546000
DIAG 1,0,8 Say it's a CP command 01547000
OI LFLAGS,SERVON SERVER mode is on 01548000
WRTERM 'Entering server mode...' 01549000
TM S1FLAGS,ISS1 Is console a S/1? 01550000
BZ SERVA No, skip init stuff 01551000
LA R1,1 Initialize 01552000
L R15,=A(INTRINI) Trap CONS interrupts 01553000
BALR R14,R15 01554000
SERVA TM FLAGS,DEBUG In DEBUG mode? 01555000
BO SERV0 Yes, then don't ignore attn 01556000
STAX SRVATTN Else ignore attention 01557000
SERV0 MVI CHKLEN,DCHKLEN Set checksum length to one 01558000
XC NUMTRY,NUMTRY Trial counter 01559000
XC SPKNUM,SPKNUM Packet number we'll use 01560000
L 15,=A(RPACK) 01561000
BALR R14,R15 Read in a packet 01562000
CLI RTYPE,AS Other side sending us a file? 01563000
BNE SERV1 Nope 01564000
SERV01 L R15,=A(RECEIVE) Get the file 01565000
BALR R14,R15 01566000
MVC OLDERR(1),ERRNUM 01567000
MVI ERRNUM,X'FF' Reset error number 01568000
B SERV0 Go around again 01569000
SERV1 CLI RTYPE,AI Init packet 01570000
BNE SERV2 Nope 01571000
L R5,LRDAT Number of pieces of data 01572000
L R15,=A(SPAR) 01573000
BALR R14,R15 Read data from other host 01574000
L R15,=A(PACKLEN) Get max send packet size 01575000
BALR R14,R15 01576000
L R15,=A(RPAR) Our paramters to send 01577000
BALR R14,R15 01578000
ST R15,LSDAT Length of reply 01579000
MVI STYPE,AY Send an ACK 01580000
L R15,=A(SPACK) 01581000
BALR R14,R15 01582000
MVC OLDERR(1),ERRNUM 01583000
MVI ERRNUM,X'FF' Reset error number 01584000
B SERV0 Loop again no matter what 01585000
SERV2 CLI RTYPE,AG Generic command 01586000
BNE SERV3 01587000
LA R3,RDAT Point to first data char 01588000
CLI 0(R3),AF Finish command 01589000
BE SERV21 Yes go handle 01590000
CLI 0(R3),AL Logout command 01591000
BNE SERV24 No 01592000
SERV21 XC LSDAT,LSDAT No data 01593000
MVI STYPE,AY Send an ACK 01594000
L R15,=A(SPACK) 01595000
BALR R14,R15 01596000
CLI 0(R3),AL Logout? 01597000
BNE SERV22 No, reset things 01598000
FSCLOSE 'KER LOG A1' Ignore error messages [14] 01599000
MVI TEMP,XON Other guy expects this 01600000
WRTERM TEMP,1 So send it 01601000
WAITT 01602000
LA 1,=C'LOG' 01603000
LA 0,3 01604000
DIAG 1,0,8 Issue CP LOG command 01605000
SERV22 MVC OLDERR(1),ERRNUM 01606000
MVI ERRNUM,X'FF' Reset error number 01607000
MVI EXTFLG,X'FF' Set exit flag 01608000
TM S1FLAGS,ISS1 Is console a S/1? 01609000
BZ SERV23 No skip reset 01610000
SR R1,R1 Clear interrupt trapping 01611000
L R15,=A(INTRINI) 01612000
BALR R14,R15 01613000
SERV23 NI LFLAGS,X'FF'-SERVON SERVER mode is off 01614000
LA 1,=C'SET LINEDIT ON' 01615000
LA 0,14 01616000
DIAG 1,0,8 01617000
STAX , Reset attn address 01618000
B SERVRET 01619000
SERV24 MVI ERRNUM,X'12' Error message number 01620000
L R15,=A(ERRPACK) Send an error packet 01621000
BALR R14,R15 01622000
B SERV0 And wait for more 01623000
SERV3 CLI RTYPE,AR Other side did GET command 01624000
BNE SERV4 01625000
L R5,LRDAT File name size 01626000
LTR R5,R5 01627000
BZ SERV35 Fail on zero length 01628000
MVC FILNAM,=18X'20' Blank out filename 01629000
MVC NAME,=18X'20' 01630000
LR R6,R5 Length of data 01631000
LA R7,RDAT Location of data 01632000
SERV30 CLI 0(R7),X'2E' Is char a dot 01633000
BNE SERV31 No try next one 01634000
MVI 0(R7),X'20' Replace with space 01635000
SERV31 CLI 0(R7),X'61' Less than Ascii "a" 01636000
BL SERV312 Yes leave as is 01637000
CLI 0(R7),X'7A' Greater than Ascii "z" 01638000
BH SERV312 Yes leave as is 01639000
NI 0(R7),X'5F' Else capitalize 01640000
SERV312 LA R7,1(R7) Bump pointer 01641000
BCTR R6,0 Any more data? 01642000
LTR R6,R6 01643000
BNZ SERV30 Yes go check 01644000
TR RDAT(130),ATOE For tokenizer 01645000
DMSKEY NUCLEUS Tokenize input 01646000
LA R1,RDAT Buffer address 01647000
L R0,LRDAT Buffer length 01648000
L R15,ASCANN 01649000
BALR R14,R15 Let CMS do the work 01650000
LR R3,R15 Save retcode 01651000
LR R6,R1 Save pointer to tokenized list 01652000
DMSKEY RESET 01653000
LTR R3,R3 OK retcode? 01654000
BNZ SERV35 Nope complain 01655000
MVC NAME(8),0(R6) Remember fn here 01656000
MVC NAME+8(8),8(R6) And ft 01657000
MVC NAME+16(2),=C'* ' Default fm just in case 01658000
CLC 16(8,R6),=8X'FF' Look for fm 01659000
BE SERV32 Not there, just send file 01660000
MVC NAME+16(2),16(R6) Get fm 01661000
SERV32 OI FLAGS,FLG1 Sending first file 01662000
XC NFSENT,NFSENT No files sent yet 01663000
L R15,=A(SEND) 01664000
BALR R14,R15 01665000
MVC OLDERR(1),ERRNUM 01666000
MVI ERRNUM,X'FF' Reset error number 01667000
B SERV0 Go around again 01668000
SERV35 MVI ERRNUM,X'0B' Error message number 01669000
L R15,=A(ERRPACK) Send an error packet 01670000
BALR R14,R15 01671000
B SERV0 And wait for more 01672000
SERV4 CLI RTYPE,AE Error packet 01673000
BNE SERV5 01674000
B SERV0 Ignore it 01675000
SERV5 CLI RTYPE,AN Packet garbled? 01676000
BNE SERV6 01677000
MVI STYPE,AN Send a NAK 01678000
XC LSDAT,LSDAT No data 01679000
L R15,=A(SPACK) 01680000
BALR R14,R15 01681000
B SERV0 And try again 01682000
SERV6 CLI RTYPE,X'00' Series/1 error? 01683000
BNE SERV7 01684000
MVI ERRNUM,S1ERRNUM Try to send error packet 01685000
L R15,=A(ERRPACK) Send an error packet 01686000
BALR R14,R15 01687000
B SERV0 01688000
SERV7 MVI ERRNUM,X'13' Error message number 01689000
L R15,=A(ERRPACK) Send an error packet 01690000
BALR R14,R15 01691000
B SERV0 01692000
* 01693000
SRVATTN BR R14 Ignore attention 01694000
* 01695000
SERVRET L R13,4(R13) 01696000
L R14,12(R13) 01697000
LM R0,R12,20(R13) 01698000
BR R14 01699000
SERVSAVE DS 18F 01700000
LTORG 01701000
DROP R11 01702000
DROP R12 01703000
EJECT 01704000
* [13 end] 01705000
* 01706000
* Read parameters from other host. Size of data passed in R5. 01707000
* Use the default for any parameter not supplied. [5] 01708000
* 01709000
SPAR CSECT 01710000
STM R14,R12,12(R13) 01711000
BALR R12,0 01712000
USING *,R12 01713000
LA R14,SPARSV 01714000
ST R13,4(R14) 01715000
ST R14,8(R13) 01716000
LR R13,R14 01717000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 01718000
L R11,=A(PARMS) 01719000
USING PARMS,R11 01720000
SR R4,R4 Zero out register 01721000
LA R7,RDAT Pointer to data buffer 01722000
C R5,ZERO Any data 01723000
BH SPAR0 01724000
LA R4,DSSIZ Default send packet size 01725000
B SPAR02 01726000
SPAR0 IC R4,0(R7) Max send packet size 01727000
S R4,SPACE Subtract the space 01728000
C R4,=A(SPMIN) Can't be below minimum 01729000
BNL SPAR01 So far, so good 01730000
LA R4,SPMIN Else, use the min valuea 01731000
B SPAR02 01732000
SPAR01 C R4,=A(SPMAX) Max send packet size 01733000
BNH SPAR02 Can't be above max 01734000
LA R4,SPMAX 01735000
SPAR02 STC R4,SPSIZ+3 Save max send packet size 01736000
C R5,ONE More than one piece of data? 01737000
BH SPAR1 Send timeout supplied 01738000
LA R4,DSTIM Else, use default 01739000
B SPAR12 01740000
SPAR1 SR R4,R4 01741000
IC R4,1(R7) Get send timeout value 01742000
S R4,SPACE 01743000
C R4,ZERO Must be non-negative 01744000
BNL SPAR12 01745000
L R4,ZERO 01746000
SPAR12 STC R4,STIME Save send timeout value 01747000
C R5,TWO More than two pieces of data? 01748000
BH SPAR2 Yes, pick up pad char 01749000
LA R4,DSPAD No, use default 01750000
B SPAR22 01751000
SPAR2 SR R4,R4 01752000
IC R4,2(R7) Get number of pad chars 01753000
S R4,SPACE 01754000
C R4,ZERO Must be non-negative 01755000
BH SPAR22 01756000
L R4,ZERO Else, use zero 01757000
SPAR22 STC R4,SPAD 01758000
C R5,=F'3' More than 3 pieces of data 01759000
BH SPAR3 Yes, get pad char to use 01760000
LA R4,DSPADC 01761000
B SPAR32 01762000
SPAR3 IC R4,3(R7) Pad char other side wants 01763000
A R4,O1H Re-controllify it 01764000
N R4,=X'0000007F' 01765000
C R4,DEL Is it a delete? 01766000
BE SPAR32 Yes, then it's OK 01767000
C R4,ZERO Is it above zero 01768000
BNL SPAR31 Yes, then OK 01769000
L R4,ZERO Else, use null 01770000
B SPAR32 01771000
SPAR31 C R4,=F'31' Is it a control char 01772000
BNH SPAR32 Yes, then OK 01773000
L R4,ZERO No, so use null 01774000
SPAR32 STC R4,SPADCH 01775000
C R5,=F'4' More than 4 pieces of data 01776000
BH SPAR4 Yes, get EOL char 01777000
LA R4,DEOL Else, use default 01778000
B SPAR42 01779000
SPAR4 IC R4,4(R7) Get the EOL char 01780000
S R4,SPACE 01781000
SPAR42 STC R4,SEOL 01782000
C R5,=F'5' More than 5 pieces of data 01783000
BH SPAR5 01784000
LA R4,DQUOTE 01785000
B SPAR52 01786000
SPAR5 SR R4,R4 01787000
IC R4,5(R7) Get quote char 01788000
C R4,SPACE Less than a space? 01789000
BNL SPAR51 No, is OK so far 01790000
LA R4,DQUOTE Yes, so use default 01791000
B SPAR52 01792000
SPAR51 C R4,=F'126' Must be tilde or less 01793000
BNH SPAR52 01794000
LA R4,DQUOTE If higher than use default 01795000
SPAR52 STC R4,SQUOTE 01796000
C R5,=F'6' More than 6 pieces of data 01797000
BH SPAR6 01798000
MVI EBQUOT,AY Default (can do it but won't) 01799000
B SPAR7 01800000
SPAR6 SR R4,R4 01801000
IC R4,6(R7) 01802000
L R15,=A(DOQUO) Set 8-bit quote char [1] 01803000
BALR R14,R15 [1] 01804000
SPAR7 C R5,=F'7' More than 7 pieces of data 01805000
BH SPAR71 Yes get checksum length 01806000
MVI CHKLEN,X'01' Else use default of one 01807000
B SPAR8 01808000
SPAR71 SR R4,R4 01809000
IC R4,7(R7) Get checksum size they want 01810000
L R15,=A(DOCHK) Check what they sent 01811000
BALR R14,R15 01812000
SPAR8 C R5,=F'8' More than 8 pieces of data 01813000
BH SPAR81 Get repeat quote they want 01814000
MVI RPTQ,X'00' Else don't do repeat prefixing 01815000
MVI ORIGQ,X'00' Reset here too [24] 01815100
B SPAR9 01816000
SPAR81 SR R4,R4 01817000
IC R4,8(R7) Get prefix they want to use 01818000
L R15,=A(DORPT) Routine to check their value 01819000
BALR R14,R15 01820000
SPAR9 L R13,4(R13) 01821000
L R14,12(R13) 01822000
LM R0,R12,20(R13) 01823000
BR R14 01824000
* 01825000
* Set checksum length 01826000
DOCHK MVI TMP,X'31' 01827000
CLM R4,B'0001',TMP Must be the character 1,2 or 3 01828000
BL DOCHK0 Below 1 so fail 01829000
MVI TMP,X'33' 01830000
CLM R4,B'0001',TMP 01831000
BNH DOCHK1 Is in the limit 01832000
MVI TMP,X'31' 01833000
DOCHK0 IC R4,TMP Else use default 01834000
DOCHK1 S R4,=F'48' Don't want it printable 01835000
CLM R4,B'0001',CHKLEN Do we want the same thing? 01836000
BE DOCHK2 Yes then we're done 01837000
MVI CHKLEN,X'01' Else use single char checksum 01838000
DOCHK2 BR R14 Return 01839000
* Set repeat count quote character. It must be different from 01840000
* the control & eight-bit quote characters. Also, both sides must 01841000
* use the same character. 01842000
DORPT C R4,=F'33' Check if in valid range 01843000
BNL DORPT0 It's 33 or above 01844000
B DORPT4 Else fail 01845000
DORPT0 C R4,=F'62' 01846000
BH DORPT1 01847000
B DORPT3 And 62 or below - OK 01848000
DORPT1 C R4,=F'96' 01849000
BNL DORPT2 It's 96 or above 01850000
B DORPT4 Else fail 01851000
DORPT2 C R4,=F'126' 01852000
BH DORPT4 If above 126 then fail 01853000
DORPT3 CLM R4,B'0001',SQUOTE Same as send quote char 01854000
BE DORPT4 Yes so fail 01855000
CLM R4,B'0001',RQUOTE Same as receive quote char 01856000
BE DORPT4 Yes so fail 01857000
CLM R4,B'0001',EBQUOT Same as eight bit prefix 01858000
BE DORPT4 Yes so fail 01859000
CLM R4,B'0001',RPTQ We planning to use same char? 01860000
BNE DORPT4 No so fail 01861000
BR R14 Yes so its OK 01862000
DORPT4 MVI RPTQ,X'00' Don't do repeat prefixing 01863000
MVI ORIGQ,X'00' Reset here too [24] 01863100
BR R14 01864000
* 01865000
SPARSV DS 18F KERMIT'S SAVE AREA 01866000
LTORG 01867000
DROP R11 01868000
DROP R12 NO LONGER NEED THEM 01869000
EJECT 01870000
* 01871000
* Set up our parameters we will send to other host. Return size 01872000
* of data in R15. [5] 01873000
* 01874000
RPAR CSECT 01875000
STM R14,R12,12(R13) 01876000
BALR R12,0 01877000
USING *,R12 01878000
LA R14,RPARSV 01879000
ST R13,4(R14) 01880000
ST R14,8(R13) 01881000
LR R13,R14 01882000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 01883000
L R11,=A(PARMS) 01884000
USING PARMS,R11 01885000
L R5,RPSIZ Receive packet size 01886000
A R5,SPACE Make it printable 01887000
STC R5,SDAT Add size info to buffer 01888000
IC R5,RTIME Receive packet time out 01889000
A R5,SPACE 01890000
STC R5,SDAT+1 01891000
IC R5,RPAD Number of padding chars. 01892000
A R5,SPACE 01893000
STC R5,SDAT+2 01894000
IC R5,RPADCH Pad character 01895000
L R3,O1H 01896000
XR R5,R3 CTL function (xor with 64) 01897000
N R5,=X'0000007F' 01898000
STC R5,SDAT+3 01899000
IC R5,REOL EOL char I need 01900000
A R5,SPACE MAKE PRINTABLE 01901000
STC R5,SDAT+4 01902000
IC R5,RQUOTE My quote char 01903000
STC R5,SDAT+5 01904000
IC R5,EBQUOT 8-BIT QUOTE CHAR [1] 01905000
STC R5,SDAT+6 PUT INTO BUFFER [1] 01906000
IC R5,CHKLEN Length of checksum 01907000
A R5,=F'48' Make into a real digit 01908000
STC R5,SDAT+7 01909000
SR R5,R5 01910000
IC R5,RPTQ Repeat quote char 01911000
C R5,ZERO Null means no 01912000
BNE RPAR0 Branch if doing repeat quoting 01913000
L R5,SPACE If not, send a blank instead 01914000
RPAR0 STC R5,SDAT+8 01915000
L R15,=F'9' Return size of data 01916000
L R13,4(R13) 01917000
L R14,12(R13) 01918000
LM R0,R12,20(R13) 01919000
BR R14 01920000
* 01921000
RPARSV DS 18F KERMIT'S SAVE AREA 01922000
LTORG 01923000
DROP R11 01924000
DROP R12 NO LONGER NEED THEM 01925000
EJECT 01926000
* 01927000
* New routine to set the 8-bit quote character depending on my 01928000
* own capabilities and the other Kermit's request. [1] 01929000
* 01930000
DOQUO CSECT 01931000
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 01932000
BALR R12,0 ESTABLISH ADDRESSABILITY 01933000
USING *,R12 01934000
LA R14,DQSAVE ADDRESS OF MY SAVE AREA 01935000
ST R13,4(R14) SAVE CALLER'S 01936000
ST R14,8(R13) 01937000
LR R13,R14 01938000
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 01939000
L R11,=A(PARMS) 01940000
USING PARMS,R11 ESTABLISH ADDRESSABILITY 01941000
LA R7,RDAT Point to data buffer 01942000
CLI EBQUOT,AN Can I do 8-bit quoting? 01943000
BE DQRET No - so forget it 01944000
CLI EBQUOT,AY Can I do it if requested? 01945000
BNE DQ0 No - I must quote 01946000
MVC EBQUOT(1),6(R7) Set new 8-bit quote char 01947000
SR R3,R3 01948000
IC R3,EBQUOT 01949000
L R15,=A(PRECHK) Validate prefix 01950000
BALR R14,R15 01951000
LTR R15,R15 Check the return code 01952000
BNZ DQ1 Failed so don't do quoting 01953000
CLC EBQUOT(1),RQUOTE Same prefix 01954000
BE DQ1 Not allowed so no quoting 01955000
CLC EBQUOT(1),SQUOTE Same prefix 01956000
BE DQ1 Not allowed so no quoting 01957000
B DQRET And leave 01958000
DQ0 CLI 6(R7),AY I need quoting - can he do it? 01959000
BE DQRET Yes - then all is settled 01960000
CLI 6(R7),AN He can't do it - don't quote 01961000
BE DQ1 He needs quoting also 01962000
CLC EBQUOT(1),6(R7) The quote chars must match 01963000
BE DQRET We match - its ok 01964000
DQ1 MVI EBQUOT,AN Else, forget the quoting 01965000
DQRET L R13,4(R13) 01966000
L R14,12(R13) 01967000
LM R0,R12,20(R13) 01968000
BR 14 01969000
* 01970000
* Check if prefix in R3 is in valid range: 33-62, 96-126. If OK, 01971000
* R15 contains a zero, else -1. 01972000
* 01973000
PRECHK C R3,=F'33' 01974000
BNL PREC0 It's 33 or above 01975000
B PREC4 Else fail 01976000
PREC0 C R3,=F'62' 01977000
BH PREC1 01978000
B PREC5 And 62 or below - OK 01979000
PREC1 C R3,=F'96' 01980000
BNL PREC2 It's 96 or above 01981000
B PREC4 Else fail 01982000
PREC2 C R3,=F'126' 01983000
BNH PREC5 Is 126 or below - OK 01984000
PREC4 L R15,=F'-1' Bad rc means we failed 01985000
BR R14 01986000
PREC5 SR R15,R15 Zero rc means all is well 01987000
BR R14 01988000
* 01989000
DQSAVE DS 18F 01990000
LTORG 01991000
DROP R11 01992000
DROP R12 DON'T NEED THEM ANYMORE 01993000
EJECT 01994000
* 01995000
SEND CSECT 01996000
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 01997000
BALR R12,0 ESTABLISH ADDRESSABILITY 01998000
USING *,R12 01999000
LA R14,SENDSAVE ADDRESS OF MY SAVE AREA 02000000
ST R13,4(R14) SAVE CALLER'S 02001000
ST R14,8(R13) 02002000
LR R13,R14 02003000
* USE R11 AS BASE REGISTER FOR 'PARMS' GLOBAL DATA AREA 02004000
L R11,=A(PARMS) 02005000
USING PARMS,R11 ESTABLISH ADDRESSABILITY 02006000
MVC EBQUOT(1),ORIG8Q IF CHANGED IN LAST X-FER [1] 02007000
MVI CXZ,X'00' Just in case [16] 02008000
MVI STATE,C'S' 02009000
SR R3,R3 02010000
ST R3,SPKNUM 02011000
ST R3,NUMTRY 02012000
MVC FST(4),=X'FF000000' INITIALIZATION STUFF 02013000
MVC ADT(4),=X'FF000000' HERE TOO,IN CASE OF RETRY 02014000
NXTFIL CLI CXZ,AZ Stop file group send [16] 02015000
BE DIEOK Yes finish up [16] 02016000
LA R1,FILINFO STUFF NEED TO GET FNAME(S) 02017000
L R15,=V(NEXTFST) 02018000
BALR R14,R15 GET NEXT/FIRST FILE 02019000
LTR R5,R15 COPY RETCODE 02020000
BNZ NOFIND RETCODE OF ZERO = ALL OK 02021000
MVI CXZ,X'00' In case aborted last file [16] 02022000
L R9,FST GET INFO FROM FSTTABLE 02023000
USING FSTD,R9 02024000
MVC FILNAM(8),FSTFNAME GET FNAME 02025000
MVC FILNAM+8(8),FSTFTYPE 02026000
MVC FILNAM+16(2),FSTFMODE 02027000
L R9,ADT 02028000
USING ADTSECT,R9 02029000
LA R5,ADTM 02030000
MVC FILNAM+16(1),0(R5) GET CORRECT FMODE 02031000
LA R5,FSENT TABLE W/FILES SENT SO FAR 02032000
LR R7,R5 KEEP TRACK OF TABLE 02033000
LA R7,160(R7) HERE, WE'RE PAST THE TABLE 02034000
L R4,NFSENT HOW MANY SENT SO FAR 02035000
FILLOOP LTR R4,R4 02036000
BZ OKSND 02037000
BCTR R4,0 DECREMENT COUNTER 02038000
CLC 0(16,R5),FILNAM SENT ALREADY? 02039000
BE NXTFIL DON'T RESEND 02040000
LA R5,16(R5) CHECK NEXT FILE 02041000
CR R5,R7 02042000
BNE FILLOOP 02043000
L R5,STORLOC SEARCH HERE NOW 02044000
B FILLOOP 02045000
OKSND TM FLAGS,FLG1 IS THIS THE FIRST FILE? 02046000
BNO SLOOP ONLY WAIT 10 SECS IF YES 02047000
NI FLAGS,X'FF'-FLG1 Turn off first file flag [13] 02048000
TM LFLAGS,SERVON In server mode? [13] 02049000
BO SLOOP Yes so skip this stuff [13] 02050000
TM S1FLAGS,ISS1 Is console a S/1? [12] 02051000
BZ SNDX No, skip init stuff [12] 02052000
LA R1,1 Initialize [12] 02053000
L R15,=A(INTRINI) Trap CONS interrupts [12] 02054000
BALR R14,R15 [12] 02055000
SNDX LA 1,=C'SL 10 SEC' Sleep before sending [13] 02056000
LA 0,9 COMMAND LENGTH IS 9 02057000
DIAG 1,0,8 SHOW IT'S A CP COMMAND 02058000
SLOOP CLI STATE,C'D' SEND DATA STATE 02059000
BE SDATA 02060000
CLI STATE,C'F' SEND FILE STATE 02061000
BE SFILE 02062000
CLI STATE,C'S' SEND INIT STATE 02063000
BE SINIT 02064000
CLI STATE,C'Z' END OF FILE STATE 02065000
BE SEOF 02066000
CLI STATE,C'B' SEND BREAK STATE 02067000
BE SBREAK 02068000
CLI STATE,C'C' COMPLETE STATE 02069000
BE COMPLETE 02070000
CLI STATE,C'A' ABORT STATE 02071000
BE ABORT ERROR - GO TO ABORT STATE 02072000
MVI ERRNUM,X'02' UNRECOGNIZED STATE 02073000
B ABORT OTHERWISE, DIE 02074000
* 02075000
SINIT CLC NUMTRY,IMXTRY SEE IF CAN SEND 02076000
BL SINIT0 YES WE CAN 02077000
MVI STATE,C'A' NOPE, GO INTO ABORT STATE 02078000
B SLOOP 02079000
SINIT0 L R3,NUMTRY 02080000
LA R3,1(R3) INCREMENT TRIAL COUNTER 02081000
ST R3,NUMTRY 02082000
L R15,=A(RPAR) Our paramters to send [5] 02083000
BALR R14,R15 02084000
ST R15,LSDAT Size of packet [5] 02085000
MVI STYPE,AS PACKET TYPE = SEND INITIATE 02086000
MVC CURCHK(1),CHKLEN Save desired value [8] 02087000
MVI CHKLEN,X'01' Init uses 1 char chksum [8] 02088000
L R15,=A(SPACK) GET ADDRESS OF ROUTINE 'SPACK' 02089000
BALR R14,R15 SAVE * AND GO TO SPACK 02090000
CLI STATE,C'A' 02091000
BE ABORT 02092000
L 15,=A(RPACK) GET ADDRESS OF 'RPACK' 02093000
BALR R14,R15 SAVE * AND GO TO RPACK 02094000
MVC CHKLEN(1),CURCHK Restore desired chksum [8] 02095000
CLI RTYPE,AE ERROR PACKET? 02096000
BNE Y1 NO, THEN MAYBE AN ACK 02097000
MVI ERRNUM,X'0A' MICRO DIED 02098000
MVI STATE,C'A' AND DIE 02099000
B SLOOP 02100000
Y1 CLI RTYPE,AY SEE IF GOT ACK 02101000
BNE N1 MAYBE IT'S 'N' 02102000
CLC SPKNUM,RPKNUM CHECK MESSAGE NUMBERS 02103000
BE AOK1 02104000
MVI ERRNUM,X'08' PACKET LOST 02105000
B SLOOP 02106000
AOK1 L R5,LRDAT Number of pieces of data [5] 02107000
L R15,=A(SPAR) 02108000
BALR R14,R15 Read data from other host [5] 02109000
L R15,=A(PACKLEN) Get max send packet size [5] 02110000
BALR R14,R15 02111000
NOCHG MVI STATE,C'F' PUT INTO SEND FILE STATE 02112000
XC NUMTRY,NUMTRY RESET TO ZERO 02113000
L R3,SPKNUM 02114000
LA R3,1(R3) ADD ONE 02115000
ST R3,SPKNUM STORE VALUE INCREMENTED BY 1 02116000
NC SPKNUM(4),=X'0000003F' MASK TO GET MOD 64 02117000
B SLOOP 02118000
N1 CLI RTYPE,AN SEE IF IT'S 'N' 02119000
BNE AB1 IF NOT, DIE 02120000
TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 02121000
BO SLOOP LEAVE ERR MSG AS IS IF I DID 02122000
MVI ERRNUM,X'09' MICRO NAK'ED 02123000
B SLOOP 02124000
AB1 MVI STATE,C'A' ELSE, ABORT 02125000
CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 02126000
BE SLOOP Yes just return [12] 02127000
MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 02128000
B SLOOP 02129000
SFILE CLC NUMTRY,MAXTRY EXCEEDED NO. OF TRIES ALLOWED? 02130000
BL OK2 NOPE, STILL OK 02131000
MVI STATE,C'A' ABORT IF YES 02132000
B SLOOP 02133000
OK2 TR FILNAM,ETOA 02134000
LA R4,FILNAM BEGINNING OF BUFFER 02135000
SR R1,R1 02136000
TRT FILNAM(8),PARSE SEND A DOT INSTEAD OF SPACE 02137000
BNZ SP 02138000
L R4,=F'8' FUDGE THE LENGTH 02139000
B SP2 02140000
SP SR R1,R4 WHERE THE TRT STOPPED 02141000
LR R4,R1 HAVE LENGTH OF THE FN 02142000
SP2 LR R5,R4 COUNTER FOR LENTH OF FILNAM 02143000
BCTR R4,0 ONE LESS FOR 'EX' COMMAND 02144000
L R7,ABUF Put FN here for encode [22] 02145000
EX R4,FIRST PICK UP THE FN 02146000
LA R4,00(R5,R7) Put the dot here [22] 02147000
MVI 0(R4),X'2E' ADD AN ASCII DOT 02148000
LA R5,1(R5) ADD ONE TO COUNTER 02149000
LA R4,FILNAM 02150000
LA R4,8(R4) NEXT AREA OF THE FILNAM 02151000
SR R1,R1 02152000
TRT FILNAM+8(8),PARSE 02153000
BNZ SP3 02154000
L R4,=F'8' FUDGE THE LENGTH 02155000
B SP4 02156000
SP3 SR R1,R4 02157000
LR R4,R1 WHERE WE STOPPED 02158000
SP4 L R7,ABUF Where to put FT [22] 02159000
LA R7,00(R5,R7) Next free spot [22] 02160000
AR R5,R4 LENGTH OF NAME WITH DOT 02161000
BCTR R4,0 MINUS ONE FOR THE 'EX' 02162000
EX R4,SECOND PICK UP FT 02163000
L R3,NUMTRY 02164000
LA R3,1(R3) INCREMENT TRIAL COUNTER 02165000
ST R3,NUMTRY 02166000
MVI STYPE,AF PACKET TYPE = FILE HEADER 02167000
ST R5,LSDAT SET BUFFER SIZE 02168000
TR FILNAM,ATOE 02169000
L R3,NFSENT 02170000
LR R4,R3 SAVE VALUE 02171000
C R4,=F'10' NEED MORE SPACE? 02172000
BE ADDSP 02173000
BH ADDSP2 02174000
M R2,=F'16' GET OFFSET INTO TABLE 02175000
LA R3,FSENT(R3) POINTER INTO TABLE 02176000
MVC 0(16,R3),FILNAM SAVE FILENAME YOU'RE SENDING 02177000
LA R4,1(R4) INCREMENT NUMBER OF FILES SENT 02178000
ST R4,NFSENT 02179000
B SNDFIL 02180000
ADDSP LA R0,4096/8 GET 4K BLOCK 02181000
DMSFREE DWORDS=(0),ERR=ERRSP,MSG=NO 02182000
ST R1,STORLOC POINTS TO EXTRA DATA AREA 02183000
OI FLAGS,FLG5 GOT MORE SPACE (TURN ON FLAG) 02184000
ADDSP2 LR R3,R4 GET CORRECT LENGTH AGAIN 02185000
S R3,=F'10' GET PROPER POINTER 02186000
M R2,=F'16' OFFSET INTO TABLE 02187000
A R3,STORLOC LOC IN TABLE 02188000
MVC 0(16,R3),FILNAM SAVE FILENAME 02189000
LA R4,1(R4) INCREMENT FILE COUNTER 02190000
ST R4,NFSENT 02191000
B SNDFIL 02192000
ERRSP MVI ERRNUM,X'10' ERR ALLOCATING MORE SPACE 02193000
MVI STATE,C'A' ABORT NOW 02194000
B SLOOP 02195000
SNDFIL XC INBFPT,INBFPT Input buffer offset [22 start] 02196000
MVC RECL,LSDAT Input buffer length 02197000
L R2,=A(NULREF) Null refill routine 02198000
ST R2,MORENC 02199000
L R15,=A(ENCODE) 02200000
BALR R14,R15 Encode fn [22 end] 02201000
L R15,=A(SPACK) GET ADDRESS OF 'SPACK' 02202000
BALR 14,15 SAVE * AND GO TO SPACK 02203000
CLI STATE,C'A' 02204000
BE ABORT 02205000
L 15,=A(RPACK) GET ADDRESS OF 'RPACK' 02206000
BALR 14,15 SAVE * AND GO TO RPACK 02207000
CLI RTYPE,AE ERROR PACKET? 02208000
BNE Y2 MAYBE AN ACK 02209000
MVI ERRNUM,X'0A' MICRO DIED 02210000
MVI STATE,C'A' SO WE DO TOO 02211000
B SLOOP 02212000
Y2 CLI RTYPE,AY SEE IF GOT ACK 02213000
BNE N2 MAYBE GOT AN 'N' 02214000
CLC SPKNUM,RPKNUM DO WE HAVE THE CORRECT ACK? 02215000
BE AOK2 02216000
MVI ERRNUM,X'08' MISSING A PACKET SOMEWHERE 02217000
B SLOOP 02218000
AOK2 XC NUMTRY,NUMTRY RESET COUNTER 02219000
L R3,SPKNUM 02220000
LA R3,1(R3) ADD ONE 02221000
ST R3,SPKNUM STORE INCREMENTED VALUE 02222000
NC SPKNUM(4),=X'0000003F' MASK TO GET MOD 64 02223000
LA R3,FILNAM GET ADDRESS OF 'FILNAM' [4] 02224000
FSOPEN (R3),FORM=E OPEN FILE FOR I/O [4] 02225000
NI FLAGS,X'FF'-FLG3 No data in input buffer [4] 02226000
NI FLAGS,X'FF'-FLG7 Not end of file yet [4] 02227000
XC LSDAT,LSDAT No data in output buffer [4] 02228000
L 15,=A(GTCHR) GET A BUFFER FULL OF DATA 02229000
BALR 14,15 DO GET-CHAR AND COME BACK 02230000
MVI STATE,C'D' Send data state [4] 02231000
C R15,ZERO Test the return code [4] 02232000
BE SLOOP Successful return code [4] 02233000
MVI STATE,C'A' Abort [4] 02234000
BH SLOOP Got read error - fail [4] 02235000
MVI STATE,C'Z' Send end-of-file state [4] 02236000
CLC LSDAT,ZERO Any data to send [4] 02237000
BE SLOOP No, goto eof state [4] 02238000
MVI STATE,C'D' Send the last packet [4] 02239000
B SLOOP 02240000
N2 CLI RTYPE,AN 02241000
BNE AB2 ELSE, DIE 02242000
TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 02243000
BO SLOOP LEAVE ERR MSG AS IS IF I DID 02244000
MVI ERRNUM,X'09' MICRO NAK'ED 02245000
B SLOOP 02246000
AB2 MVI STATE,C'A' ELSE, ABORT 02247000
CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 02248000
BE SLOOP Yes just return [12] 02249000
MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 02250000
B SLOOP 02251000
SDATA CLC NUMTRY,MAXTRY CAN WE DO IT? 02252000
BL OK4 YES 02253000
MVI STATE,C'A' ELSE ABORT 02254000
B SLOOP 02255000
OK4 L R3,NUMTRY 02256000
LA R3,1(R3) INCREMENT COUNTER 02257000
ST R3,NUMTRY 02258000
MVI STYPE,AD PACKET TYPE = DATA 02259000
L R15,=A(SPACK) 02260000
BALR 14,15 GO TO SPACK AND RETURN 02261000
CLI STATE,C'A' 02262000
BE ABORT 02263000
L 15,=A(RPACK) 02264000
BALR 14,15 SAME FOR RPACK 02265000
CLI RTYPE,AE ERROR PACKET? 02266000
BNE Y4 MAYBE AN ACK 02267000
MVI ERRNUM,X'0A' MICRO DIED 02268000
MVI STATE,C'A' SO WE DO TOO 02269000
B SLOOP 02270000
Y4 CLI RTYPE,AY SEE IF GOT 'ACK' 02271000
BNE N4 SEE IF IT'S AN 'N' 02272000
CLC SPKNUM,RPKNUM DO WE HAVE THE CORRECT ACK? 02273000
BE AOK4 02274000
MVI ERRNUM,X'08' MISSING A PACKET 02275000
B SLOOP 02276000
AOK4 XC NUMTRY,NUMTRY RESET COUNTER 02277000
L R3,SPKNUM 02278000
LA R3,1(R3) INCREMENT COUNTER 02279000
ST R3,SPKNUM 02280000
NC SPKNUM(4),=X'0000003F' MASK TO GET MOD 64 02281000
CLC LRDAT,ONE Data in ack? [16] 02282000
BNE BOK4 No just go on [16] 02283000
LA R3,RDAT Point to data [16] 02284000
CLI 0(R3),AX Abort sending file [16] 02285000
BE SDAB Yes [16] 02286000
CLI 0(R3),AZ Abort sending group [16] 02287000
BNE BOK4 No just ignore [16] 02288000
SDAB MVC CXZ(1),0(R3) Pick up data [16] 02289000
LA R3,FILNAM File we're sending [16] 02290000
FSCLOSE (R3) Close it [16] 02291000
MVI STATE,C'Z' Go send end of file [16] 02292000
MVI ERRNUM,X'16' Send cancelled [16] 02293000
B SLOOP And continue [16] 02294000
BOK4 L 15,=A(GTCHR) Get next buffer [16] 02295000
BALR 14,15 02296000
C R15,ZERO Test the return code [4] 02297000
BE SLOOP Successful return code [4] 02298000
MVI STATE,C'A' Abort [4] 02299000
BH SLOOP Got read error - fail [4] 02300000
MVI STATE,C'Z' Send end-of-file state [4] 02301000
CLC LSDAT,ZERO Any data to send [4] 02302000
BE SLOOP No, goto eof state [4] 02303000
MVI STATE,C'D' Send the last packet [4] 02304000
B SLOOP 02305000
N4 CLI RTYPE,AN 02306000
BNE AB4 02307000
TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 02308000
BO SLOOP LEAVE ERR MSG AS IS IF I DID 02309000
MVI ERRNUM,X'09' MICRO NAK'ED 02310000
B SLOOP 02311000
AB4 MVI STATE,C'A' 02312000
CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 02313000
BE SLOOP Yes just return [12] 02314000
MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 02315000
B SLOOP 02316000
SEOF CLC NUMTRY,MAXTRY CAN WE DO IT? 02317000
BL OK5 BRANCH IF YES 02318000
MVI STATE,C'A' ABORT IF NO 02319000
B SLOOP 02320000
OK5 L R3,NUMTRY 02321000
LA R3,1(R3) ADD ONE 02322000
ST R3,NUMTRY STORE INCREMENTED COUNTER 02323000
MVI STYPE,AZ PACKET TYPE = EOF 02324000
XC LSDAT,LSDAT LENGTH OF ZERO 02325000
L R15,=A(SPACK) 02326000
BALR 14,15 SAVE * AND GO TO SPACK 02327000
CLI STATE,C'A' 02328000
BE ABORT 02329000
L 15,=A(RPACK) 02330000
BALR 14,15 SAME FOR RPACK 02331000
CLI RTYPE,AE ERROR PACKET? 02332000
BNE Y5 MAYBE AN ACK 02333000
MVI ERRNUM,X'0A' MICRO DIED 02334000
MVI STATE,C'A' SO WE DO TOO 02335000
B SLOOP 02336000
Y5 CLI RTYPE,AY CHECK FOR 'ACK' 02337000
BNE N5 MAYBE WAS A 'NAK' 02338000
CLC SPKNUM,RPKNUM CORRECT ACK? 02339000
BE AOK5 02340000
MVI ERRNUM,X'08' LOST A PACKET 02341000
B SLOOP 02342000
AOK5 L R3,SPKNUM 02343000
LA R3,1(R3) ADD ONE 02344000
ST R3,SPKNUM STORE VALUE INCREMENTED BY 1 02345000
NC SPKNUM(4),=X'0000003F' MASK TO GET MOD 64 02346000
MVI STATE,C'F' SET TO SEND FILE FOR NOW 02347000
B NXTFIL GET-NEXT-FILE 02348000
NOFIND TM FLAGS,FLG1 DID IT DIE ON FIRST TRY? 02349000
BNO DIEOK NO ONES == NOT FIRST 02350000
MVI STATE,C'A' ABORT THIS ONE 02351000
TM LFLAGS,SERVON Are we a server [13] 02352000
BO NOF2 Yes handle differently [13] 02353000
WRTERM 'File not found' 02354000
B SLOOP 02355000
NOF2 NI FLAGS,X'FF'-FLG1 Clear first file status [13] 02356000
MVI ERRNUM,X'15' Set msg for error packet [13] 02357000
B SLOOP And go abort now [13] 02358000
DIEOK MVI STATE,C'B' BREAK CONNECTION 02359000
B SLOOP 02360000
N5 CLI RTYPE,AN 02361000
BNE AB5 DIE IF NOT A NAK 02362000
TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 02363000
BO SLOOP LEAVE ERR MSG AS IS IF I DID 02364000
MVI ERRNUM,X'09' MICRO NAK'ED 02365000
B SLOOP 02366000
AB5 MVI STATE,C'A' ELSE, ABORT 02367000
CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 02368000
BE SLOOP Yes just return [12] 02369000
MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 02370000
B SLOOP 02371000
SBREAK CLC NUMTRY,MAXTRY OVER OUR LIMIT? 02372000
BL OK6 BRANCH IF NO 02373000
MVI STATE,C'A' ABORT IF YES 02374000
B SLOOP 02375000
OK6 L R3,NUMTRY 02376000
LA R3,1(R3) ADD ONE 02377000
ST R3,NUMTRY INCREMEMTED TRIAL COUNTER 02378000
MVI STYPE,AB PACKET TYPE = BREAK 02379000
XC LSDAT,LSDAT LENGTH = ZERO 02380000
L R15,=A(SPACK) 02381000
BALR 14,15 SAVE * AND GO TO SPACK 02382000
CLI STATE,C'A' 02383000
BE ABORT 02384000
L 15,=A(RPACK) 02385000
BALR 14,15 SAVE * AND GO TO RPACK 02386000
CLI RTYPE,AE ERROR PACKET? 02387000
BNE Y6 MAYBE AN ACK 02388000
MVI ERRNUM,X'0A' MICRO DIED 02389000
MVI STATE,C'A' THEN WE DO TOO 02390000
B SLOOP 02391000
Y6 CLI RTYPE,AY CHECK FOR ACK 02392000
BNE N6 CHECK FOR 'N' 02393000
CLC SPKNUM,RPKNUM CORRECT ACK? 02394000
BE AOK6 02395000
MVI ERRNUM,X'08' LOST A PACKET 02396000
B SLOOP 02397000
AOK6 MVI STATE,C'C' COMPLETED STATE 02398000
CLI CXZ,X'00' Other guy stop x-fer? [16] 02399000
BE SLOOP No end OK [16] 02400000
MVI STATE,C'A' Remember error [16] 02401000
B SLOOP 02402000
N6 CLI RTYPE,AN CHECK FOR 'N' 02403000
BNE AB6 DIE IF NOT A NAK 02404000
TM FLAGS,FLG4 DID MICRO NAK OR I REJECTED? 02405000
BO SLOOP LEAVE ERR MSG AS IS IF I DID 02406000
MVI ERRNUM,X'09' MICRO NAK'ED 02407000
B SLOOP 02408000
AB6 MVI STATE,C'A' ELSE,ABORT 02409000
CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 02410000
BE SLOOP Yes just return [12] 02411000
MVI ERRNUM,X'07' UNRECOGNIZED PACKET TYPE 02412000
B SLOOP 02413000
* 02414000
ABORT LA R3,FILNAM 02415000
FSCLOSE (R3) CLOSE THE FILE 02416000
TM FLAGS,FLG1 DYING ON FILE-NOT-FOUND? 02417000
BO NOERRP IF SO, THEN NO ERROR PACKET 02418000
CLI ERRNUM,X'0A' DID THE MICRO DIE? 02419000
BE NOERRP NO ERROR PACKET IF SO 02420000
CLI ERRNUM,X'16' Other side cancel send [16] 02421000
BE NOERRP Yes no error packet [16] 02422000
* At least try to send an error packet. 02423000
* CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 02424000
* BE NOERRP No error packet if yes [12] 02425000
L R15,=A(ERRPACK) Send error packet [13] 02426000
BALR R14,R15 Error number in ERRNUM [13] 02427000
NOERRP LA R15,4 SET NON-ZERO RETCODE 02428000
B SENDRET PREPARE TO LEAVE 02429000
COMPLETE SR R15,R15 ZERO WILL BE RETCODE 02430000
SENDRET TM S1FLAGS,ISS1 Is console a S/1? [12] 02431000
BZ SENDRT2 No skip reset [12] 02432000
TM LFLAGS,SERVON In server mode? [13] 02433000
BO SENDRT2 Yes don't reset yet [13] 02434000
LR R2,R15 Save retcode [12] 02435000
SR R1,R1 Clear interrupt trapping [12] 02436000
L R15,=A(INTRINI) [12] 02437000
BALR R14,R15 [12] 02438000
LR R15,R2 Restore retcode [12] 02439000
SENDRT2 L R13,4(R13) 02440000
L R14,12(R13) 02441000
LM R0,R12,20(R13) 02442000
BR R14 02443000
SENDSAVE DS 18F 02444000
PARSE DC 32X'00' 02445000
DC X'01' STOP ON A SPACE 02446000
DC 223X'00' 02447000
FIRST MVC 0(0,R7),FILNAM Pick up the FN [22] 02448000
SECOND MVC 0(0,R7),FILNAM+8 PICK UP FT 02449000
LTORG 02450000
DROP R11 02451000
DROP R12 DON'T NEED THEM ANYMORE 02452000
EJECT 02453000
* 02454000
* Rewrite routine to pack as much data into the outgoing packet as 02455000
* possible (not just a record at a time). [4] 02456000
GTCHR CSECT 02457000
STM R14,R12,12(R13) Do standard linkage 02458000
BALR R12,0 02459000
USING *,R12 02460000
LA R14,GTSAV 02461000
ST R13,4(R14) 02462000
ST R14,8(R13) 02463000
LR R13,R14 02464000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 02465000
L R11,=A(PARMS) 02466000
USING PARMS,R11 02467000
L R2,=A(INBUF) Routine to call when [22] 02468000
ST R2,MORENC need to refill on input [22] 02469000
TM FLAGS,FLG3 Does input buffer have data? 02470000
BO GTCH0 One means yes. 02471000
L R15,=A(INBUF) Get a buffer full of data. 02472000
BALR R14,R15 02473000
LTR R15,R15 OK return code? 02474000
BNZ GTCH1 No, leave this routine. 02475000
GTCH0 L R15,=A(ENCODE) Encode the data 02476000
BALR R14,R15 02477000
GTCH1 L R13,4(R13) Return to caller 02478000
L R14,12(R13) 02479000
LM R0,R12,20(R13) Don't change retcode in R15 02480000
BR R14 02481000
GTSAV DS 18F 02482000
LTORG 02483000
EJECT 02484000
* 02485000
* Expects input buffer address in ABUF, writes to SDAT 02486000
* R8 - input buffer offset, R9 - output buffer offset, 02487000
* R10 - character count, R5 - quote character 02488000
* R3 - number of characters allowed in output buffer 02489000
* RECL - number of characters in input buffer (set in refill 02490000
* routine), MORENC has address of refill routine [22] 02491000
ENCODE CSECT 02492000
STM R14,R12,12(R13) Do standard linkage 02493000
BALR R12,0 02494000
USING *,R12 02495000
LA R14,ENCSAV 02496000
ST R13,4(R14) 02497000
ST R14,8(R13) 02498000
LR R13,R14 02499000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 02500000
L R11,=A(PARMS) 02501000
USING PARMS,R11 02502000
CLC RECL,ZERO Any data to encode? [7] 02503000
BE ENCOD6 No just return [7] 02504000
MVC RPTQ(1),ORIGQ Initialize repeat quote char [7] 02505000
MVI RPTVAL,X'00' Holds Char to be repeated [7] 02506000
MVI RPTCT,X'01' Number of repetitions [7] 02507000
L R3,MAXDAT Max packet size 02508000
LA R3,1(R3) Increment for BCT instruction 02509000
SR R9,R9 Initialize output buffer pointer 02510000
SR R10,R10 Ditto for character count 02511000
SR R5,R5 Will hold quote char 02512000
IC R5,RQUOTE 02513000
L R8,INBFPT Where we left off 02514000
ENCOD0 BCTR R3,0 Decr free space in output buffer 02515000
LTR R3,R3 Room left? 02516000
BP ENCOD1 Yes keep going 02517000
ST R8,INBFPT No, so save input buffer pointer 02518000
STC R10,LSDAT+3 Save char count 02519000
OI FLAGS,FLG3 Stuff in input buffer 02520000
SR R15,R15 OK retcode 02521000
B ENCOD6 02522000
* Room in output buffer. Now check if there's data in input buffer. 02523000
ENCOD1 C R8,RECL Any more input data? 02524000
BL ENCOD2 Yes go add to buffer 02525000
* L R15,=A(INBUF) No, get more data [22] 02526000
L R15,MORENC No, get more data [22] 02527000
BALR R14,R15 02528000
L R8,INBFPT Input buffer pointer 02529000
LTR R15,R15 OK return code? 02530000
BZ ENCOD2 Yes, there's more input 02531000
STC R10,LSDAT+3 Else, remember char count 02532000
XC INBFPT,INBFPT Reset input buffer pointer 02533000
NI FLAGS,X'FF'-FLG3 No more data in input buffer 02534000
B ENCOD6 02535000
* Input data exists. Add to buffer. 02536000
ENCOD2 SR R7,R7 02537000
L R1,ABUF ADDR OF BUFFER [2] 02538000
AR R1,R8 PLUS DISPLACEMENT [2] 02539000
IC R7,0(R1) PICK UP BYTE [2] 02540000
CLI RPTQ,X'00' Doing repeat quoting [7] 02541000
BE ENCOD23 No so skip this part [7] 02542000
L R6,RECL Get length of input record [7] 02543000
SR R6,R8 Minus chars processed [7] 02544000
C R6,ONE On last piece of input [7] 02545000
BE ENCOD21 Yes so write it out [7] 02546000
CLI RPTCT,X'5E' Max that can rep in a byte [7] 02547000
BE ENCOD21 Then that's it [7] 02548000
CLM R7,B'0001',1(R1) Current & next chars equal? [7] 02549000
BNE ENCOD21 No go write out chars [7] 02550000
SR R6,R6 Zero it out [7] 02551000
IC R6,RPTCT Number of times char appears [7] 02552000
LA R6,1(R6) Increment it [7] 02553000
STC R6,RPTCT Remember number of repeats [7] 02554000
STC R7,RPTVAL Remember repeated char [7] 02555000
LA R3,1(R3) Adjust output pointer [7] 02556000
LA R8,1(R8) Bump input pointer [7] 02557000
B ENCOD0 And get more data [7] 02558000
ENCOD21 CLI RPTCT,X'01' Were previous chars repeats [7] 02559000
BE ENCOD23 No so just add this char [7] 02560000
CLI RPTCT,RPTMIN Within bounds for prefixing [7] 02561000
BNL ENCOD22 Yes, use repeat prefixing [7] 02562000
SR R6,R6 Blank it out [7] 02563000
IC R6,RPTCT Not enough chars for repeats [7] 02564000
SR R8,R6 Adjust input buffer pointer [7] 02565000
LA R8,1(R8) Don't get prev char again [7] 02566000
LA R3,1(R3) Adjust output buffer counter [7] 02567000
MVI RPTVAL,X'00' Clear out repeated char [7] 02568000
MVC ORIGQ(1),RPTQ Save repeat quote char here [7] 02569000
MVI RPTQ,X'00' Pretend not doing prefixing [7] 02570000
B ENCOD0 Reprocess the data [7] 02571000
ENCOD22 IC R6,RPTQ Get the repeat prefix [7] 02572000
STC R6,SDAT(R9) Add to output buffer [7] 02573000
LA R9,1(R9) Bump output pointer [7] 02574000
LA R10,1(R10) Increment char count [7] 02575000
BCTR R3,0 Decrement for size [7] 02576000
IC R6,RPTCT Size of repeated sequence [7] 02577000
A R6,=F'32' Add space to make printable [7] 02578000
STC R6,SDAT(R9) Add size to output buffer [7] 02579000
LA R9,1(R9) Bump output pointer [7] 02580000
LA R10,1(R10) Increment char count [7] 02581000
BCTR R3,0 Decrement for char itself [7] 02582000
MVI RPTCT,X'01' Reset repeat count [7] 02583000
MVI RPTVAL,X'00' And this [7] 02584000
ENCOD23 CLI EBQUOT,AN DOING 8-BIT QUOTING? [1 START] 02585000
BE ENCOD3 NOPE, SO IGNORE 02586000
CLI EBQUOT,AY CAN DO IT BUT AREN'T? 02587000
BE ENCOD3 YUP 02588000
LR R6,R7 SAVE CHAR HERE 02589000
N R6,=X'0000007F' GET CHAR WITHOUT PARITY 02590000
N R7,=X'00000080' ISOLATE PARITY 02591000
LR R7,R6 RESET REGISTER 02592000
BZ ENCOD3 DON'T NEED 8-BIT QUOTING 02593000
LA R4,SDAT(R9) WHERE CHAR IS GOING 02594000
MVC 0(1,R4),EBQUOT Add 8-bit quote char to buffer 02595000
LA R9,1(R9) INCR POINTER IN OUTPUT BUFFER 02596000
LA R10,1(R10) Incr char count 02597000
BCTR R3,0 For 8-bit quote char [1 END] 02598000
ENCOD3 C R7,SPACE Is it a control character? 02599000
BL ENCOD5 Yes quote it and translate 02600000
C R7,DEL Is it a delete? 02601000
BE ENCOD5 Yes quote it and translate 02602000
CR R7,R5 Is it the quote character? 02603000
BE ENCOD51 Yes quote it 02604000
CLI EBQUOT,AN Doing 8-bit quoting [1 START] 02605000
BE ENCOD4 No how about repeat prefixing 02606000
CLI EBQUOT,AY Same question 02607000
BE ENCOD4 Not doing quoting 02608000
CLM R7,B'0001',EBQUOT Is char the 8-bit quote char? 02609000
BE ENCOD51 Yes output w/quote char [1 END] 02610000
ENCOD4 CLI ORIGQ,X'00' Doing repeat prefixing [7] 02611000
BE ENCOD52 No check for quote char [7] 02612000
CLM R7,B'0001',ORIGQ Is char repeat quote char [7] 02613000
BE ENCOD51 Yes then quote it [7] 02614000
B ENCOD52 Else don't quote it [7] 02615000
ENCOD5 A R7,O1H Add 64 to char 02616000
N R7,=X'0000007F' Get MOD 127 02617000
ENCOD51 LA R4,SDAT(R9) Next spot in output buffer [7] 02618000
MVC 0(1,R4),RQUOTE Add quote char [7] 02619000
LA R9,1(R9) Increment output buffer pointer 02620000
LA R10,1(R10) Increment character counter 02621000
BCTR R3,0 Less space in output buffer [7] 02622000
ENCOD52 STC R7,SDAT(R9) Add the character 02623000
LA R9,1(R9) Increment output buffer pointer 02624000
LA R8,1(R8) Increment input buffer pointer 02625000
LA R10,1(R10) Increment character counter 02626000
CLI RPTCT,X'01' One occurence of char [7] 02627000
BNE ENCOD53 No there's more [7] 02628000
MVC RPTQ(1),ORIGQ Restore repeat prefix [7] 02629000
B ENCOD0 Get more data 02630000
ENCOD53 SR R6,R6 Zero out for increment [7] 02631000
IC R6,RPTCT Number of repetitions [7] 02632000
BCTR R6,0 Decrement number left to do [7] 02633000
STC R6,RPTCT Store here [7] 02634000
B ENCOD0 Add char again [7] 02635000
ENCOD6 L R13,4(R13) 02636000
L R14,12(R13) 02637000
LM R0,R12,20(R13) Don't change retcode in R15 02638000
BR R14 02639000
NULREF SR R2,R2 [22 start] 02640000
BCTR R2,0 Get -1 here 02641000
ST R2,INBFPT Say no more data to encode 02642000
LR R15,R2 Error ret code 02643000
BR R14 That's it [22 end] 02644000
ENCSAV DS 18F 02645000
LTORG 02646000
EJECT 02647000
* 02648000
* Read the next line from the input file, and do EBCDIC to ASCII 02649000
* translation if requested. [4] 02650000
INBUF CSECT 02651000
STM R14,R12,12(R13) Do standard linkage 02652000
BALR R12,0 02653000
USING *,R12 02654000
LA R14,INBSAV 02655000
ST R13,4(R14) 02656000
ST R14,8(R13) 02657000
LR R13,R14 02658000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 02659000
L R11,=A(PARMS) 02660000
USING PARMS,R11 02661000
TM FLAGS,FLG7 Hit eof yet? [4] 02662000
BNO INBUFX If yes, return RC of -1 [4] 02663000
L R15,=F'-1' Error return code. 02664000
XC LSDAT,LSDAT No data to send [4] 02665000
B INBUF9 02666000
INBUFX L R4,ABUF READ INTO THIS BUFFER [2] 02667000
LA R3,FILNAM 02668000
FSREAD (R3),BUFFER=(R4),BSIZE=65536,FORM=E [2] 02669000
LTR R4,R15 PUT RESULT OF READ IN R4 02670000
BZ INBUF1 02671000
FSCLOSE (R3) CLOSE FILE 02672000
C R4,=A(ERCOD) Did we hit the end of file? 02673000
BNE INBUF0 No, it's something else. 02674000
OI FLAGS,FLG7 Set eof flag [4] 02675000
L R15,=F'-1' Error return code. 02676000
B INBUF9 02677000
INBUF0 L R15,=F'1' Error return code. 02678000
MVI ERRNUM,X'0C' INVALID RECORD LENGTH 02679000
C R4,=F'8' WAS OUR GUESS RIGHT? 02680000
BE INBUF9 IF YES, RETURN 02681000
MVI ERRNUM,X'0D' ELSE, GOT AN I/O ERROR 02682000
B INBUF9 02683000
INBUF1 LR R5,R0 GET NUMBER OF BYTES READ IN 02684000
TM FLAGS,BINF BINARY FILE X-FER [1] 02685000
BO INBUF8 YES, SKIP TRANSLATION [1] 02686000
LTR R5,R5 Any data at all [4] 02687000
BZ INBUF7 No skip translation [4] 02688000
LR R4,R5 SAVE ALSO IN R4 02689000
LR R7,R5 AND IN R7 [2] 02690000
L R3,ABUF WHERE TRANSLATING STARTS [2] 02691000
INBUF2 BCTR R4,0 SUBTRACT 1 FOR EX COMMAND 02692000
C R4,=F'255' MAX FOR TRANSLATE IS 256 [2] 02693000
BL INBUF3 IF IS UNDER MAX THEN IS OK [2] 02694000
LA R4,255 ELSE, SET TO MAX [2] 02695000
INBUF3 EX R4,TRANS EBCDIC TO ASCII TRANSLATION 02696000
C R7,=F'256' MORE CHARS LEFT TO X-LATE? [2] 02697000
BNH INBUF4 NOPE, WE'RE DONE [2] 02698000
LA R3,256(R3) X-LATE NEXT SET OF CHARS [2] 02699000
S R7,=F'256' DECR CHARS LEFT TO X-LATE [2] 02700000
LR R4,R7 NO. OF CHARS LEFT TO X-LATE [2] 02701000
B INBUF2 TRANSLATE SOME MORE [2] 02702000
INBUF4 L R8,ABUF GET LOC OF BUFFER INPUT [2] 02703000
LR R4,R5 GET BACK ORIG SIZE [2] 02704000
BCTR R4,0 [2] 02705000
L R9,ABUF HEAD OF BUFFER [2] 02706000
AR R9,R4 PLUS DISPLACEMENT [2] 02707000
INBUF5 CLI 0(R9),X'20' IS THIS A BLANK? 02708000
BNE INBUF6 NO, FOUND LAST CHAR OF LINE 02709000
BCTR R9,0 02710000
CR R9,R8 02711000
BNL INBUF5 FIND LAST CHAR 02712000
SR R5,R5 ALL BLANKS 02713000
B INBUF7 02714000
INBUF6 SR R9,R8 02715000
LR R5,R9 LENGTH OF LINE 02716000
LA R5,1(R5) Go past last char [2] 02717000
INBUF7 L R9,ABUF BUFFER HEAD [2] 02718000
AR R9,R5 PLUS DISPLACEMENT [2] 02719000
MVC 0(1,R9),=X'0D' ADD ASCII CR 02720000
LA R9,1(R9) INCREMENT POINTER 02721000
MVC 0(1,R9),=X'0A' AND ADD ASCII LF [1] 02722000
LA R5,2(R5) TWO EXTRA BYTES OF DATA NOW 02723000
INBUF8 ST R5,RECL LRECL + 2 (FOR CRLF) 02724000
XC INBFPT,INBFPT Zero input buffer pointer 02725000
SR R15,R15 Return code == success 02726000
INBUF9 L R13,4(R13) 02727000
L R14,12(R13) 02728000
LM R0,R12,20(R13) Don't change retcode in R15 02729000
BR R14 02730000
INBSAV DS 18F 02731000
TRANS TR 0(0,R3),ETOA EBCDIC TO ASCII TRANSLATION 02732000
LTORG 02733000
EJECT 02734000
* Add support for two character checksum and three character CRC. 02735000
* Expects input data to be in SDAT buffer. Registers used: R9 to 02736000
* calculate the checksum. [8] 02737000
SPACK CSECT 02738000
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 02739000
BALR R12,0 ESTABLISH ADDRESSABILITY 02740000
USING *,R12 02741000
LA R14,SPSAVE ADDRESS OF MY SAVE AREA 02742000
ST R13,4(R14) SAVE CALLER'S 02743000
ST R14,8(R13) 02744000
LR R13,R14 02745000
* Use R11 as base register for 'PARMS' global data area 02746000
L R11,=A(PARMS) 02747000
USING PARMS,R11 ESTABLISH ADDRESSABILITY 02748000
SR R9,R9 Zero out checksum register 02749000
MVI PHDR,SOH Add Control-A to packet 02750000
CLI LSDAT+3,SPMAX Data size below max? [4] 02751000
BNH SPACK0 Yup [4] 02752000
MVI ERRNUM,X'00' Data size exceeds max limit 02753000
MVI STATE,C'A' Abort on this 02754000
B SPRET 02755000
SPACK0 L R4,LSDAT Data size + space + two [8] 02756000
A R4,=F'34' for packet number and type [8] 02757000
SR R5,R5 Zero for next instruction [8] 02758000
IC R5,CHKLEN Get checksum length [8] 02759000
AR R4,R5 Account for it in pkt size [8] 02760000
STC R4,PLEN Add it to packet 02761000
AR R9,R4 And then add it to checksum 02762000
CLC SPKNUM,ZERO Check if packet number is valid 02763000
BNL SPACK01 OK if >= to 0 02764000
MVI ERRNUM,X'01' Illegal packet number 02765000
MVI STATE,C'A' 02766000
B SPRET 02767000
SPACK01 CLC SPKNUM,O1H See if is <= octal 100 02768000
BNH SPACK02 02769000
MVI ERRNUM,X'01' Illegal packet number 02770000
MVI STATE,C'A' 02771000
B SPRET 02772000
SPACK02 L R4,SPKNUM Get packet number 02773000
A R4,SPACE Add space to make it printable 02774000
STC R4,PNUM Add to buffer 02775000
AR R9,R4 And add to checksum 02776000
CLI STYPE,X'41' ASCII 'A' 02777000
BL SPACK03 Can't be less than this 02778000
CLI STYPE,X'5A' ASCII 'Z' 02779000
BNH SPACK04 Can't be greater 02780000
SPACK03 MVI ERRNUM,X'07' Illegal packet type 02781000
MVI STATE,C'A' Die on this 02782000
B SPRET 02783000
SPACK04 MVC PTYPE(1),STYPE Add message type to buffer 02784000
SR R2,R2 Zero it out 02785000
IC R2,STYPE 02786000
AR R9,R2 Add to checksum 02787000
L R6,LSDAT How much data 02788000
LTR R6,R6 Test it out 02789000
BZ SPACK3 02790000
SR R5,R5 Use to get data 02791000
SR R3,R3 Use to hold data 02792000
SPACK1 IC R3,SDAT(R5) Pick up char 02793000
AR R9,R3 Add to checksum 02794000
LA R5,1(R5) Bump pointer 02795000
CR R5,R6 Got all the data yet 02796000
BNE SPACK1 Nope get the rest 02797000
SPACK2 LR R7,R6 Munge size here 02798000
BCTR R7,0 Subtract 1 for EX function 02799000
EX R7,MOVE Get data to packet in one MOVE 02800000
SPACK3 LR R7,R9 Need copy of chksum [8] 02801000
CLI CHKLEN,X'02' What kind of checksum? [8] 02802000
BE SPACK5 2 char checkum [8] 02803000
BH SPACK4 3 char CRC [8] 02804000
ST R9,TEMP Else is one char checksum 02805000
N R9,=X'000000C0' Get MOD 192 02806000
SRL R9,6 Shift right by 6 02807000
A R9,TEMP Add the two values 02808000
N R9,=X'0000003F' Get MOD 64 of checksum 02809000
A R9,SPACE Make printable 02810000
STC R9,PDATA(R6) Add to buffer (after data) 02811000
B SPACK6 Go add EOL char 02812000
SPACK4 SR R5,R5 Zero out to get a NULL [8] 02813000
STC R5,PDATA(R6) Add NULL at end of data [8] 02814000
ST R6,TEMP Next free spot in buffer [8] 02815000
LA R5,PLEN Where checksum starts [8] 02816000
L R15,=A(CRCCLC) Calculate the CRC [8] 02817000
BALR R14,R15 Return CRC in R15 [8] 02818000
LR R7,R15 Keep in here [8] 02819000
LR R5,R7 Munge value in dif register [8] 02820000
N R5,=X'0000F000' Get bits 12-15 [8] 02821000
SRL R5,12 Shift right by 12 bits [8] 02822000
A R5,SPACE Make char printable [8] 02823000
L R6,TEMP Next free spot in buffer [8] 02824000
STC R5,PDATA(R6) Add to buffer [8] 02825000
LA R6,1(R6) Bump output pointer [8] 02826000
SPACK5 LR R5,R7 Munge in dif register [8] 02827000
N R5,=X'00000FC0' Get bits 6-11 [8] 02828000
SRL R5,6 Shift right 6 bits [8] 02829000
A R5,SPACE Make char printable [8] 02830000
STC R5,PDATA(R6) Add to buffer [8] 02831000
LA R6,1(R6) Bump pointer [8] 02832000
N R7,=X'0000003F' Get bits 0-5 [8] 02833000
A R7,SPACE Make printable [8] 02834000
STC R7,PDATA(R6) Add to buffer [8] 02835000
SPACK6 LA R6,1(R6) Bump pointer 02836000
IC R9,SEOL 02837000
STC R9,PDATA(R6) Add send end of packet char 02838000
L R6,LSDAT Amount of data [8] 02839000
A R6,=F'5' Control info and EOL char [8] 02840000
SR R5,R5 Zero for next instruction [8] 02841000
IC R5,CHKLEN Get checksum length [8] 02842000
AR R6,R5 Plus length of checksum 02843000
TM FLAGS,DEBUG Are we debugging? [14] 02844000
BNO SPACK61 No don't log packet [14] 02845000
MVC INPUT(130),SNDPKT Munge data here [14] 02846000
TR INPUT(130),ATOE Log in EBCDIC [14] 02847000
FSWRITE 'KER LOG A1',BUFFER=INPUT,BSIZE=(R6),FORM=E,RECFM=V 02848000
SPACK61 TM S1FLAGS,ISS1 is console a S/1? [12 start] 02849000
BZ SENDTTY no: do normal TTY output 02850000
OC SNDPKT,HIBITS set hi bit in each char 02851000
LA R7,S1ORDSL(,R6) incr by len of S/1 orders 02852000
STH R7,S1SDATL store len in CCW 02853000
LA R1,S1SCCW get addr of CCW 02854000
L R15,=A(SCRNIO) call routine to output via 02855000
BALR R14,R15 full-screen diagnose 02856000
LTR R15,R15 did it work? 02857000
BM S1SNDERR no: error 02858000
SS1WAIT EQU * 02859000
CLI CONSUNIT,ATTN was last intrpt an ATTN? 02860000
BE SS1READ yes: go read from console 02861000
WAITD CON1 no: wait for one 02862000
B SS1WAIT 02863000
SS1READ EQU * 02864000
XC RECPKT,RECPKT clear input buffer 02865000
LA R1,S1RCCW get CCW to read console 02866000
L R15,=A(SCRNIO) and do it now 02867000
BALR R14,R15 02868000
ST R15,S1RDBYTC save residue byte count 02869000
LTR R15,R15 did it work? 02870000
BNM SPRET yes: return to caller 02871000
S1SNDERR EQU * 02872000
MVI ERRNUM,S1ERRNUM no: flag error 02873000
MVI STATE,C'A' go into abort state 02874000
B SPRET ret to caller 02875000
SENDTTY EQU * [12 end] 02876000
TR SNDPKT(130),ATOE Send in EBCDIC 02877000
* WRTERM SNDPKT,(R6),EDIT=NO [19] 02878000
STH R6,TYLNLEN Store length in plist [19] 02879000
LA R1,TYLNPLST Point to plist [19] 02880000
SVC 202 Write to terminal [19] 02881000
DC AL4(1) See comments at plist [19] 02882000
SPRET L R13,4(R13) 02883000
L R14,12(R13) 02884000
LM R0,R12,20(R13) 02885000
BR 14 02886000
SPSAVE DS 18F 02887000
MOVE MVC PDATA(0),SDAT 02888000
* [19 begin] 02889000
* The following Plist is identical to a WRTERM macro one, 02890000
* except the macro can't gen a "2" flag which causes the 02891000
* output not to be translated with the user output translate 02892000
* table. The "8" specifies no Carriage Return is needed. 02893000
TYLNPLST DS 0D Terminal write Plist: 02894000
DC CL8'TYPLIN' Command name 02895000
DC X'01',AL3(SNDPKT) Buffer address 02896000
DC C'B',X'82' B->black, 82->no xlate or CR 02897000
TYLNLEN DC H'0' store buffer len here 02898000
* [19 end] 02899000
HIBITS DC (L'SNDPKT)X'80' Set hi bit in each char [12] 02900000
LTORG 02901000
DROP R11 02902000
DROP R12 DON'T NEED THEM ANYMORE 02903000
EJECT 02904000
* Calculate the CRC and return it in R15. Expects R5 to point to 02905000
* the start of the buffer on which the CRC is calculated. Stops 02906000
* when it reaches a NULL. [8] 02907000
CRCCLC CSECT 02908000
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 02909000
BALR R12,0 ESTABLISH ADDRESSABILITY 02910000
USING *,R12 02911000
LA R14,CRCSAV ADDRESS OF MY SAVE AREA 02912000
ST R13,4(R14) SAVE CALLER'S 02913000
ST R14,8(R13) 02914000
LR R13,R14 02915000
* Use R11 as base register for 'PARMS' global data area 02916000
L R11,=A(PARMS) 02917000
USING PARMS,R11 ESTABLISH ADDRESSABILITY 02918000
SR R3,R3 Initial CRC value is zero 02919000
CRC0 SR R4,R4 Clear out before read char 02920000
IC R4,0(R5) Get the next character 02921000
LTR R4,R4 Test it 02922000
BZ CRC1 If NULL then we're done 02923000
LA R5,1(R5) Else bump input pointer 02924000
LR R7,R3 Munge CRC here 02925000
N R7,=X'000000FF' Only want lo order byte 02926000
XR R4,R7 XOR input and CRC lo byte 02927000
LR R7,R4 Keep the original for later 02928000
N R7,=X'000000F0' Keep hi 4 bits of lowest byte 02929000
SRL R7,4 Shift it right by four 02930000
N R4,=X'0000000F' Get lo 4 bits of lowest byte 02931000
AR R4,R4 Double to get index into table 02932000
LH R4,CRCTB2(R4) Get low portion 02933000
AR R7,R7 Double to get another index 02934000
LH R7,CRCTAB(R7) Get high portion 02935000
N R4,=X'0000FFFF' Don't want propogated sign 02936000
N R7,=X'0000FFFF' Ditto 02937000
XR R4,R7 Add the two 02938000
SRL R3,8 Shift 8 bits to right 02939000
XR R3,R4 XOR table value and CRC 02940000
B CRC0 And get some more 02941000
CRC1 LR R15,R3 Return CRC in R15 02942000
L R13,4(R13) 02943000
L R14,12(R13) 02944000
LM R0,R12,20(R13) 02945000
BR 14 02946000
CRCSAV DS 18F 02947000
LTORG 02948000
DROP R11 02949000
DROP R12 DON'T NEED THEM ANYMORE 02950000
EJECT 02951000
* 02952000
* Add support for two character checksum and three character CRC. 02953000
* Expects input data to be in RECPKT buffer. Writes data out to 02954000
* RDAT buffer. Registers used: R5 to calculate checksum, R8 as 02955000
* pointer in input buffer. R9 as output buffer pointer. [8] 02956000
RPACK CSECT 02957000
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 02958000
BALR R12,0 ESTABLISH ADDRESSABILITY 02959000
USING *,R12 02960000
LA R14,RPSAVE ADDRESS OF MY SAVE AREA 02961000
ST R13,4(R14) SAVE CALLER'S 02962000
ST R14,8(R13) 02963000
LR R13,R14 02964000
* Use R11 as base register for 'PARMS' global data area 02965000
L R11,=A(PARMS) 02966000
USING PARMS,R11 ESTABLISH ADDRESSABILITY 02967000
TM S1FLAGS,ISS1 is console a S/1? [12 start] 02968000
BZ RECTTY no: skip 02969000
L R0,S1RDBYTC get residue cnt from read 02970000
LTR R0,R0 check if one has been done 02971000
BNM RPS1MOV non-neg->it has: skip 02972000
MVI SNDPKT,ASCXON send micro X-ON to prod it 02973000
LA R1,S1ORDSL+1 and init S/1 "write/read" 02974000
STH R1,S1SDATL data len = orders + 1 char 02975000
LA R1,S1SCCW point to CCW for this I/O 02976000
L R15,=A(SCRNIO) call routine to do I/O 02977000
BALR R14,R15 02978000
LTR R15,R15 did it work? 02979000
BM RPACK9 no: an err occurred 02980000
RPWAIT EQU * 02981000
CLI CONSUNIT,ATTN was last intrp an ATTN? 02982000
BE RPS1RD yes: go read console 02983000
WAITD CON1 no: wait for ATTN intrpt 02984000
B RPWAIT 02985000
RPS1RD EQU * 02986000
XC RECPKT,RECPKT clear input buffer 02987000
LA R1,S1RCCW get CCW for READ MODIFIED 02988000
L R15,=A(SCRNIO) 02989000
BALR R14,R15 perform read 02990000
LTR R0,R15 copy byte cnt & test status 02991000
BM RPACK9 len < 0 -> error: skip 02992000
RPS1MOV EQU * 02993000
* The format of the incoming buffer is: 02994000
* X'E8',X'????',<ASCII data with high bit set>,<CR> 02995000
* where the '????' is an SBA-type cursor address which would 02996000
* point to the end of the data on the screen (if it were 02997000
* really there). 02998000
MVC RECPKT(L'RECPKT-3),RECPKT+3 shift over leadin 02999000
NC RECPKT,NOHIBITS clear all hi bits 03000000
LA R6,L'RECPKT-4 get size of buf - overhead 03001000
SR R6,R0 subt residue cnt from read 03002000
BM RPACK9 data len < 0: error 03003000
LA R2,RECPKT(R6) point past last data char 03004000
MVC 0(4,R2),=X'00000000' clr ovhd after MVC 03005000
LR R0,R6 save correct data len 03006000
TM FLAGS,DEBUG Are we debugging? [14] 03007000
BNO RPACKA No don't log packet [14] 03008000
MVC INPUT(130),RECPKT Munge here [14] 03009000
TR INPUT(130),ATOE Log in EBCDIC [14] 03010000
FSWRITE 'KER LOG A1',BUFFER=INPUT,BSIZE=(R0),FORM=E,RECFM=V 03011000
B RPACKA re-join common code 03012000
RECTTY EQU * normal TTY-type read [12 end] 03013000
* RDTERM RECPKT,EDIT=NO Read in a buffer [19] 03014000
LA R1,WTRDPLST Point to Plist for read [19] 03015000
SVC 202 Read from terminal [19] 03016000
DC AL4(1) See comments at Plist [19] 03017000
LH R0,WTRDLEN Number of chars recv'd [19] 03018000
TM FLAGS,DEBUG Are we debugging? [14] 03019000
BNO RPACKB No don't log packet [14] 03020000
FSWRITE 'KER LOG A1',BUFFER=RECPKT,BSIZE=(R0),FORM=E,RECFM=V 03021000
RPACKB TR RECPKT(130),ETOA Translate to ASCII 03022000
RPACKA EQU * [12] 03023000
NI FLAGS,X'FF'-FLG4 Make guess about type of error 03024000
SR R8,R8 Index register for RECPKT 03025000
SR R5,R5 Checksum register 03026000
RPACK0 LA R7,RECPKT(R8) Address of next input char 03027000
CLI 0(R7),SOH Is it Control-A 03028000
BE RPACK1 Yes, so far so good 03029000
LA R8,1(R8) Try next character 03030000
C R8,=F'130' See if exceed buffer size 03031000
BL RPACK0 No, can keep checking 03032000
MVI ERRNUM,X'03' Yes so no "SOH" error 03033000
B RPACK71 03034000
RPACK1 SR R9,R9 Zero output buffer pointer 03035000
LA R8,1(R8) Increment input buffer pointer 03036000
LA R7,RECPKT(R8) Get loc of char count 03037000
CLI 0(R7),SOH Is it Control-A 03038000
BE RPACK1 Yes start over 03039000
CLI 0(R7),DQUOTE Equal or above the min 03040000
BNL RPACK11 Continue if yes 03041000
MVI ERRNUM,X'04' Bad packet length 03042000
B RPACK71 03043000
RPACK11 IC R5,0(R7) Start checksum 03044000
LR R7,R5 Get size field 03045000
STC R7,LRDAT+3 Data field & control info 03046000
LA R8,1(R8) Increment input pointer 03047000
SR R7,R7 Zero it out 03048000
IC R7,RECPKT(R8) Pick up packet number 03049000
C R7,=A(SOH) Is it Control-A 03050000
BE RPACK1 Yes restart packet 03051000
AR R5,R7 Add to checksum 03052000
S R7,SPACE Subtract the space 03053000
STC R7,RPKNUM+3 RPKNUM := received packet number 03054000
LA R8,1(R8) Increment input counter 03055000
IC R7,RECPKT(R8) Pick up message type 03056000
C R7,=A(SOH) Is it Control-A 03057000
BE RPACK1 Yes restart 03058000
STC R7,RTYPE Save value here 03059000
AR R5,R7 Add to checksum 03060000
LA R8,1(R8) Go to next byte 03061000
* Start of change. 03062000
* Now determine block check type for this packet. Here we violate the 03063000
* layered nature of the protocol by inspecting the packet type in 03064000
* order to detect when the two sides get out of sync. Two heuristics 03065000
* allow us to resync here: 03066000
* a. An S packet always has a type 1 checksum. 03067000
* b. A NAK never contains data, so its block check type is 03068000
* PACKET LEN-2. 03069000
L R4,LRDAT Get back the size 03070000
S R4,=F'34' Unchar(len)-2 (for SEQ & TYPE) 03071000
SR R3,R3 03072000
IC R3,CHKLEN Checksum length we expect 03073000
CLI RTYPE,AS Is this an "S" packet? 03074000
BNE RPK0 Nope 03075000
L R3,ONE Yes, use 1 char checksum 03076000
RPK0 CLI RTYPE,AN Is this a NAK? 03077000
BNE RPK1 Nope 03078000
LR R3,R4 Yes so len-2 is checksum type 03079000
RPK1 STC R3,CHKLEN Then this is chksum length 03080000
SR R4,R3 Real size of data 03081000
ST R4,LRDAT Save correct size 03082000
* End of change. 03083000
LTR R4,R4 How much data did we get 03084000
BZ RPACK3 None so that's it 03085000
RPACK2 XC TEMP,TEMP Zero it out 03086000
LA R7,RECPKT(R8) Next location in buffer 03087000
MVC TEMP+3(1),0(R7) Pick up next byte 03088000
CLI TEMP+3,SOH Is it Control-A 03089000
BE RPACK1 Yes start over 03090000
LA R7,RDAT(R9) Where the data's going 03091000
MVC 0(1,R7),TEMP+3 And move it 03092000
A R5,TEMP Add to checksum 03093000
LA R8,1(R8) Bump input buffer pointer 03094000
LA R9,1(R9) Bump output buffer pointer 03095000
BCTR R4,0 Decrement amount of input 03096000
LTR R4,R4 Any left? 03097000
BNZ RPACK2 Yes get another character 03098000
RPACK3 SR R7,R7 Zero out register 03099000
IC R7,RECPKT(R8) Get checksum 03100000
LA R8,1(R8) Bump input pointer 03101000
C R7,=A(SOH) Is it Control-A 03102000
BE RPACK1 Yes start over 03103000
S R7,SPACE Turn char back into a number 03104000
LR R4,R5 Keep copy here [8] 03105000
CLI CHKLEN,X'02' Using what checksum length 03106000
BE RPACK5 Two character checksum 03107000
BH RPACK4 Three character CRC 03108000
ST R5,TEMP Else is a 1 char checksum 03109000
N R5,=X'000000C0' Get two hi order bits 03110000
SRL R5,6 Shift it right by 6 03111000
A R5,TEMP Add the two values 03112000
N R5,=X'0000003F' Get mod 64 03113000
CR R5,R7 Computed vs received checksum 03114000
BE RPACK8 Successful 03115000
B RPACK7 We failed 03116000
RPACK4 LA R5,RECPKT Address of input buffer 03117000
LA R5,1(R5) Skip over the ^A 03118000
SR R6,R6 Use for NULL 03119000
BCTR R8,0 Go back one char 03120000
STC R6,RECPKT(R8) Next spot in output buffer 03121000
LA R8,1(R8) Next char to pick up 03122000
L R15,=A(CRCCLC) Calculate the CRC 03123000
BALR R14,R15 03124000
LR R4,R15 Keep it here 03125000
LR R5,R4 Munge while here 03126000
N R5,=X'0000F000' Get bits 12-15 03127000
SRL R5,12 Shift right by 12 03128000
CR R5,R7 Rec'v checksum = calculated one? 03129000
BNE RPACK7 No then we fail 03130000
SR R7,R7 Zero out register 03131000
IC R7,RECPKT(R8) Get next char of checksum 03132000
LA R8,1(R8) Bump input pointer 03133000
C R7,=A(SOH) Is it Control-A 03134000
BE RPACK1 Yes start over 03135000
S R7,SPACE Get real value 03136000
RPACK5 LR R5,R4 Get back the CRC 03137000
N R5,=X'00000FC0' Get bits 6-11 03138000
SRL R5,6 Shift right by six 03139000
CR R5,R7 Recv chksum = calc one? 03140000
BNE RPACK7 No 03141000
SR R7,R7 Zero out register 03142000
IC R7,RECPKT(R8) Get checksum 03143000
LA R8,1(R8) Bump input pointer 03144000
C R7,=A(SOH) Is it Control-A 03145000
BE RPACK1 Yes start over 03146000
S R7,SPACE Get back real value 03147000
N R4,=X'0000003F' Get bits 0-5 03148000
CR R4,R7 Do the last chars match 03149000
BE RPACK8 Yes 03150000
RPACK7 EQU * 03151000
* Uncomment next two lines when debugging to get first char of chksum. 03152000
* A R5,SPACE 03153000
* LINEDIT TEXT='CHK SB ...',SUB=(HEX,(R5)) 03154000
MVI ERRNUM,X'05' Bad checksum error 03155000
RPACK71 MVI RTYPE,AN Return a NAK 03156000
OI FLAGS,FLG4 RPACK NAK'ed the packet 03157000
RPACK8 L R13,4(R13) 03158000
L R14,12(R13) 03159000
LM R0,R12,20(R13) 03160000
BR 14 03161000
RPACK9 EQU * S/1 I/O error occurred [12] 03162000
MVI ERRNUM,S1ERRNUM Set error type [12] 03163000
MVI RTYPE,X'00' Set an invalid pkt type [12] 03164000
B RPACK8 Return to caller [12] 03165000
RPSAVE DS 18F 03166000
* [19 begin] 03167000
* The following Plist is identical to a RDTERM macro one, 03168000
* except the macro can't gen a "Y" code which causes the 03169000
* input not to be translated with the user input translate 03170000
* table and the buffer is blank filled. Use prompt of XON. 03171000
WTRDPLST DS 0D Terminal read Plist: 03172000
DC CL8'WAITRD' Command name 03173000
DC X'01',AL3(RECPKT) Buffer addr 03174000
DC C'Y',C'P' Y->no xlate, P->prompt 03175000
WTRDLEN DC AL2(0) Rec'd chr count ret'd here 03176000
DC AL4(XONPRO) Prompt Address 03177000
DC AL4(LXONPRO) Prompt length 03178000
DS 0D 03179000
XONPRO DC X'11' Prompt is XON 03180000
LXONPRO EQU *-XONPRO 03181000
* [19 end] 03182000
NOHIBITS DC (L'RECPKT)X'7F' Clear hi bit of each char [12] 03183000
LTORG 03184000
DROP R11 03185000
DROP R12 DON'T NEED THEM ANYMORE 03186000
EJECT 03187000
RECEIVE CSECT 03188000
STM R14,R12,12(R13) SAVE CALLER'S REGISTERS 03189000
BALR R12,0 ESTABLISH ADDRESSABILITY 03190000
USING *,R12 03191000
LA R14,RECSAVE ADDRESS OF MY SAVE AREA 03192000
ST R13,4(R14) SAVE CALLER'S 03193000
ST R14,8(R13) 03194000
LR R13,R14 03195000
* USE R11 AS BASE REGISTER FOR THE GLOBAL DATA AREA, 'PARMS' 03196000
L R11,=A(PARMS) 03197000
USING PARMS,R11 03198000
TM S1FLAGS,ISS1 Is console a S/1? [12] 03199000
BZ RECINI No, skip init stuff [12] 03200000
LA R1,1 Initialize [12] 03201000
L R15,=A(INTRINI) Trap CONS interrupts [12] 03202000
BALR R14,R15 [12] 03203000
RECINI MVC EBQUOT(1),ORIG8Q IF CHANGED IN LAST X-FER [1] 03204000
SR R6,R6 GET ZERO 03205000
ST R6,NUMTRY ZERO THIS OUT 03206000
ST R6,SPKNUM HERE TOO 03207000
MVI STATE,C'R' SET TO RECEIVE STATE 03208000
RLOOP CLI STATE,C'D' RECEIVE DATA STATE 03209000
BE RDATA 03210000
CLI STATE,C'F' RECEIVE FILE STATE 03211000
BE RFILE 03212000
CLI STATE,C'R' RECEIVE INIT STATE 03213000
BE RINIT 03214000
CLI STATE,C'C' COMPLETE STATE 03215000
BE RCOMP 03216000
CLI STATE,C'A' ABORT STATE 03217000
BE RABORT 03218000
MVI ERRNUM,X'02' UNRECOGNIZED STATE 03219000
B RABORT ELSE, DIE 03220000
RINIT CLC NUMTRY,IMXTRY SEE IF CAN RECEIVE 03221000
BL ROK1 YES, WE CAN 03222000
MVI STATE,C'A' NOPE, GO INTO ABORT STATE 03223000
B RLOOP 03224000
ROK1 L R3,NUMTRY 03225000
LA R3,1(R3) INCREMENT TRIAL COUNTER 03226000
ST R3,NUMTRY 03227000
TM LFLAGS,SERVON In server mode? [13] 03228000
BO RY1 Already read in packet [13] 03229000
MVC CURCHK(1),CHKLEN Save desired value [8] 03230000
MVI CHKLEN,X'01' Init uses 1 char chksum [8] 03231000
L R15,=A(RPACK) GET INIT INFORMATION 03232000
BALR R14,R15 03233000
MVC CHKLEN(1),CURCHK Restore desired chksum [8] 03234000
CLI RTYPE,AE ERROR PACKET? 03235000
BNE RY1 ALL OK 03236000
MVI ERRNUM,X'0A' MICRO DIED 03237000
MVI STATE,C'A' SO WE DO TOO 03238000
B RLOOP 03239000
RY1 CLI RTYPE,AS IS IT A SEND-INIT PACKET 03240000
BNE RN1 MAYBE IT GOT CLOBBERED 03241000
L R5,LRDAT Number of pieces of data [5] 03242000
L R15,=A(SPAR) Read his parameters [5] 03243000
BALR R14,R15 03244000
MVC SPKNUM(4),RPKNUM SYNCH PACKET NUMBERS 03245000
MVI STYPE,AY SET MESSAGE TYPE TO ACK 03246000
L R15,=A(RPAR) Make packet of our values [5] 03247000
BALR R14,R15 03248000
ST R15,LSDAT Size of packet [5] 03249000
MVC CURCHK(1),CHKLEN Save desired value [8] 03250000
MVI CHKLEN,X'01' Init uses 1 char chksum [8] 03251000
L R15,=A(SPACK) ADDRESS OF SPACK 03252000
BALR R14,R15 SAVE * AND GO TO SPACK 03253000
MVC CHKLEN(1),CURCHK Restore desired chksum [8] 03254000
CLI STATE,C'A' 03255000
BE RABORT 03256000
MVI STATE,C'F' SET TO RECEIVE FILE STATE 03257000
MVC OLDTRY(4),NUMTRY SAVE TRIAL COUNTER 03258000
XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 03259000
L R3,SPKNUM 03260000
LA R3,1(R3) ADD ONE 03261000
ST R3,SPKNUM STORE VALUE INCREMENTED BY 1 03262000
NC SPKNUM(4),=X'0000003F' MASK TO GET MOD 64 03263000
B RLOOP 03264000
RN1 CLI RTYPE,AN NAK (bad chksum)? 03265000
BNE RSELSE 03266000
MVI STYPE,AN SEND A NAK PACKET 03267000
XC LSDAT,LSDAT NO DATA 03268000
MVC CURCHK(1),CHKLEN Save desired value [8] 03269000
MVI CHKLEN,X'01' Init uses 1 char chksum [8] 03270000
L R15,=A(SPACK) 03271000
BALR R14,R15 03272000
MVC CHKLEN(1),CURCHK Restore desired chksum [8] 03273000
B RLOOP 03274000
RSELSE MVI STATE,C'A' ELSE,ABORT 03275000
CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 03276000
BE RLOOP Yes just return [12] 03277000
MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 03278000
B RLOOP 03279000
RFILE CLC NUMTRY,MAXTRY EXCEEDED NO. OF TRIALS ALLOWED 03280000
BL ROK2 NOPE, STILL OK 03281000
MVI STATE,C'A' ABORT IF YES 03282000
B RLOOP 03283000
ROK2 L R3,NUMTRY 03284000
LA R3,1(R3) INCREMENT TRIAL COUNTER 03285000
ST R3,NUMTRY 03286000
L R15,=A(RPACK) GET ADDRESS OF RPACK 03287000
BALR R14,R15 GO THERE AND RETURN WHEN DONE 03288000
CLI RTYPE,AE ERROR PACKET? 03289000
BNE RY2 MAYBE AN ACK 03290000
MVI ERRNUM,X'0A' MICRO DIED 03291000
MVI STATE,C'A' SO WE DO TOO 03292000
B RLOOP 03293000
RY2 CLI RTYPE,AS STILL IN INIT STATE? 03294000
BNE RNZ TRY FOR AN EOF 03295000
CLC OLDTRY,IMXTRY CAN WE TRY AGAIN? [5] 03296000
BL ROLD 03297000
MVI STATE,C'A' ELSE, ABORT 03298000
B RLOOP 03299000
ROLD L R3,OLDTRY 03300000
LA R3,1(R3) INCREMENT COUNTER 03301000
ST R3,OLDTRY 03302000
L R3,SPKNUM GET PACKET NUMBER SENT 03303000
BCTR R3,0 SUBTRACT ONE FROM IT 03304000
C R3,RPKNUM RPKNUM MUST EQUAL SPKNUM-1 03305000
BE RNUM 03306000
MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 03307000
B RNAK SEND A NAK 03308000
RNUM MVI STYPE,AY ACK PACKET 03309000
ST R3,SPKNUM MAKE SEND SEQ NO. = SPKNUM-1 03310000
L R15,=A(RPAR) Get packet with our values [5] 03311000
BALR R14,R15 03312000
ST R15,LSDAT Size of packet [5] 03313000
L R15,=A(SPACK) 03314000
BALR R14,R15 GO TO SPACK AND RETURN 03315000
CLI STATE,C'A' 03316000
BE RABORT 03317000
L R4,SPKNUM 03318000
LA R4,1(R4) ADD ONE 03319000
ST R4,SPKNUM RESTORE N TO PROPER VALUE 03320000
XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 03321000
B RLOOP 03322000
RNZ CLI RTYPE,AZ 03323000
BNE RNF MAYBE IT'S AN 'F' 03324000
CLC OLDTRY,MAXTRY CAN WE TRY AGAIN? 03325000
BL ROLD2 03326000
MVI STATE,C'A' ELSE,ABORT 03327000
B RLOOP 03328000
ROLD2 L R3,OLDTRY 03329000
LA R3,1(R3) INCREMENT COUNTER 03330000
ST R3,OLDTRY 03331000
L R3,SPKNUM GET PACKET NUMBER SENT 03332000
BCTR R3,0 SUBTRACT ONE FROM IT 03333000
C R3,RPKNUM RPKNUM MUST EQUAL SPKNUM-1 03334000
BE RNUM2 03335000
MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 03336000
B RNAK SEND A NAK 03337000
RNUM2 MVI STYPE,AY ACK PACKET 03338000
ST R3,SPKNUM SEND SEQ := SPKNUM-1 03339000
XC LSDAT,LSDAT NO DATA 03340000
L R15,=A(SPACK) 03341000
BALR R14,R15 03342000
CLI STATE,C'A' 03343000
BE RABORT 03344000
L R4,SPKNUM 03345000
LA R4,1(R4) ADD ONE 03346000
ST R4,SPKNUM RESTORE SPKNUM TO PROPER VALUE 03347000
XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 03348000
B RLOOP 03349000
RNF CLI RTYPE,AF 03350000
BNE RNB WELL, IT'S NOT A FNAME 03351000
CLC RPKNUM,SPKNUM THEY HAVE TO BE EQUAL 03352000
BE RNUM3 03353000
MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 03354000
B RNAK SEND A NAK 03355000
RNUM3 MVI STYPE,AY ACK PACKET 03356000
XC LSDAT,LSDAT NO DATA 03357000
MVI CXZ,X'00' Clear each time [16] 03358000
TM FLAGS,FLG2 OVERWRITE THE NAME SENT? 03359000
BO OVER YUP,WE DO 03360000
L R5,LRDAT Data len to decode [22] 03361000
LTR R5,R5 CHECK LENGTH 03362000
BZ SAYNO DIE IF NO FILENAME 03363000
L R2,=A(NULDMP) Null dump routine [22] 03364000
ST R2,MORDEC [22] 03365000
XC OUTBFPT,OUTBFPT Output buffer offset [22] 03366000
MVC TEMP,MAXOUT Save max here [22] 03367000
MVC MAXOUT,=A(MAXTXT) Use big number [22] 03368000
L R15,=A(DECODE) Decode the input [22] 03369000
BALR R14,R15 [22] 03370000
MVC MAXOUT,TEMP Reset [22] 03371000
L R5,OUTBFPT Len of decoded data [22] 03372000
ST R5,LRDAT Keep length here [22] 03373000
MVC FILNAM,=18X'20' Initialize to blanks 03374000
* LA R9,RDAT Location of first char 03375000
L R9,ARBUF Location of first char [22] 03376000
LR R8,R9 Points to buffer head [22] 03377000
REMDOT CLC 0(1,R9),=X'2E' LOOK FOR THE DOT 03378000
BE DOT FOUND IT 03379000
LA R9,1(R9) NEXT POSITION 03380000
LR R10,R9 03381000
SR R10,R8 GET LENGTH OF NAME SO FAR 03382000
CR R10,R5 AT END OF FN? 03383000
BL REMDOT NO,KEEP LOOKING 03384000
C R5,=F'8' Get FN (max of 8 chars) [9] 03385000
BNH DOT1 Size is OK [9] 03386000
L R5,=F'8' Truncate to 8 [9] 03387000
DOT1 BCTR R5,0 Decrement for next instr [9] 03388000
EX R5,GETFN Copy FN from buffer [9] 03389000
B DOT4 Set ft to "X" [9] 03390000
DOT LR R5,R9 SAVE OUR PLACE 03391000
LA R5,1(R5) NEXT CHARACTER 03392000
SR R9,R8 GET LENGTH OF FNAME 03393000
LR R4,R9 SAVE LENGTH ATTRIBUTE 03394000
BCTR R4,0 03395000
C R9,=F'8' MAX OF 8 CHARACTERS 03396000
BNH DOT2 03397000
L R9,=F'8' TRUNCATE EXTRA LETTERS 03398000
DOT2 BCTR R9,0 FOR EX COMMAND 03399000
LTR R9,R9 CHECK LENGTH 03400000
BM SAYNO DIE IF IT'S ZERO 03401000
EX R9,GETFN GET FILNAM 03402000
L R7,LRDAT GET LENGTH OF WHOLE NAME 03403000
SR R7,R4 AND GET LENGTH OF FTYPE 03404000
S R7,=F'3' Minus dot, fn char, ft char 03405000
LTR R7,R7 CHECK LENGTH 03406000
BM DOT4 Set ft to "X" [9] 03407000
C R7,=F'7' MAX IS 8 (7 + 1 FOR 'EX') 03408000
BNH DOT3 03409000
L R7,=F'7' TRUNCATE EXTRA LETTERS 03410000
DOT3 EX R7,GETFT GET FTYPE 03411000
B DOT5 Do translation [9] 03412000
DOT4 MVI FILNAM+8,X'58' Set FT to Ascii "X" [9] 03413000
DOT5 TR FILNAM(18),ATOE NEED IT IN EBCDIC 03414000
MVC FILNAM+16(2),FM ADD DEFAULT FMODE 03415000
OVER LA R3,FILNAM Point to fn 03416000
OC FILNAM,=CL18' ' Uppercase filename 03417000
L R15,=A(VERLET) Verify letters of fn [9] 03418000
BALR R14,R15 [9] 03419000
TM LFLAGS,WARFL Doing fn collision? [18 start] 03420000
BNO OVER3 No just delete it 03421000
LR R6,R3 Char we'll change, if needed 03422000
LA R7,FILNAM+16 Where FM starts 03423000
OVER1 FSSTATE (R3),FORM=E Does it exist already? 03424000
LTR R15,R15 03425000
BNZ OVER4 No just go on 03426000
CR R6,R7 Any more chars to work with? 03427000
BE OVER2 No so fail 03428000
MVI 0(R6),C'$' Replace char with "$" 03429000
LA R6,1(R6) Bump pointer 03430000
B OVER1 And try again 03431000
OVER2 MVI ERRNUM,X'14' Unable to rename file 03432000
MVI STATE,C'A' So abort 03433000
B RLOOP 03434000
OVER3 FSERASE (R3) Erase in case exists 03435000
OVER4 FSOPEN (R3),FORM=E Open before ACK 03436000
C R15,=F'28' File should not be found 03437000
BE RENOK Worked OK 03438000
MVI ERRNUM,X'18' No - unable to create file 03439000
MVI STATE,C'A' So we die 03440000
B RLOOP [18 end] 03441000
RENOK L R15,=A(SPACK) 03442000
BALR R14,R15 SEND ACK 03443000
CLI STATE,C'A' 03444000
BE RABORT 03445000
MVC OLDTRY(4),NUMTRY KEEP NUMTRY FOR LATER 03446000
XC NUMTRY,NUMTRY RESET TO ZERO 03447000
L R3,SPKNUM 03448000
LA R3,1(R3) ADD ONE 03449000
ST R3,SPKNUM INCREMENT COUNTER 03450000
NC SPKNUM(4),=X'0000003F' MASK TO GET MOD 64 03451000
MVI STATE,C'D' DATA RECEIVE STATE 03452000
XC OUTBFPT,OUTBFPT Init output buffer pointer [6] 03453000
B RLOOP 03454000
RNB CLI RTYPE,AB SEE IF IT'S A BREAK 03455000
BNE RNN MAYBE GOT A NAK 03456000
CLC RPKNUM,SPKNUM 03457000
BE RNUM4 03458000
MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 03459000
B RNAK SEND A NAK 03460000
RNUM4 MVI STYPE,AY ACK PACKET 03461000
XC LSDAT,LSDAT NO DATA 03462000
L R15,=A(SPACK) 03463000
BALR R14,R15 03464000
CLI STATE,C'A' 03465000
BE RABORT 03466000
MVI STATE,C'C' COMPLETE STATE 03467000
CLI CXZ,X'00' Other side kill x-fer? [16] 03468000
BE RLOOP No end OK [16] 03469000
MVI STATE,C'A' Else remember error [16] 03470000
B RLOOP 03471000
RNN CLI RTYPE,AN SEE IF GOT A NAK 03472000
BNE RNELSE 03473000
RNAK MVI STYPE,AN SEND A NAK PACKET 03474000
XC LSDAT,LSDAT NO DATA 03475000
L R15,=A(SPACK) 03476000
BALR R14,R15 03477000
B RLOOP DO NOTHING ON A NAK 03478000
RNELSE MVI STATE,C'A' ABORT OTHERWISE 03479000
CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 03480000
BE RLOOP Yes just return [12] 03481000
MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 03482000
B RLOOP 03483000
RDATA CLC NUMTRY,MAXTRY HAVE WE EXCEEDED OUR LIMIT? 03484000
BL ROK3 03485000
MVI STATE,C'A' ELSE, ABORT 03486000
B RLOOP 03487000
ROK3 L R4,NUMTRY 03488000
LA R4,1(R4) INCREMENT 03489000
ST R4,NUMTRY SAVE INCREMENTED COUNTER 03490000
L R15,=A(RPACK) 03491000
BALR R14,R15 CALL RPACK 03492000
CLI RTYPE,AE ERROR PACKET? 03493000
BNE RY3 MAYBE AN ACK 03494000
MVI ERRNUM,X'0A' MICRO DIED 03495000
MVI STATE,C'A' WE ABORT TOO 03496000
B RLOOP 03497000
RY3 CLI RTYPE,AD IS THIS A DATA PACKET? 03498000
BNE RDF MAYBE IT'S AN FNAME PACKET 03499000
CLC SPKNUM,RPKNUM CHECK FOR RIGHT PACKET 03500000
BNE DIF 03501000
L R15,=A(PTCHR) 03502000
BALR R14,R15 PUT CHARACTERS INTO FILE 03503000
LTR R15,R15 CHECK FOR NO ERROR [6] 03504000
BZ OKWR NO ERROR 03505000
MVI STATE,C'A' ABORT ON FILE SYSTEM ERROR 03506000
B RLOOP 03507000
OKWR MVI STYPE,AY ACK PACKET 03508000
XC LSDAT,LSDAT NO DATA 03509000
L R15,=A(SPACK) 03510000
BALR R14,R15 03511000
CLI STATE,C'A' 03512000
BE RABORT 03513000
MVC OLDTRY(4),NUMTRY SAVE NUMTRY'S VALUE IN OLDTRY 03514000
XC NUMTRY,NUMTRY RESET NUMTRY 03515000
L R3,SPKNUM 03516000
LA R3,1(R3) 03517000
ST R3,SPKNUM INCREMENT COUNTER 03518000
NC SPKNUM(4),=X'0000003F' MASK TO GET MOD 64 03519000
B RLOOP 03520000
DIF CLC OLDTRY,MAXTRY CAN WE DO IT? 03521000
BL DIFNUM 03522000
MVI STATE,C'A' AND ABORT 03523000
B RLOOP 03524000
DIFNUM L R4,OLDTRY 03525000
LA R4,1(R4) 03526000
ST R4,OLDTRY INCREMENT THIS COUNTER 03527000
L R4,SPKNUM 03528000
BCTR R4,0 03529000
C R4,RPKNUM RPKNUM MUST EQUAL SPKNUM-1 03530000
BE DIFOK 03531000
MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 03532000
B RDN1 SEND A NAK 03533000
DIFOK XC NUMTRY,NUMTRY RESET COUNTER TO ZERO 03534000
MVI STYPE,AY ACK PACKET 03535000
XC LSDAT,LSDAT NO DATA 03536000
ST R4,SPKNUM DECREMENT TO RESEND PACKET 03537000
L R15,=A(SPACK) 03538000
BALR R14,R15 SEND THE PACKET 03539000
CLI STATE,C'A' 03540000
BE RABORT 03541000
L R4,SPKNUM 03542000
LA R4,1(R4) ADD ONE 03543000
ST R4,SPKNUM RESTORE TO PROPER VALUE 03544000
B RLOOP AND RETURN 03545000
RDF CLI RTYPE,AF SENDING FILENAME AGAIN? 03546000
BNE RDZ 03547000
CLC OLDTRY,MAXTRY CAN WE DO IT? 03548000
BL FILOVER TRYING IT AGAIN 03549000
MVI STATE,C'A' IF NO, ABORT 03550000
B RLOOP 03551000
FILOVER L R4,OLDTRY 03552000
LA R4,1(R4) 03553000
ST R4,OLDTRY SAVE INCREMENTED VALUE 03554000
L R4,SPKNUM 03555000
BCTR R4,0 NEED VALUE OF N-1 03556000
C R4,RPKNUM SPKNUM-1 MUST EQUAL RPKNUM 03557000
BE FILOK 03558000
MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 03559000
B RDN1 SEND A NAK 03560000
FILOK XC NUMTRY,NUMTRY RESET TO ZERO 03561000
XC LSDAT,LSDAT NO DATA 03562000
MVI STYPE,AY ACK PACKET AGAIN 03563000
ST R4,SPKNUM DECREMENT FOR NOW 03564000
L R15,=A(SPACK) 03565000
BALR R14,R15 03566000
CLI STATE,C'A' 03567000
BE RABORT 03568000
L R4,SPKNUM 03569000
LA R4,1(R4) ADD ONE 03570000
ST R4,SPKNUM RESTORE TO PROPER VALUE 03571000
B RLOOP AND RETURN 03572000
RDZ CLI RTYPE,AZ IS THIS AN EOF PACKET? 03573000
BNE RDN 03574000
CLC SPKNUM,RPKNUM ARE THEY EQUAL 03575000
BE RDOK 03576000
MVI ERRNUM,X'08' PREVIOUS PACKET MISSING 03577000
B RDN1 SEND A NAK 03578000
RDOK CLC LRDAT,ONE One piece of data [16] 03579000
BNE RDWR No go write out file [16] 03580000
LA R3,RDAT Point to data [16] 03581000
CLI 0(R3),AD "D" for discard [16] 03582000
BNE RDWR No write out file [16] 03583000
LA R3,FILNAM Else get filename [16] 03584000
FSCLOSE (R3) Close the file [16] 03585000
FSERASE (R3) And delete file [16] 03586000
MVI ERRNUM,X'17' Receive cancelled [16] 03587000
MVI CXZ,X'FF' Remember that [16] 03588000
B RDXX Pick up later on [16] 03589000
* If data left in buffer when get EOF packet, write remaining 03590000
* data out to the file. [1] 03591000
RDWR CLC OUTBFPT,ZERO HOW MUCH DATA LEFT [1] 03592000
BE BUFMT NONE LEFT, SEND ACK [1] 03593000
L R9,OUTBFPT NUMBER OF CHARS IN BUFFER [1] 03594000
L R15,=A(OUTBUF) WRITE OUT BUFFER [1] [6] 03595000
BALR R14,R15 GO TO IT [1] 03596000
LTR R15,R15 CHECK RETCODE [1] 03597000
BZ BUFMT WORKED OK [1] 03598000
MVI STATE,C'A' FILE SYSTEM ERROR [1] 03599000
B RLOOP SO DIE [1] 03600000
BUFMT LA R3,FILNAM 03601000
FSCLOSE (R3) 03602000
RDXX MVI STYPE,AY ACK THE PACKET [1] 03603000
XC LSDAT,LSDAT NO DATA 03604000
L R15,=A(SPACK) 03605000
BALR R14,R15 03606000
MVC OLDTRY(4),NUMTRY SAVE NUMTRY'S VALUE HERE 03607000
XC NUMTRY,NUMTRY AND RESET COUNTER 03608000
L R3,SPKNUM 03609000
LA R3,1(R3) 03610000
ST R3,SPKNUM STORE VALUE INCREMENTED BY 1 03611000
NC SPKNUM(4),=X'0000003F' MASK TO GET MOD 64 03612000
MVI STATE,C'F' TRY FOR ANOTHER FILE 03613000
NI FLAGS,X'FF'-FLG2 Only change first file [9] 03614000
B RLOOP 03615000
RDN CLI RTYPE,AN DO WE NEED TO SEND A NAK? 03616000
BNE RDELSE 03617000
RDN1 MVI STYPE,AN SEND A NAK 03618000
XC LSDAT,LSDAT NO DATA 03619000
L R15,=A(SPACK) 03620000
BALR R14,R15 03621000
B RLOOP 03622000
RDELSE MVI STATE,C'A' UNRECOGNIZED PACKET - ABORT 03623000
CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 03624000
BE RLOOP Yes just return [12] 03625000
MVI ERRNUM,X'07' ILLEGAL PACKET TYPE 03626000
B RLOOP 03627000
SAYNO MVI STYPE,AN SEND A NAK PACKET 03628000
XC LSDAT,LSDAT NO DATA 03629000
MVI ERRNUM,X'0B' ILLEGAL FILENAME ERROR 03630000
L R15,=A(SPACK) 03631000
BALR R14,R15 03632000
B RLOOP 03633000
* 03634000
RABORT LA R3,FILNAM 03635000
FSCLOSE (R3) CLOSE OPEN FILE 03636000
CLI ERRNUM,X'0A' DID THE MICRO DIE? 03637000
BE RNOERRP NO ERROR PACKET IF SO 03638000
CLI ERRNUM,X'17' Other side cancel receive [16] 03639000
BE RNOERRP Yes no error packet [16] 03640000
* At least try to send an error packet. 03641000
* CLI ERRNUM,S1ERRNUM Was it a S/1 I/O error [12] 03642000
* BE RNOERRP Yes just return [12] 03643000
L R15,=A(ERRPACK) Send error packet [13] 03644000
BALR R14,R15 Error number in ERRNUM [13] 03645000
RNOERRP LA R15,4 SET A NON-ZERO RETCODE 03646000
B RECRET PREPARE TO LEAVE 03647000
RCOMP SR R15,R15 RETCODE OF ZERO 03648000
RECRET TM S1FLAGS,ISS1 Is console a S/1? [12] 03649000
BZ RECRET2 No skip reset [12] 03650000
TM LFLAGS,SERVON In server mode? [13] 03651000
BO RECRET2 Yes don't reset yet [13] 03652000
LR R2,R15 Save retcode [12] 03653000
SR R1,R1 Clear interrupt trapping [12] 03654000
L R15,=A(INTRINI) [12] 03655000
BALR R14,R15 [12] 03656000
LR R15,R2 Restore retcode [12] 03657000
RECRET2 L R13,4(R13) 03658000
L R14,12(R13) 03659000
LM R0,R12,20(R13) 03660000
BR 14 03661000
RECSAVE DS 18F 03662000
GETFN MVC FILNAM(0),0(R8) Pick up FNAME [22] 03663000
GETFT MVC FILNAM+8(0),0(R5) PICK UP FTYPE 03664000
LTORG 03665000
DROP R11 03666000
DROP R12 DON'T NEED THEM ANYMORE 03667000
EJECT 03668000
* 03669000
* Write data out to a file. [6] 03670000
PTCHR CSECT 03671000
STM R14,R12,12(R13) Do standard linkage 03672000
BALR R12,0 03673000
USING *,R12 03674000
LA R14,PTSAV 03675000
ST R13,4(R14) 03676000
ST R14,8(R13) 03677000
LR R13,R14 03678000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 03679000
L R11,=A(PARMS) 03680000
USING PARMS,R11 03681000
L R2,=A(OUTBUF) Routine to call to [22] 03682000
ST R2,MORDEC dump decoded data [22] 03683000
L R5,LRDAT Amount of input data 03684000
L R15,=A(DECODE) 03685000
BALR R14,R15 03686000
L R13,4(R13) 03687000
L R14,12(R13) 03688000
LM R0,R12,20(R13) Don't change retcode in R15 03689000
BR R14 03690000
PTSAV DS 18F 03691000
LTORG 03692000
DROP R11 03693000
DROP R12 DON'T NEED THEM ANYMORE 03694000
EJECT 03695000
* 03696000
* Expects R5 to contain size of input data. Other registers used: 03697000
* R4 - quote character, R8 - input buffer pointer, R9 - output 03698000
* buffer pointer (get value from OUTBFPT). Expects input to be in 03699000
* buffer RDAT and write out to buffer whose address in in ARBUF. [6] 03700000
DECODE CSECT 03701000
STM R14,R12,12(R13) Do standard linkage 03702000
BALR R12,0 03703000
USING *,R12 03704000
LA R14,DECSAV 03705000
ST R13,4(R14) 03706000
ST R14,8(R13) 03707000
LR R13,R14 03708000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 03709000
L R11,=A(PARMS) 03710000
USING PARMS,R11 03711000
SR R4,R4 Use to hold quote char 03712000
IC R4,SQUOTE 03713000
SR R8,R8 Input buffer pointer 03714000
L R9,OUTBFPT Output buffer pointer 03715000
DECOD0 MVI RPTCT,X'00' Reset each time [7] 03716000
MVI RPTVAL,X'00' Ditto [7] 03717000
SR R7,R7 Use to pick up char 03718000
LTR R5,R5 Any more data left? 03719000
BNZ DECOD1 Leave if all done 03720000
ST R9,OUTBFPT Save place in output buffer 03721000
SR R15,R15 OK return code 03722000
B DECOD8 And return to caller 03723000
DECOD1 C R9,MAXOUT Below max limit [2] 03724000
BNL DECOD7 No, write it out 03725000
CLI RPTCT,X'00' Doing a repeat [7] 03726000
BE DECOD11 No so get a char [7] 03727000
XC PAR,PAR Clear the parity flag [7] 03728000
IC R7,RPTVAL Get char we're repeating [7] 03729000
TM FLAGS,BINF In binary mode? [25] 03729100
BO DECOD6 Yes no check for eol [25] 03729200
CLI RPTVAL,ACR Ascii CR [25] 03729300
BE DECOD7 Yes, write another record [25] 03729400
CLI RPTVAL,ALF Ascii LF [25] 03729500
BE DECOD7 Yes, write another record [25] 03729600
B DECOD6 Write out to file [7] 03730000
DECOD11 BCTR R5,0 Decrement char counter 03731000
IC R7,RDAT(R8) Pick up a character 03732000
XC PAR,PAR Assume hi bit=0 [1 start] 03733000
CLI RPTQ,X'00' Doing repeat quoting [7] 03734000
BE DECOD12 No so skip next part [7] 03735000
CLM R7,B'0001',RPTQ Picked up repeat quote char? [7] 03736000
BNE DECOD12 No continue processing [7] 03737000
LA R8,1(R8) Bump input pointer [7] 03738000
BCTR R5,0 Modify buffer count [7] 03739000
SR R7,R7 Zero it out [7] 03740000
IC R7,RDAT(R8) Pick up the size [7] 03741000
S R7,=F'32' Was made printable [7] 03742000
STC R7,RPTCT Remember no. of repetitions [7] 03743000
LA R8,1(R8) Bump input pointer [7] 03744000
BCTR R5,0 Modify buffer count [7] 03745000
IC R7,RDAT(R8) Pick up repeated char [7] 03746000
DECOD12 CLI EBQUOT,AN Are we doing 8-bit quoting? 03747000
BE DECOD2 Nope 03748000
CLI EBQUOT,AY Can we do it but aren't? 03749000
BE DECOD2 Yes - so just forget it 03750000
CLM R7,B'0001',EBQUOT Did we get 8-bit quote char? 03751000
BNE DECOD2 No - continue as usual 03752000
BCTR R5,0 Decrement no. of chars left 03753000
LA R8,1(R8) Bump input pointer 03754000
IC R7,RDAT(R8) Get quoted char 03755000
MVI PAR+3,X'80' Set hi order bit on [1 end] 03756000
DECOD2 CR R7,R4 Is it the quote character? 03757000
BNE DECOD6 No it's a regular char 03758000
BCTR R5,0 Else decrement char count 03759000
LA R8,1(R8) Bump input pointer 03760000
IC R7,RDAT(R8) Pick up special char 03761000
CLC PAR,ZERO If PAR <> 0 don't check [1] 03762000
BNE DECOD4 For CR/LF (it's 8A,8D) [1] 03763000
TM FLAGS,BINF No check if binary mode [1] 03764000
BO DECOD4 Just skip it [1] 03765000
C R7,=X'0000004D' Is it a CR? (CHAR(CR)) 03766000
BNE DECOD3 No, check for LF 03767000
MVI PREV,X'4D' Yes, remember we saw a CR 03768000
LA R8,1(R8) Bump input pointer 03769000
MVI RPTVAL,ACR Set in case of repeats [25] 03769100
B DECOD7 Write out record 03770000
DECOD3 C R7,=X'0000004A' Should we write out on LF? 03771000
BNE DECOD4 No keep going 03772000
LA R8,1(R8) Bump input pointer 03773000
CLI PREV,X'4D' Was last char CR? 03774000
BE DECOD0 Yes, so ignore LF 03775000
MVI RPTVAL,ALF Set in case of repeats [25] 03775100
B DECOD7 Nope, so write out record 03776000
DECOD4 CR R7,R4 Is it the quote char 03777000
BE DECOD6 Don't convert if yes 03778000
CLI EBQUOT,AN Doing 8-bit quoting [1 start] 03779000
BE DECOD5 No don't check for quote char 03780000
CLI EBQUOT,AY Can do it but aren't? 03781000
BE DECOD5 Yup-don't check for quote char 03782000
CLM R7,B'0001',EBQUOT Is char the 8-bit quote char? 03783000
BE DECOD6 Yes - so don't convert 03784000
CLI RPTQ,X'00' Doing repeat counts 03785000
BE DECOD5 No check for quote char [7] 03786000
CLM R7,B'0001',RPTQ Is it the repeat quote char [7] 03787000
BE DECOD6 Yes, don't convert [7] 03788000
DECOD5 A R7,O1H Else add ^O100 03789000
N R7,=X'0000007F' Get modulo ^O200 03790000
DECOD6 O R7,PAR OR in the parity bit [1] 03791000
L R1,ARBUF Output buffer address [2] 03792000
AR R1,R9 Plus displacement [2] 03793000
STC R7,0(R1) Store char in buffer [2] 03794000
LA R9,1(R9) Bump output buffer pointer 03795000
LA R8,1(R8) Bump input buffer pointer 03796000
MVI PREV,X'00' Reset 03797000
SR R3,R3 Clear out for subtract [7] 03798000
IC R3,RPTCT Get no. of repetitions [7] 03799000
BCTR R3,0 Decrement repeat count [7] 03800000
LTR R3,R3 More repeats to do [7] 03801000
BNP DECOD0 Not positive, get new char [7] 03802000
STC R3,RPTCT Save modified count [7] 03803000
BCTR R8,0 Re-adjust input buf pointer [7] 03804000
STC R7,RPTVAL Remember repeated char [7] 03805000
B DECOD1 And write it out again [7] 03806000
*DECOD7 L R15,=A(OUTBUF) Routine to write out record [22] 03807000
DECOD7 L R15,MORDEC Routine to write out record [22] 03808000
BALR R14,R15 03809000
LTR R15,R15 Check the return code 03810000
BNZ DECOD8 Return if failed 03811000
XC OUTBFPT,OUTBFPT Reset output buffer pointer 03812000
SR R9,R9 Reset output buffer pointer 03813000
SR R3,R3 Clear out for subtract [7] 03814000
IC R3,RPTCT Get no. of repetitions [7] 03815000
CLI RPTVAL,ACR Ended with CR or LF? [25] 03815100
BE DECOD71 Yes do something else [25] 03815200
CLI RPTVAL,ALF Or did we end 'cause [25] 03815300
BE DECOD71 hit max lrecl [25] 03815400
LTR R3,R3 More repeats to do [7] 03816000
BP DECOD1 03817000
B DECOD0 And get more input 03818000
DECOD71 BCTR R3,0 One down [25] 03818100
LTR R3,R3 Any more to go? [25] 03818200
BNP DECOD0 No, all done [25] 03818300
STC R3,RPTCT Remember new count [25] 03818400
B DECOD1 And get new char [25] 03818500
DECOD8 L R13,4(R13) 03819000
L R14,12(R13) 03820000
LM R0,R12,20(R13) Don't change retcode in R15 03821000
BR R14 03822000
NULDMP BR R14 Null routine [22] 03823000
DECSAV DS 18F 03824000
LTORG 03825000
DROP R11 03826000
DROP R12 DON'T NEED THEM ANYMORE 03827000
EJECT 03828000
* 03829000
* Write out a buffer full of data. Expects R9 to contain the number 03830000
* of characters in the record. [6] 03831000
OUTBUF CSECT 03832000
STM R14,R12,12(R13) Do standard linkage 03833000
BALR R12,0 03834000
USING *,R12 03835000
LA R14,OUTSAV 03836000
ST R13,4(R14) 03837000
ST R14,8(R13) 03838000
LR R13,R14 03839000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 03840000
L R11,=A(PARMS) 03841000
USING PARMS,R11 03842000
L R6,LRECL Use to hold lrecl [2] 03843000
LTR R10,R9 Any data or bare CR? 03844000
BNZ OUTBF0 Yes, there's data 03845000
L R1,ARBUF Else, get addr of buffer [2] 03846000
MVI 0(R1),X'20' Make first char a space [2] 03847000
LA R10,1(R10) Length of one (fake blank line) 03848000
OUTBF0 TM FLAGS,BINF Binary data file? [1] 03849000
BO OUTBF3 If so skip translation [1] 03850000
LR R7,R10 Save size in R7 [2] 03851000
LR R1,R10 Here too [2] 03852000
L R3,ARBUF Where translating starts [2] 03853000
OUTBF1 BCTR R1,0 Subtract 1 for EX command 03854000
C R1,=F'255' Max for TRANSLATE is 256 [2] 03855000
BL OUTBF2 If is under max then is OK [2] 03856000
LA R1,255 Else, set to max [2] 03857000
OUTBF2 EX R1,TRNS EBCDIC to ASCII translation 03858000
C R7,=F'256' Chars left to translate? [2] 03859000
BNH OUTBF3 Nope, we're done [2] 03860000
LA R3,256(R3) X-late next group of chars [2] 03861000
S R7,=F'256' Decr chars left to x-late [2] 03862000
LR R1,R7 No. of chars left to x-LATE [2] 03863000
B OUTBF1 Translate some more [2] 03864000
OUTBF3 LA R3,FILNAM 03865000
CLI RFM,C'V' Is it variable format? 03866000
BE OUTBF5 Yes so leave data as is 03867000
CR R10,R6 If fixed, cannot exceed lrecl 03868000
BH OUTBF4 Ignore data after lrecl value 03869000
BE OUTBF5 Nope, it's just right 03870000
LR R2,R6 Else, get lrecl size 03871000
SR R2,R10 Pad with this many spaces 03872000
L R0,ARBUF Start of buffer [2] 03873000
AR R0,R10 Where to start padding [2] 03874000
LR R1,R2 Amount to pad by [2] 03875000
L R15,=X'00000040' Pad with spaces [2] 03876000
TM FLAGS,BINF In binary mode [1] 03877000
BNO OUTBF31 No so just pad [1] 03878000
SR R15,R15 Pad with nulls [1] 03879000
OUTBF31 MVCL R0,R14 Do it [2] 03880000
OUTBF4 LR R10,R6 Length has to be this size 03881000
OUTBF5 SR R6,R6 03882000
IC R6,RFM RECFM has to be in a register 03883000
L R7,ARBUF Addr of data buffer [2] 03884000
FSWRITE (R3),BUFFER=(R7),BSIZE=(R10),RECFM=(R6),FORM=E [2] 03885000
LTR R7,R15 Check retcode 03886000
BZ OUTBF7 Is OK so get next record 03887000
L R15,=F'-1' Bad retcode 03888000
C R7,=A(ERCOD) Is the disk read-only? 03889000
BNE OUTBF6 No check different error 03890000
MVI ERRNUM,X'0E' Yes, set error type 03891000
B OUTBF7 03892000
OUTBF6 MVI ERRNUM,X'0F' Assume a RECFM conflict 03893000
C R7,=F'16' File exists w/dif RECFM 03894000
BE OUTBF7 03895000
MVI ERRNUM,X'06' Maybe disk full error 03896000
C R7,=F'13' Yup that's it 03897000
BE OUTBF7 03898000
MVI ERRNUM,X'19' General write error 03899000
OUTBF7 L R13,4(R13) 03900000
L R14,12(R13) 03901000
LM R0,R12,20(R13) Don't change retcode in R15 03902000
BR R14 03903000
OUTSAV DS 18F 03904000
TRNS TR 0(0,R3),ATOE BACK FROM ASCII TO EBCDIC 03905000
LTORG 03906000
DROP R11 03907000
DROP R12 DON'T NEED THEM ANYMORE 03908000
* 03909000
* Send error packet. Error number is in variable errnum. [13] 03910000
ERRPACK CSECT 03911000
STM R14,R12,12(R13) Do standard linkage 03912000
BALR R12,0 03913000
USING *,R12 03914000
LA R14,ERPSAV 03915000
ST R13,4(R14) 03916000
ST R14,8(R13) 03917000
LR R13,R14 03918000
* USE R11 AS BASE REGISTER FOR THE SHARED DATA AREA 03919000
L R11,=A(PARMS) 03920000
USING PARMS,R11 03921000
MVI STYPE,AE Error packet 03922000
MVC LSDAT(4),=F'20' All msgs are this long 03923000
MVC SPKNUM(4),RPKNUM Synch packet numbers 03924000
SR R5,R5 03925000
IC R5,ERRNUM Get right message number 03926000
M R4,=F'20' Offset := ERRNUM * 20 03927000
LA R5,ERRTAB(R5) 03928000
MVC SDAT(20),0(R5) Put data here 03929000
TR SDAT(20),ETOA 03930000
L R15,=A(SPACK) 03931000
BALR R14,R15 Send error packet 03932000
L R13,4(R13) 03933000
L R14,12(R13) 03934000
LM R0,R12,20(R13) Don't change retcode in R15 03935000
BR R14 03936000
ERPSAV DS 18F 03937000
LTORG 03938000
DROP R11 03939000
DROP R12 DON'T NEED THEM ANYMORE 03940000
* 03941000
* Handle screen I/O if going via Series/1 [12 start] 03942000
SCRNIO CSECT 03943000
USING SCRNIO,R15 establish addressability 03944000
STM R0,R14,SCRNSAV save caller's reg 03945000
LR R12,R15 switch base reg 03946000
DROP R15 03947000
USING SCRNIO,R12 03948000
L R11,=A(PARMS) point to data area 03949000
USING PARMS,R11 03950000
LH R2,CONSADDR get console addr 03951000
CLRSTAT EQU * 03952000
TIO 0(R2) any previous business? 03953000
BC 6,CLRSTAT busy: loop 03954000
BC 1,SCRNERR not operational: error 03955000
DODIAG EQU * 03956000
DIAG R1,R2,X'0058' start I/O via diagnose 03957000
BC 8,WAITCOMP ok: wait for completion 03958000
BC 2,DODIAG busy: try again 03959000
B SCRNERR CSW stored or error 03960000
WAITCOMP EQU * 03961000
WAITD CON1 wait for I/O to complete 03962000
CLI CONSCHAN,X'00' did an error occur? 03963000
BNE SCRNERR yes: skip 03964000
CLI CONSUNIT,CHEND just a channel end? 03965000
BE WAITCOMP yes: wait for device end 03966000
CLI CONSUNIT,CPBRK did CP break in? 03967000
BE SCRNERR yes: we're stuck now 03968000
LH R15,CONSBYTC get I/O byte count 03969000
CLI CONSUNIT,DEVEND is it a device end? 03970000
BE SCRNRET yes: return okay 03971000
CLI CONSUNIT,CHEND+DEVEND chan end & dev end? 03972000
BE SCRNRET yes: return okay 03973000
CLI CONSUNIT,ATTN attention? 03974000
BE SCRNRET yes: return okay 03975000
SCRNERR EQU * some type of err occurred 03976000
MVC ERRCSW,CONSCSW copy CSW in error 03977000
SR R15,R15 return error code of -1 03978000
BCTR R15,0 03979000
SCRNRET EQU * 03980000
LM R0,R14,SCRNSAV restore caller's regs 03981000
BR R14 return to caller 03982000
* 03983000
SCRNSAV DS 15F reg save area 03984000
* 03985000
LTORG 03986000
DROP R12 03987000
DROP R11 [12 end] 03988000
* [12 start] 03989000
* If R1 is non-zero, get values user has set for MSG, WNG and IMSG 03990000
* and then set them off for the duration of the program. If R1 is 03991000
* zero, then reset to the values the user originally had. 03992000
SETMSGS CSECT 03993000
USING SETMSGS,R15 03994000
STM R0,R14,MSGSAV save caller's regs 03995000
LR R12,R15 switch addressability 03996000
DROP R15 03997000
USING SETMSGS,R12 03998000
L R11,=A(PARMS) point to data area 03999000
USING PARMS,R11 04000000
LTR R1,R1 Setting or clearing 04001000
BZ SETM5 Go to clearing 04002000
LA R2,QSET point to CP QUERY command 04003000
LA R4,L'QSET get length of command 04004000
ICM R4,B'1000',=X'40' flag we want resp in buff 04005000
LA R3,QSBUF Put response here 04006000
LA R5,L'QSBUF its long enough for what we 04007000
DIAG R2,R4,X'0008' need here 04008000
LR R1,R5 get length of response and 04009000
LA R2,QSBUF addr of response 04010000
BZ SETM0 skip if response fit in buf 04011000
LA R1,L'QSBUF else get length of buffer 04012000
SR R1,R5 and subt num overflow 04013000
SETM0 LA R3,MSG3 get len-1,chars of token 04014000
BAL R10,GETSET we're looking for 04015000
CLC CON,0(R4) is following one "ON"? 04016000
BNE SETM1 no: skip 04017000
OI LFLAGS,FMSGON yes: flag SET MSG ON 04018000
SETM1 LA R3,WNG3 get len-1,chats of token 04019000
BAL R10,GETSET we're looking for 04020000
CLC CON,0(R4) is following one "ON"? 04021000
BNE SETM2 no: skip 04022000
OI LFLAGS,FWNGON yes: flag SET WNG ON 04023000
SETM2 LA R3,IMSG4 get len-1,chars of token 04024000
BAL R10,GETSET we're looking for 04025000
CLC CON,0(R4) is following one "ON"? 04026000
BNE SETM3 no: skip 04027000
OI LFLAGS,FIMSGON yes: flag SET IMSG ON 04028000
SETM3 LA R2,MSGOFF Turn off MSG's 04029000
LA R4,L'MSGOFF via diagnose X'08' 04030000
DIAG R2,R4,X'0008' 04031000
LA R2,WNGOFF Ditto for WNG's 04032000
LA R4,L'WNGOFF 04033000
DIAG R2,R4,X'0008' 04034000
LA R2,IMSGOFF Ditto for IMSG's 04035000
LA R4,L'IMSGOFF 04036000
DIAG R2,R4,X'0008' 04037000
SETM4 LM R0,R12,MSGSAV restore caller's regs 04038000
BR R14 return 04039000
* 04040000
SETM5 TM LFLAGS,FMSGON was CP SET MSG ON? 04041000
BZ SETM6 no: skip 04042000
LA R2,MSGON yes: turn it ON via 04043000
LA R4,L'MSGON diagnose X'08' 04044000
DIAG R2,R4,X'0008' 04045000
SETM6 TM LFLAGS,FWNGON was CP SET WNG ON? 04046000
BZ SETM7 no: skip 04047000
LA R2,WNGON yes: turn it ON via 04048000
LA R4,L'WNGON diagnose X'08' 04049000
DIAG R2,R4,X'0008' 04050000
SETM7 TM LFLAGS,FIMSGON was CP SET IMSG ON? 04051000
BZ SETM4 no: done 04052000
LA R2,IMSGON yes: turn it ON via 04053000
LA R4,L'IMSGON diagnose X'08' 04054000
DIAG R2,R4,X'0008' 04055000
B SETM4 And return 04056000
* 04057000
* Parse the "CP Q SET" response string: 04058000
* On entry: R1 = remaining length of resp 04059000
* R2 = addr of next char in resp 04060000
* R3 = ptr to <len-1,"target"> 04061000
* On exit: R1 = remaining length of resp 04062000
* R2 = addr of char past sub-resp string 04063000
* R4 = addr of token AFTER find (ON|OFF|...) 04064000
GETSET EQU * 04065000
BAL R9,SKPWHITE scan over white space 04066000
SR R4,R4 clear for char load 04067000
IC R4,0(,R3) get len-1 of target 04068000
EX R4,VARLCLC is it right one? 04069000
BE GETSETF yes: skip 04070000
BAL R9,SKP2EOS no: skip past sub-resp 04071000
B GETSET string and loop 04072000
GETSETF EQU * 04073000
LA R2,1(R4,R2) scan past matched token 04074000
BAL R9,SKPWHITE scan past white space 04075000
LA R4,0(,R2) ret addr of next token 04076000
BAL R9,SKP2EOS but bump ptr past end of 04077000
BR R10 sub-resp string 04078000
SKPWHITE EQU * 04079000
CLI 0(R2),C' ' is it a blank? 04080000
BE SKPWNXT yes: scan over it 04081000
CLI 0(R2),X'15' is it a NewLine? 04082000
BNER R9 no - at token: return 04083000
SKPWNXT EQU * 04084000
LA R2,1(,R2) bump ptr to next char 04085000
BCT R1,SKPWHITE decr count and loop 04086000
LA R4,=X'FF' none left: ret ptr to 04087000
BR R10 unmatchable string 04088000
SKP2EOS EQU * 04089000
CLI 0(R2),C',' is it a comma? 04090000
BE SKP2EOSB yes: skip 04091000
CLI 0(R2),X'15' is it a NewLine? 04092000
BE SKP2EOSB yes: skip 04093000
LA R2,1(,R2) no: scan over char 04094000
BCT R1,SKP2EOS decr count and loop 04095000
LA R4,=X'FF' none left: ret ptr to 04096000
BR R10 unmatchable string 04097000
SKP2EOSB EQU * reached end of sub-resp 04098000
LA R2,1(,R2) point 1 past sub-resp 04099000
BCTR R1,R9 decr count and return 04100000
LA R4,=X'FF' none left: ret ptr to 04101000
BR R10 unmatchable string 04102000
* 04103000
VARLCLC CLC 0(*-*,R2),1(R3) 04104000
* 04105000
MSGSAV DS 15F save caller's regs here 04106000
QSET DC C'QUERY SET' CP QUERY SET command 04107000
CON DC C'ON' check is SET xxx is "ON" 04108000
MSG3 DC AL1(3-1),C'MSG' len-1, token name 04109000
WNG3 DC AL1(3-1),C'WNG' ditto 04110000
IMSG4 DC AL1(4-1),C'IMSG' ditto 04111000
MSGOFF DC C'SET MSG OFF' CP commands to alter 04112000
MSGON DC C'SET MSG ON' SET MSG value 04113000
WNGOFF DC C'SET WNG OFF' 04114000
WNGON DC C'SET WNG ON' 04115000
IMSGOFF DC C'SET IMSG OFF' 04116000
IMSGON DC C'SET IMSG ON' 04117000
LTORG 04118000
DROP R11 04119000
DROP R12 04120000
EJECT [12 end] 04121000
* 04122000
* Initialize for going via Series/1. [12 start] 04123000
INTRINI CSECT 04124000
USING INTRINI,R15 establish addressability 04125000
STM R0,R14,INTRSAV save caller's regs 04126000
LR R12,R15 04127000
DROP R15 04128000
USING INTRINI,R12 04129000
L R11,=A(PARMS) get base for data area 04130000
USING PARMS,R11 04131000
LTR R1,R1 anything in R1? 04132000
BZ INTRCLR no: do clean up 04133000
TM S1FLAGS,S1INIT Initialized already? [13] 04134000
BO INTRRET Yes just leave [13] 04135000
OI S1FLAGS,S1INIT Else init and flag as done [13] 04136000
XC CONSCSW,CONSCSW clear any previous data 04137000
SR R2,R2 and any prev byte count 04138000
BCTR R2,0 (set len to -1) 04139000
ST R2,S1RDBYTC 04140000
WAITT Clear screen so don't get put 04141000
SR R0,R0 04142000
LH R0,CONSADDR Get console address 04143000
N 0,=F'255' 04144000
LA 1,CLRCCW into "HOLDING" on first I/O 04145000
DIAG 1,0,X'58' if there are any CP msgs on 04146000
WAITT the screen 04147000
HNDINT SET,(CON1,CHNDLR,009,WAIT) 04148000
LA R1,CLRRDY This I/O puts the screen 04149000
TM LFLAGS,SERVON into MORE or HOLDING 04150000
BNO INTX0 with a ready or server 04151000
LA R1,CLRSRV message 04152000
INTX0 L R15,=A(SCRNIO) 04153000
BALR R14,R15 04154000
B INTRRET 04155000
INTRCLR EQU * 04156000
HNDINT CLR,(CON1) 04157000
NI S1FLAGS,X'FF'-S1INIT Turn off flag [13] 04158000
INTRRET EQU * 04159000
LM R0,R14,INTRSAV restore caller's regs 04160000
BR R14 return to caller 04161000
DS 0D CCW's to clear screen 04162000
CLRRDY DC X'29',AL3(RDYMSG),AL1(SLI),X'80',AL2(LRDYMSG) 04163000
RDYMSG DC AL1(X'C0'+ALARM),AL1(SBA),X'4040' 04164000
DC C'Ready for file transfer...' 04165000
LRDYMSG EQU *-RDYMSG 04166000
DS 0D CCW's to clear screen 04167000
CLRSRV DC X'29',AL3(SRVMSG),AL1(SLI),X'80',AL2(LSRVMSG) 04168000
SRVMSG DC AL1(X'C0'+ALARM),AL1(SBA),X'4040' 04169000
DC C'Entering server mode .....' 04170000
LSRVMSG EQU *-SRVMSG 04171000
DS 0D 04172000
CLRCCW DC X'19',AL3(0),X'20',X'FF',AL2(1) 04173000
INTRSAV DS 15F reg save area 04174000
DROP R11 04175000
DROP R12 04176000
* 04177000
* Console interrupt routine: 04178000
CHNDLR DS 0H 04179000
USING CHNDLR,R15 estab address. 04180000
STM R10,R12,CHNDSAV save only reg's we need to 04181000
LR R12,R15 04182000
DROP R15 04183000
USING CHNDLR,R12 04184000
L R11,=A(PARMS) point to data area 04185000
USING PARMS,R11 04186000
STM R2,R3,CONSCSW save CSW from interrupt 04187000
LA R2,0(,R2) display CCW addr in PER 04188000
SRL R3,16 isolate unit & chan status 04189000
LA R3,0(,R3) so they show up in PER 04190000
SR R15,R15 R15=0-> intrpt proc complete 04191000
CLI CONSUNIT,CHEND was it only a channel end? 04192000
BNE CHNDRET no: exit 04193000
LA R15,1 yes: flag we expect another 04194000
CHNDRET EQU * 04195000
LM R10,R12,CHNDSAV restore reg's 04196000
BR R14 return to CMS intrpt handler 04197000
CHNDSAV DS 3F reg save area 04198000
LTORG 04199000
DROP R12 04200000
DROP R11 [12 end] 04201000
END KERMIT 04202000