*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