Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ SEE.FS highend SEE for ANSforth 16may93jaw |
| 2 : | |||
| 3 : | anton | 1.65 | \ Copyright (C) 1995,2000,2003,2004,2006,2007,2008 Free Software Foundation, Inc. |
| 4 : | anton | 1.9 | |
| 5 : | \ This file is part of Gforth. | ||
| 6 : | |||
| 7 : | \ Gforth is free software; you can redistribute it and/or | ||
| 8 : | \ modify it under the terms of the GNU General Public License | ||
| 9 : | anton | 1.63 | \ as published by the Free Software Foundation, either version 3 |
| 10 : | anton | 1.9 | \ of the License, or (at your option) any later version. |
| 11 : | |||
| 12 : | \ This program is distributed in the hope that it will be useful, | ||
| 13 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 14 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 15 : | \ GNU General Public License for more details. | ||
| 16 : | |||
| 17 : | \ You should have received a copy of the GNU General Public License | ||
| 18 : | anton | 1.63 | \ along with this program. If not, see http://www.gnu.org/licenses/. |
| 19 : | anton | 1.9 | |
| 20 : | |||
| 21 : | anton | 1.1 | \ May be cross-compiled |
| 22 : | |||
| 23 : | \ I'm sorry. This is really not "forthy" enough. | ||
| 24 : | |||
| 25 : | \ Ideas: Level should be a stack | ||
| 26 : | |||
| 27 : | jwilke | 1.18 | require look.fs |
| 28 : | anton | 1.10 | require termsize.fs |
| 29 : | jwilke | 1.18 | require wordinfo.fs |
| 30 : | anton | 1.10 | |
| 31 : | anton | 1.1 | decimal |
| 32 : | |||
| 33 : | \ Screen format words 16may93jaw | ||
| 34 : | |||
| 35 : | VARIABLE C-Output 1 C-Output ! | ||
| 36 : | VARIABLE C-Formated 1 C-Formated ! | ||
| 37 : | VARIABLE C-Highlight 0 C-Highlight ! | ||
| 38 : | VARIABLE C-Clearline 0 C-Clearline ! | ||
| 39 : | |||
| 40 : | VARIABLE XPos | ||
| 41 : | VARIABLE YPos | ||
| 42 : | VARIABLE Level | ||
| 43 : | |||
| 44 : | : Format C-Formated @ C-Output @ and | ||
| 45 : | IF dup spaces XPos +! ELSE drop THEN ; | ||
| 46 : | |||
| 47 : | : level+ 7 Level +! | ||
| 48 : | Level @ XPos @ - | ||
| 49 : | dup 0> IF Format ELSE drop THEN ; | ||
| 50 : | |||
| 51 : | : level- -7 Level +! ; | ||
| 52 : | |||
| 53 : | VARIABLE nlflag | ||
| 54 : | pazsan | 1.15 | VARIABLE uppercase \ structure words are in uppercase |
| 55 : | anton | 1.1 | |
| 56 : | DEFER nlcount ' noop IS nlcount | ||
| 57 : | |||
| 58 : | : nl nlflag on ; | ||
| 59 : | : (nl) nlcount | ||
| 60 : | jwilke | 1.18 | XPos @ Level @ = IF EXIT THEN \ ?Exit |
| 61 : | anton | 1.1 | C-Formated @ IF |
| 62 : | C-Output @ | ||
| 63 : | anton | 1.10 | IF C-Clearline @ IF cols XPos @ - spaces |
| 64 : | anton | 1.1 | ELSE cr THEN |
| 65 : | 1 YPos +! 0 XPos ! | ||
| 66 : | Level @ spaces | ||
| 67 : | THEN Level @ XPos ! THEN ; | ||
| 68 : | |||
| 69 : | : warp? ( len -- len ) | ||
| 70 : | nlflag @ IF (nl) nlflag off THEN | ||
| 71 : | anton | 1.10 | XPos @ over + cols u>= IF (nl) THEN ; |
| 72 : | anton | 1.1 | |
| 73 : | : ctype ( adr len -- ) | ||
| 74 : | pazsan | 1.15 | warp? dup XPos +! C-Output @ |
| 75 : | anton | 1.58 | IF uppercase @ IF bounds ?DO i c@ toupper emit LOOP |
| 76 : | pazsan | 1.15 | uppercase off ELSE type THEN |
| 77 : | ELSE 2drop THEN ; | ||
| 78 : | anton | 1.1 | |
| 79 : | : cemit 1 warp? | ||
| 80 : | over bl = Level @ XPos @ = and | ||
| 81 : | IF 2drop ELSE XPos +! C-Output @ IF emit ELSE drop THEN | ||
| 82 : | THEN ; | ||
| 83 : | |||
| 84 : | anton | 1.34 | DEFER .string ( c-addr u n -- ) |
| 85 : | anton | 1.1 | |
| 86 : | [IFDEF] Green | ||
| 87 : | VARIABLE Colors Colors on | ||
| 88 : | |||
| 89 : | : (.string) ( c-addr u n -- ) | ||
| 90 : | over warp? drop | ||
| 91 : | Colors @ | ||
| 92 : | IF C-Highlight @ ?dup | ||
| 93 : | IF CT@ swap CT@ or | ||
| 94 : | ELSE CT@ | ||
| 95 : | THEN | ||
| 96 : | attr! ELSE drop THEN | ||
| 97 : | ctype ct @ attr! ; | ||
| 98 : | [ELSE] | ||
| 99 : | : (.string) ( c-addr u n -- ) | ||
| 100 : | drop ctype ; | ||
| 101 : | [THEN] | ||
| 102 : | |||
| 103 : | ' (.string) IS .string | ||
| 104 : | |||
| 105 : | anton | 1.45 | : c-\type ( c-addr u -- ) |
| 106 : | \ type string in \-escaped form | ||
| 107 : | begin | ||
| 108 : | dup while | ||
| 109 : | 2dup newline string-prefix? if | ||
| 110 : | '\ cemit 'n cemit | ||
| 111 : | newline nip /string | ||
| 112 : | else | ||
| 113 : | over c@ | ||
| 114 : | dup '" = over '\ = or if | ||
| 115 : | '\ cemit cemit | ||
| 116 : | else | ||
| 117 : | dup bl 127 within if | ||
| 118 : | cemit | ||
| 119 : | else | ||
| 120 : | base @ >r try | ||
| 121 : | 8 base ! 0 <<# # # # '\ hold #> ctype #>> 0 | ||
| 122 : | anton | 1.60 | restore |
| 123 : | r@ base ! | ||
| 124 : | anton | 1.45 | endtry |
| 125 : | anton | 1.60 | rdrop throw |
| 126 : | anton | 1.45 | endif |
| 127 : | endif | ||
| 128 : | 1 /string | ||
| 129 : | endif | ||
| 130 : | repeat | ||
| 131 : | 2drop ; | ||
| 132 : | anton | 1.1 | |
| 133 : | pazsan | 1.15 | : .struc |
| 134 : | uppercase on Str# .string ; | ||
| 135 : | anton | 1.1 | |
| 136 : | jwilke | 1.17 | \ CODES (Branchtypes) 15may93jaw |
| 137 : | anton | 1.1 | |
| 138 : | 21 CONSTANT RepeatCode | ||
| 139 : | 22 CONSTANT AgainCode | ||
| 140 : | 23 CONSTANT UntilCode | ||
| 141 : | \ 09 CONSTANT WhileCode | ||
| 142 : | 10 CONSTANT ElseCode | ||
| 143 : | 11 CONSTANT AheadCode | ||
| 144 : | 13 CONSTANT WhileCode2 | ||
| 145 : | 14 CONSTANT Disable | ||
| 146 : | jwilke | 1.17 | 15 CONSTANT LeaveCode |
| 147 : | |||
| 148 : | anton | 1.1 | |
| 149 : | \ FORMAT WORDS 13jun93jaw | ||
| 150 : | |||
| 151 : | VARIABLE C-Stop | ||
| 152 : | VARIABLE Branches | ||
| 153 : | |||
| 154 : | jwilke | 1.17 | VARIABLE BranchPointer \ point to the end of branch table |
| 155 : | anton | 1.1 | VARIABLE SearchPointer |
| 156 : | jwilke | 1.17 | |
| 157 : | \ The branchtable consists of three entrys: | ||
| 158 : | \ address of branch , branch destination , branch type | ||
| 159 : | |||
| 160 : | pazsan | 1.25 | CREATE BranchTable 128 cells allot |
| 161 : | anton | 1.1 | here 3 cells - |
| 162 : | ACONSTANT MaxTable | ||
| 163 : | |||
| 164 : | : FirstBranch BranchTable cell+ SearchPointer ! ; | ||
| 165 : | |||
| 166 : | jwilke | 1.17 | : (BranchAddr?) ( a-addr1 -- a-addr2 true | false ) |
| 167 : | \ searches a branch with destination a-addr1 | ||
| 168 : | \ a-addr1: branch destination | ||
| 169 : | \ a-addr2: pointer in branch table | ||
| 170 : | anton | 1.1 | SearchPointer @ |
| 171 : | BEGIN dup BranchPointer @ u< | ||
| 172 : | WHILE | ||
| 173 : | dup @ 2 pick <> | ||
| 174 : | WHILE 3 cells + | ||
| 175 : | REPEAT | ||
| 176 : | nip dup 3 cells + SearchPointer ! true | ||
| 177 : | ELSE | ||
| 178 : | 2drop false | ||
| 179 : | THEN ; | ||
| 180 : | |||
| 181 : | : BranchAddr? | ||
| 182 : | FirstBranch (BranchAddr?) ; | ||
| 183 : | |||
| 184 : | ' (BranchAddr?) ALIAS MoreBranchAddr? | ||
| 185 : | |||
| 186 : | : CheckEnd ( a-addr -- true | false ) | ||
| 187 : | BranchTable cell+ | ||
| 188 : | BEGIN dup BranchPointer @ u< | ||
| 189 : | WHILE | ||
| 190 : | dup @ 2 pick u<= | ||
| 191 : | WHILE 3 cells + | ||
| 192 : | REPEAT | ||
| 193 : | 2drop false | ||
| 194 : | ELSE | ||
| 195 : | 2drop true | ||
| 196 : | THEN ; | ||
| 197 : | |||
| 198 : | jwilke | 1.17 | : MyBranch ( a-addr -- a-addr a-addr2 ) |
| 199 : | \ finds branch table entry for branch at a-addr | ||
| 200 : | anton | 1.45 | dup @ |
| 201 : | jwilke | 1.17 | BranchAddr? |
| 202 : | BEGIN | ||
| 203 : | WHILE 1 cells - @ | ||
| 204 : | over <> | ||
| 205 : | anton | 1.45 | WHILE dup @ |
| 206 : | jwilke | 1.17 | MoreBranchAddr? |
| 207 : | REPEAT | ||
| 208 : | SearchPointer @ 3 cells - | ||
| 209 : | ELSE true ABORT" SEE: Table failure" | ||
| 210 : | THEN ; | ||
| 211 : | |||
| 212 : | anton | 1.1 | \ |
| 213 : | \ addrw addrt | ||
| 214 : | \ BEGIN ... WHILE ... AGAIN ... THEN | ||
| 215 : | \ ^ ! ! ^ | ||
| 216 : | \ ----------+--------+ ! | ||
| 217 : | \ ! ! | ||
| 218 : | \ +-------------------+ | ||
| 219 : | \ | ||
| 220 : | \ | ||
| 221 : | |||
| 222 : | : CheckWhile ( a-addrw a-addrt -- true | false ) | ||
| 223 : | BranchTable | ||
| 224 : | BEGIN dup BranchPointer @ u< | ||
| 225 : | WHILE dup @ 3 pick u> | ||
| 226 : | over @ 3 pick u< and | ||
| 227 : | IF dup cell+ @ 3 pick u< | ||
| 228 : | IF 2drop drop true EXIT THEN | ||
| 229 : | THEN | ||
| 230 : | 3 cells + | ||
| 231 : | REPEAT | ||
| 232 : | 2drop drop false ; | ||
| 233 : | |||
| 234 : | : ,Branch ( a-addr -- ) | ||
| 235 : | BranchPointer @ dup MaxTable u> ABORT" SEE: Table overflow" | ||
| 236 : | ! | ||
| 237 : | 1 cells BranchPointer +! ; | ||
| 238 : | |||
| 239 : | : Type! ( u -- ) | ||
| 240 : | BranchPointer @ 1 cells - ! ; | ||
| 241 : | |||
| 242 : | : Branch! ( a-addr rel -- a-addr ) | ||
| 243 : | anton | 1.45 | over ,Branch ,Branch 0 ,Branch ; |
| 244 : | \ over + over ,Branch ,Branch 0 ,Branch ; | ||
| 245 : | anton | 1.1 | |
| 246 : | \ DEFER CheckUntil | ||
| 247 : | VARIABLE NoOutput | ||
| 248 : | VARIABLE C-Pass | ||
| 249 : | |||
| 250 : | 0 CONSTANT ScanMode | ||
| 251 : | 1 CONSTANT DisplayMode | ||
| 252 : | 2 CONSTANT DebugMode | ||
| 253 : | |||
| 254 : | : Scan? ( -- flag ) C-Pass @ 0= ; | ||
| 255 : | : Display? ( -- flag ) C-Pass @ 1 = ; | ||
| 256 : | : Debug? ( -- flag ) C-Pass @ 2 = ; | ||
| 257 : | |||
| 258 : | anton | 1.45 | : back? ( addr target -- addr flag ) |
| 259 : | over u< ; | ||
| 260 : | anton | 1.1 | |
| 261 : | anton | 1.47 | : .word ( addr x -- addr ) |
| 262 : | \ print x as a word if possible | ||
| 263 : | dup look 0= IF | ||
| 264 : | anton | 1.48 | drop dup threaded>name dup 0= if |
| 265 : | anton | 1.57 | drop over 1 cells - @ dup body> look |
| 266 : | anton | 1.47 | IF |
| 267 : | anton | 1.57 | nip nip dup ." <" name>string rot wordinfo .string ." > " |
| 268 : | anton | 1.47 | ELSE |
| 269 : | anton | 1.57 | 2drop ." <" 0 .r ." > " |
| 270 : | anton | 1.47 | THEN |
| 271 : | EXIT | ||
| 272 : | then | ||
| 273 : | THEN | ||
| 274 : | nip dup cell+ @ immediate-mask and | ||
| 275 : | IF | ||
| 276 : | bl cemit ." POSTPONE " | ||
| 277 : | THEN | ||
| 278 : | dup name>string rot wordinfo .string | ||
| 279 : | ; | ||
| 280 : | pazsan | 1.35 | |
| 281 : | anton | 1.44 | : c-call ( addr1 -- addr2 ) |
| 282 : | Display? IF | ||
| 283 : | dup @ body> .word bl cemit | ||
| 284 : | THEN | ||
| 285 : | cell+ ; | ||
| 286 : | |||
| 287 : | : c-callxt ( addr1 -- addr2 ) | ||
| 288 : | Display? IF | ||
| 289 : | dup @ .word bl cemit | ||
| 290 : | THEN | ||
| 291 : | cell+ ; | ||
| 292 : | |||
| 293 : | \ here docon: , docol: , dovar: , douser: , dodefer: , dofield: , | ||
| 294 : | \ here over - 2constant doers | ||
| 295 : | |||
| 296 : | pazsan | 1.70 | [IFDEF] !does |
| 297 : | : c-does> \ end of create part | ||
| 298 : | Display? IF S" DOES> " Com# .string THEN ; | ||
| 299 : | \ maxaligned /does-handler + ; \ !! no longer needed for non-cross stuff | ||
| 300 : | [THEN] | ||
| 301 : | |||
| 302 : | anton | 1.44 | : c-lit ( addr1 -- addr2 ) |
| 303 : | Display? IF | ||
| 304 : | dup @ dup body> dup cfaligned over = swap in-dictionary? and if | ||
| 305 : | ( addr1 addr1@ ) | ||
| 306 : | dup body> @ dovar: = if | ||
| 307 : | drop c-call EXIT | ||
| 308 : | endif | ||
| 309 : | endif | ||
| 310 : | pazsan | 1.70 | over 4 cells + over = if |
| 311 : | over 1 cells + @ decompile-prim ['] call xt>threaded = >r | ||
| 312 : | over 3 cells + @ decompile-prim ['] ;S xt>threaded = | ||
| 313 : | pazsan | 1.71 | r> and if |
| 314 : | over 2 cells + @ ['] !does >body = if drop | ||
| 315 : | S" DOES> " Com# .string 4 cells + EXIT endif | ||
| 316 : | [IFDEF] !;abi-code | ||
| 317 : | over 2 cells + @ ['] !;abi-code >body = if drop | ||
| 318 : | pazsan | 1.72 | S" ;abi-code " Com# .string 4 cells + EXIT endif |
| 319 : | pazsan | 1.71 | [THEN] |
| 320 : | endif | ||
| 321 : | pazsan | 1.70 | endif |
| 322 : | anton | 1.44 | \ !! test for cfa here, and print "['] ..." |
| 323 : | dup abs 0 <# #S rot sign #> 0 .string bl cemit | ||
| 324 : | endif | ||
| 325 : | cell+ ; | ||
| 326 : | |||
| 327 : | : c-lit+ ( addr1 -- addr2 ) | ||
| 328 : | Display? if | ||
| 329 : | dup @ dup abs 0 <# #S rot sign #> 0 .string bl cemit | ||
| 330 : | s" + " 0 .string | ||
| 331 : | endif | ||
| 332 : | cell+ ; | ||
| 333 : | pazsan | 1.35 | |
| 334 : | jwilke | 1.18 | : .name-without ( addr -- addr ) |
| 335 : | anton | 1.48 | \ !! the stack effect cannot be correct |
| 336 : | \ prints a name without a() e.g. a(+LOOP) or (s") | ||
| 337 : | dup 1 cells - @ threaded>name dup IF | ||
| 338 : | anton | 1.45 | name>string over c@ 'a = IF |
| 339 : | 1 /string | ||
| 340 : | THEN | ||
| 341 : | over c@ '( = IF | ||
| 342 : | 1 /string | ||
| 343 : | THEN | ||
| 344 : | 2dup + 1- c@ ') = IF 1- THEN .struc ELSE drop | ||
| 345 : | THEN ; | ||
| 346 : | anton | 1.1 | |
| 347 : | anton | 1.45 | [ifdef] (s") |
| 348 : | anton | 1.1 | : c-c" |
| 349 : | jwilke | 1.18 | Display? IF nl .name-without THEN |
| 350 : | anton | 1.1 | count 2dup + aligned -rot |
| 351 : | Display? | ||
| 352 : | jwilke | 1.18 | IF bl cemit 0 .string |
| 353 : | anton | 1.1 | [char] " cemit bl cemit |
| 354 : | ELSE 2drop | ||
| 355 : | THEN ; | ||
| 356 : | anton | 1.45 | [endif] |
| 357 : | anton | 1.1 | |
| 358 : | anton | 1.45 | : c-string? ( addr1 -- addr2 f ) |
| 359 : | \ f is true if a string was found and decompiled. | ||
| 360 : | \ if f is false, addr2=addr1 | ||
| 361 : | \ recognizes the following patterns: | ||
| 362 : | \ c": ahead X: len string then lit X | ||
| 363 : | anton | 1.49 | \ flit: ahead X: float then lit X f@ |
| 364 : | \ s\": ahead X: string then lit X lit len | ||
| 365 : | \ .\": ahead X: string then lit X lit len type | ||
| 366 : | anton | 1.45 | \ !! not recognized anywhere: |
| 367 : | \ abort": if ahead X: len string then lit X c(abort") then | ||
| 368 : | dup @ back? if false exit endif | ||
| 369 : | dup @ >r | ||
| 370 : | r@ @ decompile-prim ['] lit xt>threaded <> if rdrop false exit endif | ||
| 371 : | r@ cell+ @ over cell+ <> if rdrop false exit endif | ||
| 372 : | \ we have at least C" | ||
| 373 : | anton | 1.49 | r@ 2 cells + @ decompile-prim dup ['] lit xt>threaded = if |
| 374 : | drop r@ 3 cells + @ over cell+ + aligned r@ = if | ||
| 375 : | anton | 1.45 | \ we have at least s" |
| 376 : | r@ 4 cells + @ decompile-prim ['] lit-perform xt>threaded = | ||
| 377 : | r@ 5 cells + @ ['] type >body = and if | ||
| 378 : | 6 s\" .\\\" " | ||
| 379 : | else | ||
| 380 : | 4 s\" s\\\" " | ||
| 381 : | endif | ||
| 382 : | \ !! make newline if string too long? | ||
| 383 : | display? if | ||
| 384 : | 0 .string r@ cell+ @ r@ 3 cells + @ c-\type '" cemit bl cemit | ||
| 385 : | else | ||
| 386 : | 2drop | ||
| 387 : | endif | ||
| 388 : | nip cells r> + true exit | ||
| 389 : | endif | ||
| 390 : | anton | 1.49 | endif |
| 391 : | ['] f@ xt>threaded = if | ||
| 392 : | display? if | ||
| 393 : | r@ cell+ @ f@ 10 8 16 f>str-rdp 0 .string bl cemit | ||
| 394 : | endif | ||
| 395 : | drop r> 3 cells + true exit | ||
| 396 : | anton | 1.45 | endif |
| 397 : | \ !! check if count matches space? | ||
| 398 : | display? if | ||
| 399 : | s\" c\" " 0 .string r@ cell+ @ count 0 .string '" cemit bl cemit | ||
| 400 : | endif | ||
| 401 : | drop r> 2 cells + true ; | ||
| 402 : | anton | 1.1 | |
| 403 : | jwilke | 1.17 | : Forward? ( a-addr true | false -- a-addr true | false ) |
| 404 : | anton | 1.45 | \ a-addr is pointer into branch table |
| 405 : | \ returns true when jump is a forward jump | ||
| 406 : | IF | ||
| 407 : | dup dup @ swap 1 cells - @ u> IF | ||
| 408 : | true | ||
| 409 : | ELSE | ||
| 410 : | drop false | ||
| 411 : | THEN | ||
| 412 : | \ only if forward jump | ||
| 413 : | ELSE | ||
| 414 : | false | ||
| 415 : | THEN ; | ||
| 416 : | anton | 1.1 | |
| 417 : | jwilke | 1.17 | : RepeatCheck ( a-addr1 a-addr2 true | false -- false ) |
| 418 : | anton | 1.1 | IF BEGIN 2dup |
| 419 : | anton | 1.45 | 1 cells - @ swap @ |
| 420 : | anton | 1.1 | u<= |
| 421 : | WHILE drop dup cell+ | ||
| 422 : | MoreBranchAddr? 0= | ||
| 423 : | UNTIL false | ||
| 424 : | ELSE true | ||
| 425 : | THEN | ||
| 426 : | ELSE false | ||
| 427 : | THEN ; | ||
| 428 : | |||
| 429 : | anton | 1.45 | : c-branch ( addr1 -- addr2 ) |
| 430 : | c-string? ?exit | ||
| 431 : | anton | 1.1 | Scan? |
| 432 : | IF dup @ Branch! | ||
| 433 : | dup @ back? | ||
| 434 : | IF \ might be: AGAIN, REPEAT | ||
| 435 : | dup cell+ BranchAddr? Forward? | ||
| 436 : | RepeatCheck | ||
| 437 : | IF RepeatCode Type! | ||
| 438 : | cell+ Disable swap ! | ||
| 439 : | ELSE AgainCode Type! | ||
| 440 : | THEN | ||
| 441 : | ELSE dup cell+ BranchAddr? Forward? | ||
| 442 : | IF ElseCode Type! drop | ||
| 443 : | ELSE AheadCode Type! | ||
| 444 : | THEN | ||
| 445 : | THEN | ||
| 446 : | THEN | ||
| 447 : | Display? | ||
| 448 : | IF | ||
| 449 : | dup @ back? | ||
| 450 : | IF \ might be: AGAIN, REPEAT | ||
| 451 : | level- nl | ||
| 452 : | dup cell+ BranchAddr? Forward? | ||
| 453 : | RepeatCheck | ||
| 454 : | IF drop S" REPEAT " .struc nl | ||
| 455 : | ELSE S" AGAIN " .struc nl | ||
| 456 : | THEN | ||
| 457 : | jwilke | 1.17 | ELSE MyBranch cell+ @ LeaveCode = |
| 458 : | IF S" LEAVE " .struc | ||
| 459 : | ELSE | ||
| 460 : | dup cell+ BranchAddr? Forward? | ||
| 461 : | IF dup cell+ @ WhileCode2 = | ||
| 462 : | IF nl S" ELSE" .struc level+ | ||
| 463 : | ELSE level- nl S" ELSE" .struc level+ THEN | ||
| 464 : | cell+ Disable swap ! | ||
| 465 : | ELSE S" AHEAD" .struc level+ | ||
| 466 : | THEN | ||
| 467 : | THEN | ||
| 468 : | anton | 1.1 | THEN |
| 469 : | THEN | ||
| 470 : | Debug? | ||
| 471 : | pazsan | 1.54 | IF @ \ !!! cross-interacts with debugger !!! |
| 472 : | anton | 1.1 | ELSE cell+ |
| 473 : | THEN ; | ||
| 474 : | |||
| 475 : | : DebugBranch | ||
| 476 : | Debug? | ||
| 477 : | pazsan | 1.54 | IF dup @ swap THEN ; \ return 2 different addresses |
| 478 : | anton | 1.1 | |
| 479 : | : c-?branch | ||
| 480 : | Scan? | ||
| 481 : | IF dup @ Branch! | ||
| 482 : | dup @ Back? | ||
| 483 : | IF UntilCode Type! THEN | ||
| 484 : | THEN | ||
| 485 : | Display? | ||
| 486 : | IF dup @ Back? | ||
| 487 : | IF level- nl S" UNTIL " .struc nl | ||
| 488 : | ELSE dup dup @ over + | ||
| 489 : | CheckWhile | ||
| 490 : | IF MyBranch | ||
| 491 : | cell+ dup @ 0= | ||
| 492 : | IF WhileCode2 swap ! | ||
| 493 : | ELSE drop THEN | ||
| 494 : | level- nl | ||
| 495 : | pazsan | 1.8 | S" WHILE " .struc |
| 496 : | anton | 1.1 | level+ |
| 497 : | jwilke | 1.17 | ELSE MyBranch cell+ @ LeaveCode = |
| 498 : | IF s" 0= ?LEAVE " .struc | ||
| 499 : | ELSE nl S" IF " .struc level+ | ||
| 500 : | THEN | ||
| 501 : | anton | 1.1 | THEN |
| 502 : | THEN | ||
| 503 : | THEN | ||
| 504 : | DebugBranch | ||
| 505 : | cell+ ; | ||
| 506 : | |||
| 507 : | : c-for | ||
| 508 : | Display? IF nl S" FOR" .struc level+ THEN ; | ||
| 509 : | |||
| 510 : | : c-loop | ||
| 511 : | pazsan | 1.54 | Display? IF level- nl .name-without nl bl cemit THEN |
| 512 : | jwilke | 1.17 | DebugBranch cell+ |
| 513 : | Scan? | ||
| 514 : | IF dup BranchAddr? | ||
| 515 : | BEGIN WHILE cell+ LeaveCode swap ! | ||
| 516 : | dup MoreBranchAddr? | ||
| 517 : | REPEAT | ||
| 518 : | THEN | ||
| 519 : | cell+ ; | ||
| 520 : | anton | 1.1 | |
| 521 : | pazsan | 1.15 | : c-do |
| 522 : | Display? IF nl .name-without level+ THEN ; | ||
| 523 : | anton | 1.1 | |
| 524 : | anton | 1.45 | : c-?do ( addr1 -- addr2 ) |
| 525 : | Display? IF | ||
| 526 : | nl .name-without level+ | ||
| 527 : | THEN | ||
| 528 : | DebugBranch cell+ ; | ||
| 529 : | pazsan | 1.8 | |
| 530 : | pazsan | 1.54 | : c-exit ( addr1 -- addr2 ) |
| 531 : | dup 1 cells - | ||
| 532 : | CheckEnd | ||
| 533 : | IF | ||
| 534 : | Display? IF nlflag off S" ;" Com# .string THEN | ||
| 535 : | C-Stop on | ||
| 536 : | ELSE | ||
| 537 : | Display? IF S" EXIT " .struc THEN | ||
| 538 : | THEN | ||
| 539 : | Debug? IF drop THEN ; \ !!! cross-interacts with debugger !!! | ||
| 540 : | anton | 1.1 | |
| 541 : | : c-abort" | ||
| 542 : | count 2dup + aligned -rot | ||
| 543 : | Display? | ||
| 544 : | IF S" ABORT" .struc | ||
| 545 : | [char] " cemit bl cemit 0 .string | ||
| 546 : | [char] " cemit bl cemit | ||
| 547 : | ELSE 2drop | ||
| 548 : | THEN ; | ||
| 549 : | |||
| 550 : | jwilke | 1.23 | [IFDEF] (compile) |
| 551 : | : c-(compile) | ||
| 552 : | Display? | ||
| 553 : | IF | ||
| 554 : | s" POSTPONE " Com# .string | ||
| 555 : | dup @ look 0= ABORT" SEE: No valid XT" | ||
| 556 : | name>string 0 .string bl cemit | ||
| 557 : | THEN | ||
| 558 : | cell+ ; | ||
| 559 : | [THEN] | ||
| 560 : | anton | 1.1 | |
| 561 : | CREATE C-Table | ||
| 562 : | jwilke | 1.18 | ' lit A, ' c-lit A, |
| 563 : | anton | 1.44 | ' does-exec A, ' c-callxt A, |
| 564 : | ' lit@ A, ' c-call A, | ||
| 565 : | pazsan | 1.37 | [IFDEF] call ' call A, ' c-call A, [THEN] |
| 566 : | anton | 1.44 | \ ' useraddr A, .... |
| 567 : | ' lit-perform A, ' c-call A, | ||
| 568 : | ' lit+ A, ' c-lit+ A, | ||
| 569 : | anton | 1.42 | [IFDEF] (s") ' (s") A, ' c-c" A, [THEN] |
| 570 : | [IFDEF] (.") ' (.") A, ' c-c" A, [THEN] | ||
| 571 : | [IFDEF] "lit ' "lit A, ' c-c" A, [THEN] | ||
| 572 : | jwilke | 1.18 | [IFDEF] (c") ' (c") A, ' c-c" A, [THEN] |
| 573 : | ' (do) A, ' c-do A, | ||
| 574 : | pazsan | 1.46 | [IFDEF] (+do) ' (+do) A, ' c-?do A, [THEN] |
| 575 : | [IFDEF] (u+do) ' (u+do) A, ' c-?do A, [THEN] | ||
| 576 : | [IFDEF] (-do) ' (-do) A, ' c-?do A, [THEN] | ||
| 577 : | [IFDEF] (u-do) ' (u-do) A, ' c-?do A, [THEN] | ||
| 578 : | ' (?do) A, ' c-?do A, | ||
| 579 : | jwilke | 1.18 | ' (for) A, ' c-for A, |
| 580 : | pazsan | 1.46 | ' ?branch A, ' c-?branch A, |
| 581 : | ' branch A, ' c-branch A, | ||
| 582 : | ' (loop) A, ' c-loop A, | ||
| 583 : | ' (+loop) A, ' c-loop A, | ||
| 584 : | [IFDEF] (s+loop) ' (s+loop) A, ' c-loop A, [THEN] | ||
| 585 : | [IFDEF] (-loop) ' (-loop) A, ' c-loop A, [THEN] | ||
| 586 : | ' (next) A, ' c-loop A, | ||
| 587 : | jwilke | 1.18 | ' ;s A, ' c-exit A, |
| 588 : | anton | 1.42 | [IFDEF] (abort") ' (abort") A, ' c-abort" A, [THEN] |
| 589 : | jwilke | 1.23 | \ only defined if compiler is loaded |
| 590 : | [IFDEF] (compile) ' (compile) A, ' c-(compile) A, [THEN] | ||
| 591 : | jwilke | 1.18 | 0 , here 0 , |
| 592 : | pazsan | 1.15 | |
| 593 : | avariable c-extender | ||
| 594 : | c-extender ! | ||
| 595 : | anton | 1.1 | |
| 596 : | \ DOTABLE 15may93jaw | ||
| 597 : | |||
| 598 : | anton | 1.44 | : DoTable ( ca/cfa -- flag ) |
| 599 : | decompile-prim C-Table BEGIN ( cfa table-entry ) | ||
| 600 : | dup @ dup 0= IF | ||
| 601 : | drop cell+ @ dup IF ( next table!) | ||
| 602 : | dup @ | ||
| 603 : | ELSE ( end!) | ||
| 604 : | 2drop false EXIT | ||
| 605 : | THEN | ||
| 606 : | THEN | ||
| 607 : | \ jump over to extender, if any 26jan97jaw | ||
| 608 : | xt>threaded 2 pick <> | ||
| 609 : | WHILE | ||
| 610 : | 2 cells + | ||
| 611 : | REPEAT | ||
| 612 : | nip cell+ perform | ||
| 613 : | true | ||
| 614 : | ; | ||
| 615 : | anton | 1.1 | |
| 616 : | : BranchTo? ( a-addr -- a-addr ) | ||
| 617 : | jwilke | 1.17 | Display? IF dup BranchAddr? |
| 618 : | pazsan | 1.15 | IF |
| 619 : | BEGIN cell+ @ dup 20 u> | ||
| 620 : | anton | 1.1 | IF drop nl S" BEGIN " .struc level+ |
| 621 : | ELSE | ||
| 622 : | jwilke | 1.17 | dup Disable <> over LeaveCode <> and |
| 623 : | anton | 1.1 | IF WhileCode2 = |
| 624 : | IF nl S" THEN " .struc nl ELSE | ||
| 625 : | level- nl S" THEN " .struc nl THEN | ||
| 626 : | ELSE drop THEN | ||
| 627 : | THEN | ||
| 628 : | dup MoreBranchAddr? 0= | ||
| 629 : | UNTIL | ||
| 630 : | THEN | ||
| 631 : | THEN ; | ||
| 632 : | |||
| 633 : | : analyse ( a-addr1 -- a-addr2 ) | ||
| 634 : | anton | 1.34 | Branches @ IF BranchTo? THEN |
| 635 : | dup cell+ swap @ | ||
| 636 : | dup >r DoTable r> swap IF drop EXIT THEN | ||
| 637 : | Display? | ||
| 638 : | IF | ||
| 639 : | pazsan | 1.35 | .word bl cemit |
| 640 : | anton | 1.34 | ELSE |
| 641 : | drop | ||
| 642 : | THEN ; | ||
| 643 : | anton | 1.1 | |
| 644 : | : c-init | ||
| 645 : | 0 YPos ! 0 XPos ! | ||
| 646 : | 0 Level ! nlflag off | ||
| 647 : | BranchTable BranchPointer ! | ||
| 648 : | c-stop off | ||
| 649 : | Branches on ; | ||
| 650 : | |||
| 651 : | : makepass ( a-addr -- ) | ||
| 652 : | anton | 1.14 | c-stop off |
| 653 : | BEGIN | ||
| 654 : | analyse | ||
| 655 : | c-stop @ | ||
| 656 : | UNTIL drop ; | ||
| 657 : | |||
| 658 : | Defer xt-see-xt ( xt -- ) | ||
| 659 : | \ this one is just a forward declaration for indirect recursion | ||
| 660 : | |||
| 661 : | : .defname ( xt c-addr u -- ) | ||
| 662 : | rot look | ||
| 663 : | if ( c-addr u nfa ) | ||
| 664 : | -rot type space .name | ||
| 665 : | else | ||
| 666 : | drop ." noname " type | ||
| 667 : | then | ||
| 668 : | space ; | ||
| 669 : | |||
| 670 : | anton | 1.28 | Defer discode ( addr u -- ) \ gforth |
| 671 : | anton | 1.69 | \G hook for the disassembler: disassemble u bytes of code at addr |
| 672 : | anton | 1.27 | ' dump IS discode |
| 673 : | |||
| 674 : | : next-head ( addr1 -- addr2 ) \ gforth | ||
| 675 : | \G find the next header starting after addr1, up to here (unreliable). | ||
| 676 : | here swap u+do | ||
| 677 : | anton | 1.43 | i head? -2 and if |
| 678 : | anton | 1.27 | i unloop exit |
| 679 : | then | ||
| 680 : | cell +loop | ||
| 681 : | here ; | ||
| 682 : | |||
| 683 : | anton | 1.55 | [ifundef] umin \ !! bootstrapping help |
| 684 : | anton | 1.27 | : umin ( u1 u2 -- u ) |
| 685 : | 2dup u> | ||
| 686 : | if | ||
| 687 : | swap | ||
| 688 : | then | ||
| 689 : | drop ; | ||
| 690 : | anton | 1.55 | [then] |
| 691 : | |||
| 692 : | anton | 1.28 | : next-prim ( addr1 -- addr2 ) \ gforth |
| 693 : | \G find the next primitive after addr1 (unreliable) | ||
| 694 : | anton | 1.27 | 1+ >r -1 primstart |
| 695 : | begin ( umin head R: boundary ) | ||
| 696 : | @ dup | ||
| 697 : | while | ||
| 698 : | anton | 1.28 | tuck name>int >code-address ( head1 umin ca R: boundary ) |
| 699 : | anton | 1.27 | r@ - umin |
| 700 : | swap | ||
| 701 : | repeat | ||
| 702 : | anton | 1.28 | drop dup r@ negate u>= |
| 703 : | \ "umin+boundary within [0,boundary)" = "umin within [-boundary,0)" | ||
| 704 : | if ( umin R: boundary ) \ no primitive found behind -> use a default length | ||
| 705 : | drop 31 | ||
| 706 : | then | ||
| 707 : | r> + ; | ||
| 708 : | anton | 1.14 | |
| 709 : | : seecode ( xt -- ) | ||
| 710 : | dup s" Code" .defname | ||
| 711 : | anton | 1.39 | >code-address |
| 712 : | anton | 1.27 | dup in-dictionary? \ user-defined code word? |
| 713 : | if | ||
| 714 : | dup next-head | ||
| 715 : | else | ||
| 716 : | dup next-prim | ||
| 717 : | then | ||
| 718 : | over - discode | ||
| 719 : | ." end-code" cr ; | ||
| 720 : | dvdkhlng | 1.68 | : seeabicode ( xt -- ) |
| 721 : | dup s" ABI-Code" .defname | ||
| 722 : | >body dup dup next-head | ||
| 723 : | swap - discode | ||
| 724 : | ." end-code" cr ; | ||
| 725 : | anton | 1.14 | : seevar ( xt -- ) |
| 726 : | s" Variable" .defname cr ; | ||
| 727 : | : seeuser ( xt -- ) | ||
| 728 : | s" User" .defname cr ; | ||
| 729 : | : seecon ( xt -- ) | ||
| 730 : | dup >body ? | ||
| 731 : | s" Constant" .defname cr ; | ||
| 732 : | : seevalue ( xt -- ) | ||
| 733 : | dup >body ? | ||
| 734 : | s" Value" .defname cr ; | ||
| 735 : | : seedefer ( xt -- ) | ||
| 736 : | dup >body @ xt-see-xt cr | ||
| 737 : | dup s" Defer" .defname cr | ||
| 738 : | anton | 1.26 | >name ?dup-if |
| 739 : | ." IS " .name cr | ||
| 740 : | anton | 1.14 | else |
| 741 : | anton | 1.52 | ." latestxt >body !" |
| 742 : | anton | 1.14 | then ; |
| 743 : | : see-threaded ( addr -- ) | ||
| 744 : | C-Pass @ DebugMode = IF | ||
| 745 : | ScanMode c-pass ! | ||
| 746 : | EXIT | ||
| 747 : | anton | 1.10 | THEN |
| 748 : | ScanMode c-pass ! dup makepass | ||
| 749 : | DisplayMode c-pass ! makepass ; | ||
| 750 : | anton | 1.14 | : seedoes ( xt -- ) |
| 751 : | dup s" create" .defname cr | ||
| 752 : | S" DOES> " Com# .string XPos @ Level ! | ||
| 753 : | >does-code see-threaded ; | ||
| 754 : | : seecol ( xt -- ) | ||
| 755 : | pazsan | 1.15 | dup s" :" .defname nl |
| 756 : | anton | 1.14 | 2 Level ! |
| 757 : | >body see-threaded ; | ||
| 758 : | : seefield ( xt -- ) | ||
| 759 : | dup >body ." 0 " ? ." 0 0 " | ||
| 760 : | s" Field" .defname cr ; | ||
| 761 : | |||
| 762 : | anton | 1.29 | : xt-see ( xt -- ) \ gforth |
| 763 : | \G Decompile the definition represented by @i{xt}. | ||
| 764 : | anton | 1.14 | cr c-init |
| 765 : | dup >does-code | ||
| 766 : | if | ||
| 767 : | seedoes EXIT | ||
| 768 : | then | ||
| 769 : | jwilke | 1.18 | dup xtprim? |
| 770 : | anton | 1.14 | if |
| 771 : | seecode EXIT | ||
| 772 : | then | ||
| 773 : | dup >code-address | ||
| 774 : | CASE | ||
| 775 : | docon: of seecon endof | ||
| 776 : | anton | 1.64 | [IFDEF] dovalue: |
| 777 : | dovalue: of seevalue endof | ||
| 778 : | [THEN] | ||
| 779 : | anton | 1.14 | docol: of seecol endof |
| 780 : | dovar: of seevar endof | ||
| 781 : | anton | 1.64 | [IFDEF] douser: |
| 782 : | anton | 1.14 | douser: of seeuser endof |
| 783 : | anton | 1.64 | [THEN] |
| 784 : | [IFDEF] dodefer: | ||
| 785 : | anton | 1.14 | dodefer: of seedefer endof |
| 786 : | anton | 1.64 | [THEN] |
| 787 : | [IFDEF] dofield: | ||
| 788 : | anton | 1.14 | dofield: of seefield endof |
| 789 : | anton | 1.64 | [THEN] |
| 790 : | dvdkhlng | 1.68 | [IFDEF] doabicode: |
| 791 : | doabicode: of seeabicode endof | ||
| 792 : | [THEN] | ||
| 793 : | anton | 1.27 | over of seecode endof \ direct threaded code words |
| 794 : | over >body of seecode endof \ indirect threaded code words | ||
| 795 : | anton | 1.14 | 2drop abort" unknown word type" |
| 796 : | ENDCASE ; | ||
| 797 : | |||
| 798 : | : (xt-see-xt) ( xt -- ) | ||
| 799 : | anton | 1.52 | xt-see cr ." latestxt" ; |
| 800 : | anton | 1.14 | ' (xt-see-xt) is xt-see-xt |
| 801 : | |||
| 802 : | : (.immediate) ( xt -- ) | ||
| 803 : | ['] execute = if | ||
| 804 : | ." immediate" | ||
| 805 : | then ; | ||
| 806 : | |||
| 807 : | : name-see ( nfa -- ) | ||
| 808 : | dup name>int >r | ||
| 809 : | dup name>comp | ||
| 810 : | over r@ = | ||
| 811 : | if \ normal or immediate word | ||
| 812 : | swap xt-see (.immediate) | ||
| 813 : | else | ||
| 814 : | anton | 1.40 | r@ ['] ticking-compile-only-error = |
| 815 : | anton | 1.14 | if \ compile-only word |
| 816 : | swap xt-see (.immediate) ." compile-only" | ||
| 817 : | else \ interpret/compile word | ||
| 818 : | r@ xt-see-xt cr | ||
| 819 : | swap xt-see-xt cr | ||
| 820 : | anton | 1.53 | ." interpret/compile: " over .name drop |
| 821 : | anton | 1.14 | then |
| 822 : | then | ||
| 823 : | rdrop drop ; | ||
| 824 : | pazsan | 1.3 | |
| 825 : | crook | 1.21 | : see ( "<spaces>name" -- ) \ tools |
| 826 : | \G Locate @var{name} using the current search order. Display the | ||
| 827 : | \G definition of @var{name}. Since this is achieved by decompiling | ||
| 828 : | \G the definition, the formatting is mechanised and some source | ||
| 829 : | \G information (comments, interpreted sequences within definitions | ||
| 830 : | \G etc.) is lost. | ||
| 831 : | anton | 1.13 | name find-name dup 0= |
| 832 : | IF | ||
| 833 : | anton | 1.24 | drop -&13 throw |
| 834 : | anton | 1.13 | THEN |
| 835 : | anton | 1.14 | name-see ; |
| 836 : | anton | 1.1 | |
| 837 : |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |