home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
ibm370
/
ik0mac.asm
< prev
next >
Wrap
Assembly Source File
|
2020-01-01
|
50KB
|
618 lines
*COPY KW 00300000
MACRO 00301000
&LABEL KW &KW,&ADDR,&CODE,&MIN=1 @SC91320 00302000
.* Define a KW for the parser 00303000
.* &1: 'keyword' or GOTO (to define ptr to next keyword item) or nil 00304000
.* (to end a list), &2: address of handler (if &1 is a 'keyword') or 00305000
.* of next item (if &1 is GOTO) (A), &3: 1-letter code if @SC91320 00306000
.* different from 1st letter of keyword, @SC91320 00306100
.* &MIN=length of min. abrv or 'DEFINE' to set up symbols @SC91320 00306200
GBLC &KVRSN,&KSYS @SC89027 00306500
LCLA &LEN 00307000
LCLC &KW1 @SC91320 00307100
AIF ('&KVRSN' EQ '4.3' OR '&KSYS' EQ '').VOK @SC90072 00307200
MNOTE 16,'* * * --> IK0MAC version number should be &KVRSN' @SC89027 00307400
.VOK ANOP @SC89027 00307600
AIF ('&KW' NE '').KWDF @SC91320 00308000
&LABEL DC X'FF' 00309000
AGO .DONE 00310000
.KWDF AIF ('&KW' NE 'DEFINE').KW @SC91320 00310100
.* Offsets for fields in KW table. @SC91320 00310200
KWLEN EQU 0 Length-1 of name, or special code @SC91320 00310300
KWADR EQU 1 Address of handler (24 bits) @SC91320 00310400
KWMIN EQU 4 Minimum recognizable length - 1 @SC91320 00310500
KWCODE EQU 5 One-letter code for keyword @SC91320 00310600
KWNAME EQU 6 Start of name @SC91320 00310700
AGO .DONE @SC91320 00310800
.KW AIF ('&KW' NE 'GOTO').KWN 00311000
&LABEL DC AL1(254),AL3(&ADDR) @SC88168 00312000
MEXIT 00313000
.KWN ANOP 00314000
&LEN SETA K'&KW-3 00315000
&KW1 SETC '&KW' @SC91320 00316000
&KW1 SETC '&KW1'(2,1) @SC91320 00316100
AIF ('&CODE' EQ '').GOTCODE @SC91320 00316200
&KW1 SETC '&CODE'(1,1) @SC91320 00316300
.GOTCODE ANOP @SC91320 00316400
&LABEL DC AL1(&LEN.),AL3(&ADDR.),AL1(&MIN.-1),C'&KW1' @SC91320 00316500
DC C&KW @SC91320 00316600
.DONE MEND 00317000
*COPY SCAN 00318000
MACRO 00319000
&LABEL SCAN &TABLE,&HELP,&NODISP @SC87320 00320000
.* Parse input using a KW table. Setup already done via NTOKN or CTOKN. 00321000
.* Dispatch to proper handler if found in table, else return. 00322000
.* &1: adr of relevant table (LA/R), &2: handler if '?' (LA), 00323000
.* &3: if 'NODISP', then dispatch to HELP handler with high byte of 00324000
.* R7 not 0 and (R1)-> KW entry (if found) 00325000
&LABEL LREG 1,&TABLE @SC86295 00326000
AIF ('&NODISP' EQ '').CALL @SC87320 00327000
AIF ('&NODISP' NE 'NODISP').ERR @SC87320 00328000
ICM 7,8,* @SC87320 00329000
.CALL BAL 14,SCAN @SC87320 00330000
B &HELP @SC86135 00331000
MEXIT @SC87320 00332000
.ERR MNOTE 2,'Invalid positional parameter &NODISP' @SC87320 00333000
MEND 00334000
*COPY HELP 00335000
MACRO 00336000
&LABEL HELP &TABLE,&RETURN 00337000
.* Display acceptable keywords, then branch 00338000
.* &1: ptr to table (LA/R), &2: place to branch (LA) 00339000
&LABEL LREG 1,&TABLE @SC86295 00340000
BAL 14,HELPKW 00341000
B &RETURN @SC86135 00342000
MEND 00343000
*COPY INITSTR @SC92300 00343060
MACRO @SC92300 00343120
&LABEL INITSTR &STRING,&LOC,®=15 @SC92300 00343180
.* Copy text string into buffer for editing, @SC92300 00343240
.* &1: 'text string', &2: (optional) initial value for R15, @SC92300 00343300
.* ®: register to use for ptr (default 15) @SC92300 00343360
LCLA &LEN @SC92300 00343420
&LEN SETA K'&STRING-2 Can't use apostrophes @SC92300 00343480
&LABEL DS 0H @SC92300 00343540
AIF ('&LOC' EQ '').NOINIT @SC92300 00343600
LA ®,&LOC @SC92300 00343660
.NOINIT MVC 0(&LEN,®),=C&STRING @SC92300 00343720
LA ®,&LEN.(,®) @SC92300 00343780
MEND @SC92300 00343840
*COPY NTOKN 00344000
MACRO 00345000
&LABEL NTOKN &H=,&N= 00346000
.* Pick next token, optionally test for ? 00347000
.* &H= handler if '?' (LA), &N= handler if none (LA) 00348000
&LABEL BAL 14,WSPTOK 00349000
B &N @SC86135 00350000
AIF ('&H' EQ '').H 00351000
CLI 0(6),C'?' @SC86115 00352000
BE &H 00353000
.H MEND 00354000
*COPY FTOKN 00355000
MACRO 00356000
&LABEL FTOKN &H=,&N= 00357000
.* Find start of next token, optionally test for ? 00358000
.* &H= handler if '?' (LA), &N= handler if none (LA) 00359000
&LABEL BAL 9,WSP @SC86295 00360000
B &N @SC86224 00361000
AIF ('&H' EQ '').H @SC86224 00362000
CLI 0(7),C'?' 00363000
BE &H 00364000
.H MEND 00365000
*COPY PTEXT 00366000
MACRO 00367000
&LABEL PTEXT &TEXT,&LEN,&AREG=3,&LREG=4 00368000
.* Set up 2 registers to point to some text and contain the length 00369000
.* &1: 'text' (where text has no doubled ' or & characters) OR 00370000
.* &1: text (LA/R), &2: length of text (LA/R), 00371000
.* &AREG= reg for ptr, &LREG= reg for len 00372000
LCLA &TEXTL 00373000
AIF ('&TEXT'(1,1) EQ '''').TEXT @SC86355 00374000
&LABEL LREG &AREG,&TEXT @SC86295 00375000
AGO .LEN @SC86355 00376000
.TEXT ANOP 00377000
&TEXTL SETA K'&TEXT-2 00378000
&LABEL LA &AREG,=C&TEXT 00379000
AIF ('&LEN' NE '').LEN @SC86355 00380000
LA &LREG,&TEXTL 00381000
MEXIT 00382000
.LEN LREG &LREG,&LEN @SC86295 00383000
MEND 00384000
*COPY KCALL 00385000
MACRO 00386000
&LABEL KCALL &NAME,&VALUE,&EXT,&E= 00387000
.* Call a routine, fill R1 with a parm if any, and allow error branch 00388000
.* &1: routine name or (reg), &2: argument (LA/R) (opt), @SC87275 00389000
.* &3: EXT if non-Kermit, @SC87275 00390000
.* &E= branch if R15 NZ (LA) or (branch,cc) with cc=suffix of B instr 00391000
LCLC &CC @SC86135 00392000
&CC SETC 'NZ' Default condition @SC86135 00393000
&LABEL LREG 1,&VALUE @SC86295 00394000
AIF ('&NAME'(1,1) EQ '(').REGDEST @SC90264 00394500
AIF ('&EXT' NE 'EXT').INTRN @SC86295 00395000
L 15,=V(&NAME) @SC86295 00396000
AGO .BAL @SC87012 00397000
.REGDEST LREG 15,&NAME @SC90264 00398000
AGO .BAL @SC87275 00400000
.INTRN L 15,=A(&NAME) @SC90264 00401000
.BAL BALR 14,15 @SC87012 00402000
AIF ('&E' EQ '').NOERR 00403000
AIF ('&EXT' NE 'EXT').NOLT @SC87012 00404000
LTR 15,15 @SC87012 00405000
.NOLT AIF (N'&E LT 2).NCC @SC87012 00406000
&CC SETC '&E(2)' @SC86135 00407000
.NCC B&CC &E(1) @SC86135 00408000
.NOERR MEND 00409000
*COPY ADCON 00410000
MACRO 00411000
ADCON 00412000
.* Define address constants for subroutine calls, etc. Takes a list. 00413000
LCLA &N @SC86295 00414000
.LUP AIF (&N GE N'&SYSLIST).DUN @SC86295 00415000
&N SETA &N+1 @SC86295 00416000
A&SYSLIST(&N) DC A(&SYSLIST(&N)) @SC87201 00417000
AGO .LUP @SC86295 00418000
.DUN MEND 00419000
*COPY LREG 00420000
MACRO 00421000
&LABEL LREG &R,&VAL @SC86295 00422000
.* Load register with parameter 00423000
.* &1: reg, &2: value (LA) or (reg) or omitted 00424000
AIF ('&VAL' EQ '').OKREG @SC86295 00425000
AIF ('&VAL'(1,1) EQ '(').REG @SC86295 00426000
&LABEL LA &R,&VAL @SC86295 00427000
MEXIT @SC86295 00428000
.REG AIF ('&VAL' EQ '(&R)').OKREG @SC86295 00429000
&LABEL LR &R,&VAL(1) @SC86295 00430000
MEXIT @SC86295 00431000
.OKREG AIF ('&LABEL' EQ '').Z @SC86295 00432000
&LABEL DS 0H @SC86295 00433000
.Z MEND @SC86295 00434000
*COPY WEAKX @SC91325 00434100
MACRO @SC91325 00434200
WEAKX &SYMBOL @SC91325 00434300
.* Test symbol for definition -- make WXTRN if undefined @SC91325 00434400
.* This macro should be invoked late in the program @SC91325 00434500
AIF (T'&SYMBOL NE 'U').DONE @SC91325 00434600
WXTRN &SYMBOL @SC91325 00434700
.DONE MEXIT @SC91325 00434800
MEND @SC91325 00434900
*COPY OPENF 00435000
MACRO 00436000
&LABEL OPENF &MODE,&NAME,&FDB,&FID,&E= 00437000
.* Open file for input or output or test existence 00438000
.* &1: S|L|I|O|T|V, &2: file name (LA/R), &3: pattern FDB (LA/R), 00439000
.* &4: file ticket (LA) (opt), &E= error branch (see KCALL) 00440000
LCLA &CODE @SC86295 00441000
AIF ('&MODE' NE 'S').CKL @SC90037 00441700
&CODE SETA 11 Check size @SC90037 00441800
AGO .MOK @SC90037 00441900
.CKL AIF ('&MODE' NE 'L').CKI @SC90037 00442000
&CODE SETA 22 @SC89073 00442200
AGO .MOK @SC89073 00442400
.CKI AIF ('&MODE' NE 'I').CKO @SC89073 00442600
&CODE SETA 1 @SC86295 00443000
AGO .MOK @SC86295 00444000
.CKO AIF ('&MODE' NE 'O').CKT @SC86295 00445000
&CODE SETA 2 @SC86295 00446000
AGO .MOK @SC86295 00447000
.CKT AIF ('&MODE' NE 'T' AND '&MODE' NE 'V').ILLM @SC91269 00448000
&CODE SETA 3 @SC86295 00449000
AIF ('&FID' NE '').ILLF @SC86295 00450000
AIF ('&MODE' EQ 'T').MOK @SC91269 00450300
&CODE SETA 24 @SC91269 00450600
.MOK ANOP , @SC86295 00451000
&LABEL LA 0,&CODE @SC86295 00452000
LREG 2,&NAME @SC86295 00453000
AIF ('&MODE' NE 'S').CALL @SC90037 00453200
LREG 6,&FID @SC90037 00453400
.CALL ANOP @SC90037 00453600
KCALL DISKIO,&FDB,E=&E @SC86295 00454000
AIF ('&FID' EQ '' OR '&MODE' EQ 'S').Z @SC90037 00455000
ST 0,&FID @SC86295 00456000
.Z MEXIT @SC86295 00457000
.ILLM MNOTE 2,'ILLEGAL MODE ''&MODE''' 00458000
MEXIT @SC86295 00459000
.ILLF MNOTE 2,'FID NOT ALLOWED WITH MODE ''&MODE''' 00460000
MEND 00461000
*COPY CLOSF 00462000
MACRO 00463000
&LABEL CLOSF &FID,&E= 00464000
.* Call DSKIO to close a file and zero ticket. NOP if already 0. 00465000
.* &1: file ticket (LA) (opt), &E= error branch (see KCALL) 00466000
&LABEL LA 0,4 @SC86295 00467000
.CAL KCALL DISKIO,&FID,E=&E @SC86295 00468000
MEND 00469000
*COPY ERRF 00470000
MACRO 00471000
&LABEL ERRF 00472000
.* Call DISKIO to analyze an error code in R15 (no options) 00473000
.* Assumes R1 -> FAB already, as if WRITF or READF just finished. 00473500
.* Clobbers TMPDW 00474000
&LABEL LA 0,12 @SC87338 00475000
CVD 15,TMPDW Save error code @SC87338 00476000
KCALL DISKIO Keep registers same @SC87338 00477000
MEND 00478000
*COPY ERASF 00479000
MACRO 00480000
&LABEL ERASF &NAME,&E= 00481000
.* Call DISKIO to erase a file 00482000
.* &1: file name (LA/R), &E= error branch (see KCALL) 00483000
&LABEL LA 0,14 @SC86295 00484000
KCALL DISKIO,&NAME,E=&E @SC86295 00485000
MEND 00486000
*COPY NXTFSET 00487000
MACRO 00488000
&LABEL NXTFSET &NAME,&TYPE,&E= 00489000
.* Call DISKIO to set up search for files 00490000
.* &1: file name (LA/R), &2: CWD => checking validity for CWD, 00491000
.* END => closing file name search, 00492000
.* &E= error branch (see KCALL) 00493000
LCLA &CODE @SC86295 00494000
&CODE SETA 5 Ordinary setup @SC86295 00495000
AIF ('&TYPE' EQ '').TOK @SC86295 00496000
&CODE SETA 7 End of search @SC86355 00497000
AIF ('&TYPE' EQ 'END').TOK @SC86355 00498000
&CODE SETA 8 Check CWD string @SC86295 00499000
.TOK ANOP 00500000
&LABEL LA 0,&CODE @SC86295 00501000
KCALL DISKIO,&NAME,E=&E Init for NXTFST call @SC86295 00502000
MEND 00503000
*COPY NXTF 00504000
MACRO 00505000
&LABEL NXTF &E= 00506000
.* Call DISKIO to get next file name in FILNAM 00507000
.* &E= error branch (see KCALL) 00508000
&LABEL LA 0,6 @SC86295 00509000
KCALL DISKIO,E=&E Find next file @SC86295 00510000
MEND 00511000
*COPY RET 00512000
MACRO 00513000
&LABEL RET &TYPE 00514000
.* Generate return from subroutines. 00515000
.* &1: MAIN if return from Kermit main code 00516000
AIF ('&TYPE' EQ 'MAIN').RMAIN @SC86295 00517000
&LABEL B RTRN @SC86295 00518000
MEXIT 00519000
.RMAIN ANOP 00520000
&LABEL KMAIN RETURN Back to system @SC89268 00523000
MEND 00528000
*COPY ENTER 00529000
MACRO 00530000
&LABEL ENTER &TYPE @SC86295 00531000
.* Establish routine entry code 00532000
.* &1: ALT if 2ndary entry or MAIN if main program or AGAIN @SC92180 00533000
.* if re-establishing context in named routine @SC92180 00533500
GBLC &RTN @SC86295 00534000
AIF ('&TYPE' EQ 'ALT').ALT @SC86141 00535000
&RTN SETC '&LABEL' 00536000
&LABEL CSECT 00537000
USING &RTN.SV,13 @SC86295 00538000
USING &LABEL,KSUBBASE @SC89268 00539000
AIF ('&TYPE' EQ 'AGAIN').DONE @SC92180 00539200
AIF ('&TYPE' EQ 'MAIN').MAIN @SC90264 00539500
SAVE (14,12),,&LABEL @SC86141 00540000
AGO .ORD @SC90264 00541000
.MAIN ANOP @SC90264 00542000
&LABEL KMAIN ENTER @SC90264 00543000
AGO .ORD @SC86141 00555000
.ALT ENTRY &LABEL @SC86141 00556000
USING &LABEL,15 @SC89215 00556500
&LABEL SAVE (14,12),,* @SC86141 00557000
L 15,=A(&RTN) Start of main routine @SC89215 00558000
DROP 15 @SC89215 00558500
.ORD LA 0,&RTN.LX @SC86295 00559000
BAL 14,SUBENT @SC86295 00560000
.DONE MEND @SC92180 00561000
*COPY EXIT 00562000
MACRO 00563000
EXIT 00564000
.* Assembler stuff for end of routine and end of local temporaries 00565000
GBLC &RTN @SC86295 00566000
DS 0D @SC86295 00567000
&RTN.LX EQU *-&RTN.SV @SC86295 00568000
DROP 13,KSUBBASE @SC89268 00569000
MEND 00570000
*COPY LOCALS 00571000
MACRO 00572000
LOCALS 00573000
.* Define storage for save area. Follow with temporaries 00574000
GBLC &RTN @SC86295 00575000
.LT LTORG @SC86141 00576000
&RTN.SV DSECT @SC86295 00577000
DS 18F @SC86295 00578000
MEND 00579000
*COPY ASCSYM 00580000
MACRO 00581000
ASCSYM &LIST 00582000
.* Define symbols (of form 'Ax') for ASCII upper-case & digits 00583000
LCLA &I,&N 00584000
LCLC &C 00585000
&N SETA K'&LIST Number of chars 00586000
&I SETA 0 00587000
.LP AIF (&I GE &N).DONE 00588000
&I SETA &I+1 00589000
&C SETC '&LIST'(&I,1) 00590000
AIF ('&C' LT 'A').LP 00591000
AIF ('&C' GT 'I').TRJR 00592000
A&C EQU C'&C'-128 00593000
AGO .LP 00594000
.TRJR AIF ('&C' GT 'R').TRSZ 00595000
A&C EQU C'&C'-135 00596000
AGO .LP 00597000
.TRSZ AIF ('&C' GT 'Z').TRNUM 00598000
A&C EQU C'&C'-143 00599000
AGO .LP 00600000
.TRNUM AIF ('&C' GT '9').LP 00601000
A&C EQU C'&C'-192 00602000
AGO .LP 00603000
.DONE MEND 00604000
*COPY NOTQR 00605000
MACRO 00606000
&LABEL NOTQR &BRANCH @SC86120 00607000
.* Test for an Ascii char range of 33-62 and 96-126 00608000
.* &1: branch if out of range (LA) 00609000
&LABEL BAL 14,CHKQR @SC86120 00610000
B &BRANCH @SC86120 00611000
MEND 00612000
*COPY UNCHR 00613000
MACRO 00614000
&LABEL UNCHR ®,&DATA,&TO 00615000
.* UnChr: Subtract an ASCII space. Set cc=M if too small. 00616000
.* &1: reg for value, &2: source (LA) if not &1, &3: dest (LA) (opt) 00617000
&LABEL CCHAR ®,&DATA,&TO,S,SPACE 00618000
MEND 00619000
*COPY TOCHR 00620000
MACRO 00621000
&LABEL TOCHR ®,&DATA,&TO 00622000
.* ToChr: Add an ASCII space 00623000
.* &1: reg for value, &2: source (LA) if not &1, &3: dest (LA) (opt) 00624000
&LABEL CCHAR ®,&DATA,&TO,A,SPACE 00625000
MEND 00626000
*COPY CTL 00627000
MACRO 00628000
&LABEL CTL ®,&DATA,&TO 00629000
.* CTL: Reverse bit 6 to make a ctl char printable and vice versa 00630000
.* &1: reg for value, &2: source (LA) if not &1, &3: dest (LA) (opt) 00631000
&LABEL CCHAR ®,&DATA,&TO,X,F64 @SC86120 00632000
MEND 00633000
*COPY CCHAR 00634000
MACRO 00635000
&LABEL CCHAR ®,&DATA,&TO,&OP,&VALUE 00636000
.* CCHAR: Used by CTL/UNCHR/TOCHR to add/subtract number 00637000
.* &1: reg for value, &2: source (LA) if not &1, &3: dest (LA) (opt), 00638000
.* &4: opcode for change, &5: operand 00639000
AIF ('&LABEL' EQ '').NOLAB 00640000
&LABEL DS 0H 00641000
.NOLAB AIF ('&DATA' EQ '').NODATA 00642000
SR ®,® @SC86120 00643000
IC ®,&DATA 00644000
.NODATA &OP ®,&VALUE 00645000
AIF ('&TO' EQ '').TO 00646000
STC ®,&TO 00647000
.TO MEND 00648000
*COPY MSGDF 00649000
MACRO 00650000
MSGDF &NM,&TEXT 00651000
.* Define error message table entry and pointer 00652000
.* &1: 3-letter error code, &2: 'text of message' 00653000
ERRTAB CSECT 00654000
ERR&NM EQU (*-ERRTAB)/4 Symbolic error number 00655000
DC AL1(L'MSG&NM),AL3(MSG&NM) 00656000
ERRMSGS CSECT 00657000
MSG&NM DC C&TEXT 00658000
MEND 00659000
*COPY RETREG 00660000
MACRO 00661000
&LABEL RETREG &ARG 00662000
.* Return current register value(s) to caller. Clobbers R1. 00663000
.* &1(1): register to be returned, &1(2): register containing value, 00664000
.* &2(1): ditto, etc. 00665000
LCLC ®,&CUR @SC89218 00666000
LCLA &N,&RO @SC89218 00667000
&LABEL L 1,4(,13) Get ptr to save area @SC89218 00668000
&N SETA 1 @SC89218 00669000
.LQ AIF ('&SYSLIST(&N)' EQ '').LP @SC89218 00670000
AIF (N'&SYSLIST(&N) GT 2).ERR1 @SC89218 00671000
® SETC '&SYSLIST(&N,1)' @SC89218 00672000
&CUR SETC '&SYSLIST(&N,2)' @SC89218 00673000
AIF ('®' EQ '').ERR2 @SC89218 00674000
AIF ('&CUR' NE '').L1 @SC89218 00675000
&CUR SETC '®' @SC89218 00676000
.L1 AIF (T'&SYSLIST(&N,1) NE 'N').ERR3 @SC89218 00677000
&RO SETA ®-11 @SC89218 00678000
AIF (&RO GE 2).L2 @SC89218 00679000
&RO SETA ®+5 @SC89218 00680000
.L2 ANOP @SC89218 00681000
&RO SETA 4*&RO @SC89218 00682000
ST &CUR,&RO.(,1) @SC89218 00683000
.LP ANOP @SC89218 00684000
&N SETA &N+1 @SC89218 00685000
AIF (&N LE N'&SYSLIST).LQ @SC89218 00686000
MEXIT @SC89218 00687000
.ERR1 MNOTE 12,'Too many items in &SYSLIST(&N)' @SC89218 00688000
MEXIT @SC89218 00689000
.ERR2 MNOTE 12,'Register not specified in &SYSLIST(&N)' @SC89218 00690000
MEXIT @SC89218 00691000
.ERR3 MNOTE 12,'Non-numeric register in &SYSLIST(&N)' @SC89218 00692000
MEND 00693000
*COPY POINTF 00694000
MACRO 00695000
&LABEL POINTF &FID,&OPTS,&E= 00696000
.* Call DISKIO to skip records just after OPEN 00697000
.* &1: file ticket (LA/R), &2: ptr to # of records to skip 00698000
.* &E= error branch (see KCALL) 00699000
AIF ('&OPTS' EQ '').ERR1 @SC89218 00700000
&LABEL LA 0,23 @SC89218 00701000
ICM 2,15,&OPTS Get number to skip @SC89218 00702000
KCALL DISKIO,&FID,E=&E @SC89218 00703000
MEXIT @SC89218 00704000
.ERR1 MNOTE 12,'Missing record count' @SC89218 00705000
MEND 00706000
*COPY HTBL 00707000
MACRO 00708000
&LABEL HTBL &A,&B,&C,&D,&E,&F,&G,&H,&I,&J,&K,&L,&M,&N,&O,&P 00709000
.* Assemble a hex constant with comma delimiters 00710000
.* &1-&16: up to 16 hex strings 00711000
&LABEL DC X'&A&B&C&D&E&F&G&H&I&J&K&L&M&N&O&P' @SC89268 00712000
MEND @SC89268 00713000
*COPY TBLFIX @SC91316 00713040
MACRO @SC91316 00713080
&NAME TBLFIX &LISTA,&LISTB @SC91316 00713120
.* Alter a translation table for selected printable characters @SC91316 00713160
.* &1: offset chars, &2: replacements (both just strings) @SC91316 00713200
LCLA &I,&N @SC91316 00713240
LCLC &CA,&CB @SC91316 00713280
AIF ('&NAME' EQ '').ERR @SC91316 00713320
&N SETA K'&LISTA Number of chars @SC91316 00713360
&I SETA 0 @SC91316 00713400
.LP AIF (&I GE &N).DONE @SC91316 00713440
&I SETA &I+1 @SC91316 00713480
&CA SETC '&LISTA'(&I,1) @SC91316 00713520
&CB SETC '&LISTB'(&I,1) @SC91316 00713560
ORG &NAME+C'&CA' @SC91316 00713600
DC C'&CB' @SC91316 00713640
AGO .LP @SC91316 00713680
.ERR MNOTE 8,'MISSING LABEL' @SC91316 00713720
.DONE ORG , @SC91316 00713760
MEND @SC91316 00713800
*COPY CHECKVER 00714000
MACRO 00715000
&LABEL CHECKVER &NAME,&VER 00716000
.* Verify that the version numbers in source components match 00717000
.* &1: source component name, &2: version number of component 00718000
GBLC &KVRSN @SC90072 00719000
AIF ('&KVRSN' EQ '&VER').VOK @SC90072 00720000
MNOTE 16,'* * * --> &NAME version number should be &KVRSN' @SC90072 00721000
MNOTE 16,'* * * --> You are attempting to use version &VER' @SC90072 00722000
.VOK MEND @SC90072 00723000
*COPY KTRACE 00723100
MACRO @LM91008 00723200
&LABEL KTRACE &TYPE,®S= @LM91008 00723300
.* Implement internal trace facility for subroutine calls @SC91008 00723400
.* &1: type of trace coding or tag value ('string' or LA) @SC91008 00723500
.* ®S= list of 1 or 2 registers to be stored with tag @SC91008 00723600
.* User examples: 00723700
.* KTRACE 'Found it',REGS=(1,7) traces 'Found it', R1, & R7 00723800
.* KTRACE 0(5),REGS=5 traces 8 bytes from ptr in R5 & R5 too 00723900
.* KTRACE FOOBAR traces 8 bytes from FOOBAR 00724000
GBLC &KTRACE @LM91008 00724100
GBLC &AADEBUG,&ZZZZOR,&AAATEST,&AZDISAB @SC92169 00724150
AIF ('&KTRACE' NE 'YES').NOTRACE @LM91008 00724200
AIF ('&TYPE'(1,1) EQ '''').LABEL @SC91008 00724300
AIF ('&TYPE' EQ 'STORAG').STORAG @LM91008 00724400
AIF ('&TYPE' EQ 'SETUP').SETUP @LM91008 00724500
AIF ('&TYPE' EQ 'DUMP').DUMP @SC92169 00724550
AIF ('&TYPE' EQ 'EXIT').EXIT @LM91008 00724600
AIF ('&TYPE' EQ 'SUBENT').SUBENT @LM91008 00724700
.* "Other" means this was a tag -- use it @SC91008 00724800
.LABEL ANOP @LM91008 00724900
&LABEL XC KTRABF,KTRABF Clear @LM91008 00725000
AIF ('®S' EQ '').NOREG @SC91008 00725100
ST ®S(1),KTRABF+8 @SC91008 00725200
AIF ('®S(2)' EQ '').NOREG @SC91008 00725300
ST ®S(2),KTRABF+12 @SC91008 00725400
.NOREG AIF ('&TYPE'(1,1) EQ '''').LTAGLIT @LM91008 00725500
MVC KTRABF(8),&TYPE Move data at specified location@LM91008 00725600
AGO .KTRCOM @LM91008 00725700
.LTAGLIT MVC KTRABF(8),=CL8&TYPE Use literal for trace entry @LM91008 00725800
AGO .KTRCOM @LM91008 00725900
.* Tracing suppressed -- still generate label if necessary @SC91008 00726000
.NOTRACE AIF ('&LABEL' EQ '').X @LM91008 00726100
&LABEL DS 0H @LM91008 00726200
.X MEXIT @LM91008 00726300
.* Inserted into subroutine entry handler @SC91008 00726400
.SUBENT ANOP @LM91008 00726500
&LABEL L 15,16(,13) Original R15 (needn't preserve) @SC91008 00726600
MVC KTRABF(7),5(15) Copy name @SC91008 00726700
MVC KTRABF+7(1),KTRAEYE Insert sequence number @SC91008 00726800
MVC KTRABF+8(8),20(13) Copy input R0,R1 @SC91008 00726900
.KTRCOM STM 14,15,KTRASV @SC91008 00727000
BAL 14,KTRASTOR @SC91008 00727100
LM 14,15,KTRASV @SC91008 00727200
MEXIT @SC91008 00727300
.* Inserted into RTRN handler @SC91008 00727400
.EXIT ANOP @SC91008 00727500
&LABEL L 1,16(,13) Get original R15 @SC91008 00727600
MVC KTRABF(7),5(1) Copy the name @SC91008 00727700
MVI KTRABF+7,C'>' Indicate EXIT from routine @LM91008 00727800
ST 15,KTRABF+8 Save return code @LM91008 00727900
MVC KTRABF+12(4),24(13) Save possible returned R1 @SC91008 00728000
LA 14,KTRASTOX Where to go when done with trace @SC91008 00728100
* Routine to copy trace entry into table @SC91008 00728200
KTRASTOR ICM 15,15,KTRAPT Get table pointer, if any @SC91008 00728300
BZR 14 Not set up yet @SC91008 00728400
C 15,KTRAHI Over limit? @LM91008 00728500
BL *+8 No, OK ... @LM91008 00728600
L 15,KTRALO Yes ... get start of table @LM91008 00728700
MVC 0(16,15),KTRABF Copy to trace table @LM91008 00728800
LA 15,16(,15) Inc. to next trace table entry @LM91008 00728900
ST 15,KTRAPT @LM91008 00729000
IC 15,KTRAEYE Bump counter @SC91008 00729100
LA 15,1(,15) @SC91008 00729200
STC 15,KTRAEYE @SC91008 00729300
NI KTRAEYE,63 Make it unprintable @SC91008 00729400
BR 14 @SC91008 00729500
KTRASTOX L 15,KTRABF+8 Restore return code @SC91008 00729600
* now restore caller's registers and return @SC91008 00729700
MEXIT @LM91008 00729800
.STORAG ANOP @LM91008 00729900
KTRAEYE DS CL8 Eye-catcher for ptr @LM91008 00730000
KTRALO DS A Start of table @SC91008 00730100
KTRAPT DS A Current pointer in table @LM91008 00730200
KTRAHI DS A Top of table @LM91008 00730300
KTRASV DS 2F Saved R14,R15 during trace @LM91008 00730400
KTRABF DS XL16 Current/last trace item @LM91008 00730500
MEXIT @LM91008 00730600
.SETUP ANOP @LM91008 00730700
MVC KTRAEYE,=CL8' KTRACE:' Fill eye-catcher @LM91008 00730800
ST 1,KTRALO @SC91008 00730900
ST 1,KTRAPT @SC91008 00731000
LA 1,45*16(,1) Allow for 45 trace entries @SC91008 00731100
ST 1,KTRAHI @SC91008 00731200
MEXIT @SC92169 00731300
.DUMP ANOP @SC92169 00731330
&LABEL TM FL1,DEBUG+TSTF Special logging in effect? @SC92169 00731360
BO DUMPTR1 Yes, do it @SC92169 00731390
WTEXT '&AADEBUG &ZZZZOR &AAATEST &AZDISAB' @SC92169 00731420
B RTRN0 Give up @SC92169 00731450
DUMPTR1 LM 5,7,KTRALO Get pointers: start, cur, top @SC92169 00731480
LR 3,7 @SC92169 00731510
SR 3,6 Length of top half of table @SC92169 00731540
SR 7,5 Length of whole table @SC92169 00731570
LR 0,7 Save for dump @SC92169 00731600
LA 2,DUMTBL Start of local copy area @SC92169 00731630
LR 1,2 Save for dump @SC92169 00731660
MVCL 2,6 Copy top half first @SC92169 00731690
LR 6,5 Start of table @SC92169 00731720
LR 3,7 Length remaining to copy @SC92169 00731750
MVCL 2,6 Copy the rest @SC92169 00731780
KHDMP (1),(0),'SUBTRACE' @SC92169 00731810
B RTRN0 @SC92169 00731840
MEND @SC92169 00731870
*COPY KHDMP @SC91008 00732000
MACRO @SC91008 00733000
&LABEL KHDMP &START,&LENGTH,&TITLE @SC91008 00734000
.* Generate a hex dump in the debug log for a selected block @SC91008 00735000
.* &1: adr of storage block (LA/R), &2: length (LA/R), @SC91008 00736000
.* &3: 8-byte title ('string' or LA/R) @SC91008 00737000
GBLC &KTRACE @SC91008 00738000
AIF ('&KTRACE' EQ 'NO').DONE @SC91008 00739000
&LABEL STM 14,2,KHDSAV Save registers @SC91008 00740000
AIF ('&SYSECT' NE 'DISKIO').OK @SC91008 00741000
MNOTE 1,'Be sure not to create a debug loop in DISKIO' SC91008 00742000
.OK AIF ('&LENGTH' EQ '').ERR1 @SC91008 00743000
AIF ('&TITLE' EQ '').ERR2 @SC91008 00744000
LREG 0,&LENGTH @SC91008 00745000
AIF ('&TITLE'(1,1) EQ '''').STRING @SC91008 00746000
LREG 2,&TITLE @SC91008 00747000
AGO .DUMP @SC91008 00748000
.STRING LA 2,=CL8&TITLE @SC91008 00749000
.DUMP KCALL KHDMP,&START Dump the block to the log file @SC91008 00750000
LM 14,2,KHDSAV Restore registers @SC91008 00751000
.DONE MEXIT @SC91008 00752000
.ERR1 MNOTE 8,'No length specified' @SC91008 00753000
MEXIT @SC91008 00754000
.ERR2 MNOTE 8,'No title specified' @SC91008 00755000
MEND @SC91008 00756000
