Return to backtrac.fs CVS log

Up to [gforth] / gforth

No header for empty backtrace lists

    1: \ backtrace handling
    2: 
    3: \ Copyright (C) 1999,2000,2003,2004,2006,2007 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 3
   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, see http://www.gnu.org/licenses/.
   19: 
   20: 
   21: \ growing buffers that need not be full
   22: 
   23: struct
   24:     cell% 0 * field buffer-descriptor \ addr u
   25:     cell% field buffer-length
   26:     cell% field buffer-address
   27:     cell% field buffer-maxlength \ >=length
   28: end-struct buffer%
   29: 
   30: : init-buffer ( addr -- )
   31:     buffer% %size erase ;
   32: 
   33: : adjust-buffer ( u addr -- )
   34:     \G adjust buffer% at addr to length u
   35:     \ this may grow the allocated area, but never shrinks it
   36:     dup >r buffer-maxlength @ over <
   37:     if ( u )
   38: 	r@ buffer-address @ over resize throw r@ buffer-address !
   39: 	dup r@ buffer-maxlength !
   40:     then
   41:     r> buffer-length ! ;
   42: 
   43: \ backtrace stuff
   44: 
   45: create backtrace-rs-buffer buffer% %allot drop
   46: \ copy of the return 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:     backtrace-rp0 @ [ 1 cells ]L - over - 0 max ;
   69: 
   70: :noname ( -- )
   71:     backtrace-return-stack
   72:     dup backtrace-rs-buffer adjust-buffer
   73:     backtrace-rs-buffer buffer-address @ swap move ;
   74: IS store-backtrace
   75: 
   76: : print-bt-entry ( return-stack-item -- )
   77:     cell - dup in-dictionary? over dup aligned = and
   78:     if
   79: 	@ dup threaded>name dup if
   80: 	    .name drop
   81: 	else
   82: 	    drop dup look if
   83: 		.name drop
   84: 	    else
   85: 		drop body> look \ !! check for "call" in cell before?
   86: 		if
   87: 		    .name
   88: 		else
   89: 		    drop
   90: 		then
   91: 	    then
   92: 	then
   93:     else
   94: 	drop
   95:     then ;
   96: 
   97: : print-backtrace ( addr1 addr2 -- )
   98:     \G print a backtrace for the return stack addr1..addr2
   99:     2dup u< IF  cr ." Backtrace:"  THEN
  100:     swap u+do
  101: 	cr
  102: 	i @ dup hex. ( return-addr? )
  103: 	print-bt-entry
  104: 	cell +loop ;
  105: 
  106: :noname ( -- )
  107:     backtrace-rs-buffer 2@ over + print-backtrace ;
  108: IS dobacktrace
  109: 
  110: [ifdef] defer-default
  111: :noname
  112:     r@ >stderr cr ." deferred word " print-bt-entry ." is uninitialized" ;
  113: is defer-default
  114: [then]