File:  [gforth] / gforth / assert.fs
Revision 1.4: download - view: text, annotated - select for diffs
Mon Oct 16 18:33:05 1995 UTC (28 years, 6 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added answords.fs and strsignal.c
added checking of documenetation of ANS Forth words
Fixed many documentation errors and added some documentation
signal handling now uses strsignal and can handle signals not present on all machines

    1: \ assertions
    2: 
    3: \ !! factor out line number printing, share with debugging.fs
    4: 
    5: variable assert-level ( -- a-addr ) \ gforth
    6: \G all assertions above this level are turned off
    7: 1 assert-level !
    8: 
    9: : assertn ( n -- ) \ gforth assert-n
   10:     \ this is internal (it is not immediate)
   11:     assert-level @ >
   12:     if
   13: 	POSTPONE (
   14:     then ;
   15: 
   16: : assert0( ( -- ) \ gforth assert-zero
   17:     \G important assertions that should always be turned on
   18:     0 assertn ; immediate
   19: : assert1( ( -- ) \ gforth assert-one
   20:     \G normal assertions; turned on by default
   21:     1 assertn ; immediate
   22: : assert2( ( -- ) \ gforth assert-two
   23:     \G debugging assertions
   24:     2 assertn ; immediate
   25: : assert3( ( -- ) \ gforth assert-three
   26:     \G slow assertions that you may not want to turn on in normal debugging;
   27:     \G you would turn them on mainly for thorough checking
   28:     3 assertn ; immediate
   29: : assert( ( -- ) \ gforth
   30:     \G equivalent to assert1(
   31:     POSTPONE assert1( ; immediate
   32: 
   33: : (endassert) ( flag -- ) \ gforth-internal
   34:     \ three inline arguments
   35:     if
   36: 	r> 3 cells + >r EXIT
   37:     else
   38: 	r>
   39: 	dup 2@ type ." :" cell+ cell+
   40: 	@ 0 .r ." : failed assertion"
   41: 	true abort" assertion failed" \ !! or use a new throw code?
   42:     then ;
   43: 
   44: : ) ( -- ) \ gforth	close-paren
   45:     \G end an assertion
   46:     POSTPONE (endassert) loadfilename 2@ 2, loadline @ , ; immediate

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