*COPY KW 00300000 MACRO 00301000 &LABEL KW &KW,&ADDR,&MIN=1 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), &MIN=length of min. abrv 00306000 GBLC &KVRSN,&KSYS @SC89027 00306500 LCLA &LEN 00307000 AIF ('&KVRSN' EQ '4.2' OR '&KSYS' EQ '').VOK @SC90072 00307200 MNOTE 16,'* * * --> IK0MAC version number should be &KVRSN' @SC89027 00307400 .VOK ANOP @SC89027 00307600 AIF ('&KW' NE '').KW 00308000 &LABEL DC X'FF' 00309000 AGO .DONE 00310000 .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 &LABEL DC AL1(&LEN.),AL3(&ADDR.),AL1(&MIN.-1),C&KW @SC88168 00316000 .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 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 ('&EXT' NE 'EXT').INTRN @SC86295 00395000 L 15,=V(&NAME) @SC86295 00396000 AGO .BAL @SC87012 00397000 .INTRN AIF ('&NAME'(1,1) NE '(').INTRNL @SC87275 00398000 LREG 15,&NAME @SC87275 00399000 AGO .BAL @SC87275 00400000 .INTRNL L 15,=A(&NAME) @SC89215 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 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, &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').ILLM @SC86295 00448000 &CODE SETA 3 @SC86295 00449000 AIF ('&FID' NE '').ILLF @SC86295 00450000 .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 .* 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 00533000 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 SAVE (14,12),,&LABEL @SC86141 00540000 AIF ('&TYPE' NE 'MAIN').ORD @SC86295 00541000 KMAIN ENTER @SC89268 00542000 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 MEND 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 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