home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
ibm370
/
ikmmac.asm
< prev
next >
Wrap
Assembly Source File
|
2020-01-01
|
39KB
|
480 lines
*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.3' 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
GBLC &DESTINA,&AADELIM @SC92300 00888000
KW '&DESTINA',SHODST,MIN=4 @SC87166 00888500
KW '&AADELIM',SHODLM,MIN=4 @SC88095 00889000
MEND 00890000
*COPY KSETPRC 00891000
MACRO 00892000
KSETPRC 00893000
.* System-specific SET handlers (in any order). No operands. 00894000
GBLC &DELIMSG @SC92300 00894500
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 '&DELIMSG' @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
GBLC &AARECFM @SC87166 00929000
KW '&AARECFM',SHORFM @SC87166 00929500
MEND 00930000
*COPY KFILSET 00931000
MACRO 00932000
KFILSET 00933000
.* Specific SET FILE handlers (any order). No operands. 00934000
GBLC &FIXED,&VARIABL @SC92300 00934500
PUSH PRINT @SC87012 00935000
PRINT GEN @SC87012 00936000
SETCMDS CSECT @SC92300 00937000
SETRFMKW KW '&FIXED',SETT,F @SC92300 00938000
KW '&VARIABL',SETT,V @SC92300 00939000
KW , @SC87012 00943000
SET CSECT @SC92300 00943500
.* 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 4,SETRFMKW @SC92300 00953000
LA 6,FILRCF @SC92300 00953600
BAL 14,SHOBRV @SC92300 00954200
NOP 0 @SC92300 00954800
.* 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' @PG89001 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 XINFO=0 @SC92086 01034500
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
ZXINFO MFVAR XINFO,PRE=MF @SC92086 01044500
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 @PG89001 01085000
TM SVCFLG,INTERCPT Intercepting? @PG89001 01086000
BO WTXICP Yes, do it @PG89001 01087000
TPUT (1),(0) @PG89001 01088000
B WTXRET @PG89001 01089000
WTXICP KCALL ICPTYP Call interception code @PG89001 01090000
WTXRET LM 14,1,ICPRGS Restore @PG89001 01091000
BR R15 @PG89001 01092000
* 01095000
KSYSETOA DC A(RATOA) Override E/A table for TTY @SC88301 01096000
KSYSATOE DC A(ATORA) Override A/E @SC88301 01097000
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,&AEACMD,&CONOPTS,&S1CMD1 @SC91311 01145500
GBLA &MAXLR,&MAXBS @SC86268 01146000
GBLC &BADFSPC,&CWDERRM,&CWDPRVS,&DESTINA,&DIRHDNG @SC92300 01146300
GBLC &FILCLSN,&FILCOPY,&FILDELT,&FILRENM,&FMTFSPC @SC92300 01146600
GBLC &KBYTFRE,&NOCPCMD,&NOFSPEC @SC92300 01146900
&KSYS SETC 'MUSIC' System name 01147000
MNOTE '*** Kermit-&KSYS release &KVRSN..&KEDIT &KTAG (&KDATE) ***' 01148000
** BEGIN LANGUAGE-SPECIFIC DATA ** ** MUSIC-specific ** @SC92300 01148030
&BADFSPC SETC 'Invalid file name' @SC92300 01148060
&CWDERRM SETC 'Must be a valid 4-digit MUSIC code' @SC92300 01148090
&CWDPRVS SETC 'Not enough privileges to change code' @SC92300 01148120
&DIRHDNG SETC 'Name Lrecl RFM Kbytes Lines +01148150
Date/time' @SC92086 01148180
&FILCLSN SETC 'File name collision' @SC88049 01148210
&FILCOPY SETC 'File copied' (<26 bytes) @SC92300 01148240
&FILDELT SETC 'File deleted' (<26 bytes) @SC92300 01148270
&FILRENM SETC 'File renamed' (<26 bytes) @SC92300 01148300
&FMTFSPC SETC 'Filespec has format: fn' @SC91224 01148330
&KBYTFRE SETC ' KBytes Free' @SC92300 01148360
&NOCPCMD SETC 'CP commands not supported' @SC92300 01148390
&NOFSPEC SETC 'Missing file name' @SC92300 01148420
* Subcommand keywords @SC92300 01148450
&DESTINA SETC 'DESTINATION' kwd->AAAASET, m=4 @SC87166 01148480
** END LANGUAGE-SPECIFIC DATA ** @SC92300 01148510
&MAXLR SETA 32767 Max lrecl 01149000
&MAXBS SETA 32767 Max blksize 01150000
&AEACMD SETC '0AL1(0)' AEA command prefix (X'F3'=WSF) @SC90173 01150500
&S1CMD SETC 'X''C2''' S/1 command prefix @SC90264 01151000
&S1CMD1 SETC 'X''C3''' S/1 command prefix for Status Req @SC91311 01151100
&CONOPTS SETC 'STCQBIT' SETCON options @SC91311 01151200
&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
MAXWS EQU 1920 Max fullscreen output buffer @SC90277 01156100
MAXRS EQU 1920 Max fullscreen input buffer @SC90277 01156200
FSRDOF EQU 0 Offset of data in fullscreen read @SC92030 01156250
MAXDOF EQU 0 Offset of disk out buffer @SC90264 01156300
STMGT EQU 0 Overhead for storage mngmnt @SC90264 01156600
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 < 9025 Kermit extended max pkt @SC90277 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,' @SC92030 01169000
MNOTE '--- TGET, TPUT, USRCOM' @SC92030 01169500
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
GBLC &HANDXON @SC92300 01182500
&LABEL CLI S1HND,XON @SC87338 01183000
BNE STRT1Z @SC87338 01184000
BAL 14,TTYCHK @SC92030 01185000
B STRT1Z TTY, suppress message @SC87338 01186000
WTEXT '&HANDXON' @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
SAVE (14,12),,&LABEL @SC90264 01204500
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
