*COPY DMSFREE 00800000 MACRO 00801000 &LABEL DMSFREE &DWORDS=(0),&ERR= 00802000 .* Obtain free storage block: len=8*(R0). Returns ptr in R1, but 00803000 .* preserves registers 2-14 00804000 .* &DWORDS= length in doublewords should be in R0, 00805000 .* &ERR= branch if failure 00806000 GBLC &KVRSN,&KSYS @SC89027 00806100 AIF ('&KVRSN' EQ '4.2' OR '&KSYS' EQ '').VOK @SC90072 00806200 MNOTE 16,'* * * --> IKMMAC version number should be &KVRSN' @SC89027 00806300 .VOK ANOP @SC89027 00806400 &LABEL LREG 0,&DWORDS @SC86299 00807000 SLA 0,3 @SC86299 00808000 AIF ('&ERR' NE '').COND @SC86345 00809000 GETMAIN R,LV=(0) @SC86299 00810000 MEXIT 00811000 .COND GETMAIN R,LV=(0) 00812000 SLR 15,15 00813000 LTR 15,15 @SC86345 00814000 BNZ &ERR @SC86345 00815000 MEND 00816000 *COPY DMSFRET 00817000 MACRO 00818000 &LABEL DMSFRET &DWORDS=(0),&LOC=(1),&ERR= 00819000 .* Return free storage block: len=8*(R0), adr=(R1). Preserve R2-14. 00820000 .* &DWORDS= length in doublewords should be in R0, &LOC= adr (in R1), 00821000 .* &ERR= branch if failure 00822000 &LABEL LREG 0,&DWORDS @SC86299 00823000 SLA 0,3 @SC86299 00824000 FREEMAIN R,LV=(0),A=&LOC @SC86299 00825000 MEND 00826000 *COPY RTEXT 00827000 MACRO 00828000 &LABEL RTEXT &BUF,&PROMPT=,&E= 00829000 .* Read from the terminal, possible prompt. Get length read in R0. 00830000 .* &1: read buffer (len=130) (LA), &PROMPT(1)= prompt buf. if any 00831000 .* (LA/R), &PROMPT(2)= prompt length (LA/R), &E= branch if error 00832000 &LABEL DS 0H @SC86299 00833000 AIF (T'&PROMPT EQ 'O').NOPR @SC87268 00834000 KCALL SUPFNC,7,E=RTE&SYSNDX Skip prompt if stacked @SC88095 00835000 TPUT &PROMPT(1),&PROMPT(2),ASIS @SC87268 00836000 .NOPR ANOP 00837000 RTE&SYSNDX KCALL GETLIN,&BUF,E=&E @SC88095 00838000 MEND 00839000 *COPY SAVEF 00840000 MACRO 00841000 &LABEL SAVEF &TICK,&E= @SC88168 00842000 .* Update disk directory for given file (ticket ptr in R1) 00843000 .* &1: adr of file access ticket (A), &E= branch on error 00844000 MEND 00845000 *COPY WRITF 00846000 MACRO 00847000 &LABEL WRITF &TICK,&BUFFER=,&BSIZE=,&E= 00848000 .* Write to a disk file (ticket ptr in R1) 00849000 .* &1: adr of file access ticket returned by OPENF (A), 00850000 .* &BUFFER= data ptr (LA/R), &BSIZE= data length (LA/R) - if either is 00851000 .* given, it replaces FDB value (see OPENF), &E= branch on error 00852000 &LABEL L 1,&TICK 00853000 AIF ('&BUFFER' EQ '').WSZ 00854000 LREG 15,&BUFFER 00855000 ST 15,FDBBUFF-FABD(1) 00856000 .WSZ AIF ('&BSIZE' EQ '').WGO 00857000 LREG 15,&BSIZE 00858000 ST 15,FDBBSIZ-FABD(1) 00859000 .WGO LA 0,10 Write a record to a file... 00860000 KCALL DISKIO,E=&E 00861000 MEND 00862000 *COPY READF 00863000 MACRO 00864000 &LABEL READF &TICK,&NONUM,&BUFFER=,&BSIZE=,&E= 00865000 .* Read from disk file (see WRITF) 00866000 .* &2: NONUM means chop off numbers 00867000 &LABEL L 1,&TICK 00868000 AIF ('&BUFFER' EQ '').RSZ 00869000 LREG 15,&BUFFER 00870000 ST 15,FDBBUFF-FABD(1) 00871000 .RSZ AIF ('&BSIZE' EQ '').RGO 00872000 LREG 15,&BSIZE 00873000 ST 15,FDBBSIZ-FABD(1) 00874000 .RGO AIF (T'&NONUM EQ 'O').RDC @SC88101 00875000 AIF ('&NONUM' NE 'NONUM').ER1 @SC88101 00876000 SR 0,0 Code 0 for chopping off numbers @SC88101 00877000 AGO .RCAL @SC88101 00878000 .RDC LA 0,9 Read a record to a file... @SC88101 00879000 .RCAL KCALL DISKIO,E=&E 00880000 MEXIT 00881000 .ER1 MNOTE 2,'INVALID PARAMETER ''&NONUM''' @SC88101 00882000 MEND 00883000 *COPY KSETKW 00884000 MACRO 00885000 KSETKW , @SC87166 00886000 .* Define system-specific SET/SHOW parameters (keywords) 00887000 KW 'DESTINATION',SHODST,MIN=4 @SC87166 00888000 KW 'DELIM',SHODLM,MIN=4 @SC88095 00889000 MEND 00890000 *COPY KSETPRC 00891000 MACRO 00892000 KSETPRC 00893000 .* System-specific SET handlers (in any order). No operands. 00894000 PUSH PRINT @SC86355 00895000 PRINT GEN @SC86355 00896000 SETDST KCALL CWDSET @SC86164 00897000 B RTRN Preserve return code @SC86295 00898000 SETDLM NTOKN N=SETDLM1,H=SETDLMH @SC88095 00899000 LTR 7,7 Exactly one character? @SC88095 00900000 BNZ SETDLMH No, explain it @SC88095 00901000 MVC LNDLM,0(6) Yes, use that character @SC88095 00902000 B RTRN0 @SC88095 00903000 SETDLM1 MVI LNDLM,C' ' Turn delimiter off @SC88095 00904000 B RTRN0 @SC88095 00905000 SETDLMH PTEXT 'Line delimiter: one char or none' @SC88095 00906000 B SUBERR @SC88095 00907000 POP PRINT @SC86355 00908000 MEND 00909000 *COPY KSHOPRC 00910000 MACRO 00911000 KSHOPRC 00912000 .* System-specific SHOW handlers (in same order as KW). No operands. 00913000 PUSH PRINT @SC86355 00914000 PRINT GEN @SC86355 00915000 SHODST LA 8,UCODE 00916000 LA 9,4 00917000 BAL 14,SHOCHRN 00918000 B SETDST 00919000 SHODLM LA 8,LNDLM Show delimiter @SC88095 00920000 BAL 14,SHOCHR @SC88095 00921000 B SETDLM @SC88095 00922000 POP PRINT @SC86355 00923000 MEND 00924000 *COPY KFILKW 00925000 MACRO 00926000 KFILKW , @SC87166 00927000 .* Define system-specific file attribute parameters (keywords) 00928000 KW 'RECFM',SHORFM @SC87166 00929000 MEND 00930000 *COPY KFILSET 00931000 MACRO 00932000 KFILSET 00933000 .* Specific SET FILE handlers (any order). No operands. 00934000 PUSH PRINT @SC87012 00935000 PRINT GEN @SC87012 00936000 SETRECVF MVC FILRCF,0(6) Copy RECFM @SC88120 00937000 B RTRN0 @SC87012 00938000 * @SC87012 00939000 SETRFM BAL 4,SETSCN @SC87012 00940000 KW 'FIXED',SETRECVF @SC87012 00941000 KW 'VARIABLE',SETRECVF @SC87012 00942000 KW , @SC87012 00943000 .* add any others here @SC87012 00944000 POP PRINT @SC87012 00945000 MEND 00946000 *COPY KFILSHO 00947000 MACRO 00948000 KFILSHO 00949000 .* Specific SHOW FILE handlers (same order as KW). No operands. 00950000 PUSH PRINT @SC87012 00951000 PRINT GEN @SC87012 00952000 SHORFM LA 8,FILRCF @SC88120 00953000 BAL 14,SHOCHR @SC87012 00954000 B SETRFM @SC87166 00955000 .* add any others here @SC87012 00956000 POP PRINT @SC87012 00957000 MEND 00958000 *COPY WTEXT 00959000 MACRO 00960000 &LABEL WTEXT &ARG,&LEN 00961000 .* Display some text, e.g., WTEXT 'Hi there' or WTEXT (3),(4) 00962000 .* Preserves R2-R14 00963000 .* &1: 'text' (where text has no doubled ' or & characters) OR 00964000 .* &1: adr of text (LA/R), &2: length of text (LA/R) 00965000 GBLC &KSYS @SC88308 00966000 &LABEL PTEXT &ARG,&LEN,AREG=1,LREG=0 @SC86295 00967000 AIF ('&KSYS' NE 'MUSIC').TPUT @SC88308 00968000 BAL 15,WTEXT 'TPUT' @MC88304 00969000 MEXIT @SC88308 00970000 .TPUT SVC 93 'TPUT' @SC88308 00971000 MEND 00972000 *COPY FDBD 00973000 MACRO 00974000 FDBD 00975000 .* Map of File Descriptor Block + File Access Block 00976000 .* Required items below: FABCOMM, FDBD-FDBLRC, FDBSIZE, FDBDATE, 00977000 .* FDBDLRTR, FDBCOP, FDBINFO. See also FDBPAT. 00978000 FABD DSECT , @SC86295 00979000 FDBD DS 0F Beginning of short descriptor @SC86295 00980000 FDBBUFF DS A Buffer ptr @SC86295 00981000 FDBBSIZ DS F Max record length @SC86295 00982000 FDBRCF DS C Record format @SC86295 00983000 FDBFLGS DS X Flags @SC86295 00984000 FDBACTV EQU X'80' File is already open @SC86295 00985000 * SVATT EQU X'40' Preserve attributes @SC90033 00985500 * APPN EQU X'10' DISP=MOD @SC86295 00986000 FWRITE EQU X'04' File opened in WRITE mode 00987000 FDBLRC DS H File record length @SC86295 00988000 FDBSIZE DS F File size in Kbytes @SC88235 00990000 FDBCOP EQU *-FDBD Length to copy for OPEN @SC90037 00990500 FDBDATE DS XL7,X Time stamp: packed yyyymmddhhmmss @SC88235 00991000 FDBINFO EQU *-FDBD Length of info returned 00992000 FABLRTR DS F Record length for truncation @SC88120 00993000 FABUNIT DS X File Unit Number 00994000 FABRC DS X Return code on last file operation 00995000 FABCOMM DS CL8 Last I/O command executed 00996000 FABFN DS CL22 MUSIC filename & code 00997000 FABDWDS EQU (*-FABD+7)/8 @SC86295 00998000 MEND 00999000 *COPY FDBPAT 01000000 MACRO 01001000 FDBPAT &N,&RFM,&SIZ @SC88120 01002000 .* Define system-dependent part of output FDB patterns 01003000 .* &1: variable-name prefix (or null if defining init. values) 01004000 .* &2: RECFM (1-char), &3: LRECL (skip rest of FDB if omitted)@SC88120 01005000 LCLC &R,&F,&L,&S @SC90037 01006000 AIF ('&N' EQ '').ALC @SC86316 01007000 &R SETC 'RCF' @SC88120 01008000 &F SETC 'FLGS' @SC88120 01009000 &L SETC 'LRC' @SC88120 01010000 &S SETC 'FSIZ' @SC90037 01010500 .ALC ANOP @SC86316 01011000 &N&R DC C'&RFM' RECFM @SC88120 01012000 &N&F DC X'00' Flags @SC88120 01013000 AIF ('&SIZ' EQ '').DONE @SC88120 01014000 &N&L DC Y(&SIZ) LRECL @SC88120 01015000 &N&S DC F'0' File size in Kbytes @SC90037 01015500 .DONE ANOP @SC88120 01016000 MEND 01017000 *COPY KSYSVAR 01018000 MACRO 01019000 KSYSVAR 01020000 PUSH PRINT 01021000 PRINT GEN 01022000 .* Define system-dependent globally-known variables 01023000 MFINDBUF DS A Ptr to MFIND1 I/O Buffer 01024000 UCODE DS CL4,C User code 01025000 SCODE DS CL4,C Search Code @SC88308 01026000 FCODE DS CL4 Code located by MFINDX 01027000 * Extra FDB for file manipulations 01028000 DSKSTT DS 0F 01029000 DS XL(FABDWDS*8) Room for FDB @SC86295 01030000 * MFIO Basic Caller's Request Block 01031000 DSKST MFARG 0,RLAB=ZRC,ULAB=ZLU,PICT=Y 01032000 MFARG NAME=0,INFIN=0,INFOUT=0,ARG=0 01033000 MFARG PHYS=0,UCTL=0,UINFO=0,TAG=0 01034000 MFARG EOFPT=0,FSARG=0 01035000 MFGEN , 01036000 * All other MFIO Control Blocks 01037000 MFNAME MFVAR NAME,PRE=MF,PICT=Y 01038000 ZINFIN MFVAR INFIN,PRE=MFI,PICT=Y 01039000 ZINFOUT MFVAR INFOUT,PRE=MFO,PICT=Y 01040000 ZARG MFVAR ARG,PRE=MF,PICT=Y 01041000 ZPHYS MFVAR PHYS,PRE=MF,PICT=Y 01042000 ZUCTL MFVAR UCTL,PRE=MF,PICT=Y 01043000 ZUINFO MFVAR UINFO,PRE=MF,PICT=Y 01044000 MFTAG MFVAR TAG,PRE=MF,PICT=Y 01045000 ZEOFPT MFVAR EOFPT,PRE=MF,PICT=Y 01046000 ZFSARG MFVAR FSARG,PRE=FS,PICT=Y 01047000 * Variables for file directory search 01048000 NXFLG DS X Search Flags 01049000 NFERR EQU X'01' Error on MFIND1 01050000 NFEND EQU X'02' End of search on MFINDX 01051000 NFSOK EQU X'04' Search in progress 01052000 NFSERRS EQU X'08' Error in MFINDX 01053000 NFWLD EQU X'10' Wildcard search necessary 01054000 NFFND EQU X'20' Found at least one file in search @SC88308 01055000 * 01056000 DESTL DS X Non-zero if CWD set. 01057000 * 01058000 NXFN DS CL22 Pattern filespec 01059000 LCFN DS CL22 Located filename 01060000 NXFNL DS F Length of Pattern filespec 01061000 PARMAREA DS 10F Parameter passing block 01062000 NXFLTYP DS F MFINDX Filetype 01063000 NXBKNUM DS F MFINDX Backup number 01064000 NXDIRLOC DS F MFINDX Directory Location 01065000 NXSVFLG DS H MFINDX Flags 01066000 GTPB DS 3F Ptrs for terminal read 01067000 * 01068000 ICPRGS DS 4F Save area for interception code 01069000 SVCOPTR DS 2F Buffer Output and End ptrs 01070000 SVCFLG DS X System Intercept Flag 01071000 INTERCPT EQU X'01' Interception in Progress 01072000 POP PRINT 01073000 MEND 01074000 *COPY KSYSTF 01075000 MACRO 01076000 KSYSTF 01077000 .* Define system-dependent globally-known constants and init. variables 01078000 .* symb .DS + label &P.DEFS mark start of variables/init. values 01079000 GBLC &STORDS @SC89268 01079500 LCLC &P 01080000 PUSH PRINT 01081000 PRINT GEN 01082000 AIF ('&SYSECT' EQ '&STORDS').DS @SC89268 01083000 &P SETC 'I' For initial values @SC88308 01084000 WTEXT STM 14,1,ICPRGS Save @MC88304 01085000 TM SVCFLG,INTERCPT Intercepting ? @MC88304 01086000 BO WTXICP Yes, do it @MC88304 01087000 TPUT (1),(0) @MC88304 01088000 B WTXRET @MC88304 01089000 WTXICP KCALL ICPTYP Call interception code @MC88304 01090000 WTXRET LM 14,1,ICPRGS Restore @MC88304 01091000 BR R15 @MC88304 01092000 * @MC88304 01093000 ADCON ICPTYP @MC88304 01094000 * 01095000 KSYSETOA DC A(RATOA) Override E/A table for TTY @SC88301 01096000 KSYSATOE DC A(ATORA) Override A/E @SC88301 01097000 ADCON GETLIN 01098000 F10 DC F'10' 01099000 F17 DC F'17' 01100000 FM17 DC F'-17' 01101000 SYSATR DC AL1(ADOT,ABL+2,AI,A4) ."I4 System type=MUSIC @SC88273 01102000 LSYSATR EQU *-SYSATR Length of stuff for A-packet @SC88273 01103000 LOGNAM DC C'KERMIT.LOG' 01104000 REPNAM DC C'KERMIT.REPLY' 01105000 SYSTAKE DC C'*COM:SYSTEM.KERMINI' File type 01106000 LSYST EQU *-SYSTAKE @SC86295 01107000 USRTAKE DC C'KERMIT.INI' User for init file 01108000 LUSRT EQU *-USRTAKE 01109000 ASTER DC C'*' Search all default @SC88308 01110000 BLNAME DC CL22' ' Blank name 01111000 QUEST DC C'?' Question mark wildcard 01112000 KMAIL1 DC C'KERMAIL ' System cmd for invoking mail @SC90037 01112100 KMAIL2 DC C' ' @SC90037 01112200 KMAIL3 DC C' ' @SC90037 01112300 KPRNT1 DC C'KERMPRT ' System cmd for printing @SC90037 01112400 KPRNT2 DC C' ' @SC90037 01112500 KPRNT3 DC C' ' @SC90037 01112600 KSUBM1 DC C'KERMSUB ' System cmd for submitting job @SC90037 01112700 KSUBM2 DC C' ' @SC90037 01112800 KSUBM3 DC C' ' @SC90037 01112900 * Default File Creation Values... 01113000 ZINFDEF DC F'32',F'-100',F'-1',H'80',X'0400',X'0000C0C0' 01114000 LZINFDEF EQU *-ZINFDEF 01115000 * Read Plist 01116000 TRM MFARG IO,(RD,FILL),U=9,ARG=TRMARG,PHYS=TRMPHYS 01117000 MFGEN 01118000 * Write Plist 01119000 PRT MFARG IO,(WR,TRUNC),U=6,ARG=TRMARG,PHYS=TRMPHYS 01120000 MFGEN 01121000 TRMARG MFVAR ARG,PRE=TRM 01122000 TRMPHYS MFVAR PHYS,PRE=TRM 01123000 KSYSNIT CSECT @SC89215 01123500 .DS ANOP 01124000 &P.DEFS DS 0D 01125000 &P.LNDLM DC C' ' Initially no delimiter @SC88095 01126000 &P.KPRPL DC AL1(L'KPRPT) @SC89268 01127000 &P.KPRPT DC C'Kermit-MUSIC>' 01128000 ORG &P.KPRPT+20 @SC87268 01129000 POP PRINT 01130000 MEND 01131000 *COPY KSYSBUF 01132000 MACRO 01133000 KSYSBUF 01134000 .* Store buffer ptrs from R1 and increment R1 for specific buffers 01135000 ST 1,MFINDBUF MFIND1 I/O Buffer 01136000 A 1,=F'5120' 10 * 512 byte buffers 01137000 ST 1,GTPB Terminal interactive read buffer 01138000 LA 1,130(1) 01139000 MEND 01140000 *COPY SSYMS 01141000 MACRO 01142000 SSYMS 01143000 .* Set global symbols for conditional assembly 01144000 GBLC &KVRSN,&KSYS,&KDATE,&RTN,&TYPCMD,&S1CMD,&KCONT @SC88309 01145000 GBLC &KEDIT,&STORDS,&KTAG @SC90067 01145500 GBLA &MAXLR,&MAXBS @SC86268 01146000 &KSYS SETC 'MUSIC' System name 01147000 MNOTE '*** Kermit-&KSYS release &KVRSN..&KEDIT &KTAG (&KDATE) ***' 01148000 &MAXLR SETA 32767 Max lrecl 01149000 &MAXBS SETA 32767 Max blksize 01150000 &S1CMD SETC 'C2' S/1 command prefix @LP88187 01151000 &KCONT SETC 'T' Default controller type TTY @SC88309 01152000 PUSH PRINT 01153000 PRINT GEN 01154000 MAXWT EQU 230 Max WRTERM buffer 01155000 MAXRT EQU 230 Max RDTERM buffer 01156000 LFID EQU 22 Max length of filespec 01157000 &TYPCMD SETC 'LIST' Host command for TYPE @SC86299 01158000 TYPMIN EQU 4 Min abbrv of system TYPE cmd or 2 @SC86299 01159000 FBRK1 EQU C'<' Starting character for options @SC89218 01159300 FBRK2 EQU C'>' Ending character for options @SC89218 01159600 KMAXE EQU 1920-7 < 9025 Kermit extended max pkt @SC87351 01160000 STKDWDS EQU 511 Size of save-area stack @SC87012 01161000 &STORDS SETC 'KSTORG' Storage DSECT for Kermit globals @SC89268 01161200 KWRKBASE EQU 11 Base register for work area @SC89268 01161400 KSUBBASE EQU 12 Base register for CSECT @SC89268 01161600 POP PRINT 01162000 MEND @SC86268 01163000 *COPY SYSMACS 01164000 MACRO 01165000 SYSMACS 01166000 .* Include system control block definition macros and list all macros 01167000 MNOTE '---MACROs: CALL, FREEMAIN, GETMAIN, LOCORE, MFARG, MFGEN,' 01168000 MNOTE '--- MFREQ, MFSET, MFVAR, MUSVC, PRIVS, REGS, USRCOM' 01169000 USING $LOCORE,0 01170000 $LOCORE LOCORE , 01171000 ORG $LOCORE+X'800' 01172000 USRCOM 01173000 MUSVC 01174000 PRIVS , 01175000 UPRIVS EQU $JOBFGS+4 01176000 REGS 01177000 MEND @SC86268 01178000 *COPY STRTMSGS 01179000 MACRO 01180000 &LABEL STRTMSGS 01181000 .* Print system-dependent start-up messages 01182000 &LABEL CLI S1HND,XON @SC87338 01183000 BNE STRT1Z @SC87338 01184000 CLI TRMTP,C'T' @SC88308 01185000 BE STRT1Z @SC88308 01186000 CLI TRMTP,C'V' @SC89020 01186300 BE STRT1Z @SC89020 01186600 WTEXT 'Handshake is XON -- not needed' @SC87338 01187000 STRT1Z DS 0H @SC87338 01188000 MEND @SC87338 01189000 *COPY KMAIN 01190000 MACRO 01191000 &LABEL KMAIN &TYPE 01192000 .* Linkage conventions with system. 01193000 .* &1: ENTER if entering, RETURN if returning 01194000 AIF ('&TYPE' NE 'RETURN').ENT @SC89268 01195000 &LABEL L 13,4(13) Unlink @SC86295 01196000 ST 15,16(13) Save return code @SC86295 01197000 LA 0,STODWDS+STKDWDS @SC87012 01198000 LR 1,KWRKBASE @SC89268 01199000 DMSFRET DWORDS=(0),LOC=(1) @SC86295 01200000 LM 14,12,12(13) Restore registers @SC86295 01201000 BR 14 @SC86295 01202000 MEXIT , @SC89268 01203000 .ENT AIF ('&TYPE' NE 'ENTER').OTH @SC89268 01204000 LR KSUBBASE,15 @SC89268 01205000 L 10,=A(COMMON) Common code addressibility @SC86316 01206000 LA 0,STODWDS+STKDWDS @SC87012 01207000 DMSFREE DWORDS=(0) Get storage for vars + stack @SC86295 01208000 LR KWRKBASE,1 Get addressibility @SC89268 01209000 LR 0,1 @SC86295 01210000 LA 1,8*STODWDS Length of storage @SC86295 01211000 SR 15,15 Zero fill @SC86295 01212000 MVCL 0,14 @SC86295 01213000 LR 15,0 Start of stack @SC86295 01214000 A 0,=A(8*STKDWDS) End of stack @SC87012 01215000 STM 15,0,STKPTR @SC86295 01216000 ST 15,STKLO @SC89089 01217000 LM 15,1,16(13) Restore registers @SC86295 01218000 MEXIT , @SC89268 01219000 .OTH MNOTE 12,'Invalid type &TYPE' @SC89268 01220000 MEND @SC89268 01221000