home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
ibm370
/
ikxmac.asm
< prev
next >
Wrap
Assembly Source File
|
2020-01-01
|
49KB
|
602 lines
*COPY RTEXT 00800000
MACRO 00801000
&LABEL RTEXT &BUF,&PROMPT=,&E= 00802000
.* Read from the terminal, possible prompt. Get length read in R0. 00803000
.* &1: read buffer (len=130) (LA), &PROMPT(1)= prompt buf. if any 00804000
.* (LA/R), &PROMPT(2)= prompt length (LA/R), &E= branch if error 00805000
GBLC &KVRSN,&KSYS @SC89027 00806000
AIF ('&KVRSN' EQ '4.3' OR '&KSYS' EQ '').VOK @SC90072 00807000
MNOTE 16,'* * * --> IKXMAC version number should be &KVRSN' @SC89027 00808000
.VOK ANOP @SC89027 00809000
&LABEL DS 0H @SC86299 00810000
AIF (T'&BUF EQ 'O').ERRB @SC87268 00811000
AIF (T'&PROMPT EQ 'O').NOPR @SC87268 00812000
AIF (N'&PROMPT NE 2).ERRP @SC87268 00813000
AIF ('&PROMPT(1)' EQ '' OR '&PROMPT(2)' EQ '').ERRP @SC87268 00814000
LREG 1,&PROMPT(1) @SC90264 00815000
LREG 0,&PROMPT(2) @SC90264 00816000
STM 0,1,GTLPRPS Save prompt ptrs @SC90264 00817000
AGO .GETL @SC90264 00818000
.NOPR XC GTLPRPS,GTLPRPS @SC90264 00819000
.GETL KCALL GETLIN,&BUF,E=&E @SC88095 00820000
MEXIT @SC87268 00821000
.ERRB MNOTE 2,'BUFFER ADDRESS OMITTED' @SC87268 00822000
MEXIT @SC87268 00823000
.ERRP MNOTE 2,'INVALID PROMPT PARAMETER' @SC87268 00824000
MEND 00825000
*COPY WTEXT 00826000
MACRO 00827000
&LABEL WTEXT &ARG,&LEN 00828000
.* Display some text, e.g., WTEXT 'Hi there' or WTEXT (3),(4) 00829000
.* Preserves R2-R14 00830000
.* &1: 'text' (where text has no doubled ' or & characters) OR 00831000
.* &1: adr of text (LA/R), &2: length of text (LA/R) 00832000
&LABEL PTEXT &ARG,&LEN,AREG=1,LREG=0 @SC86295 00833000
BAL 15,WTEXT @SC87020 00834000
MEND 00835000
*COPY DMSFREE 00836000
MACRO 00837000
&LABEL DMSFREE &DWORDS=(0),&ERR= 00838000
.* Obtain free storage block: len=8*(R0). Returns ptr in R1, but 00839000
.* preserves registers 2-13 00840000
.* &DWORDS= length in doublewords should be in R0, 00841000
.* &ERR= branch if failure 00842000
&LABEL LREG 0,&DWORDS @SC86299 00843000
SLA 0,3 @SC86299 00844000
ST 0,GTMLEN Bytes requested @SC90264 00845000
AIF ('&ERR' EQ '').DOORDIE @SC90264 00846000
EXEC CICS GETMAIN SET(1) FLENGTH(GTMLEN) NOHANDLE, @SC90264 00847000
L 15,DFHEIBP @SC90264 00848000
CLC F0,EIBRCODE-DFHEIBLK(15) @SC90264 00849000
BNE &ERR @SC90264 00850000
AGO .DONE @SC90264 00851000
.DOORDIE ANOP @SC90264 00852000
EXEC CICS GETMAIN SET(1) FLENGTH(GTMLEN), @SC90264 00853000
.DONE ANOP @SC90264 00854000
MEND 00855000
*COPY DMSFRET 00856000
MACRO 00857000
&LABEL DMSFRET &DWORDS=(0),&LOC=(1),&ERR= 00858000
.* Return free storage block: len=8*(R0), adr=(R1). Preserve R2-13. 00859000
.* &DWORDS= length in doublewords should be in R0, &LOC= adr (in R1), 00860000
.* &ERR= branch if failure 00861000
.* Note: &DWORDS is ignored @SC90264 00862000
&LABEL ST 2,GTMSAV @SC90264 00863000
LREG 2,&LOC @SC90264 00864000
EXEC CICS FREEMAIN DATA(0(,2)), @SC90264 00865000
L 2,GTMSAV @SC90264 00866000
MEND 00867000
*COPY WRITF 00868000
MACRO 00869000
&LABEL WRITF &TICK,&BUFFER=,&BSIZE=,&E= 00870000
.* Write to a disk file (ticket ptr in R1) 00871000
.* &1: adr of file access ticket returned by OPENF (A), 00872000
.* &BUFFER= data ptr (LA/R), &BSIZE= data length (LA/R) - if either is 00873000
.* given, it replaces FDB value (see OPENF), &E= branch on error 00874000
&LABEL READF &TICK,BUFFER=&BUFFER,BSIZE=&BSIZE,E=&E,CODE=10 00875000
MEND 00876000
*COPY READF 00877000
MACRO 00878000
&LABEL READF &TICK,&NONUM,&BUFFER=,&BSIZE=,&E=,&CODE=9 00879000
.* Read from disk file (or write) (see WRITF, but also...) 00880000
.* &2: NONUM means chop off numbers 00881000
LCLC &R @SC86299 00882000
LCLA &C @SC88101 00883000
&C SETA &CODE @SC88101 00884000
AIF (T'&NONUM EQ 'O').RDC @SC88101 00885000
AIF ('&NONUM' NE 'NONUM' OR &CODE NE 9).ER1 @SC88101 00886000
&C SETA 0 Code 0 means exclude sequence nos.@SC88101 00887000
.RDC ANOP @SC88101 00888000
&LABEL L 1,&TICK @SC86299 00889000
AIF ('&BUFFER' EQ '').BZ @SC86299 00890000
AIF ('&BUFFER'(1,1) NE '(').BLA @SC86299 00891000
&R SETC '&BUFFER(1)' @SC86299 00892000
AGO .BST @SC86299 00893000
.BLA LA 15,&BUFFER @SC86299 00894000
&R SETC '15' @SC86299 00895000
.BST ST &R,FDBBUFF-FABD(1) @SC86299 00896000
.BZ AIF ('&BSIZE' EQ '').SZ @SC86299 00897000
AIF ('&BSIZE'(1,1) NE '(').SLA @SC86299 00898000
&R SETC '&BSIZE(1)' @SC86299 00899000
AGO .SST @SC86299 00900000
.SLA LA 15,&BSIZE @SC86299 00901000
&R SETC '15' @SC86299 00902000
.SST ST &R,FDBBSIZ-FABD(1) @SC86299 00903000
.SZ LA 0,&C @SC88101 00904000
KCALL DISKIO,E=&E @SC86299 00905000
MEXIT 00906000
.ER1 MNOTE 2,'INVALID PARAMETER ''&NONUM''' @SC88101 00907000
MEND 00908000
*COPY SAVEF 00909000
MACRO 00910000
&LABEL SAVEF &TICK,&E= @SC88168 00911000
.* Update disk directory for given file (ticket ptr in R1) 00912000
.* &1: adr of file access ticket (A), &E= branch on error 00913000
&LABEL L 1,&TICK @SC88168 00914000
READF &TICK,E=&E,CODE=21 @SC88168 00915000
MEND 00916000
*COPY KSETKW 00917000
MACRO 00918000
KSETKW , @SC87166 00919000
.* Define system-specific SET/SHOW parameters (keywords) 00920000
GBLC &AADELIM,&DESTINA @SC92300 00921000
KW '&AADELIM',SHODLM,MIN=4 @SC88095 00921500
KW '&DESTINA',SHODST,MIN=3 @SC87166 00922000
MEND 00923000
*COPY KSETPRC 00924000
MACRO 00925000
KSETPRC 00926000
.* System-specific SET handlers (in any order). No operands. 00927000
GBLC &DELIMSG @SC92300 00927500
SETDLM NTOKN N=SETDLM1,H=SETDLMH @SC88095 00928000
LTR 7,7 Exactly one character? @SC88095 00929000
BNZ SETDLMH No, explain it @SC88095 00930000
MVC LNDLM,0(6) Yes, use that character @SC88095 00931000
B RTRN0 @SC88095 00932000
SETDLM1 MVI LNDLM,C' ' Turn delimiter off @SC88095 00933000
B RTRN0 @SC88095 00934000
SETDLMH PTEXT '&DELIMSG' @SC88095 00935000
B SUBERR @SC88095 00936000
SETDST KCALL CWDSET @SC86164 00937000
B RTRN Preserve return code @SC86295 00938000
MEND 00939000
*COPY KSHOPRC 00940000
MACRO 00941000
KSHOPRC 00942000
.* System-specific SHOW handlers (in same order as KW). No operands. 00943000
SHODLM LA 8,LNDLM Show delimiter @SC88095 00944000
BAL 14,SHOCHR @SC88095 00945000
B SETDLM @SC88095 00946000
SHODST LA 8,DEST @SC86316 00947000
LH 9,DESTL Get length @SC86316 00948000
BAL 14,SHOCHRN @SC86295 00949000
B SETDST @SC87166 00950000
MEND 00951000
*COPY KFILKW 00952000
MACRO 00953000
KFILKW , @SC87166 00954000
.* Define system-specific file attribute parameters (keywords) 00955000
GBLC &AARECFM @SC92300 00956000
KW '&AARECFM',SHORFM @SC87166 00956300
MEND 00957000
*COPY KFILSET 00958000
MACRO 00959000
KFILSET 00960000
.* Specific SET FILE handlers (any order). No operands. 00961000
GBLC &FIXED,&UNDEFND,&VARIABL @SC92300 00962000
SETCMDS CSECT @SC92300 00963000
SETRFMKW KW '&FIXED',SETT,F @SC92300 00964000
KW '&VARIABL',SETT,V @SC92300 00965000
KW '&UNDEFND',SETT,U @SC86295 00966000
KW , @SC87012 00969000
SET CSECT @SC92300 00969500
MEND 00970000
*COPY KFILSHO 00971000
MACRO 00972000
KFILSHO 00973000
.* Specific SHOW FILE handlers (same order as KW). No operands. 00974000
SHORFM LA 4,SETRFMKW @SC92300 00975000
LA 6,FILRCF @SC92300 00975500
BAL 14,SHOBRV @SC92300 00976000
NOP 0 @SC92300 00976500
MEND 00978000
*COPY FDBD 00979000
MACRO 00980000
FDBD 00981000
.* Map of File Descriptor Block + File Access Block 00982000
.* Required items below: FABCOMM, FDBD-FDBLRC, FDBSIZE, FDBDATE, 00983000
.* FDBDLRTR, FDBCOP, FDBINFO. See also FDBPAT. 00984000
LFUID EQU 8 Length of user id in filespec @SC92150 00985000
LFFNM EQU 8 Length of file id in filespec @SC90264 00986000
LFID EQU 1+LFUID+LFFNM Length of internal filespec @SC90264 00987000
LFKEY EQU LFUID+LFFNM+5 Length of KSDS key @SC90264 00988000
FABD DSECT , @SC86295 00989000
FABRESP DS XL6 Saved response code @SC90264 00990000
FABNORD DS H Byte count of last transfer @SC90264 00991000
FDBD DS 0F Beginning of short descriptor @SC86295 00992000
FDBBUFF DS A Buffer ptr @SC86295 00993000
FDBBSIZ DS F Max record length @SC86295 00994000
FDBRCF DS C Record format @SC86295 00995000
FDBFLGS DS X Flags @SC86295 00996000
FDBACTV EQU X'80' File is already open @SC86295 00997000
* SVATT EQU X'40' Preserve attributes @SC90033 00998000
* APPN EQU X'10' DISP=MOD @SC86295 00999000
FDBENQ EQU X'04' Resource is enqueued @SC92126 00999500
FDBLRC DS H File record length @SC86295 01000000
FDBSIZE DS F File size in Kbytes @SC86299 01001000
FDBCOP EQU *-FDBD Length to copy for OPEN @SC86295 01002000
FDBDATE DS XL7 Time stamp: packed yyyymmddhhmmss @SC88235 01003000
* Must align FABFID to abut FABRN (halfword) @SC90264 01004000
FABFID DS 0CL(LFID) File designator @SC90264 01005000
FABFLGS DS X Flags indicating type of file @SC90264 01006000
FABFMAIN EQU X'01' Flag for MAIN TS queue @SC90264 01007000
FABFTS EQU X'02' Flag for TS queue @SC90264 01008000
FABFTD EQU X'04' Flag for TD queue @SC90264 01009000
FABFPGM EQU X'08' Flag for pipe file @SC90264 01010000
FABFSPL EQU X'10' Flag for spool file @SC90264 01011000
FABFTAK EQU X'20' Flag for internal Kermit file @SC90264 01012000
FABFUID DS CL(LFUID) User name @SC90264 01013000
FABFNAM DS CL(LFFNM) File name @SC90264 01014000
FABRN DS H Record number @SC90264 01015000
FDBNREC DS H Number of records @SC90264 01016000
FDBFL2 DS X More flags @SC90264 01017000
FDBXRCF DS X External format flags @SC90264 01018000
FDBXLRC DS H External old LRECL @SC90264 01019000
FDBXBLK DS H External old block size @SC90264 01020000
FDBINFO EQU *-FDBD Length of info returned @SC86295 01021000
FABIOF DS X More flags @SC90264 01022000
FABLRTR DS F Record length for truncation @SC88120 01023000
FABUWORD DS F Reserved for user applications @SC90264 01024000
FABCOMM DS CL8 Command name @SC87351 01025000
.* CLOSE Close file named in FABFID @SC90264 01026000
.* CWD Set new user directory or QFN prefix: string is at@SC90264 01027000
.* FABFID+2 with 2-byte unsigned length at FABFID @SC90264 01028000
.* DELETE Delete file named in FABFID @SC90264 01029000
.* OPEN I Open file named in FABFID for input @SC90264 01030000
.* OPEN O Open file named in FABFID for output @SC90264 01031000
.* READ Read a record from (already open) file @SC90264 01032000
.* READ TD Read a record from (already open) TD queue @SC90264 01033000
.* READ TS Read a record from (already open) TS queue @SC90264 01034000
.* TEST Check whether file named in FABFID exists @SC90264 01035000
.* WRIT TD Write a record to (already open) TD queue @SC90264 01036000
.* WRIT TS Write a record to (already open) TS queue @SC90264 01037000
.* WRITE Write a record to (already open) file @SC90264 01038000
FABDWDS EQU (*-FABD+7)/8 @SC86295 01039000
MEND 01040000
*COPY FDBPAT 01041000
MACRO 01042000
FDBPAT &N,&RFM,&SIZ @SC88120 01043000
.* Define system-dependent part of output FDB patterns 01044000
.* &1: variable-name prefix (or null if defining init. values) 01045000
.* &2: RECFM (1-char), &3: LRECL (skip rest of FDB if omitted)@SC88120 01046000
LCLC &R,&F,&L,&S,&P4 @SC90037 01047000
AIF ('&N' EQ '').ALC @SC86316 01048000
&R SETC 'RCF' @SC88120 01049000
&F SETC 'FLGS' @SC88120 01050000
&L SETC 'LRC' @SC88120 01051000
&S SETC 'FSIZ' @SC90037 01052000
.ALC ANOP @SC86316 01053000
&N&R DC C'&RFM' RECFM @SC88120 01054000
&N&F DC X'00' Flags @SC88120 01055000
AIF ('&SIZ' EQ '').DONE @SC88120 01056000
&N&L DC Y(&SIZ) LRECL @SC88120 01057000
&N&S DC F'0' File size in Kbytes @SC90037 01058000
.DONE ANOP @SC88120 01059000
MEND 01060000
*COPY KFSBLKD @SC90264 01061000
MACRO @SC90264 01062000
KFSBLK 01063000
.* Map of Kermit File System block @SC90264 01064000
KFSBLK DSECT , @SC90264 01065000
KFSNEXT DS A Ptr to next block in chain @SC90264 01066000
KFSPREV DS A Ptr to previous block in chain @SC90264 01067000
KFSFUID DS CL(LFUID) User name @SC90264 01068000
KFSFNAM DS CL(LFFNM) File name @SC90264 01069000
KFSDAT EQU * Info about file @SC90264 01070000
KFSLRC DS H File record length @SC90264 01071000
KFSNREC DS H Number of records @SC90264 01072000
KFSSIZE DS F File size in bytes @SC90264 01073000
KFSDATE DS XL7 Time stamp: yyyymmddhhmmss @SC90264 01074000
KFSLEN EQU *-KFSDAT Length of block on disk @SC90264 01075000
DS X Spare for packing @SC90264 01076000
KFSDWDS EQU (*-KFSBLK+7)/8 @SC90264 01077000
MEND @SC90264 01078000
*COPY KSYSVAR 01079000
MACRO 01080000
KSYSVAR 01081000
.* Define system-dependent globally-known variables 01082000
CSAPTR DS F Ptr to common system area @SC90264 01083000
RTXTSV DS F Saved register for prompt @SC89214 01084000
STRBUF DS A Address of string editing buffer @SC90264 01085000
SCRLSTIO DS D Saved I/O code from SCRNIO @SC92016 01085500
DSKSTT DS (FABDWDS)D Dummy FAB @SC90264 01086000
ORG DSKSTT+FDBD-FABD Start of FDB @SC90264 01087000
DSKFDB DS XL(FDBINFO) Room for FDB @SC86299 01088000
ORG DSKSTT+FABFID-FABD Start of file name @SC90264 01089000
DSKSTNM DS CL(LFID) @SC90264 01090000
ORG , @SC90264 01091000
DESTL DS H'0' Length @SC86299 01092000
DEST DS CL60 Default PREFIX @SC90264 01093000
LINLEN DS H Length of invocation buffer @SC90264 01094000
GTMLEN DS F Length of getmained area @NL90264 01095000
GTMSAV DS F Saved reg during DMSFREE @SC90264 01096000
GTLBUFP DS A Ptr to buffer for terminal input @SC90264 01097000
GTPBPTRS DS 2F Address and length of input buffer@SC88095 01098000
GTLPRPS DS 2F Ptrs to prompt (passed to GETLIN) @SC90264 01099000
ICPRGS DS 8F Saved registers for type-out @SC88026 01100000
ICPFL DS X Flag for type-out interception @SC87020 01101000
FSCTRMF DS X Flag for terminal activity @SC90264 01102000
FSCOTP DS H Current screen write adr @SC90264 01103000
* Storage for directory scan @SC90264 01104000
NXFFNL DS F Length of pattern @SC90264 01105000
NXPTR DS F Current search position @SC90264 01106000
NXPTR2 DS F Current search position for TS @SC90264 01107000
NXDEST DS CL(LFID) Pattern @SC90264 01108000
NXDNAM EQU NXDEST+1+LFUID Start of name part @SC90264 01109000
KUSERID DS CL(LFUID) Userid (to be filled at startup) @SC90264 01110000
CURFUID DS CL(LFUID) Current userid @SC90264 01111000
PTRKFS DS A Ptr to chain of internal files @SC90264 01112000
PTRFRE DS A Ptr to chain of free blocks @SC90264 01113000
PTRFREM DS A Ptr to chain of free megablocks @SC90264 01114000
USRTOTL DS F Total bytes for current user @SC90264 01115000
TMPBLK DS A Ptr to block for current file @SC90264 01116000
QFNBP DS A Ptr to ring of QFN buffers @SC90264 01117000
QFNPTR DS A Ptr to current QFN buffer 1 @SC90264 01118000
QFNSHB DS H Offset to display form of QFN 2 @SC90264 01119000
QFNSHL DS H Length of display form 3 @SC90264 01120000
DSKFL DS X Flags for disk search @SC90264 01121000
PLOAD EQU X'40' Auxiliary pgm loaded for pipes @SC90264 01122000
WARB EQU X'20' Arbitrary chars seen @SC90264 01123000
WFN EQU X'08' Filename contains wild chars @SC88246 01124000
NFFND EQU X'01' Found at least one file in search @SC90264 01125000
COPID DS CL3 CICS operator id @LM90264 01126000
CSCRNHT DS H Terminal screen height in lines @LM90264 01127000
CSCRNWD DS H Screen width in columns @LM90264 01128000
CSYSID DS CL4 Local CICS system name @LM90264 01129000
KTSGIDNE DS H Number of entries per TSGID @SC91150 01130000
KTSBPSEG DS X Log(length of TS segment) @SC91150 01131000
MEND 01133000
*COPY KSYSTF 01134000
MACRO 01135000
KSYSTF 01136000
.* Define system-dependent globally-known constants and init. variables 01137000
.* symb .DS + label &P.DEFS mark start of variables/init. values 01138000
GBLC &STORDS,&KTRMS @SC91260 01139000
LCLC &P 01140000
AIF ('&SYSECT' EQ '&STORDS').DS @SC89268 01141000
&P SETC 'I' For initial values 01142000
WTEXT STM 14,5,ICPRGS Save @SC89268 01143000
L 2,=A(ICPTYP) Call interception routine @SC89268 01144000
BR 2 @SC89268 01145000
KSYSATOE DC A(0) Normal TTY E/A translation @SC88302 01146000
KSYSETOA DC A(0) @SC88302 01147000
SYSATR DC AL1(ADOT,ABL+2,AI,A7) ."I7 System type=CICS @SC90264 01148000
LSYSATR EQU *-SYSATR Length of stuff for A-packet @SC88273 01149000
KFILE DC CL8'KERMFSF' Name of Kermit file system KSDS @SC90264 01150000
LIMKFS DC A(LIMDSK) User quota of storage in KSDS @SC90264 01151000
CUTKFS DC A(CUTDSK) Absolute cutoff ("disk full") @SC90264 01152000
LOGNAM DC C'KLOG&KTRMS..TS' File id for debug log @SC91260 01152300
REPNAM DC C'KREP&KTRMS..TS' File id for reply from server @SC91260 01152600
SYSUID DC CL(LFUID)'0000' System userid @SC92150 01153000
SYSTAKE DC C'KSYS.TD' File id for system KERMINI @SC90264 01154000
LSYST EQU *-SYSTAKE @SC86299 01155000
USRTAKE DC C'KINIT.TAKE' User init file @SC90264 01156000
LUSRT EQU *-USRTAKE @SC86299 01157000
KMAIL1 DC C'KERMAIL R(_...) ' System cmd for invoking mail@SC91150 01158000
KMAIL2 DC C' LIST(' @SC90037 01159000
KMAIL3 DC C')' @SC90037 01160000
KPRNT1 DC C'KERMPRT R(_...) ' System cmd for printing @SC91150 01161000
KPRNT2 DC C' OPTIONS(' @SC90037 01162000
KPRNT3 DC C')' @SC90037 01163000
KSUBM1 DC C'KERMSUB R(_...) ' System cmd to submit job @SC91150 01164000
KSUBM2 DC C' OPTIONS(' @SC90037 01165000
KSUBM3 DC C')' @SC90037 01166000
* 01167000
FSCBEG DC H'1' Screen adr for first output line @SC90264 01168000
FSCEND DC Y(80*22-1) Limiting screen adr @SC90264 01169000
KSYSNIT CSECT @SC89215 01170000
.DS ANOP 01171000
&P.DEFS DS 0D 01172000
* 01173000
&P.KPRPL DC AL1(1+L'KPRPT) @SC89334 01174000
&P.KPRPT DC C'Kermit-CICS>' @SC90264 01175000
DC AL1(XON) @SC89334 01176000
ORG &P.KPRPT+21 @SC89334 01176500
&P.LNDLM DC C' ' Initially no delimiter @SC88095 01177000
MEND 01180000
*COPY KSYSBUF 01181000
MACRO 01182000
KSYSBUF 01183000
.* Store buffer ptrs from R1 and increment R1 for specific buffers 01184000
.* 01185000
ST 1,STRBUF Ptr to string editing buffer @SC90264 01186000
LA 1,256(,1) 8*N @SC90264 01187000
ST 1,GTLBUFP Ptr to terminal input buffer @SC90264 01188000
LA 1,256(,1) 8*N @SC90264 01189000
ST 1,QFNBP Ptr to ring of QFN buffers @SC90264 01190000
LA 1,((3*(QFNSIZ+4)+7)/8)*8(,1) 8*N @SC90264 01191000
MEND 01192000
*COPY SSYMS 01193000
MACRO 01194000
SSYMS 01195000
.* Set global symbols for conditional assembly 01196000
GBLC &KVRSN,&KSYS,&KDATE,&RTN,&TYPCMD,&S1CMD,&KCONT @SC88309 01197000
GBLC &KEDIT,&STORDS,&KTAG,&AEACMD,&CONOPTS,&S1CMD1 @SC91311 01198000
GBLC &USER,&KTRMS @SC91260 01199000
GBLA &MAXLR,&MAXBS @SC86268 01200000
GBLC &ANYCICS,&BADFSPC,&BADOUTF,&BYTSALW,&BYTSUSD @SC92300 01200050
GBLC &CWDERRM,&DESTINA,&DIRHDNG,&FILCLSN,&FMTFSPC @SC92300 01200100
GBLC &NODIRDF,&NOFSPEC,&OTHERL6 @SC92300 01200150
&KSYS SETC 'CICS' System name @SC90264 01201000
MNOTE '*** Kermit-&KSYS release &KVRSN..&KEDIT &KTAG (&KDATE) ***' 01202000
** BEGIN LANGUAGE-SPECIFIC DATA ** ** CICS-specific ** @SC92300 01202030
&ANYCICS SETC 'any CICS program' @SC90264 01202060
&BADFSPC SETC 'Invalid filespec' @SC90264 01202090
&BADOUTF SETC 'Illegal output file' @SC90264 01202120
&BYTSALW SETC ' bytes allowed, ' @SC90264 01202150
&BYTSUSD SETC ' bytes used in ' @SC90264 01202180
&CWDERRM SETC 'Must be a valid file prefix' @SC92300 01202210
&DIRHDNG SETC 'Name RFM LRECL #recs Kbytes Type+01202240
Date/time' @SC92150 01202270
&FILCLSN SETC 'File name collision' @SC90264 01202300
&FMTFSPC SETC 'Enter filespec' @SC91224 01202330
&NODIRDF SETC 'No directory defined' @SC90264 01202360
&NOFSPEC SETC 'Missing filespec' @SC90264 01202390
&OTHERL6 SETC 'OTHER' Must be length <7 @SC92300 01202420
* Subcommand keywords 01202450
&DESTINA SETC 'PREFIX' kwd->AAAASET, m=3 @SC87166 01202480
** END LANGUAGE-SPECIFIC DATA ** @SC92300 01202510
&MAXLR SETA 32767 Max lrecl @SC91150 01203000
&MAXBS SETA 32767 Max blksize @SC86268 01204000
&S1CMD SETC '0X''0''' S/1 command prefix @SC90264 01205000
&S1CMD1 SETC '0X''0''' S/1 command prefix for Status @SC91311 01205100
&CONOPTS SETC 'STCNORD+STCQBIT' SETCON options @SC91311 01205200
&AEACMD SETC '0X''0''' AEA command prefix (X'F3'=WSF) @SC90173 01206000
&KCONT SETC 'T' Default controller type (TTY) @SC88309 01207000
LIMDSK EQU 100000 User disk space quota for KSDS @SC90264 01208000
CUTDSK EQU 150000 Storage cutoff ("disk full") @SC90264 01209000
QFNSIZ EQU 54 Length of quoted file name @SC90264 01210000
MAXWT EQU 1024 Max TTY write buffer @SC90264 01211000
MAXRT EQU 1024 Max TTY read buffer @SC90264 01212000
MAXWS EQU 1920 Max fullscreen input buffer @SC90277 01213000
MAXRS EQU 1920 Max fullscreen output buffer @SC90277 01214000
FSRDOF EQU 3 Offset of data in fullscreen read @SC92030 01214500
MAXDOF EQU LFKEY Data offset into buffer @SC90264 01215000
STMGT EQU 0 Overhead for storage mngmnt @SC90264 01216000
&TYPCMD SETC 'TYPE' Host command for TYPE @SC90264 01217000
TYPMIN EQU 2 Min abbrv of system TYPE cmd or 2 @SC90264 01218000
FBRK1 EQU C'<' Starting character for options @SC89218 01219000
FBRK2 EQU C'>' Ending character for options @SC89218 01220000
KMAXE EQU 1920 < 9025 Kermit extended max pkt @SC90264 01221000
STKDWDS EQU 511 Size of save-area stack @SC87012 01222000
&STORDS SETC 'DFHEISTG' Append Kermit globals to STG @SC90264 01223000
KSUBBASE EQU 12 Base register for CSECT @SC89268 01224000
KWRKBASE EQU 11 Base register for work area @SC89268 01225000
&USER SETC 'OPID' Use OPID for id @SC90264 01226000
&KTRMS SETC ';;;;' Signal for inserting terminal id @SC91260 01226500
WXTRN KVALID External security routine @SC90264 01227000
WXTRN KHOST,KHIDE External security routine @SC90264 01228000
MEND @SC86268 01229000
*COPY SYSMACS 01230000
MACRO 01231000
SYSMACS 01232000
.* Include system control block definition macros and list all macros 01233000
MNOTE '---COPIES: DFHCSADS, DFHDCTDS, DFHTSMDS' 01234000
MNOTE '---MACROS: DFHEIEND, DFHEIENT, DFHEIRET, DFHEISTG,' 01235000
MNOTE '--- EXEC' 01236000
KFSBLK , @SC90264 01237000
COPY DFHCSADS @SC90264 01238000
DCTCBAR EQU 8 Ptr to DCT entry @SC90264 01239000
COPY DFHDCTDS @SC90264 01240000
AIF ('&SYSPARM' GE '1.7').CICS2 @SC90264 01241000
TDDCTSDS EQU TDDCTCBA Ptr to DCB info CICS 1.6 @SC90264 01242000
DCTSDSTF EQU DCTSDSCI+48 TYPEFILE status (= OFLGS in DCB) @SU91304 01243000
DCTSDSOP EQU X'80' Output @SC90264 01244000
DCTSDSRF EQU DCTSDSCI+36 RECFM in DCB @SU91304 01245000
DCTSDSBL EQU DCTSDSCI+62 BLKSIZE in DCB @SU91304 01246000
DCTSDSRL EQU DCTSDSCI+82 LRECL in DCB @SU91304 01247000
.CICS2 ANOP @SC90264 01248000
AIF ('&SYSPARM' LT '3.1').CICS3 @SC93006 01248200
TDDCTSDS EQU TDEXASDS Ptr to SDSCI in CICS 3 @SC93006 01248400
DCTSDSTF EQU DCTSDTF TYPEFILE status @SC93006 01248600
.CICS3 ANOP @SC93006 01248800
TSMAPBAR EQU 1 @SC90264 01249000
TSGIDBAR EQU 1 @NL90264 01250000
TSUTBAR EQU 1 @NL90264 01251000
TSUTEAR EQU 1 @NL90264 01252000
COPY DFHTSMDS @SC90264 01253000
DROP TSMAPBAR @SC90264 01254000
DFHEISTG , @SC90264 01255000
MEND @SC86268 01256000
*COPY STRTMSGS 01257000
MACRO 01258000
&LABEL STRTMSGS 01259000
.* Print system-dependent start-up messages 01260000
GBLC &HANDXON @SC92300 01260500
&LABEL CLI S1HND,XON @SC87338 01261000
BNE STRT1Z @SC87338 01262000
BAL 14,TTYCHK @SC92030 01263000
B STRT1Z TTY, suppress message @SC87338 01264000
WTEXT '&HANDXON' @SC87338 01265000
STRT1Z DS 0H @SC87338 01266000
MEND @SC87338 01267000
*COPY KMAIN 01268000
MACRO 01269000
&LABEL KMAIN &TYPE 01270000
.* Linkage conventions with system. 01271000
.* &1: ENTER if entering, RETURN if returning 01272000
GBLC &RTN @SC90264 01273000
AIF ('&TYPE' NE 'RETURN').ENT @SC89268 01274000
&LABEL DS 0H @SC90264 01275000
L DFHEIBR,DFHEIBP @SC91150 01276000
USING DFHEIBLK,DFHEIBR @SC91150 01277000
ICM 2,15,DFHEICAP Any comm area? @SC91150 01278000
BZ KR&SYSNDX No, issue a read @SC91150 01279000
CLC EIBCALEN,=H'7' Length of comm area? @SC91150 01280000
BL KR&SYSNDX Not long enough for a return code @SC91150 01281000
MVC 0(7,2),=C'R(....)' Set up for return code @SC91150 01282000
STM 15,15,2(2) Ok return it @SC91150 01283000
KR&SYSNDX DS 0H @SC91150 01284000
DROP DFHEIBR @SC91150 01285000
DFHEIRET Unlink @SC90264 01286000
MEXIT , @SC89268 01287000
.ENT AIF ('&TYPE' NE 'ENTER').OTH @SC89268 01288000
&LABEL DFHEIENT DATAREG=(KWRKBASE),CODEREG=(KSUBBASE), @LM90264+01289000
EIBREG=(4) @SC90264 01290000
L 10,=A(COMMON) Common code addressibility @SC86316 01291000
LA 0,STORAG @SC86295 01292000
LA 1,8*STODWDS Length of storage @SC86295 01293000
SR 15,15 Zero fill @SC86295 01294000
MVCL 0,14 @SC86295 01295000
LR 15,0 Start of stack @SC86295 01296000
A 0,=A(8*STKDWDS) End of stack @SC87012 01297000
STM 15,0,STKPTR @SC86295 01298000
ST 15,STKLO @SC89089 01299000
LR 15,KSUBBASE Get entry address @SC90264 01300000
MEXIT , @SC89268 01301000
.OTH MNOTE 12,'Invalid type &TYPE' @SC89268 01302000
MEND @SC87338 01303000
*COPY SETUSER @SC90264 01304000
MACRO @SC90264 01305000
&LABEL SETUSER 01306000
.* Grab appropriate userid according to global symbol &USER @SC90264 01307000
.* The code can use R0-9,14,15 but should avoid USING's @SC90264 01308000
.* Valid values: OPID, TERM, UID, OTHER. @SC92150 01309000
GBLC &USER @SC90264 01310000
AIF ('&USER' NE 'OPID').CHKTRM @SC90264 01311000
&LABEL MVC KUSERID(3),COPID Set default directory @SC90264 01312000
MVC KUSERID+3(5),=CL5' ' @SC92150 01313000
MEXIT @SC90264 01314000
.CHKTRM AIF ('&USER' NE 'TERM').CHKUID @SC92150 01315000
&LABEL L 15,DFHEIBP @SC90264 01316000
MVC KUSERID,EIBTRMID-DFHEIBLK(15) @SC90264 01317000
MVC KUSERID+4(4),=CL4' ' @SC92150 01317500
MEXIT @SC90264 01318000
.CHKUID AIF ('&USER' NE 'UID').CHKOTH @SC92150 01318200
&LABEL EXEC CICS ASSIGN USERID(KUSERID), @SC92150 01318400
MEXIT @SC92150 01318600
.CHKOTH AIF ('&USER' NE 'OTHER').ERR @SC90264 01319000
KCALL KUSER,KUSERID,EXT @SC90264 01320000
MEXIT @SC90264 01321000
.ERR MNOTE 12,'Invalid USER type &USER' @SC90264 01322000
MEND @SC90264 01323000
*COPY SAVE 01324000
MACRO 01325000
&LABEL SAVE ®S,&DUM,&TAG @SC90264 01326000
.* Save registers as in OS type-1 linkage 01327000
.* &1: (reg1,reg2) to save, &2 is not used, &3: optional eyecatcher 01328000
LCLA &LEN,&OFF @SC90264 01329000
LCLC &NAME @SC90264 01330000
AIF (N'®S NE 2).ER1 @SC90264 01331000
AIF ('&TAG' EQ '').NOTAG @SC90264 01332000
AIF ('&TAG' EQ '*').DEFTAG @SC90264 01333000
&NAME SETC '&TAG' @SC90264 01334000
&LEN SETA K'&TAG @SC90264 01335000
AGO .SETTAG @SC90264 01336000
.DEFTAG ANOP @SC90264 01337000
&NAME SETC '&LABEL' @SC90264 01338000
&LEN SETA 1 @SC90264 01339000
AIF ('&LABEL' NE '').LOOPC @SC90264 01340000
&NAME SETC '&SYSECT' @SC90264 01341000
.LOOPC AIF ('&NAME'(1,&LEN) EQ '&NAME').SETTAG @SC90264 01342000
&LEN SETA &LEN+1 @SC90264 01343000
AGO .LOOPC @SC90264 01344000
.SETTAG ANOP @SC90264 01345000
&OFF SETA ((&LEN+6)/2)*2 @SC90264 01346000
&LABEL B &OFF.(,15) Skip over tag @SC90264 01347000
DC AL1(&LEN) Length of tag @SC90264 01348000
DC C'&NAME' Tag @SC90264 01349000
AGO .STOR @SC90264 01350000
.NOTAG ANOP @SC90264 01351000
&LABEL DS 0H @SC90264 01352000
.STOR AIF (T'®S(1) NE 'N').ER1 @SC90264 01353000
&OFF SETA ®S(1)*4+20 @SC90264 01354000
AIF (&OFF LE 75).OFFOK @SC90264 01355000
&OFF SETA &OFF-64 @SC90264 01356000
.OFFOK STM ®S(1),®S(2),&OFF.(13) Save @SC90264 01357000
MEXIT @SC90264 01358000
.ER1 MNOTE 12,'INVALID REGISTER LIST ®S' @SC90264 01359000
MEND @SC90264 01360000
*COPY Global variables in open code @SC91260 01390000
GBLC &KTRMS @SC91260 01391000
