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

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