*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,&REG=15                          @SC92300 00343180
.* Copy text string into buffer for editing,                   @SC92300 00343240
.*  &1: 'text string', &2: (optional) initial value for R15,   @SC92300 00343300
.*  &REG: 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    &REG,&LOC                                       @SC92300 00343660
.NOINIT  MVC   0(&LEN,&REG),=C&STRING                          @SC92300 00343720
         LA    &REG,&LEN.(,&REG)                               @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 &REG,&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 &REG,&DATA,&TO,S,SPACE                                   00618000
         MEND                                                           00619000
*COPY                                                 TOCHR             00620000
         MACRO                                                          00621000
&LABEL   TOCHR &REG,&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 &REG,&DATA,&TO,A,SPACE                                   00625000
         MEND                                                           00626000
*COPY                                                 CTL               00627000
         MACRO                                                          00628000
&LABEL   CTL   &REG,&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 &REG,&DATA,&TO,X,F64                            @SC86120 00632000
         MEND                                                           00633000
*COPY                                                 CCHAR             00634000
         MACRO                                                          00635000
&LABEL   CCHAR &REG,&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    &REG,&REG                                       @SC86120 00643000
         IC    &REG,&DATA                                               00644000
.NODATA  &OP   &REG,&VALUE                                              00645000
         AIF   ('&TO' EQ '').TO                                         00646000
         STC   &REG,&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  &REG,&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
&REG     SETC  '&SYSLIST(&N,1)'                                @SC89218 00672000
&CUR     SETC  '&SYSLIST(&N,2)'                                @SC89218 00673000
         AIF   ('&REG' EQ '').ERR2                             @SC89218 00674000
         AIF   ('&CUR' NE '').L1                               @SC89218 00675000
&CUR     SETC  '&REG'                                          @SC89218 00676000
.L1      AIF   (T'&SYSLIST(&N,1) NE 'N').ERR3                  @SC89218 00677000
&RO      SETA  &REG-11                                         @SC89218 00678000
         AIF   (&RO GE 2).L2                                   @SC89218 00679000
&RO      SETA  &REG+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,&REGS=                                   @LM91008 00723300
.* Implement internal trace facility for subroutine calls      @SC91008 00723400
.*  &1: type of trace coding or tag value ('string' or LA)     @SC91008 00723500
.*  &REGS= 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   ('&REGS' EQ '').NOREG                           @SC91008 00725100
         ST    &REGS(1),KTRABF+8                               @SC91008 00725200
         AIF   ('&REGS(2)' EQ '').NOREG                        @SC91008 00725300
         ST    &REGS(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
