TMGTPSTP.m

       ;"------------------------------------------------------------
       ;"------------------------------------------------------------
       ;"
       ;" 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.  This includes accessing global variables --
       ;"  because it will mess up the "naked reference".
       ;"------------------------------------------------------------
       ;"------------------------------------------------------------
       
    STEPTRAP(Pos)
               ;"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.
       
       new tpBlankLine
       new tpAction
       new tpKeyIn
       new tpRunMode,tpStepMode
       new tpI
       new tpDone
       new result set result=1  ;1=step into, 2=step over
       
       ;"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_" "
       
       do VCUSAV2^TMGTERM
       if tpRunMode'=2 do
       . do ShowCodePos(Pos,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(Pos,ScrWidth,ScrHeight)
       . do CUP^TMGTERM(1,ScrHeight+4) ;"Cursor to line (x,y) 
       . write tpBlankLine,!
       . do CUU^TMGTERM(1)
       . write "Action (? for help): "
       . if tpStepMode="into" write "step INTO// " set DefAction="I"
       . else  write "step OVER// " set DefAction="O"
       . read tpAction,!
       . if tpAction="" 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
       . . write tpBlankLine,!
       . . do CUU^TMGTERM(1)
       . . new tpLine
       . . read " enter M code: ",tpLine,!
       . . 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 "Hh"[tpAction do  quit
       . . set tpRunMode=2
       . . set tpDone=1
       . else  do  quit
       . . new tpNLines
       . . for tpNLines=1:1:5 write tpBlankLine,!
       . . do CUU^TMGTERM(5)
       . . write " L  -- run in sLow mode",!
       . . write " M  -- enter any line of M code",!
       . . write " O  -- step OVER line",!
       . . write " I  -- step INTO line",!
       . . write " R  -- run",!
       . . write " H  -- Hide debug code",!
       
    SPDone
       do VCULOAD2^TMGTERM
       set TMGRunMode=tpRunMode
       if tpStepMode="into" set result=1
       else  set result=2
       set TMGStepMode=tpStepMode
       quit result
       
       
    ErrTrap(Pos)
               ;"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(Pos,ScrWidth,ScrHeight)
       
       ETDone
       do VCULOAD2^TMGTERM
       quit 
       
       
       
       
    ShowCode(Pos,ScrWidth,ScrHeight,Wipe)
       ;"Purpose: This will display code at the top of the screen
       ;"Input: Pos -- string like this: X+2^ROUTINE[$DMOD]
       ;"      ScrWidth -- width of code display (Num of columns)
       ;	
       ;"      Wipe -- OPTIONAL.  if 1, then code area is wiped blank
       
       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 nlFGColor=$get(TMGNlFGColor,3)
       set nlBGColor=$get(TMGNlBGColor,0)
       set dbFGColor=$get(TMGDbFGColor,0)
       set dbBGColor=$get(TMGDbBGColor,3)
       
       set BlankLine=" "
       for i=1:1:ScrWidth-1 set BlankLine=BlankLine_" "
       
       do VCOLORS^TMGTERM(dbFGColor,dbBGColor)
       
       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 VCOLORS^TMGTERM(nlFGColor,nlBGColor)
       . for i=0:1:ScrHeight+1 write BlankLine
       
       set s=$piece(Pos,"$",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)
       else  set StartOffset=0
       
       for i=StartOffset:1:(ScrHeight+StartOffset) do
       . new line,Bl,ref,LoopOffset
       . set ref=Label_"+"_i_"^"_Routine
       . set line=$text(@ref)
       . if (i=Offset) do 
       . . do VCOLORS^TMGTERM(nlFGColor,nlBGColor)
       . . 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 VCOLORS^TMGTERM(dbFGColor,dbBGColor)
       
       for i=1:1:ScrWidth write "~"
       write !
       
    SCDone
       ;"do VCULOAD^TMGTERM
       do VCOLORS^TMGTERM(nlFGColor,nlBGColor)
       
       ;"do CUD^TMGTERM(2)
       
       quit