/samples/Forth/tools.fth
Forth | 133 lines | 85 code | 45 blank | 3 comment | 6 complexity | 1f1b7257ba0a6fa3fc79a2163f087676 MD5 | raw file
- \ -*- forth -*- Copyright 2004, 2013 Lars Brinkhoff
- ( Tools words. )
- : .s ( -- )
- [char] < emit depth (.) ." > "
- 'SP @ >r r@ depth 1- cells +
- begin
- dup r@ <>
- while
- dup @ .
- /cell -
- repeat r> 2drop ;
- : ? @ . ;
- : c? c@ . ;
- : dump bounds do i ? /cell +loop cr ;
- : cdump bounds do i c? loop cr ;
- : again postpone branch , ; immediate
- : see-find ( caddr -- end xt )
- >r here lastxt @
- begin
- dup 0= abort" Undefined word"
- dup r@ word= if r> drop exit then
- nip dup >nextxt
- again ;
- : cabs ( char -- |char| ) dup 127 > if 256 swap - then ;
- : xt. ( xt -- )
- ( >name ) count cabs type ;
- : xt? ( xt -- flag )
- >r lastxt @ begin
- ?dup
- while
- dup r@ = if r> 2drop -1 exit then
- >nextxt
- repeat r> drop 0 ;
- : disassemble ( x -- )
- dup xt? if
- ( >name ) count
- dup 127 > if ." postpone " then
- cabs type
- else
- .
- then ;
- : .addr dup . ;
- : see-line ( addr -- )
- cr ." ( " .addr ." ) " @ disassemble ;
- : see-word ( end xt -- )
- >r ." : " r@ xt.
- r@ >body do i see-line /cell +loop
- ." ;" r> c@ 127 > if ." immediate" then ;
- : see bl word see-find see-word cr ;
- : #body bl word see-find >body - ;
- : type-word ( end xt -- flag )
- xt. space drop 0 ;
- : traverse-dictionary ( in.. xt -- out.. )
- \ xt execution: ( in.. end xt2 -- in.. 0 | in.. end xt2 -- out.. true )
- >r here lastxt @ begin
- ?dup
- while
- r> 2dup >r >r execute
- if r> r> 2drop exit then
- r> dup >nextxt
- repeat r> 2drop ;
- : words ( -- )
- ['] type-word traverse-dictionary cr ;
- \ ----------------------------------------------------------------------
- ( Tools extension words. )
- \ ;code
- \ assembler
- \ in kernel: bye
- \ code
- \ cs-pick
- \ cs-roll
- \ editor
- : forget ' dup >nextxt lastxt ! 'here ! reveal ;
- \ Kernel: state
- \ [else]
- \ [if]
- \ [then]
- \ ----------------------------------------------------------------------
- ( Forth2012 tools extension words. )
- \ TODO: n>r
- \ TODO: nr>
- \ TODO: synonym
- : [undefined] bl-word find nip 0= ; immediate
- : [defined] postpone [undefined] invert ; immediate
- \ ----------------------------------------------------------------------
- : @+ ( addr -- addr+/cell x ) dup cell+ swap @ ;
- : !+ ( x addr -- addr+/cell ) tuck ! cell+ ;
- : -rot swap >r swap r> ;