Changeset 2898


Ignore:
Timestamp:
Mar 19, 2012, 7:46:09 PM (3 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.