/fth/see.fth
Forth | 218 lines | 191 code | 27 blank | 0 comment | 3 complexity | 80c696ad213b8ea6f7983fbbe2f9b33c MD5 | raw file
- \ @(#) see.fth 98/01/26 1.4
- \ SEE ( <name> -- , disassemble pForth word )
- \
- \ Copyright 1996 Phil Burk
-
- ' file? >code rfence a!
-
- anew task-see.fth
-
- : .XT ( xt -- , print execution tokens name )
- >name
- dup c@ flag_immediate and
- IF
- ." POSTPONE "
- THEN
- id. space
- ;
-
- \ dictionary may be defined as byte code or cell code
- 0 constant BYTE_CODE
-
- BYTE_CODE [IF]
- : CODE@ ( addr -- xt , fetch from code space ) C@ ;
- 1 constant CODE_CELL
- .( BYTE_CODE not implemented) abort
- [ELSE]
- : CODE@ ( addr -- xt , fetch from code space ) @ ;
- CELL constant CODE_CELL
- [THEN]
-
- private{
-
- 0 value see_level \ level of conditional imdentation
- 0 value see_addr \ address of next token
- 0 value see_out
-
- : SEE.INDENT.BY ( -- n )
- see_level 1+ 1 max 4 *
- ;
-
- : SEE.CR
- >newline
- see_addr ." ( ".hex ." )"
- see.indent.by spaces
- 0 -> see_out
- ;
- : SEE.NEWLINE
- see_out 0>
- IF see.cr
- THEN
- ;
- : SEE.CR?
- see_out 6 >
- IF
- see.newline
- THEN
- ;
- : SEE.OUT+
- 1 +-> see_out
- ;
-
- : SEE.ADVANCE
- code_cell +-> see_addr
- ;
- : SEE.GET.INLINE ( -- n )
- see_addr @
- ;
-
- : SEE.GET.TARGET ( -- branch-target-addr )
- see_addr @ see_addr +
- ;
-
- : SEE.SHOW.LIT ( -- )
- see.get.inline .
- see.advance
- see.out+
- ;
-
- exists? F* [IF]
- : SEE.SHOW.FLIT ( -- )
- see_addr f@ f.
- 1 floats +-> see_addr
- see.out+
- ;
- [THEN]
-
- : SEE.SHOW.ALIT ( -- )
- see.get.inline >name id. space
- see.advance
- see.out+
- ;
-
- : SEE.SHOW.STRING ( -- )
- see_addr count 2dup + aligned -> see_addr type
- see.out+
- ;
- : SEE.SHOW.TARGET ( -- )
- see.get.target .hex see.advance
- ;
-
- : SEE.BRANCH ( -- addr | , handle branch )
- -1 +-> see_level
- see.newline
- see.get.inline 0>
- IF \ forward branch
- ." ELSE "
- see.get.target \ calculate address of target
- 1 +-> see_level
- nip \ remove old address for THEN
- ELSE
- ." REPEAT " see.get.target .hex
- drop \ remove old address for THEN
- THEN
- see.advance
- see.cr
- ;
-
- : SEE.0BRANCH ( -- addr | , handle 0branch )
- see.newline
- see.get.inline 0>
- IF \ forward branch
- ." IF or WHILE "
- see.get.target \ calculate adress of target
- 1 +-> see_level
- ELSE
- ." UNTIL=>" see.get.target .hex
- THEN
- see.advance
- see.cr
- ;
-
- : SEE.XT { xt -- }
- xt
- CASE
- 0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0 -> see_addr THEN ENDOF
- ['] (LITERAL) OF see.show.lit ENDOF
- ['] (ALITERAL) OF see.show.alit ENDOF
- [ exists? (FLITERAL) [IF] ]
- ['] (FLITERAL) OF see.show.flit ENDOF
- [ [THEN] ]
- ['] BRANCH OF see.branch ENDOF
- ['] 0BRANCH OF see.0branch ENDOF
- ['] (LOOP) OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr ENDOF
- ['] (+LOOP) OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr ENDOF
- ['] (DO) OF see.newline ." DO" 1 +-> see_level see.cr ENDOF
- ['] (?DO) OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF
- ['] (.") OF .' ." ' see.show.string .' " ' ENDOF
- ['] (C") OF .' C" ' see.show.string .' " ' ENDOF
- ['] (S") OF .' S" ' see.show.string .' " ' ENDOF
-
- see.cr? xt .xt see.out+
- ENDCASE
- ;
-
- : (SEE) { cfa | xt -- }
- 0 -> see_level
- cfa -> see_addr
- see.cr
- 0 \ fake address for THEN handler
- BEGIN
- see_addr code@ -> xt
- BEGIN
- dup see_addr ( >newline .s ) =
- WHILE
- -1 +-> see_level see.newline
- ." THEN " see.cr
- drop
- REPEAT
- CODE_CELL +-> see_addr
- xt see.xt
- see_addr 0=
- UNTIL
- cr
- 0= not abort" SEE conditional analyser nesting failed!"
- ;
-
- }PRIVATE
-
- : SEE ( <name> -- , disassemble )
- '
- dup ['] FIRST_COLON >
- IF
- >code (see)
- ELSE
- >name id.
- ." is primitive defined in 'C' kernel." cr
- THEN
- ;
-
- PRIVATIZE
-
- 0 [IF]
-
- : SEE.JOKE
- dup swap drop
- ;
-
- : SEE.IF
- IF
- ." hello" cr
- ELSE
- ." bye" cr
- THEN
- see.joke
- ;
- : SEE.DO
- 4 0
- DO
- i . cr
- LOOP
- ;
- : SEE."
- ." Here are some strings." cr
- c" Forth string." count type cr
- s" Addr/Cnt string" type cr
- ;
-
- [THEN]