File:  [gforth] / gforth / Attic / backtrace.fs
Revision 1.1: download - view: text, annotated - select for diffs
Sun Jan 3 21:48:36 1999 UTC (22 years, 9 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added ]L, IN-DICTIONARY? and IN-RETURN-STACK? to stuff.fs
refactored a few words to use IN-DICTIONARY?
added backtrace hooks to CATCH, THROW and (DOERROR)
added simple backtrace printing

    1: \ backtrace handling
    2: 
    3: \ Copyright (C) 1999 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation; either version 2
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program; if not, write to the Free Software
   19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: 
   21: 
   22: \ growing buffers that need not be full
   23: 
   24: struct
   25:     cell% 0 * field buffer-descriptor \ addr u
   26:     cell% field buffer-length
   27:     cell% field buffer-address
   28:     cell% field buffer-maxlength \ >=length
   29: end-struct buffer%
   30: 
   31: : init-buffer ( addr -- )
   32:     buffer% %size erase ;
   33: 
   34: : adjust-buffer ( u addr -- )
   35:     \G adjust buffer% at addr to length u
   36:     \ this may grow the allocated area, but never shrinks it
   37:     dup >r buffer-maxlength @ over <
   38:     if ( u )
   39: 	r@ buffer-address @ over resize throw r@ buffer-address !
   40: 	dup r@ buffer-maxlength !
   41:     then
   42:     r> buffer-length ! ;
   43: 
   44: \ backtrace stuff
   45: 
   46: create backtrace-rs-buffer buffer% %allot \ copy of the rturn stack at throw
   47: 
   48: : init-backtrace ( -- )
   49:     backtrace-rs-buffer init-buffer ;
   50:     
   51: init-backtrace
   52: 
   53: :noname ( -- )
   54:     DEFERS 'cold
   55:     init-backtrace ;
   56: IS 'cold
   57: 
   58: : backtrace-return-stack ( -- addr u )
   59:     \ addr is the address of top element of return stack (the stack
   60:     \ grows downwards), u is the number of aus that interest us on the
   61:     \ stack.
   62:     rp@ in-return-stack?
   63:     if
   64: 	rp@ [ 2 cells ]L +
   65:     else \ throw by signal handler with insufficient information
   66: 	handler @ cell - \ beyond that we know nothing
   67:     then
   68:     rp0 @ over - [ 10 cells ]L - 0 max ; \ the bottom 10 cells (and often
   69: 					 \ more) are uninteresting
   70: 
   71: :noname ( -- )
   72:     backtrace-empty @
   73:     if
   74: 	backtrace-return-stack
   75: 	dup backtrace-rs-buffer adjust-buffer
   76: 	backtrace-rs-buffer buffer-address @ swap move
   77: 	backtrace-empty off
   78:     then ;
   79: IS store-backtrace
   80: 
   81: : print-backtrace ( addr1 addr2 -- )
   82:     \G print a backtrace for the return stack addr1..addr2
   83:     swap u+do
   84: 	cr
   85: 	i @ dup hex. ( return-addr? )
   86: 	cell - dup in-dictionary? if
   87: 	    @ look drop .name
   88: 	else
   89: 	    drop
   90: 	then
   91: 	cell +loop ;
   92: 
   93: :noname ( -- )
   94:     backtrace-rs-buffer 2@ over + print-backtrace ;
   95: IS dobacktrace

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>