git.gag.com Git - debian/pforth/blob - 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]