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(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
       ;"                              $ZTEP value set, so this function should set it.

      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(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)
      . 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 "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
      . else  do  quit
      . . 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",!

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

      quit result


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)

      ;"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)
      ;
      ;"      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(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)
      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)
      . set line=$$Substitute^TMGSTUTL(line,$Char(9),">>>>>")
      . 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