Annotation of gforth/backtrace.fs, revision 1.1
1.1 ! anton 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>