\ SPY TRACE Debugging Tool \ \ For PFE: The Portable Forth Environment Version 0.9.14 \ Running on Intel Pentium Processors Under Linux 1.2.8 \ \ Written by: \ R. J. Brown III \ rj@eli.wariat.org \ \ Copyright 1992, 1993, 1996 \ Elijah Laboratories, Inc. \ 759 Independence Dr. #5 \ Palatine IL 60074 \ 847 705-0370 \ http://eli.wariat.org/ \ ALL RIGHTS RESERVED WORLDWIDE \ \ This software is provided subject to the terms of the GNU GENERAL \ PUBLIC LICENSE, a copy of which must be provided as an attachment to \ this file. \ \ This file provides a spy trace facility for PFE Ver 0.9.14 under Linux \ Ver 1.2.8 running on an Intel Pentium processors (or its equivalent). \ \ Debugging is aided by providing a display whenever a traced function \ is entered or exited. Both the calling word and the called word are \ displayed along with the effected portion of the stack to show passed \ arguments for entered words and returned values for exited words. The \ display appears as: \ \ foo ==> bar ( a=1 b=2 c=3 ) \ \ when bar is called from foo, and as: \ \ foo <== bar ( x=10 y=20 ) \ \ when bar returns to foo. The definition of bar must have included the \ stack effect comment: \ \ : bar < a b c -- x y > blah blah blah ; \ \ with the stack effect immediatly following the word name. If the \ stack is not properly balanced with respect to the stack effect \ comment, a stack balance error will be displayed and execution forced \ into step mode. \ \ The package provides for a pause point after each line is displayed. \ If the package is in single step mode, a distinctive display is made \ while waiting for a proceed character: \ \ proceeds in continuous mode; \ Q or q quits, preserving the data stack; \ A or a aborts, clearing the data stack; \ \ Any other character will single step to the next pause point. \ \ If the package is in continuous mode, will put it in single step \ mode, Q, q, A, and a will have the effect described above. In \ continuous mode, the keyboard is sampled, but no disticntive display \ occurs, and execution continues until one of the above characters is \ detected. \ \ \ Control VARIABLEs and their associated meaning: \ \ STEP ON -> single step, \ OFF -> continuous. \ \ SHOW-LEVEL ON -> Display number showing function nesting, \ OFF -> Don't display function nesting number. \ \ nest-tab Number of spaces to indent for each nesting level. \ \ nest-margin Right margin to inhibit nesting indentation. \ \ Rmargin Right margin to determine display wrap-around. \ \ NESTED Current nesting level, should be zero to start. \ \ \ Using the Spy Trace Package \ \ A single colon definition may be spied by using .: instead of : \ to define it. A group of colon definitions may be spied by \ placing DBG-: before the first word, and STD-: after the last \ word. \ \ The behavior of execute and perform may be spied upon (without \ the stack display or balance check) by using .execute and \ .perform in place of execute and perform. \ \ ---------------------------------------------------------------- include macros include stacks \ ---------------- Control Variables ---------------- variable spy \ on to display spytrace info spy on \ default is on variable spy-sound \ controls spy trace sounds spy-sound on \ initialy sound is on! variable nested \ level of traced definition nesting 0 nested ! \ is initially zero : +nest ( -- ) \ increase nesting level 1 nested +! ; : -nest ( -- ) \ decrease nesting level -1 nested +! ; variable nest-tab \ tab size for nesting 3 nest-tab ! \ 3 looks nice variable nest-margin \ max indent allowed 40 nest-margin ! \ half way across screen is default variable stack-check \ watch the stack stack-check on \ we usually do! variable step \ on to single step colon definitions step on \ default is on \ ---------------- Subroutines ---------------- : fog-horn ( -- ) \ attention getting sound effect spy-sound @ \ does he want sound effects? if \ yes, emit \ crippled due to vt100 compatibility requirement :-( then ; \ under LMI Forths, it was *MUSICAL*, sort of ;-) : :indent ( -- ) \ indent according to nesting level spy @ not ?exit \ skip if not verbose mode cr \ start new line nested @ 1- 0 max nest-tab @ * \ compute indentation nest-margin @ min \ limit to something reasonable 0 ?do i nest-tab @ mod \ indentation loop; at tab stop? 0 = if ascii : \ yes, use vertical dotted line else bl \ else use blank space then emit \ output selected character loop ; variable show-level \ on ==> show nesting level numerically show-level off \ default is don't show it! : :indent# ( -- ) \ indent with nesting level shown :indent \ indent to proper position show-level @ if \ show the level? base @ decimal \ display in decimal nested @ . \ show nesting level base ! then ; \ restore previous base \ ---------------- Find Who Called a Word ---------------- nil equ ['].args \ forward references nil equ ['].vals \ ditto variable cfa \ tenative cfa : ?-?-? ; \ the "unknown" cfa : ; \ substitute for the outer interpreter 200 constant longest-word \ only look back this far in dictionary \ when looking for a header : header? ( addr -- flag ) \ is this a header? >name 0<> ; : find-cfa ( rp -- ) \ find cfa pointed to by rp dup ['] -trailing here between? \ is it in dictionary? if \ yes, dup 3 and 0= \ & on a word boundry? if \ yes, dup longest-word - swap \ limit search to "longest-word" do \ search for a header i header? \ is this a header? if i cfa ! leave then \ yes, we're done! -1 cells \ no point to next candidate +loop exit \ we either found one or timed out then then drop ; \ clean stack & return 100 stack dostk \ to stack pointers to do frames : do-frame? ( rp -- flag ) \ is rp pointing inside a do frame on return stack? nil swap \ assume answer is false dostk empty? \ anything on the do stack? if \ yes, dostk ^bot cell+ dostk ^top \ boundries of do stack do dup i @ 2 cells - i @ between? \ is rp inside a do frame? if nip t swap leave then \ yes, set answer true -1 cells +loop \ no, keep searching dostack then drop ; \ just return the flag : .called ( -- ) \ print name of who called the current word ['] ?-?-? cfa ! \ default is don't know who r0 @ 1 cells + rp@ 1 cells + do \ search r-stack for valid address i do-frame? not if \ only valid if not do control stuff i @ find-cfa \ if not, try to find the cfa cfa @ ['] ?-?-? <> if \ is it still unknown? leave then then \ no, we found it! 1 cells +loop \ else keep looking cfa @ >name .name bl emit ; \ display the word's name \ ---------------- Wait for a Key with Spinning Cursor ---------------- create cursor-chs here \ table of characters for "spinning" cursor ascii \ c, ascii | c, ascii / c, ascii - c, here swap - constant #cursor-chs \ length of cursor character table : key ( -- key ) \ wait for a keystroke with a fancy cursor begin #cursor-chs 0 do \ for all cursor chars cursor-chs i + c@ emit \ display cursor char 8 emit 100 ms loop \ back up over it ?terminal until \ until a key is hit bl emit 8 emit \ back over it key ; \ and return the key \ ---------------- The Mock Interpreter ---------------- 250 constant mock-length \ max command length create mock-line mock-length 2+ allot \ command line buffer variable mock-nest \ nesting of mock-interpreter 0 mock-nest ! \ initially zero variable mock-depth \ place to save depth before evaluate : mock-abort ( -- ) cr ." abort was prevented!" cr \ announce it! begin depth 1- mock-depth @ > while \ stack ok? drop repeat ; \ no, adjust it : mock-interpreter ( -- ) \ poor man's outer interpreter 1 mock-nest +! \ nest begin :indent# \ indent mock-nest @ 0 do \ for interpreter nesting level ascii > emit \ show a > for each nesting loop bl emit \ show prompt mock-line 1+ mock-length expect \ get next line span @ mock-line c! \ get its length mock-line c@ 0<> while \ quit if empty depth mock-depth ! \ remember depth mock-line count ['] evaluate catch \ interpret command if mock-abort then \ intercepting any serious errors repeat -1 mock-nest +! ; \ un-nest \ ---------------- Keystroke Command Dispatcher ---------------- : step' ( keystroke -- ) \ common commands for step & run mode case of >r mock-interpreter r> endof ascii v of spy on ( verbose ) endof ascii t of spy off ( terse ) endof ascii q of nested off cr ." quited! " quit endof ascii a of nested off cr ." aborted! " abort endof endcase ; : >upper ( char -- char ) \ convert a char to upper case dup ascii a ascii z between? \ lower case? if [ ascii a ascii a - ] literal + then ; \ yes, fix! : step? ( -- ) \ test for step & run mode commands step @ if key >upper case \ step mode commands of step off endof ( else ) dup step' endcase else ?terminal if key >upper case \ run mode commands of step on recurse endof ( else ) dup step' endcase then then ; \ ---------------- Parameter Compilation ---------------- variable #parms \ number of parameters so far 0 #parms ! \ initially zero : litq' c" litq" ; ' litq' >body @ constant litq : "parm ( -- ) \ compiles parameter name string litq , \ qouted string literal bl word c@ 1+ allot align \ read it in 1 #parms +! ; \ bump parameter counter \ ---------------- Parameter List Display ---------------- variable rmargin \ right margin wrap point 65 rmargin ! \ initially 65 for 80 col display \ ( this seems to work well... ) : room? ( ^string -- ) \ is there room for string on this line? c@ \ length of string out @ \ position on line before this string + \ position on line after this string rmargin @ \ maximum allowable right margin < ; \ will line be too long? variable spybase \ radix to display parameter values 10 spybase ! \ default is ten! variable out( \ where parameter list starts if we have to wrap line : .parms ( a b ... .a .b ... n -- a b ... ) \ print parameters spy @ if \ showing trace info? ." ( " out @ out( ! \ yes, open paren 1st stack-check @ 0= if ." ... " else \ show variable list dup 0 ?do dup i - pick dup \ get its name string room? not if ascii \ emit \ room on line? :indent# \ no, wrap it begin out @ out( @ < while \ space over to bl emit repeat then \ open paren count type ascii = emit \ display the name dup 2* i - pick \ get its value base @ swap spybase @ base ! \ set display radix . base ! loop then \ display value ." ) " then \ close paren 0 ?do drop loop \ discard name strings step? ; \ give user a break : .vals ( .x .y ... n -- ) \ end of value display :indent# \ indent spy @ if r> r> .called >r >r \ say who called ." <== " .called then \ say who was called r> drop \ discard our rtn addr stack-check @ if \ are we checking? depth over 2* - 1- r> \ exit & entry depths 2dup - if \ check stack balance >r >r .parms :indent r> r> \ show returned values spy on step on \ screech to a halt! ." --> unbalanced stack, entry depth=" . \ show ." exit depth=" . ." <-- " \ depths fog-horn step? \ get his attention! else 2drop .parms then \ show returned values else r> drop .parms then \ ditto stack-check on -nest ; \ always be careful! : token_size+ postpone cell+ ; immediate : .args ( .a .b ... n -- ) \ display calling arguments +nest :indent# \ indent deeper spy @ if r> r> .called >r >r \ say who called ." ==> " .called then \ say who was called depth over 2* - 1- \ compute entry depth r> swap >r >r \ save for stack check .parms \ show the arguments stack-check on \ reset stack check override r> dup >r \ point to val names begin dup @ ['] .vals <> while \ until the end, token_size+ repeat \ skip over val names token_size+ >r ; \ continue... ' .args equ ['].args \ resolve forward refrences ' .vals equ ['].vals \ ditto \ ---------------- Hooks ---------------- variable enter-hook \ default enter hook action ' noop enter-hook ! \ default defaults to noop : ^enter-hook ( 'word -- ^enter-hook ) \ point to enter hook >body ; \ this is first cfa in colon definition : enter-hook@ ( 'word -- cfa ) \ get word's enter hook action ^enter-hook @ ; : enter-hook! ( cfa 'word -- ) \ store a new enter hook action ^enter-hook ! ; variable exit-hook \ default exit hook action ' noop exit-hook ! \ default defaults to noop variable dummy-exit-hook \ drain for non-existent exit hooks : ^exit-hook ( 'word -- ^exit-hook ) ^enter-hook begin dup @ case \ look for exit hook ['] ; of drop dummy-exit-hook exit endof \ ain't none! ['] .args of token_size+ exit endof \ found it! endcase token_size+ again ; \ keep looking : exit-hook@ ( 'word -- cfa ) ^exit-hook @ ; : exit-hook! ( cfa 'word -- ) ^exit-hook ! ; : set-enter-hook \ Syntax: set-enter-hook \ Result: Sets the enter hook of to \ and displays the name \ of the old hook word. \ ' ( ) ' ( ) \ read arguments over enter-hook@ >name .name bl emit \ show old hook name swap enter-hook! ; \ set new hook : set-exit-hook \ just like above only for exit hook ' ( ) ' ( ) \ read arguments over exit-hook@ >name .name bl emit \ show old hook name swap exit-hook! ; \ set new hook \ This word patches the enter hook to jump around all the spy tracing \ code, thereby making the word run in almost true real-time, except for \ the overhead of the jump. : unspy' ( cfa -- ) \ disable spy tracing for a word >body dup begin token_size+ \ next token dup @ \ get that token ['] .vals = until token_size+ \ find spytrace end swap jump over ! \ stuff br in front token_size+ swap swap ! ; \ stuff branch addr : unspy ' dup enter-hook@ >name .name bl emit \ Syntax: unspy unspy' ; \ This word patches the enter-hook to the default enter hook, as stored \ in the variable enter-hook. The idea is to undo the effect of \ unspy. ) : respy' ( cfa -- ) \ resume spy tracing a word enter-hook @ \ put cfa's on stack over enter-hook! \ set new hook >body token_size+ \ point to branch addr ['] noop swap ! ; \ cancel branch address : respy ' dup enter-hook@ >name .name bl emit \ Syntax: respy respy' ; \ ---------------- Compile Parameter List ---------------- : no-stack-check stack-check off ; \ flags word with no stack comment : no-effect ( -- ) \ trace for no stack effect in source code postpone no-stack-check \ enter hook postpone noop \ compile br addr slot 0 postpone literal \ no arguments postpone .args \ to print them postpone no-stack-check \ exit hook 0 postpone literal \ no values postpone .vals ; \ to print them : .parms' ( -- ) \ compile call & return spy-tracing code c" (" delim? not if \ stack effect comment? no-effect exit then \ no, treat special enter-hook @ , \ yes, compile hook postpone noop \ compile br addr slot #parms off ['] "parm c" --" for-each \ compile arg names #parms @ postpone literal \ # of arguments postpone .args \ to print them exit-hook @ , \ compile exit hook #parms off ['] "parm c" )" for-each \ compile val names #parms @ postpone literal \ # of values postpone .vals ; \ to print them \ ---------------- Special Calls ---------------- : .perform ( ^cfa -- ) \ trace perform operations :indent# spy @ if cr .called ." performed " dup @ >name .name then step? perform ; : .execute ( cfa -- ) \ trace execute operations :indent# spy @ if cr .called ." executed " dup >name .name then step? execute ; \ ---------------- Redefine Colon Definitions ---------------- : jump \ do a jump in threaded code to another word. r> \ point to token following "jump" @ >body \ point to place to continue >r ; \ return to there : *: \ define a word, or redefine it if it is already defined. >in @ bl word find if \ does name already exist? swap >in ! >r : r> \ yes, make new definition last @ name> \ get its cfa over >body cell+ ! \ stuff into old definition ['] jump \ get cfa of jump word swap >body ! \ stuff into old definition else drop >in ! : then ; \ no, name does not exist, declare it, : .: *: .parms' ; \ spy-trace version of colon definer variable old-: ' : old-: ! \ old : defining word cfa variable new-: ' .: new-: ! \ new : for debugging variable now-: \ : cfa to use now : std-: old-: @ now-: ! ; \ use standard : word : dbg-: new-: @ now-: ! ; \ use debugging : word std-: \ use standard : for now : : now-: perform ; \ vectored : word \ ---------------- Commands Used As Hooks ---------------- : spy-on spy on ; \ controls display of trace info : spy-off spy off ; : step-on step on ; \ controls single stepping : step-off step off ; : 1s spy-on step-on ; \ controls both : 0s spy-off step-off ; : mi mock-interpreter ; \ invokes the mock interpreter : reset 1s nested off dostk empty! ; \ reset everything to initial state \ ---------------- Modified DO words for Spytracing ---------------- : tracing? ( -- flag ) \ are we compiling spytracing headers? now-: @ new-: @ = ; \ we are if we are using the new colon : do-hook rp@ dostk push ; \ this saves the address of a do frame : do tracing? if postpone do-hook then postpone do ; immediate : ?do tracing? if postpone do-hook then postpone ?do ; immediate : loop-hook dostk pop drop ; \ the discards the saved do frame address : loop postpone loop tracing? if postpone loop-hook then ; immediate : +loop postpone +loop tracing? if postpone loop-hook then ; immediate