Changeset 2898


Ignore:
Timestamp:
Mar 19, 2012, 8:46:09 PM (2 years ago)
Author:
wmb
Message:

Colorized the decompiler output.

Location:
forth
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • forth/kernel/kernel.fth

    r2871 r2898  
    370370: [""]  \ word  (s Compile-time: -- ) 
    371371        (s Run-time: -- pstr ) 
    372    compile ("s)  safe-parse-word ", 
     372   compile (p")  safe-parse-word ", 
    373373; immediate 
    374374 
    375375\ Obsolete 
    376376: ["]   \ string"  (s -- str ) 
    377    compile ("s)    ," 
     377   compile (p")    ," 
    378378; immediate 
    379379 
     
    384384: compile-pstring  ( adr len -- ) 
    385385   state @  if 
    386       compile ("s) ", 
     386      compile (p") ", 
    387387   else 
    388388      switch-string "temp npack 
     
    637637; 
    638638: ?throw  ( flag throw-code -- )  swap  if  throw  else  drop  then  ; 
    639 : ("s)  (s -- str-addr )  skipstr  ( addr len )  drop 1-  ; 
     639: (p")  (s -- str-addr )  skipstr  ( addr len )  drop 1-  ; 
    640640 
    641641nuser 'lastacf         \ acf of latest definition 
  • forth/lib/decomp.fth

    r2825 r2898  
    5757headerless 
    5858\ Like ." but goes to a new line if needed. 
    59 : cr".  ( adr len -- )  dup ?line type  ; 
     59: cr".  ( adr len -- )  dup ?line magenta-letters type cancel  ; 
    6060: .."   ( -- )  [compile] " compile cr".  ; immediate 
    6161 
     
    281281; 
    282282 
    283 : put"          (s -- )  ascii " emit space  ; 
    284  
    285 : .cword        (s ip -- ip' )  \ Display run-time word, e.g. (is) sans '()' 
    286    dup token@ ?cr                     ( ip acf ) 
    287    >name name>string                  ( ip adr len ) 
    288    swap 1+ swap 2 -  type space       ( ip )    \ Remove parentheses 
    289    ta1+ 
    290 ; 
     283: put"          (s -- )  ascii " emit  space  ; 
     284 
     285: cword-name  (s ip -- ip' $ name$ ) 
     286   dup token@          ( ip acf ) 
     287   >name name>string   ( ip name$ ) 
     288   swap 1+ swap 2 -    ( ip name$' )  \ Remove parentheses 
     289   rot ta1+ -rot       ( ip' name$ ) 
     290   2 pick count        ( ip name$ $ ) 
     291   2swap               ( ip $ name$ ) 
     292; 
     293: .string-tail  ( $ name$ -- ) 
     294   2 pick over +  3 + ?line    ( $ name$ )  \ Keep word and string on the same line 
     295   cr".  space                 ( $ ) 
     296   red-letters type            ( ) 
     297   .." "" "                    ( ) 
     298; 
     299 
     300: pretty-n. ( n -- )  green-letters n. cancel ; 
     301: pretty-.  ( n -- )  green-letters  . cancel ; 
     302 
    291303: .word         ( ip -- ip' )  dup token@ check-[compile] ?cr .name   ta1+  ; 
    292304: skip-word     ( ip -- ip' )  ta1+  ; 
    293 : .inline       ( ip -- ip' )  ta1+ dup unaligned-@  n.  na1+   ; 
     305: .inline       ( ip -- ip' )  ta1+ dup unaligned-@  pretty-n.  na1+   ; 
    294306: skip-inline   ( ip -- ip' )  ta1+ na1+  ; 
    295 : .wlit         ( ip -- ip' )  ta1+ dup unaligned-w@ 1- . wa1+  ; 
     307: .wlit         ( ip -- ip' )  ta1+ dup unaligned-w@ 1- pretty-. wa1+  ; 
    296308: skip-wlit     ( ip -- ip' )  ta1+ wa1+  ; 
    297 : .llit         ( ip -- ip' )  ta1+ dup unaligned-l@ 1- . la1+  ; 
     309: .llit         ( ip -- ip' )  ta1+ dup unaligned-l@ 1- pretty-. la1+  ; 
    298310: skip-llit     ( ip -- ip' )  ta1+ la1+  ; 
    299 : .dlit         ( ip -- ip' )  ta1+ dup d@ (d.) type  ." . "  2 na+  ; 
     311: .dlit         ( ip -- ip' )  ta1+ dup d@ (d.) green-letters type  ." . " cancel  2 na+  ; 
    300312: skip-dlit     ( ip -- ip' )  ta1+ 2 na+  ; 
    301313: skip-branch   ( ip -- ip' )  +branch  ; 
    302 : .quote        ( ip -- ip' )  .word   .word   ; 
    303 : skip-quote    ( ip -- ip' )  ta1+ ta1+  ; 
    304 : .compile      ( ip -- ip' )  ." compile " ta1+ .word   ; 
     314: .compile      ( ip -- ip' )  .." compile " ta1+ .word   ; 
    305315: skip-compile  ( ip -- ip' )  ta1+ ta1+  ; 
    306316: skip-string   ( ip -- ip' )  ta1+ +str  ; 
     
    310320: skip-(')      ( ip -- ip' )  ta1+ ta1+  ; 
    311321headerless 
    312 : .is           ( ip -- ip' )  ." to "  ta1+ dup token@ .name  ta1+ ; 
    313 : .string-tail  ( ip -- ip' )  dup count type  +str  ; 
    314 : .string       ( ip -- ip' )  .cword .string-tail  put"  ; 
    315 : .pstring      ( ip -- ip' )  ?cr  ." p"  put"  ta1+ .string-tail  put"  ; 
    316 : .nstring      ( ip -- ip' )  ?cr         put"  ta1+  dup ncount type  +nstr  put"  ; 
     322: .is           ( ip -- ip' )  .." to "  ta1+ dup token@ .name  ta1+ ; 
     323: .string       ( ip -- ip' )  cword-name              .string-tail +str   ; 
     324: .nstring      ( ip -- ip' )  ta1+  dup ncount " n""" .string-tail +nstr  ; 
    317325 
    318326\ Use this version of .branch if the structured conditional code is not used 
     
    326334   then 
    327335; 
    328  
    329336: dummy ; 
    330337 
     
    345352   ( 16 ) [compile]  (')             ( 17 ) [compile]  (of) 
    346353   ( 18 ) [compile]  (endof)         ( 19 ) [compile]  (endcase) 
    347    ( 20 ) [compile]  ("s)            ( 21 ) [compile]  (is) 
     354   ( 20 ) [compile]  (p")            ( 21 ) [compile]  (is) 
    348355   ( 22 ) [compile]  (dlit)          ( 23 ) [compile]  (llit) 
    349356   ( 24 ) [compile]  (n")            ( 25 ) [compile]  isdefer 
     
    366373   ( 16 )     .(')                   ( 17 )     .of 
    367374   ( 18 )     .endof                 ( 19 )     .endcase 
    368    ( 20 )     .pstring               ( 21 )     .is 
     375   ( 20 )     .string                ( 21 )     .is 
    369376   ( 22 )     .dlit                  ( 23 )     .llit 
    370377   ( 24 )     .nstring               ( 25 )     .is 
     
    448455: .immediate  ( acf -- )   immediate? if   .." immediate"   then   ; 
    449456 
    450 : .definer    ( acf definer-acf -- acf )  .name  dup .name  ; 
     457: .definer    ( acf definer-acf -- acf ) 
     458   magenta-letters .name  dup blue-letters  .name  cancel 
     459; 
    451460 
    452461: dump-body  ( pfa -- ) 
    453462   push-hex 
    454    dup @ n. 2 spaces  8 emit.ln 
     463   dup @ pretty-n. 2 spaces  8 emit.ln 
    455464   pop-base 
    456465; 
    457466\ Display category of word 
    458467: .:           ( acf definer -- )  .definer space space  >body  .pf   ; 
    459 : .constant    ( acf definer -- )  over >data ?   .definer drop  ; 
    460 : .2constant   ( acf definer -- )  over >data dup ?  na1+ ? .definer drop  ; 
     468: .constant    ( acf definer -- )  over >data @ pretty-n.  .definer drop  ; 
     469: .2constant   ( acf definer -- )  over >data dup @ pretty-n.  na1+ @ pretty-n. .definer drop  ; 
    461470: .vocabulary  ( acf definer -- )  .definer drop  ; 
    462471: .code        ( acf definer -- )  .definer >code disassemble  ; 
    463472: .variable    ( acf definer -- ) 
    464    over >data n.   .definer   .." value = " >data ? 
     473   over >data n.   .definer   ." value = " >data @ pretty-n. 
    465474; 
    466475: .create     ( acf definer -- ) 
    467    over >body n.   .definer   .." value = " >body dump-body 
     476   over >body n.   .definer   ." value = " >body dump-body 
    468477; 
    469478: .user        ( acf definer -- ) 
    470    over >body ?   .definer   .."  value = "   >data  ? 
     479   over >body @ n.   .definer   ."  value = "   >data @ pretty-n. 
    471480; 
    472481: .defer       ( acf definer -- ) 
    473    .definer  .." is " cr  >data token@ (see) 
     482   .definer  ." is " cr  >data token@ (see) 
    474483; 
    475484: .alias       ( acf definer -- ) 
     
    477486; 
    478487: .value      ( acf definer -- ) 
    479    swap >data ? .definer 
     488   swap >data @ pretty-n. .definer 
    480489; 
    481490 
     
    487496   .definer   >body ."    (Body: " dump-body ."  ) " cr 
    488497; 
    489  
    490498 
    491499\ Classify a word based on its acf 
Note: See TracChangeset for help on using the changeset viewer.