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