TMGTPSTP.m
From VistApedia
;"------------------------------------------------------------ ;"------------------------------------------------------------ ;" ;" GT.M STEP TRAP ;" ;" K. Toppenberg ;" 4-13-2005 ;" License: GPL Applies ;" ;" This code module will allow tracing through code. ;" It is used as follows: ;" ;" set $ZSTEP="do STEPTRAP^TMGTRSTP($ZPOS) zstep into zcontinue" ;" zstep into ;" do ^MyFunction ;"<--- put the function you want to trace here ;" ;" set $ZSTEP="" ;"<---turn off step capture ;" quit ;" ;" ;" Dependencies: ;" Uses TMGTERM ;" ;"Notes: ;" This function will be called inbetween lines of the main ;" program that is being traced. Thus is function can't do ;" anything that might change the environment of the main ;" program. ;"------------------------------------------------------------ ;"------------------------------------------------------------ STEPTRAP(idePos,Msg) ;"Purpose: This is the line that is called by GT.M for each zstep event. ;" It will be used to display the current code execution point, and ;" query user as to plans for future execution: run/step/ etc. ;"Input: idePos -- a text line containing position, as returned bye $ZPOS ;" Msg -- OPTIONAL -- can be used by programs to pass in info. ;" If Msg=1, then this function was called without the ;" $ZSTEP value set, so this function should set it. new NakedRef set NakedRef=$$LGR^%ZOSV ;"save naked reference new tpBlankLine new tpAction new tpKeyIn new tpRunMode,tpStepMode new tpI new tpDone new result set result=1 ;1=step into, 2=step over new ViewOffset set ViewOffset=0 ;"Run modes: 0=running mode ;" 1=stepping mode ;" 2=Don't show code ;" 3=running SLOW mode ;" -1=quit set tpRunMode=$get(TMGRunMode,1) set tpStepMode=$get(TMGStepMode,"into") new ScrHeight,ScrWidth set ScrHeight=$get(TMGScrHeight,10) set ScrWidth=$get(TMGScrWidth,80) set tpBlankLine=" " for tpI=1:1:ScrWidth-1 set tpBlankLine=tpBlankLine_" " new ArrayName set ArrayName="^TMP(""TMGIDE"",$J,""MODULES"")" set idePos=$$ConvertPos(idePos,ArrayName) do VCUSAV2^TMGTERM if tpRunMode'=2 do . do ShowCodePos(idePos,ScrWidth,ScrHeight) else do . do CUP^TMGTERM(1,2) write tpBlankLine,! write tpBlankLine,! do CUU^TMGTERM(2) if (tpRunMode=0)!(tpRunMode=3)!(tpRunMode=2) do . write tpBlankLine,! . do CUU^TMGTERM(1) . write "(Press any key to pause)",! . read *tpKeyIn:0 . if (tpKeyIn>0) set tpRunMode=1 . else if tpRunMode=3 hang 1 if tpRunMode=2 goto SPDone ;"Don't showmode --> goto SPDone set tpDone=0 if tpRunMode=1 for do quit:tpDone=1 . new DefAction set DefAction="O" . do ShowCodePos(idePos,ScrWidth,ScrHeight,,ViewOffset) . do CUP^TMGTERM(1,ScrHeight+4) ;"Cursor to line (x,y) . write tpBlankLine,! . do CUU^TMGTERM(2) . if tpWatchLine'="" do . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"" set $etrap="""",$ecode=""""" . . xecute tpWatchLine . . write ! . write tpBlankLine,! . do VTATRIB^TMGTERM(7) ;"reverse text . for i=1:1:ScrWidth write "~" . do VTATRIB^TMGTERM(0) ;"reset text . write ! . do CUU^TMGTERM(2) . write "Action (? for help): " . if tpStepMode="into" write "step INTO// " set DefAction="I" . else write "step OVER// " set DefAction="O" . new loop . for loop=1:1:20 write " " . for loop=1:1:20 write $char(8) ;"backspace . set tpAction=$$READ^XGF(1) write ! . ;"read tpAction,! . if tpActionn="" set tpAction=DefAction . if "rR"[tpAction do quit . . set tpRunMode=0 . . set tpDone=1 . if "lL"[tpAction do quit . . set tpRunMode=3 . . set tpDone=1 . if "mM"[tpAction do quit . . new temp . . do CUU^TMGTERM(1) . . do CHA^TMGTERM(1) ;"move to x=1 on this line . . write tpBlankLine,! . . do CUU^TMGTERM(1) . . read " enter M code (^ to cancel): ",tpLine,! . . if (tpLine'="^") do . . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" . . . write ! ;"get below bottom line for output. . . . xecute tpLine . if "iI"[tpAction do quit . . set tpStepMode="into" . . ;"set $ZSTEP="do STEPTRAP^TMGTPSTP($ZPOS) zstep into zcontinue" . . set tpDone=1 . if "Oo"[tpAction do quit . . set tpStepMode="over" . . ;"set $ZSTEP="do STEPTRAP^TMGTPSTP($ZPOS) zstep over zcontinue" . . set tpDone=1 . if "Bb"[tpAction do quit . . new idePos . . read "Enter breakpoint (e.g. Label+8^MyFunct): ",idePos,! . . set idePos=Pos_":""n tmg s tmg=$$STEPTRAP^TMGTPSTP($ZPOS,1)""" . . ZBREAK @idePos . if "Hh"[tpAction do quit . . set tpRunMode=2 . . set tpDone=1 . if "Ww"[tpAction do quit . . new temp . . do CUU^TMGTERM(1) . . do CHA^TMGTERM(1) ;"move to x=1 on this line . . write tpBlankLine,! . . do CUU^TMGTERM(1) . . read "Enter M code (^ to cancel): ",temp,! . . if temp'="^" set tpWatchLine=temp . if "Aa"[tpAction do quit . . set ViewOffset=ViewOffset-1 . if "Zz"[tpAction do quit . . set ViewOffset=ViewOffset+1 . else do quit . . write ! . . new tpNLines . . for tpNLines=1:1:5 write tpBlankLine,! . . do CUU^TMGTERM(5) . . write " L -- run in sLow mode M -- enter any line of M code",! . . write " O -- step OVER line I -- step INTO line",! . . write " R -- run H -- Hide debug code",! . . write " B -- set Breakpoint W - enter variable watch code ",! . . write " A -- scroll upward Z -- scroll downward",! SPDone do VCULOAD2^TMGTERM set TMGRunMode=tpRunMode if tpStepMode="into" set result=1 else set result=2 set TMGStepMode=tpStepMode if $get(Msg)=1 do . set $ZSTEP="N TMGTrap S TMGTrap=$$STEPTRAP^TMGTPSTP($ZPOS) zstep:(TMGTrap=1) into zstep:(TMGTrap=2) over zcontinue" . zstep:(result=1) into zstep:(result=2) over new discard set discard=$get(@NakedRef) ;"reset naked reference. quit result BlankLine write tpBlankLine do CHA^TMGTERM(1) ;"move to x=1 on this line quit ErrTrap(idePos) ;"Purpose: This is the line that is called by GT.M for each ztrap event. ;" It will be used to display the current code execution point new ScrHeight,ScrWidth set ScrHeight=$get(TMGScrHeight,10) set ScrWidth=$get(TMGScrWidth,70) do VCUSAV2^TMGTERM do ShowCodePos(idePos,ScrWidth,ScrHeight) ETDone do VCULOAD2^TMGTERM quit ShowCode(idePos,ScrWidth,ScrHeight,Wipe,ViewOffset) ;"Purpose: This will display code at the top of the screen ;"Input: idePos -- string like this: X+2^ROUTINE[$DMOD] ;" ScrWidth -- width of code display (Num of columns) ;" ScrHeight -- height of code display (number of rows) ;" Wipe -- OPTIONAL. if 1, then code area is wiped blank ;" ViewOffset -- OPTIONAL. If a value is supplied, then ;" the display will be shifted up or down (i.e. to view ;" code other than at the point of execution) ;" Positive numbers will scroll page downward. new i new Routine,Label,Offest,s new LastRou,LastLabel,LastOffset new dbFGColor,bBGColor,nlFGColor,nlBGColor new BlankLine new StartOffset set ScrWidth=$get(ScrWidth,80) set ScrHeight=$get(ScrHeight,10) set BlankLine=" " for i=1:1:ScrWidth-1 set BlankLine=BlankLine_" " do VTATRIB^TMGTERM(7) ;"reverse text do CUP^TMGTERM(1,1) ;"Cursor to line (1,1) write BlankLine,! ;"This is needed for some reason... do CUU^TMGTERM(2) if $get(Wipe)=1 do goto SCDone . do VTATRIB^TMGTERM(0) ;"reset colors . for i=0:1:ScrHeight+1 write BlankLine set s=$piece(idePos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE set Routine=$piece(s,"^",2) set Label=$piece(s,"^",1) set Offset=+$piece(Label,"+",2) set Label=$piece(Label,"+",1) set s="=== Routine: ^"_Routine_" " write s for i=1:1:ScrWidth-$length(s) write "=" write ! if Offset>(ScrHeight) do set StartOffset=(Offset-ScrHeight)+2 else set StartOffset=0 set StartOffset=StartOffset+$get(ViewOffset) for i=StartOffset:1:(ScrHeight+StartOffset) do . new line,Bl,ref,LoopOffset . set ref=Label_"+"_i_"^"_Routine . set line=$text(@ref) . set line=$$Substitute^TMGSTUTL(line,$Char(9)," ") . if (i=Offset) do . . do VTATRIB^TMGTERM(0) ;"reset colors . . write ">" . else write " " . if $length(line)>(ScrWidth-1) do . . write $extract(line,1,ScrWidth-4),"...",! . else do . . write $extract(line,1,ScrWidth-1) . . write $extract(BlankLine,1,ScrWidth-$length(line)-1),! . if (i=Offset) do VTATRIB^TMGTERM(7) ;"reverse colors for i=1:1:ScrWidth write "~" write ! SCDone do VTATRIB^TMGTERM(0) ;"reset colors quit ScanMod(Module,pArray) ;"Purpose: To scan a module and find all the labels/entry points/Entry points ;"Input: Module -- The name of the module, like "XGF" (not "XGF.m" or "^XGF") ;" pArray -- pointer to (name of) array Will be filled like this ;" pArray(1,"TAG")="Label1" ;" pArray(1,"OFFSET")=1 ;" pArray(2,"TAG")="Label2" ;" pArray(2,"OFFSET")=9 ;" pArray(3,"TAG")="Label3" etc. ;" pArray(3,"OFFSET")=15 ;" pArray("Label1")=1 ;" pArray("Label2")=2 ;" pArray("Label3")=3 ;"Output: Results are put into array ;"Result: none new i set i=1 new LabelNum set LabelNum=0 new line set line="" if $get(Module)="" goto SMDone for do quit:(line="") . new ch . set line=$text(+i^@Module) . if line="" quit . set line=$$Substitute^TMGSTUTL(line,$Char(9)," ") ;"replace tabs for spaces . set ch=$extract(line,1) . if (ch'=" ")&(ch'=";") do . . new label . . set label=$piece(line," ",1) . . set LabelNum=LabelNum+1 . . set @pArray@(LabelNum,"TAG")=label . . set @pArray@(LabelNum,"OFFSET")=i . . set @pArray@(label)=LabelNum . set i=i+1 SMDone quit ConvertPos(Pos,pArray) ;"Purpose: to convert a text positioning line from one that is relative to the last tag/label, into ;" one that is relative to the start of the file ;" e.g. START+8^MYFUNCT --> +32^MYFUNCT ;"Input: Pos -- a position, as returned from $ZPOS ;" pArray -- pointer to (name of). Array holding holding tag offsets ;" pArray will be in this format: ;" pArray("ModuleA",1,"TAG")="ALabel1" ;" pArray("ModuleA",1,"OFFSET")=1 ;" pArray("ModuleA",2,"TAG")="ALabel2" ;" pArray("ModuleA",2,"OFFSET")=9 ;" pArray("ModuleA","Label1")=1 ;" pArray("ModuleA","Label2")=2 ;" pArray("ModuleA","Label3")=3 ;" pArray("ModuleB",1,"TAG")="BLabel1" ;" pArray("ModuleB",1,"OFFSET")=4 ;" pArray("ModuleB",2,"TAG")="BLabel2" ;" pArray("ModuleB",2,"OFFSET")=23 ;" pArray("ModuleB","Label1")=1 ;" pArray("ModuleB","Label2")=2 ;" pArray("ModuleB","Label3")=3 ;" NOTE: -- if array passed is empty, then this function will call ScanModule to fill it ;"Result: returns the new position line, relative to the start of the file/module ;" new s new result set result="" new Routine,Label,Offset set s=$piece(Pos,"$",1) ;"e.g. X+2^ROUTINE$DMOD-->X+2^ROUTINE if s="" goto CPDone set Routine=$piece(s,"^",2) if Routine="" goto CPDone set s=$piece(s,"^",1) set Offset=$piece(s,"+",2) if Offset="" set Offset=1 else set Offset=+Offset set Label=$piece(s,"+",1) if $data(@pArray@(Routine))=0 do . new p2Array set p2Array=$name(@pArray@(Routine)) . do ScanMod(Routine,p2Array) new i set i=+$get(@pArray@(Routine,Label)) if i=0 goto CPDone new GOffset set GOffset=@pArray@(Routine,i,"OFFSET") set result="+"_+(GOffset+Offset)_"^"_Routine CPDone quit result