/* REXX PLILBLS Find all labels and display all occurrences of those labels. Impact Analysis . SYSEXEC STRSORT . SYSEXEC SEGMENT (macro) . (alias) ENTRIES . (alias) ENC Modification History 20040831 fxc fixed to work for the Enterprise Compiler; 20040927 fxc discriminate between source and list 20041019 fxc VPUT LBLLIST overwrites LBLLIST of SEGMENT; 20050118 fxc account for MARGINI (shifts source over 1 byte); 20060324 fxc position cursor in the command line; 20231128 fxc only examine 5 bytes to identify the compiler; 20240503 fxc default TRACE to N; */ address ISREDIT "MACRO (opts)" address ISPEXEC "CONTROL ERRORS RETURN" call A_INIT /* -*/ rc = Trace("O"); rc = trace(tv) call B_POSITION /* -*/ if sw.0ErrorFound then return /* bail out */ if sw.0mon then say lastline-topline+1 "lines to be examined." call C_LOCATE_LABELS /* */ if sw.0mon then say Words(lbllist) "labels" call D_EXPOSE_LABELS /* */ /* For ENTRIES NOCALLS, all the PROC and END statements are visible */ if sw.0Comm then, call E_EXPOSE_COMMENTS /* -*/ foundlbls = STRSORT(foundlbls) /* sort the labels */ if sw.0rpt then, call R_REPORT /* -*/ lbllist = foundlbls /* restore */ address ISPEXEC "VPUT LBLLIST SHARED" "UP MAX" exit(1) /*@ PLILBLS */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ address ISPEXEC parse source srcline parse var srcline . . ex_nam . /* macro name */ zerralrm = "NO" zerrhm = "ISR00000" parse value "0 0 0 0 0 0 0 0 0 0 0" with, sw. . parse value "" with, end_on_line. found_on_line. used_on_line., tv lbllist . push opts; pull opts opts = Strip(opts,"T",")") if WordPos("?",opts) > 0 then call HELP /* -*/ sw.0mon = Wordpos("MONITOR",opts) > 0 sw.0rpt = Wordpos("REPORT" ,opts) > 0 sw.0Comm = Wordpos("COMMENT",opts) > 0 sw.0noc = Wordpos("NOCALLS",opts) > 0 |, Wordpos("ENC" ,opts ex_nam) > 0 sw.0ent = Wordpos("ENTRIES",opts ex_nam) > 0 |, Wordpos("ENC" ,opts ex_nam) > 0 parse var opts "TRACE" tv . parse value tv "N" with tv . alfa = "ABCDEFGHIJKLMNOPQRSTUVWXYZ@$#%abcdefghijklmnopqrstuvwxyz" badchars = "=(" return /*@ A_INIT */ /* If DATA_WIDTH is 133, it's a compiler listing so look for a '1' in column-1. If DATA_WIDTH is 80, it's source. . ----------------------------------------------------------------- */ B_POSITION: /*@ */ address ISREDIT "(dw) = DATA_WIDTH" /* LRECL */ if dw = 80 then, do "F FIRST P'^'" end else, if dw = 72 then, /* numbered source */ do "F FIRST P'^' 1 72 " end else, if dw = 133 then, do "SEGMENT LABELS" address ISPEXEC "VGET LBLLIST SHARED" parse var lbllist ".SRC" src_start . src_end . "LABEL" src_start "= .SB" "LABEL" src_end-1 "= .SE" lastline = src_end-1 "F FIRST '1' 1 .SB .SE" "(text) = LINE" .zcsr if Left(text,5) = "15668" then, /* Optimizer */ call BO_OPT_LISTING /* */ else, if Left(text,5) = "15655" then, /* compiler listing */ call BE_ENT_LISTING /* */ return /* processing complete */ end else do zerrsm = "What is this stuff?" zerrlm = "LRECL isn't either 80 (source) or 133 (list). ", "I don't know how to process it." address ISPEXEC "SETMSG MSG(ISRZ002)" exit end /* not 80 or 133 ! */ "LABEL .zcsr = .SB" /* source code */ "(topline,lc) = CURSOR" "F p'^' LAST" /* locate last line */ "LABEL .zcsr = .SE" "(lastline,lc) = CURSOR" lbnd = 2 /* left boundary */ rbnd = lbnd + 70 return /*@ B_POSITION */ /* . ----------------------------------------------------------------- */ BE_ENT_LISTING: /*@ */ address ISREDIT "F 'Line.File' 6 .SB .SE" if rc <> 0 then do zerrsm = "Parse error" zerrlm = "Didn't find STMT header" address ISPEXEC "SETMSG MSG(ISRZ002)" sw.0ErrorFound = 1 return end "F P'#' 9 .SB .SE" if rc <> 0 then do zerrsm = "Parse error" zerrlm = "Didn't find first statement" address ISPEXEC "SETMSG MSG(ISRZ002)" sw.0ErrorFound = 1 return end "(text) = LINE" .zcsr if Substr(text,32,1) = "|" then, lbnd = 33 /* left boundary */ else, lbnd = 32 /* left boundary */ rbnd = lbnd + 70 return /*@ BE_ENT_LISTING */ /* . ----------------------------------------------------------------- */ BO_OPT_LISTING: /*@ */ address ISREDIT lastline = src_end-1 "(lastline,lc) = CURSOR" "F 'STMT LEV NT' 6 .SB .SE" if rc <> 0 then do zerrsm = "Parse error" zerrlm = "Didn't find STMT header" address ISPEXEC "SETMSG MSG(ISRZ002)" sw.0ErrorFound = 1 return end "F P' # ' 8 .SB .SE" if rc <> 0 then do zerrsm = "Parse error" zerrlm = "Didn't find first statement" address ISPEXEC "SETMSG MSG(ISRZ002)" sw.0ErrorFound = 1 return end "(text) = LINE" .zcsr if Substr(text,19,1) = "|" then, lbnd = 20 /* left boundary */ else, lbnd = 19 /* left boundary */ rbnd = lbnd + 70 return /*@ BO_OPT_LISTING */ /* . ----------------------------------------------------------------- */ C_LOCATE_LABELS: /*@ */ address ISREDIT firstornext = "FIRST" do forever "F .SB .SE ':'" firstornext lbnd rbnd if rc > 0 then leave /* not found */ firstornext = "NEXT" "(text) = LINE" .zcsr parse var text =(lbnd) text =(rbnd) /* snip ASA char */ parse var text front ":" rest if Words(front) > 1 then iterate lbl = Strip(front) if Pos(Left(lbl,1),alfa) = 0 then iterate if Pos(Left(lbl,1),badchars) > 0 then iterate "(lx,lc) = CURSOR" ; currln = lx do while Pos(";",rest) = 0 /* find whole statement */ currln = currln + 1 "(extra) = LINE" currln parse var extra =(lbnd) extra =(rbnd) rest = Space(rest extra,1) end /* find whole statement */ upper rest /* shift to uppercase */ rest = Strip(rest) if sw.0ent & Left(rest,4) <> "PROC" then iterate upper lbl /* shift to uppercase */ if sw.0mon then say lbl lbllist = lbllist lbl /* add to the list */ lx = lx + 0 /* strip zeroes */ found_on_line.lbl = found_on_line.lbl lx end /* forever */ return /*@ C_LOCATE_LABELS */ /* . ----------------------------------------------------------------- */ D_EXPOSE_LABELS: /*@ */ d_tv = trace() /* what setting at entry ? */ address ISREDIT "X ALL" foundlbls = lbllist /* save a copy */ do while lbllist <> "" rc = Trace("O"); rc = trace(d_tv) parse var lbllist lbl lbllist if sw.0mon then say lbl loc = "FIRST" do forever "SEEK .SB .SE" loc lbl lbnd rbnd if rc > 0 then leave /* didn't find */ "(xstat) = XSTATUS .zcsr" /* X or NX ? */ "XSTATUS .zcsr = NX" /* show this line */ loc = "NEXT" "(thisline,col) = CURSOR" /* where are we ? */ "(text) = LINE" thisline /* acquire source line */ thisline = thisline + 0 /* strip zeroes */ if Wordpos(thisline,found_on_line.lbl) > 0 then do "XSTATUS .zcsr = NX" /* show this line */ "F ';'" "XSTATUS .zcsr = NX" /* show this line */ iterate /* keep 'found on' line */ end upper text /* shift to uppercase */ parse var text =(lbnd) front (lbl) back =(rbnd) if Left( Strip(back),1 ) = "(" then do if sw.0noc then, "XSTATUS .zcsr =" xstat "CURSOR = .zcsr" rbnd /* prevent reprocessing */ iterate /* subroutine call */ end revfront = Reverse(front) parse var revfront word1 word2 . if word1 = "OT" then, if word2 = "OG" then do used_on_line.lbl = used_on_line.lbl thisline if sw.0noc then "XSTATUS .zcsr =" xstat "CURSOR = .zcsr" rbnd /* prevent reprocessing */ iterate /* keep 'GO TO' */ end if Wordpos(word1,Reverse("CALL GOTO LEAVE")) > 0 then do used_on_line.lbl = used_on_line.lbl thisline if sw.0noc then do "XSTATUS .zcsr =" xstat "CURSOR = .zcsr" rbnd /* prevent reprocessing */ iterate /* keep CALL GOTO LEAVE */ end "F ';'" /* end of CALL */ "CURSOR = .zcsr" rbnd /* prevent reprocessing */ iterate /* keep CALL GOTO LEAVE */ end if Wordpos(";DNE",revfront) > 0 |, Wordpos("DNE",revfront) > 0 then do end_on_line.lbl = end_on_line.lbl thisline "CURSOR = .zcsr" rbnd /* prevent reprocessing */ iterate end "XSTATUS .zcsr =" xstat /* maybe exclude this line */ "CURSOR = .zcsr" rbnd /* prevent reprocessing */ end /* forever */ end /* lbllist */ return /*@ D_EXPOSE_LABELS */ /* Expose all the code between an END and the following PROC. . ----------------------------------------------------------------- */ E_EXPOSE_COMMENTS: /*@ */ address ISREDIT loc = "LAST" /* start from the bottom */ do forever "F NX 'PROC' WORD" loc if rc > 0 then leave loc = "PREV" do forever /* find prior END */ "LABEL .zcsr = .XB" "CURSOR = .zcsr" 1 /* prevent reprocessing */ "F P'^' NX" loc /* prior shown-line */ if rc > 0 then leave /* top of source? */ "(text) = LINE" .zcsr /* acquire text */ parse var text =(lbnd) text =(rbnd) if WordPos("END" ,text) > 0 |, WordPos("END;",text) > 0 then, do "LABEL .zcsr = .XA" "RESET .XA .XB" /* expose all lines */ "CURSOR = .zcsr" 1 /* prevent reprocessing */ leave end end /* forever */ end /* forever */ return /*@ E_EXPOSE_COMMENTS */ /* . ----------------------------------------------------------------- */ R_REPORT: /*@ */ r_tv = trace() /* what setting at entry ? */ address ISREDIT do while foundlbls <> "" rc = Trace("O"); rc = trace(r_tv) parse var foundlbls lbl foundlbls /* isolate */ text = Left(lbl,24) "Found on" Strip(found_on_line.lbl) if end_on_line.lbl <> "" then, text = text " END on" Strip(end_on_line.lbl) if Length(text) > 70 then do do while Length(text) > 70 lbpos = LastPos(" ",text,70) savedtxt = Substr(text,lbpos+1) text = Left(text,lbpos) "LINE_BEFORE .SB = NOTELINE '"text"'" text = Copies(" ",33) savedtxt end /* while length > 70 */ end "LINE_BEFORE .SB = NOTELINE '"text"'" text = Left(" ",24) " Used on" Strip(used_on_line.lbl) if Length(text) > 70 then do do while Length(text) > 70 lbpos = LastPos(" ",text,70) savedtxt = Substr(text,lbpos+1) text = Left(text,lbpos) "LINE_BEFORE .SB = NOTELINE '"text"'" text = Copies(" ",33) savedtxt end /* while length > 70 */ end "LINE_BEFORE .SB = NOTELINE '"text"'" end /* foundlbls */ return /*@ R_REPORT */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" ex_nam = Left("PLILBLS",8) /* predictable size */ say " "ex_nam" displays all the labels in a PL/I program. Options can " say " be used to restrict the display to classes of usage. " say " " say " Syntax: "ex_nam" " say " " say " " say " " say " " say " " say " MONITOR displays key information throughout processing. " say " " say " REPORT places a summary report of where-found/where-used " say " at the top of the source. " say " " say " NOCALLS excludes the invocation points and shows only the " say " target labels. " say " " say " COMMENT exposes all the code between a visible END statement" say " and the PROC immediately following. " say " " say " ENTRIES excludes ordinary labels; shows only PROCEDURE " say " entry points. " say " " say " TRACE tv will use the value following TRACE to place " say " the execution in REXX TRACE Mode. " say " " if sysvar("SYSISPF") = "ACTIVE" then, address ISPEXEC "CONTROL DISPLAY REFRESH" exit /*@ HELP */