/* REXX PLIPOS Annotate a PL/I declare with the start- and end-positions for each field. |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| | | | WARNING: EMBEDDED COMPONENTS. | | See text following TOOLKIT_INIT | | | |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| Written by Frank Clarke 19981009 rexxhead@yahoo.com Impact Analysis . SYSEXEC ELEMLEN Modification History 20040316 fxc corrected calculation of total length; 20050621 fxc enable FORCE; 20051206 fxc finally figured out how to get it to do multiple DCLs; it was not re-initing TEXT in E_ANNOTATE and was blowing up when it tried to start the second DCL; 20070717 fxc warning when BIT elements present; PLIPOS doesn't calculate the length correctly; 20080124 fxc rc(1) at exit; 20090602 fxc correct calc of totlen.fq_name; 20240503 fxc change $ to @ everywhere; */ address ISREDIT /* REXXSKEL ver.20021008 */ "MACRO (opts)" signal on syntax signal on novalue call TOOLKIT_INIT /* conventional start-up -*/ rc = Trace("O"); rc = Trace(tv) address ISPEXEC "CONTROL ERRORS RETURN" call A_INIT /* -*/ call B_FIND_FIRST /* -*/ if sw.0error_found then return call C_DO_ELEMENT /* -*/ if sw.0error_found then exit call D_ROLL_UP /* -*/ if sw.0Rpt = 0 then, call E_ANNOTATE /* -*/ else, call F_ANALYZE /* REPORT was specified -*/ if sw.0GML & sw.0Rpt then, call G_DUMP_GML /* */ if sw.0SaveLog then, call ZB_SAVELOG /* */ exit 1 /*@ PLIPOS */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO parse value "0 0 0 0 0 0 0 0 0" with, gml. . call AA_REINIT /* -*/ call AL_SETUP_LOG /* -*/ return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ AA_REINIT: /*@ */ if branch then call BRANCH address TSO parse value "1 1 1 1 1 " with, start. depth. , efflvl. , . parse value "0 0 0 0 0 0 0 0 " with, agg. end. , length. totlen. , no_room fillseq , . parse value "" with, elemdata. , /* declared name/type/len */ delim_q , extratext , text parent. , parent_id , parent_name, spec , /* data for ELEMLEN */ . /* parse var info source . */ group_list = "BASE" /* fq name list */ parent_q = 1 /* lvl # in DCL */ elemdata.BASE = "BASE" save_lvl = 1 /* effective level */ start = 1 return /*@ AA_REINIT */ /* . ----------------------------------------------------------------- */ AL_SETUP_LOG: /*@ */ if branch then call BRANCH address TSO parse value "0" with, log# log. parse value Date("S") Time("S") Time("N") with, yyyymmdd sssss hhmmss . parse var yyyymmdd 4 yrdigit 5 mm 7 dd /* 9 12 14 maybe */ if Pos(yrdigit,"13579") > 0 then mm = mm + 12 /* mm=24 */ logtag = Substr("ABCDEFGHIJKLMNOPQRSTUVWX",mm,1) /* logtag=X */ subid = logtag""dd""Right(sssss,5,0) /* X1423722 ? */ vb4k.0 = "NEW CATALOG UNIT(SYSDA) SPACE(1 5) TRACKS", "RECFM(V B) LRECL(4096) BLKSIZE(0)" vb4k.1 = "SHR" /* if it already exists... */ logdsn = "@@LOG."exec_name"."subid".#CILIST" gmldsn = "@@GML."exec_name"."subid".#CILIST" call ZL_LOGMSG(exec_name "started by" Userid() yyyymmdd hhmmss) call ZL_LOGMSG("Arg:" opts ) return /*@ AL_SETUP_LOG */ /* Find the first text of the declare; eliminate all front comments. . ----------------------------------------------------------------- */ B_FIND_FIRST: /*@ */ if branch then call BRANCH address ISREDIT line# = 0 slug = '' do forever line# = line# + 1 /* next line */ "(text) = LINE" line# /* acquire text */ if rc > 0 then leave parse var text 2 text 73 slug = Space(slug text,1) do while Left(slug,2) = '615C'x /* slash-asterisk */ ptb = Pos('5C61'x,slug) /* asterisk-slash */ if ptb = 0 then leave /* no comment-end */ else do slug = Delstr(slug,1,ptb+1) /* snip */ slug = Strip(slug) end end /* while comment-start */ if slug <> "" then, /* non-empty */ if Left(slug,2) <> '615C'x then leave /* non-comment */ end /* forever */ if rc > 0 then do sw.0error_found = 1 zerrsm = "No text" zerrlm = "No PL/I declare found in text." address ISPEXEC "SETMSG MSG(ISRZ002)" return end first_line = line# line# = line# - 1 text = "" return /*@ B_FIND_FIRST */ /* Isolate each "line" of the DCL and pass to ELEMLEN. A "line" may span lines or be fragmentary. . ----------------------------------------------------------------- */ C_DO_ELEMENT: /*@ */ c_tv = trace() /* what setting at entry ? */ if branch then call BRANCH address ISREDIT "RENUM" "UNNUM" do forever /* re-evaluate every time */ line# = line# + 1 "(line) = LINE" line# if rc > 0 then leave parse var line 2 line 73 upper line text = Strip(text) Strip(line) call CA_ISOLATE_STMT /* each line in order -*/ rc = Trace("O"); rc = trace(c_tv) if sw.0Error_Found then leave end /* forever */ return /*@ C_DO_ELEMENT */ /* Find a comma or semicolon at the end of the statement. Isolate this fragment of text and pass it to ELEMLEN. . ----------------------------------------------------------------- */ CA_ISOLATE_STMT: /*@ */ ca_tv = trace() /* what setting at entry ? */ if branch then call BRANCH address ISREDIT pt = 0 /* pointer */ if \sw.0Diag then rc = Trace("O") do forever if pt >= Length(text) then do /* end of our rope */ line# = line# + 1 "(line) = LINE" line# if rc > 0 then leave parse var line 2 line 73 upper line pt = Length(text) text = text Strip(line) end /* end of text and no comma */ pt = pt + 1 /* advance pointer */ char = Substr(text,pt,1) /* isolate this character */ if Pos(char,",;()'/") = 0 then iterate if Pos(char,",;") > 0 then, if delim_q = "" then leave if char = "'" then , if Word(delim_q,1) = "'" then, parse var delim_q . delim_q /* remove match */ else delim_q = char delim_q if char = "(" then delim_q = char delim_q ; else, if char = ")" then , if Word(delim_q,1) = "(" then, parse var delim_q . delim_q /* remove match */ if char = "/" then, /* start of comment? */ if Substr(text,pt,2) = "615C"x then do /* slash-asterisk */ pt2 = Pos('5C61'x,text) /* asterisk-slash */ do while pt2 = 0 /* find the end */ line# = line# + 1 "(line) = LINE" line# if rc > 0 then sw.0boom=1 if sw.0boom then leave parse var line 2 line 73 text = text Strip(line) pt2 = Pos('5C61'x,text) /* asterisk-slash */ end /* while */ if sw.0boom then leave text = Delstr(text,pt,pt2-pt+2) end /* it was a comment */ end /* forever */ if sw.0boom then do address TSO "CLEAR" say "Premature end-of-text" sw.0error_found = '1' return end else, if char = ";" then sw.0Stmt_End = 1 rc = Trace("O") rc = trace(ca_tv) parse var text spec =(pt) . +1 text if Word(spec,1) = "DCL" then /* stacked DCL */ spec = DelWord(spec,1,1) /* snip DCL */ address TSO "NEWSTACK" "ELEMLEN" spec "((QUIET" /* 3 zork dec fixed(5) -*/ pull ans /* response from ELEMLEN */ if sw.0Rpt then, call ZL_LOGMSG(ans) "at position" start.eff_lvl if WordPos("INDET",ans) > 0 then do /* Oops.... */ sw.0Error_Found = 1 say ans say "Unable to calculate storage length" return end /* Indeterminate value */ call CAA_ANALYZE_RESPONSE ans /* each stmt in order -*/ "DELSTACK" return /*@ CA_ISOLATE_STMT */ /* What did ELEMLEN say? What level is this element at? Group or data? How long? How deep? The response from ELEMLEN contains these elements: # name {varies} Length ## Depth ## Total ## -or- # name {varies} Group of ## -or- # name {varies} Align on aaa -or- # name {varies} Pointer aligned In particular, {name} may contain parentheses if it is an array, or the arrayspec might be part of {varies}. In either case, the "Depth" value or the "Group" value is equivalent to any arrayspec present. The "key" of all this data must be the fully-qualified name of any element or group to guard against a duplicate element-name in different sub-structures. . ----------------------------------------------------------------- */ CAA_ANALYZE_RESPONSE: /*@ */ if branch then call BRANCH address TSO arg info /* response from ELEMLEN */ parse var info level name rest /* 3 zork fixed dec(5) .... */ if Datatype(level,"W") = 0 then return if WordPos( "BIT",rest ) + Pos( " BIT",rest) > 0 then, sw.0ContainsBits = 1 /* mark for warning */ if Pos("(",name) > 0 then do /* separate arrayspec */ parse var name name "(" other rest = "("other rest end /* separate arrayspec */ if sw.0Stmt_End then, if level = "1" then do /* stacked DCL */ call D_ROLL_UP /* -*/ if sw.0Rpt = 0 then, call E_ANNOTATE /* -*/ else, call F_ANALYZE /* REPORT was specified -*/ call AA_REINIT /* -*/ sw.0Stmt_End = 0 end /* stacked DCL */ if name = "FILLER" |, name = "*" then do fillseq = fillseq + 1 name = name"{"Right(fillseq,3,0) end wdpt = 0 do Words(parent_q) /* all prior parent levels */ wdpt = wdpt + 1 /* index */ parent_lvl = Word(parent_q,wdpt) /* isolate */ if level > parent_lvl then do /* sub-element */ parent_name = Word(group_list,wdpt) leave end end /* parent_q */ fq_name = Strip(parent_name":"name , "L" , ":") group_list = Space(fq_name group_list,1) parent_q = Space(level parent_q,1) eff_lvl = Words(Translate(fq_name,' ',':')) efflvl.fq_name = eff_lvl parent.fq_name = parent_name /* who's my daddy? */ if eff_lvl <> save_lvl then do call ZL_LOGMSG("Level chgd from" save_lvl "to" eff_lvl". ", "Start set to" start.save_lvl) start.eff_lvl = start.save_lvl start = start.save_lvl end info = rest /* clip level and name */ if SWITCH("ALIGN") then do baseelem = KEYWD("ON") /* ON ZORK.FURBLE */ baseelem = Translate(baseelem,":",".") altkey = "BASE:"baseelem start = Max(start.baseelem,start.altkey) start.1 = start /* start.eff_lvl */ end /* ALIGN */ else, if SWITCH("ALIGNED") then do @x = SWITCH("POINTER") start = 1 start.1 = start /* start.eff_lvl */ end /* POINTER */ else, if SWITCH("GROUP") then do agg.fq_name = 1 /* it's an aggregate */ depth.fq_name = KEYWD("OF") , /* GROUP OF ## */ * depth.parent_name end else do depth.fq_name = KEYWD("DEPTH") , * depth.parent_name length.fq_name = KEYWD("LENGTH") totlen.fq_name = KEYWD("TOTAL") * depth.fq_name end elemdata.fq_name = level name info start.fq_name = start /* START is changed only when there is a change-of-level. For elements at the same level, it increments only by the element length. the total length (mult by any array depth) is tracked for the next level change. */ end.fq_name = start.fq_name + totlen.fq_name - 1 start = start + totlen.fq_name start.eff_lvl = start.eff_lvl + totlen.fq_name save_lvl = eff_lvl return /*@ CAA_ANALYZE_RESPONSE */ /* All rows have been analyzed. Begin at the bottom and work up, accumulating lengths and annotating non-data group items. . ----------------------------------------------------------------- */ D_ROLL_UP: /*@ */ if branch then call BRANCH address TSO if Subword(Reverse(parent_q), 1, 2) = "1 1" then do revtext = Reverse(parent_q) revtext = Delword(revtext,1,1) /* snip one word */ parent_q = Reverse(revtext) /* restore */ revtext = Reverse(group_list) revtext = Delword(revtext,1,1) /* snip one word */ group_list = Reverse(revtext) /* restore */ if sw.0Rpt then, call ZL_LOGMSG("Snipped BASE") end do dx = 1 to Words(group_list) fq_name = Word(group_list,dx) /* isolate */ eff_lvl = Words(Translate(fq_name,' ',':')) if length.fq_name = 0 then do /* group */ low_lvl = eff_lvl + 1 /* next deeper */ length.fq_name = length.low_lvl /* roll up */ totlen.fq_name = length.fq_name end.fq_name = start.fq_name + totlen.fq_name - 1 length.low_lvl = 0 /* reset */ end length.eff_lvl = length.eff_lvl + totlen.fq_name if sw.0Rpt then, call ZL_LOGMSG("Strt="start.fq_name, "Len="length.fq_name, "Dpt="depth.fq_name, "End="end.fq_name, fq_name) end /* dx */ /* Last adjustment: we forced level-1 to be 'BASE'. We may have removed that as the first action of this block... or we may not have removed it. If it's still here, shave it off. */ if Word(group_list,Words(group_list)) = "BASE" then do ct = Words(group_list) group_list = Delword(group_list,ct,1) parent_q = Delword(parent_q ,ct,1) end /* BASE */ return /*@ D_ROLL_UP */ /* From the top down, starting at presumed position 1, calculate end position as {start + length - 1}. The start position is the most recent start position of the next superior level. . ----------------------------------------------------------------- */ E_ANNOTATE: /*@ */ if branch then call BRANCH address ISREDIT dcl_len = length.1 /* overall length */ spotlen = Length(dcl_len) /* number of digits */ if spotlen < 3 then sluglen = 9 /*st-en*/ if spotlen = 3 then sluglen = 11 /*str-end*/ if spotlen > 3 then, if sw.0Force then sluglen = spotlen+spotlen+5 else sluglen = spotlen + 6 /* start */ buflen = sluglen + 1 buffer = Copies(" ",buflen) next_ln = first_line prefstrt = 9999 /* super high */ do ex = Words(group_list) to 1 by -1 fq_name = Word(group_list,ex) /* isolate */ fq_brk = Translate(fq_name,' ',':') elemnm = Word(fq_brk,efflvl.fq_name) parse var elemnm elemnm "{" /* snip off seq from FILLER */ call EA_LOCATE_LINE /* -*/ if sw.0endfile then leave call ES_SLUG /* Build the slug -*/ if prefstrt < 200 &, Substr(text,prefstrt,buflen) = "" then do text = Overlay(slug,text,prefstrt,buflen) end else, if Right(text,buflen) = "" then do pt = 73 - buflen text = Overlay(slug,text,pt) prefstrt = pt /* preferred insertion pt */ end else, if Substr(text,2,buflen) = "" then do text = Overlay(slug,text,2,buflen) prefstrt = 2 /* preferred insertion pt */ end else, /* no room to load it */ no_room = no_room + 1 "LINE" next_ln "= (text)" next_ln = next_ln + 1 end /* ex */ if sw.0ContainsBits then, extratext = " ===> Structure contains BIT elements. ", " Calculated length is probably wrong." if no_room > 0 then do zerrsm = "Missing data" zerrlm = no_room "lines were not annotated because there was ", "no room to write the comment on the line. Please ", "make sure there are" buflen "bytes of empty ", "space either at the right or the left ", "margins of the source ", "text on every line. " extratext address ISPEXEC "SETMSG MSG(ISRZ002)" end /* no_room */ else, if sw.0ContainsBits then do zerrsm = "" zerrlm = extratext address ISPEXEC "SETMSG MSG(ISRZ002)" end /* no_room */ return /*@ E_ANNOTATE */ /* . Given: NEXT_LN, a pointer to a text line which may contain the element name. If not, inch down until found. . ----------------------------------------------------------------- */ EA_LOCATE_LINE: /*@ */ if branch then call BRANCH address ISREDIT do forever "(text) = LINE" next_ln if rc > 0 then do sw.0endfile = 1 return end parse var text text 73 uptext = Translate(text) if Pos(elemnm,uptext) > 1 then, /* found! */ return else next_ln = next_ln + 1 /* next line */ end /* forever */ return /*@ EA_LOCATE_LINE */ /* . Given: SPOTLEN (2, 3, or more). Build the slug. . ----------------------------------------------------------------- */ ES_SLUG: /*@ */ if branch then call BRANCH address ISREDIT select when spotlen < 3 then do slug = Right(start.fq_name,2,0)"-"Right(end.fq_name,2,0) slug = '615C'x""slug""'5C61'x end when spotlen = 3 then do slug = Right(start.fq_name,3,0)"-"Right(end.fq_name,3,0) slug = '615C'x""slug""'5C61'x end otherwise do if sw.0Force then, slug = '615C'x, || Right(start.fq_name,spotlen,0)"-", || Right(end.fq_name,spotlen,0), || '5C61'x else, slug = '615C'x, || " "Right(start.fq_name,spotlen,0)" ", || '5C61'x end end /* select */ return /*@ ES_SLUG */ /* . ----------------------------------------------------------------- */ F_ANALYZE: /*@ */ if branch then call BRANCH address ISREDIT grade = Length( length.1 ) /* 240 -> 3; 87 -> 2 */ do ex = Words(group_list) to 1 by -1 fq_name = Word(group_list,ex) /* isolate */ fq_brk = Translate(fq_name,' ',':') elemnm = Word(fq_brk,efflvl.fq_name) msg=Left( , Copies(' ',2*efflvl.fq_name)""elemdata.fq_name , 45), Left("L="totlen.fq_name,7) , Left("St="start.fq_name,8) , Left("End="start.fq_name + totlen.fq_name - 1,8) call ZL_LOGMSG(msg) /* -*/ if sw.0GML then, call FG_SET_GML /* each stmt in order */ end /* ex */ call ZB_SAVELOG /* -*/ address ISPEXEC "VIEW DATASET("logdsn")" return /*@ F_ANALYZE */ /* . ----------------------------------------------------------------- */ FG_SET_GML: /*@ */ if branch then call BRANCH address TSO /* row-start */ txt = ":row." parse value gml.0+1 txt with, @z@ gml.@z@ 1 gml.0 . /* name */ revname = Translate( Reverse( fq_name ),' ',':') name = Reverse( Word( revname,1) ) if Pos("{",name) > 0 then, txt = ":c.*" else, txt = ":c."name parse value gml.0+1 txt with, @z@ gml.@z@ 1 gml.0 . /* shape */ if agg.fq_name then, txt = ":c.*" else do if Pos("CHAR",elemdata.fq_name) > 0 then type = "C"; else, if Pos("DEC" ,elemdata.fq_name) > 0 then type = "D"; else, if Pos("BIN" ,elemdata.fq_name) > 0 then type = "B"; else, if Pos("BIT" ,elemdata.fq_name) > 0 then type = "X"; else, if Pos("PIC" ,elemdata.fq_name) > 0 then type = "Z"; else, if Pos("PTR" ,elemdata.fq_name) > 0 then type = "@"; else, if Pos("POINTER" ,elemdata.fq_name) > 0 then type = "@"; else, type = "?" txt = ":c."type""length.fq_name+0 end parse value gml.0+1 txt with, @z@ gml.@z@ 1 gml.0 . /* start-end */ txt = ":c."Right(start.fq_name,grade,0)"-"Right(end.fq_name,grade,0) parse value gml.0+1 txt with, @z@ gml.@z@ 1 gml.0 . /* description */ if agg.fq_name then, txt = ":c.(agg)" else, txt = ":c." parse value gml.0+1 txt with, @z@ gml.@z@ 1 gml.0 . return /*@ FG_SET_GML */ /* Attach the front-end and the tail-end GML code . ----------------------------------------------------------------- */ G_DUMP_GML: /*@ */ if branch then call BRANCH address TSO call GA_PROLOG /* -*/ "ALLOC FI(@GML) DA("gmldsn") REU" vb4k.0 call GF_LOAD_FRONT /* */ "EXECIO" gml.0 "DISKW @GML (STEM GML." call GT_LOAD_TAIL /* */ "FREE FI(@GML)" call GZ_EPILOG /* -*/ address ISPEXEC "VIEW DATASET("gmldsn")" return /*@ G_DUMP_GML */ /* . ----------------------------------------------------------------- */ GA_PROLOG: /*@ */ if branch then call BRANCH address ISPEXEC call DEIMBED /* */ dd = "" do Words(ddnlist) /* each LIBDEF DD */ parse value ddnlist dd with dd ddnlist @ddn = @ddn.dd /* PLIB322 <- PLIB */ "LIBDEF ISP"dd "LIBRARY ID("@ddn") STACK" end ddnlist = ddnlist dd return /*@ GA_PROLOG */ /* . ----------------------------------------------------------------- */ GF_LOAD_FRONT: /*@ */ if branch then call BRANCH address ISPEXEC daid = daid.GML "LMOPEN DATAID("daid") OPTION(INPUT)" "LMMFIND DATAID("daid") MEMBER(FRONT)" do forever "LMGET DATAID("daid") MODE(INVAR) DATALOC(TEXT)", "DATALEN(DL) MAXLEN(255)" if rc > 0 then leave queue text end /* forever */ address TSO "EXECIO" queued() "DISKW @GML" return /*@ GF_LOAD_FRONT */ /* . ----------------------------------------------------------------- */ GT_LOAD_TAIL: /*@ */ if branch then call BRANCH address ISPEXEC "LMMFIND DATAID("daid") MEMBER(BACK)" do forever "LMGET DATAID("daid") MODE(INVAR) DATALOC(TEXT)", "DATALEN(DL) MAXLEN(255)" if rc > 0 then leave queue text end /* forever */ "LMCLOSE DATAID("daid")" address TSO "EXECIO" queued() "DISKW @GML (FINIS" return /*@ GT_LOAD_TAIL */ /* . ----------------------------------------------------------------- */ GZ_EPILOG: /*@ */ if branch then call BRANCH address ISPEXEC dd = "" do Words(ddnlist) /* each LIBDEF DD */ parse value ddnlist dd with dd ddnlist @ddn = @ddn.dd /* PLIB322 <- PLIB */ "LIBDEF ISP"dd daid = daid.dd "LMFREE DATAID(DAID)" address TSO "FREE FI("@ddn")" end ddnlist = ddnlist dd return /*@ GZ_EPILOG */ /* . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ address TSO sw.0Force = SWITCH("FORCE") sw.0Diag = SWITCH("DIAGNOSE") sw.0Rpt = SWITCH("REPORT") sw.0GML = SWITCH("GML") sw.0SaveLog = SWITCH("LOG") return /*@ LOCAL_PREINIT */ /* subroutines below LOCAL_PREINIT are not selected by SHOWFLOW */ /* Parse out the embedded components at the back of the source code. . ----------------------------------------------------------------- */ DEIMBED: Procedure expose, /*@ */ (tk_globalvars) ddnlist @ddn. daid. address TSO address ISPEXEC "VGET ZSCREENW" fb80po.0 = "NEW UNIT(VIO) SPACE(5 5) TRACKS DIR(40)", "RECFM(F B) LRECL("zscreenw") BLKSIZE(0)" parse value "" with ddnlist @ddn. daid. lastln = sourceline() currln = lastln /* */ if Left(sourceline(currln),2) <> "*/" then return currln = currln - 1 /* previous line */ "NEWSTACK" address ISPEXEC do while sourceline(currln) <> "/*" text = sourceline(currln) /* save with a short name ! */ if Left(text,3) = ")))" then do /* package the queue */ parse var text ")))" ddn mbr . /* PLIB PANL001 maybe */ if Pos(ddn,ddnlist) = 0 then do /* doesn't exist */ ddnlist = ddnlist ddn /* keep track */ @ddn = ddn || Random(999) @ddn.ddn = @ddn address TSO "ALLOC FI("@ddn")" fb80po.0 "LMINIT DATAID(DAID) DDNAME("@ddn")" daid.ddn = daid end daid = daid.ddn "LMOPEN DATAID("daid") OPTION(OUTPUT)" do queued() parse pull line "LMPUT DATAID("daid") MODE(INVAR) DATALOC(LINE)" , "DATALEN("zscreenw")" end "LMMADD DATAID("daid") MEMBER("mbr")" "LMCLOSE DATAID("daid")" end /* package the queue */ else push text /* onto the top of the stack */ currln = currln - 1 /* previous line */ end /* while */ address TSO "DELSTACK" return /*@ DEIMBED */ /* . ----------------------------------------------------------------- */ ZB_SAVELOG: /*@ */ if branch then call BRANCH address TSO if Symbol("LOG#") = "LIT" then return /* not yet set */ "ALLOC FI(@LOG) DA("logdsn") REU" vb4k.0 "EXECIO" log# "DISKW @LOG (STEM LOG. FINIS" "FREE FI(@LOG)" return /*@ ZB_SAVELOG */ /* . ----------------------------------------------------------------- */ ZL_LOGMSG: Procedure expose, /*@ */ (tk_globalvars) log. log# rc = Trace("O") address TSO parse arg msgtext parse value log#+1 msgtext with, zz log.zz 1 log# . if monitor then say, msgtext return /*@ ZL_LOGMSG */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" if helpmsg <> "" then do ; say ""; say helpmsg; end ex_nam = Left(exec_name,8) /* predictable size */ say " " say " "ex_nam" inserts start- and end-position information comments " say " into a PL/I declare. " say " " say " Syntax: "ex_nam" " say " (( " say " " say " " say " " say " " say "*** " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " FORCE causes both the from- and to- positions to be shown even" say " if the length of the structure is > 999. " say " " say " REPORT maintains a log of activity as the DCL is parsed, but " say " does not annotate the DCL. " say " " say " GML produces GML text for a specification document. The " say " output text can be pasted into the body of a GML table " say " to produce a formatted description of the record. " say " REPORT must be specified for GML to be recognized. " say " " say " LOG causes the LOG-file to be written to disk during " say " shutdown. " say " " say " DIAGNOSE turns on trace in CA_ " say " " say "*** " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " Debugging tools provided include: " say " " say " MONITOR: shows the report as it is being produced. Only " say " valid if REPORT was requested. " say " " say " BRANCH: show all paragraph entries. " say " " say " TRACE tv: will use value following TRACE to place the " say " execution in REXX TRACE Mode. " say " " say " " say " Debugging tools can be accessed in the following manner: " say " " say " "ex_nam" debug-options " say " " say " For example: " say " " say " "ex_nam" REPORT TRACE ?R " if sw.inispf then, address ISPEXEC "CONTROL DISPLAY REFRESH" exit /*@ HELP */ /* . ----------------------------------------------------------------- */ BRANCH: Procedure expose, /*@ */ sigl exec_name rc = trace("O") /* we do not want to see this */ arg brparm . origin = sigl /* where was I called from ? */ do currln = origin to 1 by -1 /* inch backward to label */ if Right(Word(Sourceline(currln),1),1) = ":" then do parse value sourceline(currln) with pgfname ":" . /* Label */ leave ; end /* name */ end /* currln */ select when brparm = "NAME" then return(pgfname) /* Return full name */ when brparm = "ID" then do /* wants the prefix */ parse var pgfname pgfpref "_" . /* get the prefix */ return(pgfpref) end /* brparm = "ID" */ otherwise say left(sigl,6) left(pgfname,40) exec_name "Time:" time("L") end /* select */ return /*@ BRANCH */ /* . ----------------------------------------------------------------- */ DUMP_QUEUE: /*@ Take whatever is in stack */ rc = trace("O") /* and write to the screen */ address TSO "QSTACK" /* how many stacks? */ stk2dump = rc - tk_init_stacks /* remaining stacks */ if stk2dump = 0 & queued() = 0 then return say "Total Stacks" rc , /* rc = #of stacks */ " Begin Stacks" tk_init_stacks , /* Stacks present at start */ " Excess Stacks to dump" stk2dump do dd = rc to tk_init_stacks by -1 /* empty each one. */ say "Processing Stack #" dd " Total Lines:" queued() do queued();pull line;say line;end /* pump to the screen */ "DELSTACK" /* remove stack */ end /* dd = 1 to rc */ return /*@ DUMP_QUEUE */ /* Handle CLIST-form keywords added 20020513 . ----------------------------------------------------------------- */ CLKWD: Procedure expose info /*@ hide all except info */ arg kw kw = kw"(" /* form is 'KEY(DATA)' */ kw_pos = Pos(kw,info) /* find where it is, maybe */ if kw_pos = 0 then return "" /* send back a null, not found*/ rtpt = Pos(") ",info" ",kw_pos) /* locate end-paren */ slug = Substr(info,kw_pos,rtpt-kw_pos+1) /* isolate */ info = Delstr(info,kw_pos,rtpt-kw_pos+1) /* excise */ parse var slug (kw) slug /* drop kw */ slug = Reverse(Substr(Reverse(Strip(slug)),2)) return slug /*@CLKWD */ /* Handle multi-word keys 20020513 . ----------------------------------------------------------------- */ KEYWD: Procedure expose info /*@ hide all vars, except info*/ arg kw kw_pos = wordpos(kw,info) /* find where it is, maybe */ if kw_pos = 0 then return "" /* send back a null, not found*/ kw_val = word(info,kw_pos+Words(kw))/* get the next word */ info = Delword(info,kw_pos,2) /* remove both */ return kw_val /*@ KEYWD */ /* . ----------------------------------------------------------------- */ KEYPHRS: Procedure expose, /*@ */ info helpmsg exec_name /* except these three */ arg kp wp = wordpos(kp,info) /* where is it? */ if wp = 0 then return "" /* not found */ front = subword(info,1,wp-1) /* everything before kp */ back = subword(info,wp+1) /* everything after kp */ parse var back dlm back /* 1st token must be 2 bytes */ if length(dlm) <> 2 then /* Must be two bytes */ helpmsg = helpmsg "Invalid length for delimiter("dlm") with KEYPHRS("kp")" if wordpos(dlm,back) = 0 then /* search for ending delimiter*/ helpmsg = helpmsg "No matching second delimiter("dlm") with KEYPHRS("kp")" if helpmsg <> "" then call HELP /* Something is wrong */ parse var back kpval (dlm) back /* get everything b/w delim */ info = front back /* restore remainder */ return Strip(kpval) /*@ KEYPHRS */ /* . ----------------------------------------------------------------- */ NOVALUE: /*@ */ say exec_name "raised NOVALUE at line" sigl say " " say "The referenced variable is" condition("D") say " " zsigl = sigl signal SHOW_SOURCE /*@ NOVALUE */ /* . ----------------------------------------------------------------- */ SHOW_SOURCE: /*@ */ call DUMP_QUEUE /* Spill contents of stacks -*/ if sourceline() <> "0" then /* to screen */ say sourceline(zsigl) rc = trace("?R") nop exit /*@ SHOW_SOURCE */ /* . ----------------------------------------------------------------- */ SS: Procedure /*@ Show Source */ arg ssbeg ssend . if ssend = "" then ssend = 10 if \datatype(ssbeg,"W") | \datatype(ssend,"W") then return ssend = ssbeg + ssend do ssii = ssbeg to ssend ; say Strip(sourceline(ssii),'T') ; end return /*@ SS */ /* . ----------------------------------------------------------------- */ SWITCH: Procedure expose info /*@ */ arg kw sw_val = Wordpos(kw,info) > 0 /* exists = 1; not found = 0 */ if sw_val then /* exists */ info = Delword(info,Wordpos(kw,info),1) /* remove it */ return sw_val /*@ SWITCH */ /* . ----------------------------------------------------------------- */ SYNTAX: /*@ */ errormsg = exec_name "encountered REXX error" rc "in line" sigl":", errortext(rc) say errormsg zsigl = sigl signal SHOW_SOURCE /*@ SYNTAX */ /* . ----------------------------------------------------------------- */ TOOLKIT_INIT: /*@ */ address TSO info = Strip(opts,"T",")") /* clip trailing paren */ info = Strip(opts,"L","(") /* clip trailing paren */ upper info parse source sys_id how_invokt exec_name DD_nm DS_nm, as_invokt cmd_env addr_spc usr_tokn parse value "" with tv helpmsg . parse value 0 "ISR00000 YES" "Error-Press PF1" with, sw. zerrhm zerralrm zerrsm sw.nested = sysvar("SYSNEST") = "YES" sw.batch = sysvar("SYSENV") = "BACK" sw.inispf = sysvar("SYSISPF") = "ACTIVE" if Word(info ,1) = "?" then call HELP /* I won't be back */ "QSTACK" ; tk_init_stacks = rc /* How many stacks? */ parse value SWITCH("BRANCH") SWITCH("MONITOR") SWITCH("NOUPDT") with, branch monitor noupdt . parse value mvsvar("SYSNAME") sysvar("SYSNODE") with, #tk_cpu node . parse value KEYWD("TRACE") "N" with tv . tk_globalvars = "exec_name tv helpmsg sw. zerrhm zerralrm ", "zerrsm zerrlm tk_init_stacks branch monitor ", "noupdt" call LOCAL_PREINIT /* for more opts -*/ return /*@ TOOLKIT_INIT */ /* )))GML FRONT :gdoc. .dv dd 'P43OSXM (1200 bytes)' .dv format 'TP43-04-02' .dv caption 'P43OSXM (Long Station Master)' .* .* ---------> Make appropriate replacements in the .DVs above .* .* ---> Format this with 'SCRIPT.R40.MACLIB(DSMPROF4)' .* ---> for Device=3270 .PM 1 .bm 0 .tm 0 .PL 60 .LL 78 :rdef id=data cwidths='2.3i .6i 1.2i *' arrange='1 1 1 1 / 2 3 4 5' align='left center center center left'. :rdef id=dbdy cwidths='2.3i .6i 1.2i *' arrange='2 3 4 5' align='left center center left'. :table refid=data. :thd. :c. .sx / DDNAME: &dd // Format name: &format / :c.Field Name :c.Type :c.Pos :c.Description :ethd. :row refid=dbdy. )))GML BACK :tcap.&caption :tdesc. :p. 'Field Name' is the declared variable name. :p. 'Type' describes the format of the data item as stored and its length: .br B=Binary .br C=Character (string) .br D=Packed decimal .br P=Pointer .br X=Hexadecimal/Bit .br Z=Picture-format; these are usually numbers but may take other forms. .br *=aggregate; this data item is formed of one or more items which may have different data types and lengths. :p. 'Pos' shows the from-to columns where the data can be found in the stored record. In some cases, a constant location cannot be specified and would have to be calculated on a case-by-case basis. :p. 'Description' is a more elaborate description of the usage and valid values which may appear in the field. :etable. :egdoc. */