Columbia Kermit

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

/ Columbia Kermit / kermit.zip / ibm370 / ik0com.asm < prev next >

Wrap

Assembly Source File | 2020-01-01 | 94KB | 1,161 lines

*COPY IK0COM 01800000 CHECKVER IK0COM,4.3 @SC90072 01800500 TITLE 'COMMON - Kermit-370 common routines/data areas' 01801000 COMMON CSECT 01802000 * Translat - translates data. On entry R2->buffer, R3=length @SC86202 01803000 * R14 = return address, R15->translate table @SC86202 01804000 * R1-R3 are destroyed, R15 is set to 0 @SC86202 01805000 TRANSLAT LTR 3,3 Anything to do? @SC86202 01806000 BNP TRANSRET No, quit @SC86202 01807000 ALR 2,3 End of source @SC86202 01808000 TRLOOP LR 1,2 @SC86202 01809000 SR 1,3 Ptr to remaining bytes @SC86202 01810000 BCTR 3,0 Count for EX @SC86202 01811000 EX 3,TREX Translate the input segment @SC86202 01812000 N 3,=F'-256' Remove count done @SC86202 01813000 BNZ TRLOOP Loop thru source @SC86202 01814000 TRANSRET SR 15,15 Done, set RC=0 @SC86202 01815000 BR 14 @SC86202 01816000 TREX TR 0(,1),0(15) @SC86202 01817000 * 01817060 * Get TOD in R0; clobber R1,R15,TMPDW; return via R14 @SC91172 01817120 ACCTTOD STCK TMPDW Get time in timer units @SC91172 01817180 LM 0,1,TMPDW @SC91172 01817240 SRDL 0,12 Convert to microsec @SC91172 01817300 D 0,=F'4000000' 4-sec chunks + remainder @SC91172 01817360 LR 15,0 Save remainder @SC91172 01817420 SR 0,0 @SC91172 01817480 SLDL 0,2 Convert back to seconds @SC91172 01817540 SRL 15,20 Convert remainder also @SC91172 01817600 ALR 1,15 Add back in @SC91172 01817660 BC 12,*+8 @SC91172 01817720 AL 0,F1 @SC91172 01817780 D 0,=F'86400' Get time of day in seconds @SC91172 01817840 BR 14 @SC91172 01817900 * 01818000 * Subroutine to test for undelimited v-binary format @SC86151 01819000 RDWSET XC RDWLEN,RDWLEN Usual format @SC86151 01820000 LA 0,5 Header length of 5 for D-binary @SC86262 01821000 CLI TYPFIL,C'D' Is it? @SC86262 01822000 BE RDWSOK Yes, use it @SC86262 01823000 LA 0,2 Header length of 2 for V-binary @SC86262 01824000 CLI TYPFIL,C'V' Test for special type @SC86151 01825000 BNER 14 Not V-binary @SC86151 01826000 RDWSOK DS 0H @SC86262 01827000 ST 0,MAXOUT Init for decoding @SC86151 01828000 ST 0,RDWLEN @SC86151 01829000 BR 14 @SC86151 01830000 * @SC92030 01830100 * Test if line mode terminal type: return with skip if not @SC92030 01830200 TTYCHK CLI TRMTP,C'T' @SC92030 01830300 BER 14 No skip if TTY @SC92030 01830400 CLI TRMTP,C'F' @SC92030 01830500 BER 14 Go if full-screen non-transparent @SC92030 01830600 CLI TRMTP,C'V' @SC92030 01830700 BER 14 Go if VTAM TTY @SC92030 01830800 B 4(,14) @SC92030 01830900 * 01831000 * Subroutine to increment pkt sequence number 01832000 INCRSEQ IC 3,SEQ @SC86135 01833000 LA 3,1(3) 01834000 N 3,MOD64 01835000 STC 3,SEQ @SC86135 01836000 LA 3,1 @SC86295 01837000 AL 3,PAKCNT @SC86295 01838000 ST 3,PAKCNT Update packet count @SC86295 01839000 BR 14 01840000 * 01841000 * Subroutines to interpret RPACK data 01842000 INPUTSPK SR 3,3 Clear counter @SC86276 01843000 KCALL SPACK,E=INPUTRTY @SC86276 01844000 INPUT SR 3,3 Clear loop counter 01845000 INPUTLUP KCALL RPACK Read data 01846000 INPUTINR DS 0H @SC88074 01847000 IC 4,RTYPE Test byte @SC86158 01848000 TM FL3,ZPRO @SC88074 01848200 BO INPUTQRT Must stop pronto @SC88074 01848400 MVI ERRNUM,ERRIPT Assume bad packet type @SC88074 01848600 BAL 2,CLKP Look up in list @SC86158 01849000 * Standard packet types for special treatment @SC86158 01850000 INPUTST DC AL1(AE),AL3(INPUTERR) Error packet @SC86158 01851000 DC AL1(AN),AL3(INPUTNAK) NAK packet @SC86158 01852000 DC AL1(AQ),AL3(INPUTQAB) RPACK error @SC86158 01853000 DC AL1(AT),AL3(INPUTTIM) Time out @SC86355 01854000 DC AL1(00),AL3(INPUTCNT) OK so far @SC86158 01855000 * 01856000 INPUTCNT DS 0H @SC86158 01857000 CLC SEQ,RSN 01858000 BNE INPUTMIS Go if pkt num mismatch 01859000 INPUTQRT LR 2,8 Get next-state table address 01860000 LR 14,9 For in-line return @SC86295 01861000 B CLKP Look up in expected list @SC86158 01862000 * 01863000 INPUTMIS MVI ERRNUM,ERRMIS Missing pkt @SC86156 01864000 B INPUTRTY Retry 01865000 * 01866000 INPUTQAB MVC ERRNUM,RPKERN RPACK error: get code @SC89219 01867000 CLI STYPE,AB @SC88168 01867500 BNE INPUTRTY Retry if not a BRK pkt 01868000 INPUTACK MVI RTYPE,AY Fake an ACK @SC88092 01869000 IC 4,RTYPE @SC86158 01870000 B INPUTQRT And go handle the ACK 01871000 * 01872000 INPUTTIM MVI ERRNUM,ERRTIM Timed out @SC86355 01873000 B INPUTRTY @SC86355 01874000 INPUTNAK MVI ERRNUM,ERRNAK Micro NAK'ed @SC86156 01875000 IC 2,SEQ Expected packet number @SC88092 01875100 LA 2,1(2) @SC88092 01875200 N 2,MOD64 Get next number @SC88092 01875300 CLM 2,1,RSN Is that what we got? @SC88092 01875400 BE INPUTACK Yes, treat as an ACK @SC88092 01875500 INPUTRTY BAL 2,SENDRTY Resend to the limit @SC86276 01876000 B INPUTLUP And interpret response 01877000 * 01878000 INPUTERR CLI STYPE,AI Trying to send I packet? @SC89263 01879000 BE IPKSKP Ok, other Kermit too stupid @SC89263 01879300 MVI ERRNUM,ERRABO Micro aborted @SC89263 01879600 LR 2,9 Save return @SC86295 01880000 BAL 9,DECODEN Decode error message @SC86295 01881000 LR 9,2 @SC86295 01882000 L 0,WBUF Ptr to decoded message @BS86090 01883000 L 1,WBUFL @BS86090 01884000 L 14,EMSGP Ptr to msg buffer @BS86090 01885000 LA 15,LEMSG @BS86090 01886000 CR 1,15 @BS86090 01887000 BNH *+6 @BS86090 01888000 LR 1,15 Truncate msg @BS86090 01889000 ST 1,EMSGL Save effective length @BS86090 01890000 MVCL 14,0 Save in buffer @BS86090 01891000 L 1,EMSGP @BS86090 01892000 TR 0(LEMSG,1),ATOED Convert to EBCDIC @SC89301 01893000 INPUTABR SR 4,4 Look for end of table @SC86158 01894000 B INPUTQRT @SC86158 01895000 * 01896000 * CLKP - Subroutine to dispatch to routine from table lookup @SC86158 01897000 * R2->table, R4=char, R14->return if null entry in table @SC86158 01898000 * Each entry has AL1(char),AL3(adr), last char=00 @SC86158 01899000 CLKNXT LA 2,4(2) Next state @SC86158 01900000 CLKP CLM 4,1,0(2) Match? @SC86158 01901000 BE CLKF Yes, go do it @SC86158 01902000 CLI 0(2),0 01903000 BNE CLKNXT Not at the end yet @SC86158 01904000 CLKF ICM 2,7,1(2) Pick routine address @SC86158 01905000 BNZR 2 Go to that routine if any @SC86295 01906000 BR 14 Or fall down to caller @SC86158 01907000 * 01908000 * Retry sending same packet until success or abort @SC86276 01909000 SENDRTY LA 3,1(3) Increment retry counter @SC86276 01910000 CL 3,LIMTRY Did we retry enough? @SC86276 01911000 BNL INPUTABR Yes, abort if limit reached @SC86276 01912000 LA 15,1 @SC86276 01913000 AL 15,RTRCNT @SC86276 01914000 ST 15,RTRCNT Update retry count @SC86276 01915000 TM FL5,NAK0 @SC90037 01916000 BO SENDNAK Haven't sent anything yet @SC86276 01917000 KCALL SIO,E=SENDRTY Resend the same packet @SC86276 01918000 BR 2 Success, return @SC86276 01919000 * 01920000 * Subroutine to send a NAK 01921000 SENDNAK MVI STYPE,AN A NAK pkt 01922000 XC DATL,DATL no data 01923000 B SENDPK Send the packet @SC86276 01924000 * 01925000 * Subroutine to send an ACK 01926000 SENDACK XC DATL,DATL no data length 01927000 SENDACKL MVI STYPE,AY an ACK pkt 01928000 SR 3,3 Clear counter @SC86276 01929000 SENDPK KCALL SPACK,E=SENDRTY Send the packet @SC86276 01930000 BR 2 return 01931000 * 01932000 * Set up command to foreign server. Trade parms if necessary 01933000 IPKSET KCALL INTINI,4,E=INPUTABR Initialize for sending @SC87300 01934000 TM FL3,PXCH @SC86155 01935000 BO IPKFIN @SC86155 01936000 MVI SEQ,0 @SC86155 01937000 MVC LIMTRY,MAXTNT Limit for INIT retries @SC86345 01938000 KCALL RPARSET @SC86155 01939000 KCALL RPAR Our I packet to send @SC86155 01940000 ICM 8,8,STYPE Save packet type @SC86295 01941000 MVI STYPE,AI Packet type = initialize @SC86155 01942000 BAL 9,INPUTSPK Send RPAR and interpret response @SC86295 01943000 STCM 8,8,STYPE Restore packet type @SC86295 01944000 KCALL SPAR Interpret reply to our I packet @SC86155 01945000 IPKFIN MVI SEQ,0 Reset packet number @SC86155 01946000 MVC LIMTRY,MAXTRY Nominal retry limit @SC86295 01947000 B 12(8) Skip over 3-entry table @SC88074 01948000 IPKSKP XC DATL,DATL Pretend we got an empty ACK @SC89263 01948300 BR 9 ... and resume above @SC89263 01948600 * 01949000 * Subroutine to skip over white-space 01950000 WSP LM 6,7,LEN Length and address of input 01951000 LTR 6,6 Any more data left to scan? 01952000 BNPR 9 Nope, fail @SC86135 01953000 WSPLUP CLI 0(7),C' ' @SC86115 01954000 BE WSPNXT Skip a blank 01955000 CLI 0(7),NL 01956000 BNE WSPEND Skip a new-line char 01957000 WSPNXT LA 7,1(7) next char 01958000 BCT 6,WSPLUP decrement length 01959000 BR 9 01960000 * 01961000 WSPEND STM 6,7,LEN Save new non-white spot 01962000 B 4(9) Skip return 01963000 * 01964000 * Subroutine to get next token from commands 01965000 TOK LM 6,7,LEN Length and address of input 01966000 LTR 6,6 Any more data to tokenize? 01967000 BNPR 9 No, error return @SC86135 01968000 MVI BRK,C' ' Init break char @SC88306 01968500 * 01969000 TOKLUP CLI 0(7),C' ' @SC86115 01970000 BE TOKSKP Found a blank terminator 01971000 CLI 0(7),NL 01972000 BE TOKSKP Found a new-line terminator 01973000 CLI 0(7),C',' @SC86115 01974000 BNE TOKNXT Not a comma 01975000 C 7,ADR Is comma the first char? 01976000 BNE TOKSKP No, must be a token itself 01977000 TOKNXT LA 7,1(7) Next char 01978000 BCT 6,TOKLUP decrement remaining length 01979000 TOKSKP BCTR 6,0 remaining length of input 01980000 ST 6,LEN Save it for next time 01981000 LTR 6,6 Did we run off the end? @SC88306 01981200 BM *+10 Yes, nothing left @SC88306 01981400 MVC BRK,0(7) No, keep the break char for ref. @SC88306 01981600 LA 6,1(7) Next spot to scan @SC86224 01982000 S 7,ADR Length of token 01983000 ST 6,ADR Next spot to scan @SC86224 01984000 SR 6,7 @SC86224 01985000 BCTR 6,0 Address of token @SC86224 01986000 BCTR 7,0 Token length - 1 01987000 B 4(9) Skip return 01988000 * 01989000 * Subroutine to skip white-space and pick next token 01990000 WSPTOK BAL 9,WSP 01991000 B 0(14) Ran off the end @SC86135 01992000 BAL 9,TOK 01993000 B 0(14) No more tokens @SC86135 01994000 B 4(14) Skip return 01995000 * 01996000 * Interpret decimal number from string at (R6) of length=(R7) 01997000 * Clobber R4,R7,R15. Return value in R0 and skips if ok. 01998000 * If R15 changed, it points to first non-numeric character 01999000 GETNUM LTR 4,7 Copy length @SC86316 01999200 BNPR 14 Nothing, skip it @SC89218 01999400 C 4,F Length must be <16 @SC87012 02000000 BHR 14 @SC87012 02001000 BCTR 7,0 Change for EX @SC86316 02002000 LR 15,6 Don't lose pointer to input @SC86316 02003000 GETNUML CLI 0(15),C'0' @SC86316 02004000 BLR 14 Go if not numeric @SC86316 02005000 CLI 0(15),C'9' @SC86316 02006000 BHR 14 Go if not numeric @SC86316 02007000 LA 15,1(15) Bump input pointer @SC86316 02008000 BCT 4,GETNUML Go if more @SC86316 02009000 EX 7,GETNUMPK Pack the input @SC86316 02010000 CVB 0,TMPDW Convert to binary @SC86316 02011000 B 4(14) Return and skip @SC86316 02012000 GETNUMPK PACK TMPDW,0(,6) @SC86316 02013000 * 02014000 * Test for Ascii char range of 33-62 and 96-126, skip on return if ok 02015000 * Character must be in low byte of R4 02016000 CHKQR CLM 4,1,SPACE+3 @SC86120 02017000 BNHR 14 Cannot use control char or blank @SC86120 02018000 CLM 4,1,MOD64+3 @SC86120 02019000 BL 4(14) OK, 33-62 @SC86120 02020000 CLM 4,1,LOCASE+96 @SC86295 02021000 BLR 14 @SC86120 02022000 CLM 4,1,LOCASE+127 @SC86295 02023000 BNLR 14 @SC86120 02024000 B 4(14) OK, 96-126 @SC86120 02025000 * 02026000 * Subroutine to scan a parse table built by KW macro 02027000 * R6->word, R7=length-1, R1->table. Clobbers R14,R15 @SC90239 02027500 * hi byte of R7 is a flag for just lookup and return @SC91320 02027600 * 2nd byte of R7 is a code to look up (not word vs name) @SC91320 02027700 SCAN CLI 0(6),C'?' @SC86115 02028000 BE HELPKW 02029000 MVC OPRND,0(6) Copy token for lookup @SC87034 02030000 TR OPRND,UPCASE And convert to upper case @SC87034 02031000 SR 15,15 02032000 SCANLUP CLI KWLEN(1),254 @SC90239 02033000 BH 4(14) Return to caller if end @SC88168 02034000 BL *+12 Not a branch to new list @SC88168 02035000 ICM 1,7,KWADR(1) Yes, get ptr to new list @SC90239 02036000 B SCANLUP And resume search @SC87117 02037000 CLM 7,4,F0 @SC91320 02037600 BNE SCANCODE Signal for checking the codes @SC91320 02038200 CLM 7,1,KWMIN(1) Compare token length vs min abbr @SC90239 02039000 BL SCANNO Go if < min 02040000 CLM 7,1,KWLEN(1) Compare token and kw lengths @SC90239 02041000 BH SCANNO Go if length of token > kw's 02042000 EX 7,SCANCLC 02043000 BE SCANYES 02044000 SCANNO IC 15,KWLEN(,1) KW length - 1 @SC90239 02045000 LA 1,KWNAME+1(15,1) Space over name to next item @SC90239 02046000 B SCANLUP Continue checking 02047000 * 02048000 SCANCODE CLM 7,4,KWCODE(1) The right code? @SC91320 02048300 BNE SCANNO @SC91320 02048600 SCANYES CLM 7,8,F0 Flagged just to find entry? @SC86355 02049000 BNER 14 Yes, got it @SC86355 02050000 ICM 14,7,KWADR(1) No, get handler address @SC90239 02052000 BR 14 02053000 * 02054000 SCANCLC CLC KWNAME(,1),OPRND Compare token to KW @SC90239 02055000 * 02056000 * Utility routine to set up linkage 02057000 SUBENT LR KSUBBASE,15 CSECT addressibility @SC89268 02058000 KTRACE SUBENT @LM91008 02058200 L 15,STKPTR Current end of stack @SC86295 02059000 AR 0,15 Our needs @SC86295 02060000 C 0,STKLIM Does it fit? @SC86295 02061000 BH SUBDIE No, (that's incredible) @SC86295 02062000 ST 0,STKPTR New end @SC86295 02063000 CL 0,STKHI @SC89089 02063200 BNH *+8 @SC89089 02063400 ST 0,STKHI New high limit of stack usage @SC89089 02063600 ST 13,4(15) Link subroutines @SC86295 02064000 ST 15,8(13) @SC86295 02065000 LR 13,15 @SC86295 02066000 LR 1,0 End of local variables @SC87012 02067000 LA 0,72(15) Start=end of save area @SC87012 02068000 SR 1,0 @SC87012 02069000 BNP *+8 No locals @SC87012 02070000 SR 15,15 @SC87012 02071000 MVCL 0,14 Zero-fill all locals @SC87012 02072000 L 15,4(13) @SC87012 02073000 LM 0,1,20(15) Restore R0,R1 @SC87012 02074000 BR 14 Go @SC86295 02075000 SUBDIE LM 14,12,12(13) @SC86295 02076000 LA 15,1 @SC87012 02077000 LCR 15,15 Set return code = -1 @SC87012 02078000 BR 14 Go @SC86295 02079000 * 02080000 * Common exit code 02081000 RETSNRC MVI BCTU,1 Reset chksum at end of transfer @SC86295 02082000 MVC BCTOFF,F0 (and flag) @SC92085 02082200 ST 0,KAFUNC Save for KACCT call @AB89191 02082500 KCALL INTINI,0 Close line for transfer @SC86295 02083000 KCALL SUPFNC,10 Get time @SC86295 02084000 S 15,SECTOT Take elapsed time @SC86295 02085000 BNM *+8 Ok, no wrap @SC86345 02086000 A 15,=F'1759218604' Wraps by 2**44/10000 @SC86345 02087000 ST 15,CSECTOT Save elapsed time in csec @SC86345 02088000 SR 14,14 @SC86295 02089000 LA 0,100 @SC86295 02090000 DR 14,0 Convert to sec @SC86295 02091000 AR 14,14 Check remainder @SC86295 02092000 CR 14,0 @SC86295 02093000 BL *+8 @SC86295 02094000 A 15,F1 Round up @SC86295 02095000 ST 15,SECTOT @SC86295 02096000 ICM 15,15,KAEXIT R15 -> stats exit routine @AB89191 02096100 BZ RTRN0 0 ==> no exit supplied @AB89191 02096200 L 0,KAFUNC R0 = SEND/RECEIVE indicator @AB89191 02096300 LA 1,NSENTAC R1 -> file transfer statistics @AB89191 02096400 LA 2,TRMLIN R2 -> current LINE definition @AB89191 02096500 BALR 14,15 Call accounting exit @AB89191 02096600 B RTRN0 @SC86295 02097000 WXTRN KACCT @AB89191 02097200 KAEXIT DC AL4(KACCT) Accounting exit (if supplied) @AB89191 02097400 RTRNUM BAL 14,LDERR Fetch error code @SC87117 02098000 B RTRN @SC87117 02099000 RTRN2 LA 15,2 Indicate error @SC86295 02100000 B RTRN @SC86295 02101000 RTRNM1 SR 15,15 Error = -1 @SC86295 02102000 BCTR 15,0 @SC86295 02103000 B RTRN @SC86295 02104000 RTRN0 SR 15,15 No errors @SC86295 02105000 B RTRN @SC86295 02106000 SUBERR WTEXT (3),(4) Print prepared message @SC86295 02107000 RTRN1 LA 15,1 Indicate error @SC86295 02108000 RTRN ST 13,STKPTR Free the storage @SC86295 02109000 L 13,4(13) Unlink @SC86295 02110000 KTRACE EXIT @LM91008 02110200 L 14,12(13) Restore registers @SC86295 02111000 LM 0,12,20(13) @SC86295 02112000 LTR 15,15 Test return code @SC86295 02113000 BR 14 @SC86295 02114000 * 02115000 * Subroutine to fetch error code (but 0 if no transfers yet) 02116000 LDERR SR 15,15 02117000 CLI ERRNUM,ERRNFT No file transfer isn't an error @HF86157 02118000 BER 14 @HF86157 02119000 IC 15,ERRNUM Return status code @HF86157 02120000 BR 14 @HF86157 02121000 * 02122000 * Subroutine to decode without disk-write 02123000 DECODEN NI FL1,255-EOF No EOF yet 02124000 XC WBUFL,WBUFL No data in WBUF yet 02125000 MVI LCKOLD,0 Start at normal state @SC91275 02125300 MVI DECESCP,0 @SC91275 02125600 OI FL1,NAME No disk-writes 02126000 KCALL DECODE Decode data into WBUF @SC86135 02127000 NI FL1,255-NAME Turn this off 02128000 BR 9 @SC86295 02129000 * 02130000 * Subroutine to encode without disk-read 02131000 ENCODEN XC RBUFP,RBUFP Start encoding at beg of RBUF 02132000 MVI LCKOLD,0 Start at normal state @SC91275 02132500 OI FL1,NAME Indicate not to do disk reads 02133000 KCALL ENCODE Encode it into DATA @SC86135 02134000 NI FL1,255-NAME Turn this off 02135000 LTR 15,15 Did it work? @SC89072 02135300 BP INPUTABR No, something awful happened @SC89072 02135600 BR 9 @SC86295 02136000 * 02137000 * Subroutine to display the contents of the KW tables 02138000 * R1->table. Clobbers 1,2,3,4,7,15. Return via R14 @SC90239 02138500 HELPKW SR 7,7 token length holder 02139000 LA 2,16 Tab width for display @SC86295 02140000 LA 3,CMD+79 Display buffer limit offset @SC86295 02141000 LR 4,1 KW table address 02142000 WTEXT '&ONEFOLL' @SC92300 02143000 HELPNL LA 1,CMD+1 Display buffer offset @SC86295 02144000 MVI CMD,C' ' Start blanking it @SC86115 02145000 MVC CMD+1(79),CMD blank 80 chars 02146000 HELPNT CLI KWLEN(4),254 @SC90239 02147000 BH HELPEND Return if end of tokens @SC88168 02148000 BL *+12 Not branch to other list @SC88168 02149000 ICM 4,7,KWADR(4) Yes, get ptr to new list @SC90239 02150000 B HELPNT And resume scan @SC87117 02151000 IC 7,KWLEN(4) Length-1 of current token @SC90239 02152000 IC 15,KWMIN(,4) Min abbreviation length - 1 @SC90239 02154000 EX 7,HELPMVC move it to display buffer 02155000 LA 4,KWNAME+1(7,4) Skip to next token in KW table @SC90239 02156000 MVI 15(1),C' ' Move a blank separator @SC86115 02157000 TR 0(15,1),LOCASE Make everthing lower case @SC86295 02158000 EX 15,TRUPCAS Upper case the minimum @SC86295 02159000 BXLE 1,2,HELPNT Loop if more room on line @SC86295 02160000 WTEXT CMD,80 display one line of tokens 02161000 B HELPNL and continue with next line 02162000 * 02163000 HELPEND LA 0,CMD+1 @SC86295 02164000 CR 6,0 Is there anything accumulated? @SC86295 02165000 BER 14 No, display buffer empty @SC86135 02166000 WTEXT CMD,80 02167000 BR14 BR 14 02168000 * 02169000 HELPMVC MVC 0(,1),KWNAME(4) Copy KW @SC90239 02170000 * 02171000 * Subroutine to compress a file specification @HF86223 02172000 PAKFIL LA 1,PREFIX Start with prefix @HF86223 02173000 L 7,RBUF Put FN here for encode @SC86155 02174000 BAL 14,PAKFOR @SC86295 02175000 LA 0,FFENC @SC86295 02176000 KCALL FSPEC,FILNAM Copy name with possible override @SC86295 02177000 LR 7,15 New output ptr @SC86295 02178000 LA 1,SUFFIX Finish with suffix @SC86224 02179000 BAL 14,PAKFOR @SC86295 02180000 S 7,RBUF Length of buffer @SC86155 02181000 ST 7,RBUFL @SC86155 02182000 BR 9 @HF86223 02183000 * 02184000 * Subroutine to append characters to the filespec @HF86223 02185000 PAKFOR SR 2,2 Number of characters to append @HF86223 02186000 ICM 2,1,0(1) Probably none @HF86223 02187000 BZR 14 @SC86295 02188000 BCTR 2,0 Copy into buffer @HF86223 02189000 EX 2,PAKRMV @HF86223 02190000 EX 2,PAKRTR And ASCII it @HF86223 02191000 LA 7,1(2,7) New end of string @HF86223 02192000 BR 14 @SC86295 02193000 * 02194000 PAKRMV MVC 0(0,7),1(1) @HF86223 02195000 PAKRTR TR 0(0,7),ETOAD @SC89301 02196000 * 02197000 * Routines to add decimal and string arguments to a buffer @SC86209 02198000 * Input: R15->insert point, R4=dec. value, R2->return @SC86209 02199000 EDDEC CVD 4,TMPDW Get packed decimal @SC86209 02200000 MVC 0(10,15),=X'40202020202020202120' @SC86209 02201000 LA 9,10(15) End of possible string @SC86209 02202000 LA 1,9(15) Last possible start of signif. @SC86209 02203000 EDMK 0(10,15),TMPDW+3 @SC86209 02204000 LTR 4,4 Check sign @SC86209 02205000 BNM EDDPOS @SC86209 02206000 BCTR 1,0 Back up and insert minus @SC86209 02207000 MVI 0(1),C'-' @SC86209 02208000 EDDPOS LR 8,1 Start @SC86209 02209000 SR 9,8 Length @SC86209 02210000 * R8->argument string, R9=length @SC86209 02211000 EDCHAR EX 9,EDCHRMV Copy string to buffer (1 extra) @HF86223 02212000 AR 15,9 Update output ptr @SC86209 02213000 BR 2 @SC86295 02214000 EDCHRMV MVC 0(0,15),0(8) Copy string to buffer @HF86223 02215000 * 02216000 * Enter here with R7->position in CMD, R1->filespec. Return to (R2). 02217000 STAFSP LA 0,FFDSP @SC86295 02218000 KCALL FSPEC Copy name for display @SC86295 02219000 STAPM15 LR 0,15 Output ptr @BS86090 02220000 STAPMSG LA 1,CMD Start of string @SC86295 02221000 SR 0,1 Get length @SC86295 02222000 WTEXT (1),(0) @SC86295 02223000 BR 2 @SC86295 02224000 * 02225000 TRUPCAS TR 0(,1),UPCASE Upcase @SC86158 02227000 * 02228000 * Main command loop implementation of TAKE files 02271000 USING SERVERSV,13 Uses locals of caller, e.g. SERVER@SC86295 02272000 LOOPS STM 0,1,RETADR Initialize for main loop @SC86295 02273000 BR 14 @SC86295 02274000 * 02275000 LUPERK BCT 15,LUPBAD Go if bad operand: try on system @SC86171 02276000 MVI ERRNUM,ERRKCE Kermit command error 02277000 OI FL5,CMERR Note error @SC86295 02278000 B LOOP @SC86295 02279000 LOOP0 CLI ERRNUM,ERRKCE Stale error? @SC86295 02280000 BNE LOOP No, keep old error code @SC86295 02281000 MVI ERRNUM,ERRNOE Clear old error condition @SC86295 02282000 B LOOP @SC86295 02283000 LUPFNF MVI ERRNUM,ERRFNF File not found @SC86295 02284000 B LUPWRTE @SC86239 02285000 LUPINV MVI ERRNUM,ERRKCE Invalid command @SC86239 02286000 LUPWRTE OI FL5,CMERR Note error @SC86171 02287000 LUPWRT WTEXT (3),(4) @SC86355 02288000 * 02289000 LOOP MVC OLDERR,ERRNUM @SC86171 02290000 ICM 2,15,TAKLEV Get current TAKE level @SC86295 02291000 BZ LUPEX @SC86295 02292000 BCTR 2,0 @SC86295 02293000 SLA 2,2 Get offset into table @SC86295 02294000 LA 2,TAKTAB(2) Point into TAKE file table @SC86295 02295000 TM FL5,CMERR+TKHLT @SC86239 02296000 BO LUPREX Quit reading on error @SC86239 02297000 NI FL5,255-CMERR-TKMSG Clear error flag @SC86239 02298000 READF 0(2),NONUM,E=LUPRER @SC88101 02299000 LA 1,CMD Ptr to buffer, R0 = length @SC86171 02300000 LR 3,1 @SC88006 02300100 AR 3,0 Get end of buffer @SC88006 02300200 BCTR 3,0 @SC88006 02300300 CLI 0(3),C' ' Find last non-blank @SC88006 02300400 BE *-6 @SC88006 02300500 LA 0,1(3) One past end of buffer @SC88006 02300600 SR 0,1 Get trimmed length @SC88006 02300700 BNP LOOP Nothing there, ignore it @SC88006 02300800 B LUPPRS Go parse 02301000 * 02302000 LUPRER C 15,F12 EOF code? 02303000 BE LUPCLO Yes, close the file 02304000 ERRF , Analyze the error @SC87338 02305000 LUPREX OI FL5,CMERR Note error @SC86171 02306000 TM FL5,TKMSG Already issued message? @SC86239 02307000 BO LUPCLO Don't overdo it @SC86239 02308000 WTEXT '&ERRTAKE' @SC86239 02309000 OI FL5,TKMSG @SC86239 02310000 LUPCLO CLOSF (2) Close the file @SC86135 02311000 L 2,TAKLEV Get TAKE level 02312000 BCTR 2,0 And decrement it 02313000 ST 2,TAKLEV 02314000 B LOOP 02315000 * 02316000 LUPEX NI FL5,255-CMERR-TKMSG Clear error flag @SC86239 02317000 L 14,RETADR @SC86295 02318000 BR 14 02319000 * 02320000 LUPKRM TM FL5,KRMONLY Already seen KERMIT prefix? @SC90059 02320200 BO LUPBAD Yes, let's not clown around @SC90059 02320400 OI FL5,KRMONLY Override SYSCMD option for now @SC90059 02320600 B LUPTOK @SC90059 02320800 LUPPRS DS 0H @SC87034 02321000 STM 0,1,SCANPTR Save for parser @SC86171 02322000 NI FL5,255-KRMONLY Allow possibility of host cmd @SC90059 02322500 LTR 2,2 @SC86171 02323000 BZ LUPTOK Not from TAKE @SC86171 02324000 TM FL2,ECHO @SC86171 02325000 BNO LUPTOK Not echoing @SC86171 02326000 WTEXT (1),(0) Echo to terminal @SC86171 02327000 LUPTOK MVC SCANSV,SCANPTR Save for system @SC86295 02328000 NTOKN N=LOOP 02329000 CLI 0(6),C'*' @SC86115 02330000 BE LOOP Go if comment 02331000 L 1,CMDPTR @SC86295 02332000 SCAN (1),LOOP @SC86295 02333000 LUPBAD PTEXT '&KCMDERR' @SC92300 02334000 TM FL2,PASS @SC86295 02335000 BZ LUPINV Don't try as system cmd @SC86295 02336000 TM FL5,KRMONLY KERMIT prefix? @SC90059 02336300 BO LUPINV Yes, don't try as system cmd @SC90059 02336600 MVC SCANPTR,SCANSV Restore string ptrs @SC86295 02337000 OI FL4,UCMD @SC86295 02338000 KCALL SUPFNC,3,E=(LOOP,NM) And execute it @SC86295 02339000 B LUPINV @SC86295 02340000 * 02341000 LUPSET KCALL SET,E=LUPERK Call SET routine @SC86295 02342000 B LOOP0 @SC86295 02343000 * 02344000 LUPSHO KCALL SHOW,E=LUPERK Call SHOW routine @SC86295 02345000 B LOOP0 @SC86295 02346000 * 02346200 LUPVERS PTEXT 'Kermit-&KSYS Version &KVRSN..&KEDIT &KTAG (&KDATE.)' 02346400 B LUPWRT @SC90339 02346600 * 02347000 LUPCWD KCALL CWDSET,E=LUPERK @SC86295 02348000 B LOOP0 @SC86295 02349000 * 02350000 LUPHNTS KCALL HINTS @SC91295 02350200 B LOOP0 @SC91295 02350400 * 02350600 LUPGIV KCALL GIVTAB,E=LUPERK @SC87117 02351000 B LOOP0 @SC87117 02352000 * 02353000 LUPTAK BAL 9,LUPTINS Look for file @SC86295 02354000 B LUPFNF Not found @SC86295 02355000 MVI ERRNUM,ERRNOE No error @SC86295 02356000 B LOOP OK @SC86295 02357000 * 02358000 LUPTIN STM 1,2,SCANPTR Set up scan @SC86295 02359000 LUPTINS SR 0,0 Flags for TAKE parsing @SC86295 02360000 KCALL FSPEC,FILNAM Get filespec @SC86295 02361000 BAL 14,LUPCKFN @SC86295 02362000 LR 3,9 Save return @SC86295 02363000 BAL 14,LUPCNF Check for illegal extras @SC86295 02364000 LR 9,3 @SC86295 02365000 PTEXT '&MAXNEST' @SC92300 02366000 L 5,TAKLEV Current TAKE level @SC86295 02367000 LA 14,TAKMAX @SC86295 02368000 CR 5,14 @SC86295 02369000 BNL LUPINV @SC86239 02370000 SLA 5,2 Offset into table @SC86295 02371000 LA 5,TAKTAB(5) Point into table of TAKE files @SC86295 02372000 PTEXT '&NOTFOUN' In case of error @SC92300 02373000 MVI ERRNUM,ERRFNF In case of error @SC86171 02374000 OPENF I,FILNAM,TAKFDB,0(5),E=0(9) @SC86295 02375000 PTEXT '&TAKLOOP' @SC86239 02376000 USING FDBD,1 @SC86295 02377000 TM FDBFLGS,FDBACTV Check for file active already @SC86295 02378000 DROP 1 @HF86232 02379000 BZ LUPTIOK @SC86295 02380000 CLOSF (5) @SC86295 02381000 BR 9 @SC86295 02382000 LUPTIOK L 3,TAKLEV Get current take level 02383000 LA 3,1(3) And increment 02384000 ST 3,TAKLEV 02385000 B 4(9) @SC86295 02386000 * 02387000 LUPCKFN LTR 15,15 @SC86295 02388000 BZR 14 No problem, R15=0 @SC86295 02389000 BCT 15,LUPINV Error, R15>1 @SC86295 02390000 B LUPWRTE Help requested, R15=1 @SC86295 02391000 * 02392000 LUPSTA BAL 14,LUPCNF Check for illegal extras @SC86295 02393000 MVC ERRNUM(2),OLDERR Restore from last command @SC92210 02394000 KCALL STATUS Write error message @SC86156 02395000 B LOOP0 @SC86295 02396000 * 02397000 LUPSPA KCALL DSPACE @SC86164 02398000 B LOOP0 @SC86295 02399000 * 02400000 LUPDMP KCALL DUMP,E=LUPERK Dump translation table @SC86156 02401000 B LOOP0 @SC86295 02402000 * 02402200 LUPSIM KCALL SIMLAT,E=LUPERK Replay file as packet input @SC91312 02402400 B LOOP0 @SC91312 02402600 * 02403000 LUPHSTI DS 0H @SC86295 02404000 AIF ('&TYPCMD' EQ 'TYPE').TYPOK @SC86295 02405000 MVC 0(,6),=CL16'&TYPCMD' Use right name @SC86295 02406000 EX 7,*-6 @SC86295 02407000 .TYPOK A 7,LEN Add remaining to token length 02408000 LA 5,2(7) Plus one for separator @SC86171 02409000 STM 5,6,SCANPTR Reset for tokenizer @SC86171 02410000 LUPHST PTEXT '&SYSCMND' @SC86295 02411000 FTOKN H=LUPWRTE,N=LUPINV Point to command @SC86239 02412000 LA 1,3 Execute host command @SC86316 02413000 LUPSYS OI FL4,UCMD User command, check for EXEC's @SC86316 02414000 PTEXT '&BADSCMD' @SC86295 02415000 KCALL SUPFNC,E=(LUPWRTE,M) Execute it @SC86295 02416000 B LOOP 02417000 AIF ('&KSYS' NE 'CMS').CM1Z @SC86355 02418000 * 02419000 LUPCP PTEXT '&CPCMND' @SC92300 02420000 FTOKN N=LUPINV,H=LUPWRTE @SC86295 02421000 LR 0,7 @SC86295 02422000 LA 1,4 @SC86295 02423000 B LUPSYS @SC86295 02424000 .CM1Z ANOP 02425000 * 02426000 LUPCNF FTOKN N=0(14),H=LUPCRH @SC86295 02427000 PTEXT '&EXTRAOP' @SC86295 02428000 B LUPINV @SC86295 02429000 LUPCRH PTEXT '&NOOPERS' @SC90179 02430000 B LUPWRTE @SC86295 02431000 DROP 13 02432000 GRDATA DC &S1CMD,X'70' @SC90264 02434000 GRDL EQU *-GRDATA @SC87215 02435000 XLFCT DC A(KMAXF) Extended packet size base @SC86202 02436000 AKMIN DC A(KMIN) Packet min size @SC86295 02437000 AMAXRT DC A(MAXRT) Longest terminal read @SC86295 02439000 AMAXRS DC A(MAXRS) Longest fullscreen read @SC90277 02439500 F64KP DC A(((&MAXLR+7+5+4)/8)*8) Size of disk buffers @SC87351 02440000 F0 DC F'0' 02441000 F1 DC F'1' 02442000 F2 DC F'2' 02443000 F3 DC F'3' @SC86295 02444000 F4 DC F'4' @SC86295 02445000 F5 DC F'5' 02446000 F8 DC F'8' 02447000 F12 DC F'12' 02448000 F64 DC F'64' 02449000 BLANK EQU F64+3 EBCDIC blank @SC86295 02450000 F DC F'15' 02451000 MOD64 DC F'63' 02452000 F256 DC F'256' 02453000 FLFID1 DC A(ACTLEN) Length of items in filespec table @SC91172 02453500 SPACE DC A(ABL) ASCII SPACE 02454000 LOBIT DC X'0000007F' 02462000 * Parameter defaults. Must map directly into DEFPARM etc. 02463000 KSYSTF , @SC86295 02464000 DS 0F --------Init for LOG file @SC86295 02465000 DC A(0) Buffer ptr @SC86295 02466000 DC A(LPKT) Buffer length @SC86295 02467000 FDBPAT ,V,LPKT Default disk RECFM, etc. @SC88120 02468000 DS 0F --------Init for SEND/RECEIVE file @SC86295 02471000 DC A(0) Addr of FSWRITE buffer @SC86295 02472000 DC F'&MAXLR' Buffer length @SC89215 02473000 FDBPAT ,V,80 Default disk RECFM, etc. @SC88120 02474000 DS 0F --------Init for TAKE file (read-only) @SC86295 02477000 DC A(0) Buffer ptr (CMD) @SC86295 02478000 DC F'256' Max buffer size @SC86295 02479000 FDBPAT ,V Default disk RECFM (no LRECL) @SC88120 02480000 * 02481000 IMAXTNT DC F'16' Retry limit during setup @SC86345 02482000 IMAXTRY DC F'5' Retry limit during transfer @SC86164 02483000 ILCLDLY DC F'10' Time to wait before sending @SC86164 02484000 IBAUD DC F'1200' Assumed baud rate @SC88325 02484500 IRPSIZ DC A(KMAX) Max receive size @SC86295 02485000 ISPSIZ DC A(KDEF) Max send size @SC86295 02487000 IMAXOUT DC F'&MAXLR' Max output buffer @SC86268 02488000 * Send mode Rpack interpret input table @SC89263 02488100 ISNDST DC AL1(AY),AL3(0) Micro ACK'd @SC89263 02488200 DC XL1'FF',AL3(SNDABR) Stop @SC89263 02488300 DC AL1(AN),AL3(INPUTMIS) Repeated trigger packet @SC89263 02488400 DC AL1(00),AL3(SNDABR) Error routine @SC89263 02488500 ITRMLIN DC CL8' ' Current data line @SC87166 02489000 IATFLG DC 9X'FF' Attribute-honoring flags @SC91109 02489500 ITYPFIL DC C'T' Type of file (T,B,V,D),see BINF @SC86151 02490000 ICLSNFL DC C'O' Collision default is OVERWRITE @SC90033 02490200 ITRNCFL DC C'T' Truncate by default (vs. F or H) @SC88120 02490500 IDEFPRM DC AL1(KDEF+ABL,ABL,ABL,64,CR+ABL,A#,AN,A1,ABL,ABL) SC86149 02491000 DC AL1(ABL,ABL,ABL,ABL) Extended size defaults @TB86196 02492000 DC X'0' Capabilities of micro RCAPA @SC86295 02493000 DC X'28' Capabilities I have SCAPA @SC91275 02494000 LONGP EQU X'02' LONGP bit in CAPAS flags @TB86196 02495000 MORCAPAS EQU X'01' More CAPAS bytes exist @TB86196 02496000 DC AL1(CR) EOL char I need (cr) REOL @SC86295 02497000 DC AL1(CR) EOL I'll send SEOL @SC86295 02498000 DC AL1(SOH) Incoming pkt start char RMARK @SC86295 02499000 DC AL1(SOH) Outbound pkt start char SMARK @SC86295 02500000 DC AL1(A#) Micro's ctl-quote char RCTLQ @SC86295 02501000 DC AL1(A#) Ctl-quote char we'll use SCTLQ @SC86295 02502000 DC AL1(AAMP) Orig 8-bit quote char EBQC @SC86295 02503000 DC AL1(5) Time limit - micro to wait RTIMO @SC86295 02504000 DC AL1(0) Timeout, if we can do it TIMOUT @SC86295 02505000 DC AL1(120) Timeout, if we can do it TIMOSRV@SC90045 02505100 DC AL1(0) Recieve parity is MARK RPRTY @SC88288 02505300 DC AL1(DAT8) Send parity is NONE SPRTY @SC88288 02505600 DC C'1' User requested chk type BCTC @SC92085 02506000 DC AL1(ATIL) Original repeat prefix RPTQC @SC86295 02507000 DC &AEACMD,AL2(8),X'0F02' D/O strct fld AEADAT @SC90173 02508000 DC X'0',X'00',AL2(1) D/O id is 1 AEAFLG @SC90173 02508300 DC AL2(7+2),X'0F1F',X'00C000' Not spanned AEABUFL@SC90173 02508600 DC &S1CMD,AL1(SBA),X'5D7F',AL1(SBA),X'0005' S1DATA @SC90264 02509000 COMMON CSECT Resume addressible constants @SC89215 02511200 MAXLRC DC F'&MAXLR' Max lrecl @SC89215 02511400 AKMAX DC A(KMAX) Normal packet maximum @SC89215 02511600 MAXBSZ DC F'&MAXBS' Max blksiz @SC86268 02512000 BUFSIZ DC Y(LPKT) Length of packet buffers @SC86190 02513000 * 02514000 IS1EOL DC AL1(CR) In case micro lost one S1EOL @SC90173 02514300 DC AL1(XON) Handshake for micro S1HND @SC90173 02514600 * Constants for COMMON 02515000 LTORG 02516000 * Translation for conversion to hex notation @SC86156 02517000 TRHEX EQU *-240 @SC86156 02518000 DC C'0123456789ABCDEF' @SC86156 02519000 * ASCII to EBCDIC translate table 02520000 ATOED HTBL 00,01,02,03,37,2D,2E,2F,16,05,25,0B,0C,0D,0E,0F 0 C89268 02521000 HTBL 10,11,12,13,3C,3D,32,26,18,19,3F,27,1C,1D,1E,1F 1 C89268 02522000 HTBL 40,5A,7F,7B,5B,6C,50,7D,4D,5D,5C,4E,6B,60,4B,61 2 C89268 02523000 HTBL F0,F1,F2,F3,F4,F5,F6,F7,F8,F9,7A,5E,4C,7E,6E,6F 3 C89268 02524000 HTBL 7C,C1,C2,C3,C4,C5,C6,C7,C8,C9,D1,D2,D3,D4,D5,D6 4 C89268 02525000 HTBL D7,D8,D9,E2,E3,E4,E5,E6,E7,E8,E9,AD,E0,BD,5F,6D 5 C89268 02526000 HTBL 79,81,82,83,84,85,86,87,88,89,91,92,93,94,95,96 6 C89268 02527000 HTBL 97,98,99,A2,A3,A4,A5,A6,A7,A8,A9,C0,4F,D0,A1,07 7 C89268 02528000 HTBL 00,01,02,03,37,2D,2E,2F,16,05,25,0B,0C,0D,0E,0F 8 C89268 02529000 HTBL 10,11,12,13,3C,3D,32,26,18,19,3F,27,1C,1D,1E,1F 9 C89268 02530000 HTBL 40,5A,7F,7B,5B,6C,50,7D,4D,5D,5C,4E,6B,60,4B,61 A C89268 02531000 HTBL F0,F1,F2,F3,F4,F5,F6,F7,F8,F9,7A,5E,4C,7E,6E,6F B C89268 02532000 HTBL 7C,C1,C2,C3,C4,C5,C6,C7,C8,C9,D1,D2,D3,D4,D5,D6 C C89268 02533000 HTBL D7,D8,D9,E2,E3,E4,E5,E6,E7,E8,E9,AD,E0,BD,5F,6D D C89268 02534000 HTBL 79,81,82,83,84,85,86,87,88,89,91,92,93,94,95,96 E C89268 02535000 HTBL 97,98,99,A2,A3,A4,A5,A6,A7,A8,A9,C0,4F,D0,A1,07 F C89268 02536000 * EBCDIC to ASCII translate table 02537000 ETOAD HTBL 00,01,02,03,00,09,00,7F,00,00,00,0B,0C,0D,0E,0F 0 C89268 02538000 HTBL 10,11,12,13,00,00,08,00,18,19,00,00,1C,1D,1E,1F 1 C89268 02539000 HTBL 00,00,00,00,00,0A,17,1B,00,00,00,00,00,05,06,07 2 C89268 02540000 HTBL 00,00,16,00,00,00,00,04,00,00,00,00,14,15,00,1A 3 C89268 02541000 HTBL 20,00,00,00,00,00,00,00,00,00,5C,2E,3C,28,2B,7C 4 C89268 02542000 HTBL 26,00,00,00,00,00,00,00,00,00,21,24,2A,29,3B,5E 5 C89268 02543000 HTBL 2D,2F,00,00,00,00,00,00,00,00,7C,2C,25,5F,3E,3F 6 C89268 02544000 HTBL 00,00,00,00,00,00,00,00,00,60,3A,23,40,27,3D,22 7 C89268 02545000 HTBL 00,61,62,63,64,65,66,67,68,69,00,7B,00,00,00,00 8 C89268 02546000 HTBL 00,6A,6B,6C,6D,6E,6F,70,71,72,00,7D,00,00,00,00 9 C89268 02547000 HTBL 00,7E,73,74,75,76,77,78,79,7A,00,00,00,5B,00,00 A C89268 02548000 HTBL 00,00,00,00,00,00,00,00,00,00,00,00,00,5D,00,00 B C89268 02549000 HTBL 7B,41,42,43,44,45,46,47,48,49,00,00,00,00,00,00 C C89268 02550000 HTBL 7D,4A,4B,4C,4D,4E,4F,50,51,52,00,00,00,00,00,00 D C89268 02551000 HTBL 5C,00,53,54,55,56,57,58,59,5A,00,00,00,00,00,00 E C89268 02552000 HTBL 30,31,32,33,34,35,36,37,38,39,7C,00,00,00,00,00 F C89268 02553000 * Table to remove 8th bit (overlaps LOCASE following) @SC87253 02554000 OFF80 DC 128AL1(*-OFF80) @SC87253 02555000 * Table to convert EBCDIC text to lower case 02556000 LOCASE DC 256AL1(*-LOCASE) @SC91316 02557000 LOCASE TBLFIX ABCDEFGHIJKLMNOPQRSTUVWXYZ, @SC91316.02558000 abcdefghijklmnopqrstuvwxyz @SC91316 02559000 * Table to convert EBCDIC text to upper case @SC89215 02561100 UPCASE DC 256AL1(*-UPCASE) @SC91316 02561200 UPCASE TBLFIX abcdefghijklmnopqrstuvwxyz, @SC91316.02561300 ABCDEFGHIJKLMNOPQRSTUVWXYZ @SC91316 02561400 ETCETERA CSECT @SC90278 02561620 * A-to-E table based on Hollerith cards @SC90278 02561640 ATOEKP HTBL 00,01,02,03,37,2D,2E,2F,16,05,25,0B,0C,0D,0E,0F 0 C90278 02561660 HTBL 10,11,12,13,3C,3D,32,26,18,19,3F,27,1C,1D,1E,1F 1 C90278 02561680 HTBL 40,4F,7F,7B,5B,6C,50,7D,4D,5D,5C,4E,6B,60,4B,61 2 C90278 02561700 HTBL F0,F1,F2,F3,F4,F5,F6,F7,F8,F9,7A,5E,4C,7E,6E,6F 3 C90278 02561720 HTBL 7C,C1,C2,C3,C4,C5,C6,C7,C8,C9,D1,D2,D3,D4,D5,D6 4 C90278 02561740 HTBL D7,D8,D9,E2,E3,E4,E5,E6,E7,E8,E9,4A,E0,5A,5F,6D 5 C90278 02561760 HTBL 79,81,82,83,84,85,86,87,88,89,91,92,93,94,95,96 6 C90278 02561780 HTBL 97,98,99,A2,A3,A4,A5,A6,A7,A8,A9,C0,6A,D0,A1,07 7 C90278 02561800 HTBL 20,21,22,23,24,15,06,17,28,29,2A,2B,2C,09,0A,1B 8 C90278 02561820 HTBL 30,31,1A,33,34,35,36,08,38,39,3A,3B,04,14,3E,E1 9 C90278 02561840 HTBL 41,42,43,44,45,46,47,48,49,51,52,53,54,55,56,57 A C90278 02561860 HTBL 58,59,62,63,64,65,66,67,68,69,70,71,72,73,74,75 B C90278 02561880 HTBL 76,77,78,80,8A,8B,8C,8D,8E,8F,90,9A,9B,9C,9D,9E C C90278 02561900 HTBL 9F,A0,AA,AB,AC,AD,AE,AF,B0,B1,B2,B3,B4,B5,B6,B7 D C90278 02561920 HTBL B8,B9,BA,BB,BC,BD,BE,BF,CA,CB,CC,CD,CE,CF,DA,DB E C90278 02561940 HTBL DC,DD,DE,DF,EA,EB,EC,ED,EE,EF,FA,FB,FC,FD,FE,FF F C90278 02561960 TITLE 'Variable storage for Kermit-370' 02562000 &STORDS DSECT , @SC89268 02563000 STORAG EQU * @SC89268 02563500 KTRACE STORAG @LM91008 02563600 * - - - Translate tables (user-settable or program-modified) 02564000 TRTBL DS CL256 For finding blanks @SC86295 02565000 ATOE DS CL256 For converting to EBCDIC @SC86295 02566000 ETOA DS CL256 For converting to ASCII @SC86295 02567000 TATOE DS CL256 For converting packets to EBCDIC @SC87117 02568000 TETOA DS CL256 For retrieving input ASCII @SC87117 02569000 * - - - Variables initialized to zeroes 02572000 SCANPTR DS 0D Len and address of parse buffer 02573000 LEN DS F 02574000 ADR DS F 02575000 SCANSV DS D Saved len and adr @SC86295 02576000 CMD DS CL256 Buffer @SC86121 02577000 CBUF DS A Address of CP response buffer @SC86121 02578000 MSNDBUF DS A Adr of filespec buffer @SC88306 02578300 MSNDPTR DS A Scan ptr for readout @SC88306 02578600 AEPTRS DS 2A Tables to use (normal or "T") @SC92352 02578800 DATL DS F Send packet size @SC86121 02579000 KBYTES DS F Size of current file @SC86158 02581000 FDATE DS XL7 Date/time of current file @SC88235 02581500 * Program flags @SC86316 02582000 FL1 DS X @SC86316 02583000 TSTF EQU X'80' Special option for debugging @SC86295 02584000 ROVR EQU X'40' Overwrite sent filename 02585000 REN EQU X'20' Rename incoming file 02586000 KEEP EQU X'10' Keep incomplete files @SC90037 02587000 NAME EQU X'08' Encoding/decoding a name 02588000 BINF EQU X'04' Binary data 02589000 EOF EQU X'02' End-of-file 02590000 DEBUG EQU X'01' Debug mode ON 02591000 FL2 DS X @SC86316 02592000 FOPTS EQU X'80' Found file options @SC89218 02592500 TABS EQU X'40' Expand tabs 02593000 EOFZ EQU X'20' Truncate at ^Z for EOF 02594000 SRV EQU X'10' In SERVER mode 02595000 PASS EQU X'08' Try 'illegal' cmds on system @SC86295 02596000 ECHO EQU X'04' Echo TAKE files @SC86171 02597000 PROTO EQU X'02' Line ready for transfers @SC86295 02598000 DAT8 EQU X'01' 8-bit data line @SC86316 02599000 *--- DAT8 is now used only in RPRTY/SPRTY @SC88288 02599500 FL3 DS X @SC86316 02600000 ZPRO EQU X'80' Stop protocol mode pronto @SC88074 02600500 SVATT EQU X'40' Preserve attributes of old files @SC90033 02600700 PXCH EQU X'20' Parameters exchanged @SC86152 02601000 APPN EQU X'10' Append to existing files @SC86203 02602000 FCLRF EQU X'08' Skipping two lines on screen @SC92030 02602500 FL4 DS X @SC86316 02603000 TTAB EQU X'80' Use separate tables for terminal @SC87117 02604000 SFM EQU X'20' Sending from memory @SC86158 02605000 TXT EQU X'10' Xmitting text to micro @SC86158 02606000 NPS EQU X'08' Xmitting without protocol @SC86165 02607000 NMCHNG EQU X'04' Filename collsion occurring @SC90033 02607500 UCMD EQU X'02' User command entered @SC86158 02608000 NMOK EQU X'01' Filename collsion already checked @SC87012 02609000 FL5 DS X @SC86316 02610000 CMERR EQU X'80' Syntax error on last command @SC86171 02611000 TKHLT EQU X'40' Quit TAKE file on error @SC86171 02612000 NAK0 EQU X'10' Send NAK during Resend @SC90037 02614000 SALL EQU X'08' Search all disks for SEND @SC86209 02615000 TKMSG EQU X'04' Already issued TAKE error msg @SC86239 02616000 KRMONLY EQU X'02' Saw KERMIT prefix on subcmd @SC90059 02616500 * 02617000 RPKERN DS X Tentative error code from RPACK @SC89219 02617500 SEQ DS X Current pkt number @SC86135 02618000 RSN DS X Received pkt number @SC86135 02619000 CARCTL DS X Code for converting carriage ctl @SC91116 02619200 BRK DS C Break char for last parsed word @SC88306 02619500 TRMFLG DS X Flag(s) for terminal I/O @SC87275 02620000 TRMTP DS C Type of terminal line @SC87166 02621000 DBGFLG DS X Type of debug log @SC88168 02621100 DBGON EQU X'80' Logging on @SC88168 02621200 DBGIO EQU X'40' Logging of I/O info (SERIES1) @SC88168 02621300 DBGRW EQU X'20' Logging raw packets, not EBCDIC @SC88168 02621400 DBGSV EQU X'10' Log file closed after each entry @SC88168 02621500 DBGLO EQU X'08' Logging of I/O info w/ long buffer@SC90222 02621600 DBGTI EQU X'04' Logging of TOD before and after @SC91172 02621800 RBUF DS A Addr of FSREAD buffer @SC86121 02622000 CLEN DS A Length of non-tokenized parm @SC86121 02623000 NSENT DS F Number of files sent @SC86121 02624000 TSENT DS F Pointer to sent files table @SC86121 02625000 TXTPTR DS 3F Ptrs to start and end of text @SC89268 02627000 RBUFL DS F Record len (if recfm = V) @SC86121 02628000 RDWLEN DS F Record descriptor length @SC86151 02629000 SNDPKL DS F SNDPKT length for I/O @SC86295 02630000 RCVPKL DS F RCVPKT length after I/O @SC86295 02631000 WRCMD DS A Ptr to output packet I/O command @SC90173 02631300 WRCMDL DS 2F Length of commands, input to skip @SC90173 02631600 APKT DS A Ptr to packet buffer @SC86190 02632000 ASPKT DS A Ptr to effective send packet @SC86190 02633000 AASPKT DS A Ptr to send packet @SC86190 02634000 ASDATA DS A Ptr to data to send @SC86190 02635000 ARPKT DS A Ptr to receive packet buffer @SC86190 02636000 ARDATA DS A Ptr to received data @SC86190 02637000 FILPTR DS A Ticket for FILNAM file I/O @SC86295 02638000 LOGPTR DS A Ticket for LOG file I/O @SC86295 02639000 SIMPTR DS A Ticket for replay file I/O @SC91312 02639100 KHDSAV DS 5F Save area for hex dumps @SC91008 02639200 KAFUNC DS F SEND/RECEIVE indicator @AB89191 02639500 *--------- Start of data area known to accounting routine @SC90179 02639700 NSENTAC DS F Number of files sent @AB89191 02640000 TOUTOT DS 2F I*8 count of bytes sent @SC86295 02641000 TINTOT DS 2F I*8 count of bytes received @SC86295 02642000 DSKTOT DS 2F I*8 count of disk I/O bytes @SC86295 02643000 SSVDSK DS 2F Saved disk byte count @SC88092 02643500 PAKCNT DS F Number of packets sent/received @SC86295 02644000 RTRCNT DS F Number of retries @SC86295 02645000 SECTOT DS F Duration of transfer (sec) @SC86295 02646000 CSECTOT DS F Duration of transfer (csec) @SC86345 02647000 RECTRC DS F Count of record truncations @SC87268 02648000 RECFLD DS F Count of record foldings @SC88120 02648200 EMSGL DS F Length of msg @BS86090 02648500 TINSV DS 12F 3 snapshots of progress @SC88325 02648700 ERRNUM DS X Error number @SC92210 02648730 REASON DS X Reason for rejecting A-pkt @SC92210 02648760 *--------- NSENTAC to here is known to accounting routine @SC90179 02648800 LSTATS EQU *-NSENTAC Size of area to initialize @SC90179 02649000 TRANEND DS XL4 Ending time of last transfer @SC91172 02649500 PREFIX DS X,CL(FORMAXL) Prefix count and buffer @HF86223 02650000 SUFFIX DS X,CL(FORMAXL) Suffix count and buffer @HF86223 02651000 FILNAM DS CL(LFID) SEND/REC filename @SC86295 02654000 FLNOPTS DS 2AL4 File options @SC89218 02654300 FLNFLGS DS X @SC91116 02654400 FLNCC EQU X'80' File with carriage control @SC91116 02654500 LFOPTS EQU *-FLNOPTS Length of options @SC89218 02654600 DS 0F @SC86295 02655000 IFILE DS CL(LFID) Name of file(s) to send @SC86295 02656000 IFOPTS DS XL(LFOPTS) File options @SC91116 02656200 JFSPEC DS X Length of foreign filespec @SC86224 02656400 JFNAM DS CL95 Filespec @SC86224 02656600 DS 0F So LFSTF is 4*N @SC90264 02656700 LFSTF EQU *-IFILE Length of file info @SC89218 02656800 XFILE DS CL(LFID) Intended name of received file @SC90033 02656900 LIMTRY DS F Max packet retries 02657000 FREEDW DS F Size of aux. storage @SC86295 02658000 FREEPTR DS A Ptr to aux. storage @SC87286 02659000 FREED1 DS A Ptr to 1st disk buffer area @SC90264 02659100 FREED2 DS A Ptr to 2nd disk buffer area @SC90264 02659200 STKLO DS A Start of stack space @SC89089 02659300 STKHI DS A High extent of stack usage @SC89089 02659600 STKPTR DS F Current stack end @SC86295 02660000 STKLIM DS F End of stack storage @SC86295 02661000 EVCTR DS F Count of files opened @SC86295 02662000 EMSGP DS A Ptr to micro message @BS86090 02663000 LEMSG EQU 80 Max msg length kept 8*N @SC90264 02665000 LMARG DS F Left margin for SEND (0=>none) @SC87253 02666000 RMARG DS F Right margin (0=>none) @SC87253 02667000 RBUFP DS F RBUF pointer 02668000 WBUFL DS F Data length in WBUF 02669000 MAXSIZ DS 2A(KDEF-16) Max pkt size sent 02670000 ORGR0 DS F Saved R0 at main entry @SC87253 02671000 ORGR1 DS F Saved R1 at main entry @SC86295 02672000 * Plists for reading and writing in protocol mode 02673000 SIOPTRS DS 2F Address, length of data to send @SC90173 02674000 RIOPTRS DS 2F For reading data (max length) @SC90173 02675000 * 02679000 CDESPTR DS A(0) @SC90040 02679300 LALF EQU 14 Length of fields (must be even): @SC91325 02679600 TRNALF DS CL(LALF)'ASCII' @SC91325 02679700 FILALF DS CL(LALF)'EBCDIC' Logical char-set @SC91325 02679800 FILALF2 DS CL(LALF)'EBCDIC' Actual char-set (if complex) @SC91325 02679900 RIOC DS F Saved data length from prev read @SC86295 02680000 PREV DS C Previous char decoded 02681000 DECESCP DS C Saved DLE prefix, if any @SC91275 02681200 LCKCAPA DS X Flag x'20' if using locking shift @SC91275 02681400 LCKFRC DS X Flag x'21' if FORCE mode @SC91275 02681600 LCKOLD DS X Current locking shift state @SC91275 02681800 * - - - Variables initialized via block MVC's 02682000 KSYSTF , @SC86295 02683000 * Specifications for LOG file @SC86295 02684000 LOGFDB DS 0F @SC86295 02685000 LOGBUF DS A Buffer ptr @SC86295 02686000 DS A(LPKT) Buffer size @SC86295 02687000 FDBPAT LOG,V,LPKT Default disk RECFM, etc. @SC88120 02689000 * Specifications for SEND/RECEIVE file @SC86295 02692000 FILFDB DS 0F @SC86295 02693000 WBUF DS A,F Adr,length of FSWRITE buffer @SC86121 02694000 FDBPAT FIL,V,80 Default disk RECFM, etc. @SC88120 02696000 * Specifications for TAKE file (read-only) @SC86295 02699000 TAKFDB DS 0F @SC86295 02700000 TAKBUF DS A Buffer ptr (CMD) @SC86295 02701000 DS F'256' Max buffer size @SC86295 02702000 FDBPAT TAK,V Default disk RECFM (no LRECL) @SC88120 02703000 * 02705000 MAXTNT DS F'16' Retry limit during setup @SC86345 02706000 MAXTRY DS F'5' Retry limit during transfer @SC86164 02707000 LCLDLY DS F'10' Time to wait before sending @SC86164 02708000 BAUD DS F'1200' Assumed baud rate @SC88325 02708500 RPSIZ DS A(KMAX) Max receive size @SC86295 02709000 SPSIZ DS A(KDEF) Max send size @SC86295 02710000 MAXOUT DS F'&MAXLR' Max output buffer @SC86268 02711000 * Send mode Rpack interpret input table @SC89263 02711100 SNDST DS AL1(AY),AL3(0) Micro ACK'd @SC89263 02711200 DS XL1'FF',AL3(SNDABR) Stop @SC89263 02711300 RTYPPRV DS AL1(AN),AL3(INPUTMIS) Repeated trigger packet @SC89263 02711400 DS AL1(00),AL3(SNDABR) Error routine @SC89263 02711500 TRMLIN DS CL8' ' Current data line @SC87166 02712000 ATFLG DS X Attribute-honoring flags @SC90037 02712040 ATFLNG EQU X'80' Length of file @SC90037 02712080 ATFTYP EQU X'40' Type of file @SC90037 02712120 ATFDAT EQU X'20' Date of file creation @SC90037 02712160 ATFCRE EQU X'10' Creator of file @SC90037 02712200 ATFACT EQU X'08' Account @SC90037 02712240 ATFARE EQU X'04' Area @SC90037 02712280 ATFPWD EQU X'02' Password @SC90037 02712320 ATFBLK EQU X'01' Blocksize @SC90037 02712360 ATFL2 DS X @SC90037 02712400 ATFACC EQU X'80' Access @SC90037 02712440 ATFENC EQU X'40' Encoding @SC90037 02712480 ATFDSP EQU X'20' Disposition @SC90037 02712520 ATFPRO EQU X'18' Protection @SC90037 02712560 ATFORG EQU X'04' Origin @SC90037 02712600 ATFFMT EQU X'02' Format @SC90037 02712640 ATFSFO EQU X'01' System info @SC90037 02712680 ATFL3 DS X @SC90037 02712720 ATFXLN EQU X'80' Byte count @SC90037 02712760 ATFL4 DS X @SC91109 02712770 ATFEND EQU X'01' End of attributes @SC91109 02712780 ATFL5 DS 5X @SC91109 02712790 * 02712800 TYPFIL DS C'T' Type of file (T,B,V,D),see BINF @SC86151 02713000 CLSNFL DS C'O' Collision default is OVERWRITE @SC90033 02713200 TRNCFL DC C'T' Truncate or Fold or Halt @SC88120 02713500 * 02714000 DEFPARM DS AL1(KDEF+ABL,ABL,ABL,64,CR+ABL,A#,AN,A1,ABL,ABL) SC86149 02715000 DS AL1(ABL,ABL,ABL,ABL) Extended size defaults @TB86196 02716000 RCAPA DS X'0' Capabilities of micro @SC86149 02717000 SCAPA DS X'8' Capabilities I have (A-packets) @SC86149 02718000 REOL DS AL1(CR) EOL char I need (cr) 02719000 SEOL DS AL1(CR) EOL I'll send 02720000 RMARK DS AL1(SOH) Incoming pkt start char 02721000 SMARK DS AL1(SOH) Outbound pkt start char 02722000 RCTLQ DS AL1(A#) Micro's ctl-quote char 02723000 SCTLQ DS AL1(A#) Ctl-quote char we'll use 02724000 EBQC DS AL1(AAMP) Orig 8-bit quote char 02725000 RTIMO DS AL1(5) Time limit - micro to wait for us @SC86164 02726000 TIMOUT DS AL1(0) Timeout, if we can implement it @SC86164 02727000 TIMOSRV DS AL1(120) Timeout, if we can implement it @SC90045 02727100 RPRTY DS AL1(0) Recieve parity is MARK @SC88288 02727300 SPRTY DS AL1(DAT8) Send parity is NONE @SC88288 02727600 BCTC DS C'1' User requested chksum length @SC92085 02728000 RPTQC DS AL1(ATIL) Original repeat prefix 02729000 AEADAT DS &AEACMD,AL2(8),X'0F02' D/O strct fld @SC90173 02730000 AEAFLG DS X,X'00',AL2(1) D/O id is 1 @SC90173 02730600 AEADOL EQU *-AEADAT Length of just D/O field @SC91352 02730900 AEABUFL DS AL2,X'0F1F',X'00C000' Not spanned @SC90173 02731200 AEAL EQU *-AEADAT @SC90173 02731800 S1DATA DS &S1CMD,AL1(SBA),X'5D7F',AL1(SBA),X'0005' @SC90264 02732400 S1ORDL EQU *-S1DATA @SC90173 02733000 WRRD EQU *-1 Zap this to 0 for just write @SC90173 02733600 * ... but ONLY if we really won't read again @SC90173 02734200 LDEFS EQU *-DEFS @SC86295 02735000 * 02736000 S1XOPL DS 2A For sending prompt @SC90173 02737000 SCRPRBUF DS XL(S1ORDL) Command stream @SC90173 02737300 ORG SCRPRBUF @SC90173 02737600 DS XL(GRDL) @SC90173 02737900 ORG SCRPRBUF @SC90173 02738200 DS XL(AEAL) @SC90173 02738500 ORG , @SC90173 02738800 TRNSPL EQU *-SCRPRBUF Length of longest command string @SC90173 02739100 S1EOL DS AL1(CR) In case micro lost one @SC90173 02739400 S1HND DS AL1(XON) Handshake for micro @SC90173 02739700 SVHND DS X Saved value of HANDSHAKE char @SC87343 02740000 * - - - Initialized to zeroes 02741000 RPTQ DS X Repeat prefix 02742000 EBQ DS X 8-bit quoting char (off) 02743000 BCTOFF DS F Offset in checksum encoding (0/1) @SC92085 02743500 BCTU DS X Checksum length in use 02744000 BCTR DS X Other Kermit's chksum length 02745000 RPADN DS X Receive padding count 02746000 SPADN DS X Send pad count @SC86164 02747000 RPADC DS X Receive pad char 02748000 SPADC DS X Send pad char @SC86164 02749000 CTLTAB DS 160X Table of sendable ctl chars @SC93173 02749500 TMP DS X 02750000 TMPDW DS D Work double word 02751000 FSIZE DS F Record length @SC86203 02752000 FRECF DS C Record format flag @SC86151 02753000 STYPE DS C Type of packet sent @SC86295 02754000 RTYPE DS C Type of packet received @SC86295 02755000 ACCTFLG DS X Flag for transaction log @SC89218 02755200 ERRLAST DS X Error code on last file xferred @SC89218 02755400 REALAST DS X Reason code on last file @SC89218 02755600 OLDERR DS XL2 Saved ERRNUM+REASON in loop @SC90033 02757000 OPRND DS CL32 Upcased operand for table lookup @SC87034 02759000 TCTLQ DS X XECHO control character escape @SC86165 02760000 TABTBL DS XL20 Tab stops @SC86355 02761000 TABCNT DS H Current number of tabs @SC86355 02762000 STOPBUF DS CL8 Work area @SC91032 02762500 KSYSVAR , Specific variables @SC87012 02763000 DS 0D @SC86295 02764000 STODWDS EQU (*-STORAG)/8 @SC86295 02765000 TITLE 'ERRMSG - List of error messages' @SC86135 02766000 * Table of error messages @SC86156 02767000 MSGDF NOE,'&NOERROR' Err #0 @SC86156 02768000 MSGDF NFT,'&NOTRANS' Err #1 @SC86156 02768500 MSGDF TRC,'&TCANCEL' Err #2 @SC86156 02769000 MSGDF USC,'&BADSERV' Err #3 @SC86156 02769500 MSGDF TIE,'&TERMIOE' Err #4 @SC86156 02770000 MSGDF BPC,'&BADCHEK' Err #5 @SC86156 02770500 MSGDF IPS,'&BADPSYN' Err #6 @SC86158 02771000 MSGDF IPT,'&BADPTYP' Err #7 @SC86156 02771500 MSGDF MIS,'&LOSTPAK' Err #8 @SC86156 02772000 MSGDF NAK,'&GOTNAK' Err #9 @SC86156 02772500 MSGDF ABO,'&MICROAB' Err #10 @SC86156 02773000 MSGDF FNE,'&BADNAME' Err #11 @SC86156 02773500 MSGDF FNF,'&NOTFOUN' Err #12 @SC86156 02774000 MSGDF FUL,'&DSKFULL' Err #13 @SC86345 02774500 MSGDF DIE,'&DSKIOER' Err #14 @SC86345 02775000 MSGDF MOP,'&MISSOPR' Err #15 @SC86158 02775500 MSGDF SYS,'&BADSCMD' Err #16 @SC86268 02776000 MSGDF KCE,'&KCMDERR' Err #17 @SC86171 02776500 MSGDF TIM,'&NOPACKS' Err #18 @SC86355 02777000 MSGDF RTR,'&RECTRNC' Err #19 @SC87268 02777500 MSGDF COM,'&BADCOMM' Err #20 @SC87300 02778000 MSGDF PTY,'&NO8THBQ' Err #21 @SC89072 02778500 MSGDF FTS,'&TOOSHRT' Err #22 @SC89218 02779000 MSGDF SOH,'&NOSTART' Err #23 @SC89219 02779500 MSGDF OPT,'&BADOPTN' Err #24 @SC89249 02780000 MSGDF DSP,'&BADDISP' Err #25 @SC90037 02780500