Columbia Kermit

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

/ Columbia Kermit / kermit.zip / cmsoriginal / cmsv2.asm next >

Wrap

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