Difference between revisions of "TMGTPSTP.m"

Latest revision as of 08:56, 10 July 2012

;"------------------------------------------------------------
;"------------------------------------------------------------
;"
;" 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