git.gag.com Git - debian/pforth/blob - fth/see.fth

   1 \ @(#) see.fth 98/01/26 1.4
   2 \ SEE ( <name> -- , disassemble pForth word )
   3 \
   4 \ Copyright 1996 Phil Burk
   5
   6 ' file? >code rfence a!
   7
   8 anew task-see.fth
   9
  10 : .XT ( xt -- , print execution tokens name )
  11     >name
  12     dup c@ flag_immediate and
  13     IF
  14         ." POSTPONE "
  15     THEN
  16     id. space
  17 ;
  18
  19 \ dictionary may be defined as byte code or cell code
  20 0 constant BYTE_CODE
  21
  22 BYTE_CODE [IF]
  23     : CODE@ ( addr -- xt , fetch from code space )   C@ ;
  24     1 constant CODE_CELL
  25     .( BYTE_CODE not implemented) abort
  26 [ELSE]
  27     : CODE@ ( addr -- xt , fetch from code space )   @ ;
  28     CELL constant CODE_CELL
  29 [THEN]
  30
  31 private{
  32
  33 0 value see_level  \ level of conditional imdentation
  34 0 value see_addr   \ address of next token
  35 0 value see_out
  36
  37 : SEE.INDENT.BY ( -- n )
  38     see_level 1+ 1 max 4 *
  39 ;
  40
  41 : SEE.CR
  42     >newline
  43     see_addr ." ( ".hex ." )"
  44     see.indent.by spaces
  45     0 -> see_out
  46 ;
  47 : SEE.NEWLINE
  48     see_out 0>
  49     IF see.cr
  50     THEN
  51 ;
  52 : SEE.CR?
  53     see_out 6 >
  54     IF
  55         see.newline
  56     THEN
  57 ;
  58 : SEE.OUT+
  59     1 +-> see_out
  60 ;
  61
  62 : SEE.ADVANCE
  63     code_cell +-> see_addr
  64 ;
  65 : SEE.GET.INLINE ( -- n )
  66     see_addr @
  67 ;
  68
  69 : SEE.GET.TARGET  ( -- branch-target-addr )
  70     see_addr @ see_addr +
  71 ;
  72
  73 : SEE.SHOW.LIT ( -- )
  74     see.get.inline .
  75     see.advance
  76     see.out+
  77 ;
  78
  79 exists? F* [IF]
  80 : SEE.SHOW.FLIT ( -- )
  81     see_addr f@ f.
  82     1 floats +-> see_addr
  83     see.out+
  84 ;
  85 [THEN]
  86
  87 : SEE.SHOW.ALIT ( -- )
  88     see.get.inline >name id. space
  89     see.advance
  90     see.out+
  91 ;
  92
  93 : SEE.SHOW.STRING ( -- )
  94     see_addr count 2dup + aligned -> see_addr type
  95     see.out+
  96 ;
  97 : SEE.SHOW.TARGET ( -- )
  98     see.get.target .hex see.advance
  99 ;
 100
 101 : SEE.BRANCH ( -- addr | , handle branch )
 102     -1 +-> see_level
 103     see.newline
 104     see.get.inline  0>
 105     IF  \ forward branch
 106         ." ELSE "
 107         see.get.target \ calculate address of target
 108         1 +-> see_level
 109         nip \ remove old address for THEN
 110     ELSE
 111         ." REPEAT " see.get.target .hex
 112         drop \ remove old address for THEN
 113     THEN
 114     see.advance
 115     see.cr
 116 ;
 117
 118 : SEE.0BRANCH ( -- addr | , handle 0branch )
 119     see.newline
 120     see.get.inline 0>
 121     IF  \ forward branch
 122         ." IF or WHILE "
 123         see.get.target \ calculate adress of target
 124         1 +-> see_level
 125     ELSE
 126         ." UNTIL=>" see.get.target .hex
 127     THEN
 128     see.advance
 129     see.cr
 130 ;
 131
 132 : SEE.XT  { xt -- }
 133     xt
 134     CASE
 135         0 OF see_level 0> IF ." EXIT " see.out+ ELSE ." ;" 0  -> see_addr THEN ENDOF
 136         ['] (LITERAL) OF see.show.lit ENDOF
 137         ['] (ALITERAL) OF see.show.alit ENDOF
 138 [ exists? (FLITERAL) [IF] ]
 139         ['] (FLITERAL) OF see.show.flit ENDOF
 140 [ [THEN] ]
 141         ['] BRANCH    OF see.branch ENDOF
 142         ['] 0BRANCH   OF see.0branch ENDOF
 143         ['] (LOOP)    OF -1 +-> see_level see.newline ." LOOP " see.advance see.cr  ENDOF
 144         ['] (+LOOP)   OF -1 +-> see_level see.newline ." +LOOP" see.advance see.cr  ENDOF
 145         ['] (DO)      OF see.newline ." DO" 1 +-> see_level see.cr ENDOF
 146         ['] (?DO)     OF see.newline ." ?DO " see.advance 1 +-> see_level see.cr ENDOF
 147         ['] (.") OF .' ." ' see.show.string .' " ' ENDOF
 148         ['] (C") OF .' C" ' see.show.string .' " ' ENDOF
 149         ['] (S") OF .' S" ' see.show.string .' " ' ENDOF
 150
 151         see.cr? xt .xt see.out+
 152     ENDCASE
 153 ;
 154
 155 : (SEE) { cfa | xt  -- }
 156     0 -> see_level
 157     cfa -> see_addr
 158     see.cr
 159     0 \ fake address for THEN handler
 160     BEGIN
 161         see_addr code@ -> xt
 162         BEGIN
 163             dup see_addr ( >newline .s ) =
 164         WHILE
 165             -1 +-> see_level see.newline
 166             ." THEN " see.cr
 167             drop
 168         REPEAT
 169         CODE_CELL +-> see_addr
 170         xt see.xt
 171         see_addr 0=
 172     UNTIL
 173     cr
 174     0= not abort" SEE conditional analyser nesting failed!"
 175 ;
 176
 177 }PRIVATE
 178
 179 : SEE  ( <name> -- , disassemble )
 180     '
 181     dup ['] FIRST_COLON >
 182     IF
 183         >code (see)
 184     ELSE
 185         >name id.
 186         ."  is primitive defined in 'C' kernel." cr
 187     THEN
 188 ;
 189
 190 PRIVATIZE
 191
 192 0 [IF]
 193
 194 : SEE.JOKE
 195     dup swap drop
 196 ;
 197
 198 : SEE.IF
 199     IF
 200         ." hello" cr
 201     ELSE
 202         ." bye" cr
 203     THEN
 204     see.joke
 205 ;
 206 : SEE.DO
 207     4 0
 208     DO
 209         i . cr
 210     LOOP
 211 ;
 212 : SEE."
 213     ." Here are some strings." cr
 214     c" Forth string." count type cr
 215     s" Addr/Cnt string" type cr
 216 ;
 217
 218 [THEN]