[openfirmware] [commit] r2898 - in forth: kernel lib
repository service
svn at openfirmware.info
Mon Mar 19 20:46:10 CET 2012
Author: wmb
Date: Mon Mar 19 20:46:09 2012
New Revision: 2898
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2898
Log:
Colorized the decompiler output.
Modified:
forth/kernel/kernel.fth
forth/lib/decomp.fth
Modified: forth/kernel/kernel.fth
==============================================================================
--- forth/kernel/kernel.fth Sat Mar 17 02:51:04 2012 (r2897)
+++ forth/kernel/kernel.fth Mon Mar 19 20:46:09 2012 (r2898)
@@ -369,12 +369,12 @@
: [""] \ word (s Compile-time: -- )
(s Run-time: -- pstr )
- compile ("s) safe-parse-word ",
+ compile (p") safe-parse-word ",
; immediate
\ Obsolete
: ["] \ string" (s -- str )
- compile ("s) ,"
+ compile (p") ,"
; immediate
: \ \ rest-of-line (s -- ) \ skips rest of line
@@ -383,7 +383,7 @@
: compile-pstring ( adr len -- )
state @ if
- compile ("s) ",
+ compile (p") ",
else
switch-string "temp npack
then
@@ -636,7 +636,7 @@
if skipstr $abort else skipstr 2drop then
;
: ?throw ( flag throw-code -- ) swap if throw else drop then ;
-: ("s) (s -- str-addr ) skipstr ( addr len ) drop 1- ;
+: (p") (s -- str-addr ) skipstr ( addr len ) drop 1- ;
nuser 'lastacf \ acf of latest definition
: lastacf ( -- acf ) 'lastacf token@ ;
Modified: forth/lib/decomp.fth
==============================================================================
--- forth/lib/decomp.fth Sat Mar 17 02:51:04 2012 (r2897)
+++ forth/lib/decomp.fth Mon Mar 19 20:46:09 2012 (r2898)
@@ -56,7 +56,7 @@
hidden definitions
headerless
\ Like ." but goes to a new line if needed.
-: cr". ( adr len -- ) dup ?line type ;
+: cr". ( adr len -- ) dup ?line magenta-letters type cancel ;
: .." ( -- ) [compile] " compile cr". ; immediate
\ Positional case defining word
@@ -280,28 +280,38 @@
dup immediate? if .." [compile] " then
;
-: put" (s -- ) ascii " emit space ;
+: put" (s -- ) ascii " emit space ;
-: .cword (s ip -- ip' ) \ Display run-time word, e.g. (is) sans '()'
- dup token@ ?cr ( ip acf )
- >name name>string ( ip adr len )
- swap 1+ swap 2 - type space ( ip ) \ Remove parentheses
- ta1+
+: cword-name (s ip -- ip' $ name$ )
+ dup token@ ( ip acf )
+ >name name>string ( ip name$ )
+ swap 1+ swap 2 - ( ip name$' ) \ Remove parentheses
+ rot ta1+ -rot ( ip' name$ )
+ 2 pick count ( ip name$ $ )
+ 2swap ( ip $ name$ )
+;
+: .string-tail ( $ name$ -- )
+ 2 pick over + 3 + ?line ( $ name$ ) \ Keep word and string on the same line
+ cr". space ( $ )
+ red-letters type ( )
+ .." "" " ( )
;
+
+: pretty-n. ( n -- ) green-letters n. cancel ;
+: pretty-. ( n -- ) green-letters . cancel ;
+
: .word ( ip -- ip' ) dup token@ check-[compile] ?cr .name ta1+ ;
: skip-word ( ip -- ip' ) ta1+ ;
-: .inline ( ip -- ip' ) ta1+ dup unaligned-@ n. na1+ ;
+: .inline ( ip -- ip' ) ta1+ dup unaligned-@ pretty-n. na1+ ;
: skip-inline ( ip -- ip' ) ta1+ na1+ ;
-: .wlit ( ip -- ip' ) ta1+ dup unaligned-w@ 1- . wa1+ ;
+: .wlit ( ip -- ip' ) ta1+ dup unaligned-w@ 1- pretty-. wa1+ ;
: skip-wlit ( ip -- ip' ) ta1+ wa1+ ;
-: .llit ( ip -- ip' ) ta1+ dup unaligned-l@ 1- . la1+ ;
+: .llit ( ip -- ip' ) ta1+ dup unaligned-l@ 1- pretty-. la1+ ;
: skip-llit ( ip -- ip' ) ta1+ la1+ ;
-: .dlit ( ip -- ip' ) ta1+ dup d@ (d.) type ." . " 2 na+ ;
+: .dlit ( ip -- ip' ) ta1+ dup d@ (d.) green-letters type ." . " cancel 2 na+ ;
: skip-dlit ( ip -- ip' ) ta1+ 2 na+ ;
: skip-branch ( ip -- ip' ) +branch ;
-: .quote ( ip -- ip' ) .word .word ;
-: skip-quote ( ip -- ip' ) ta1+ ta1+ ;
-: .compile ( ip -- ip' ) ." compile " ta1+ .word ;
+: .compile ( ip -- ip' ) .." compile " ta1+ .word ;
: skip-compile ( ip -- ip' ) ta1+ ta1+ ;
: skip-string ( ip -- ip' ) ta1+ +str ;
: skip-nstring ( ip -- ip' ) ta1+ +nstr ;
@@ -309,11 +319,9 @@
headers
: skip-(') ( ip -- ip' ) ta1+ ta1+ ;
headerless
-: .is ( ip -- ip' ) ." to " ta1+ dup token@ .name ta1+ ;
-: .string-tail ( ip -- ip' ) dup count type +str ;
-: .string ( ip -- ip' ) .cword .string-tail put" ;
-: .pstring ( ip -- ip' ) ?cr ." p" put" ta1+ .string-tail put" ;
-: .nstring ( ip -- ip' ) ?cr put" ta1+ dup ncount type +nstr put" ;
+: .is ( ip -- ip' ) .." to " ta1+ dup token@ .name ta1+ ;
+: .string ( ip -- ip' ) cword-name .string-tail +str ;
+: .nstring ( ip -- ip' ) ta1+ dup ncount " n""" .string-tail +nstr ;
\ Use this version of .branch if the structured conditional code is not used
\ : .branch ( ip -- ip' ) .word dup <w@ . /branch + ;
@@ -325,7 +333,6 @@
.." exit " ta1+
then
;
-
: dummy ;
\ classify each word in a definition
@@ -344,7 +351,7 @@
( 14 ) [compile] exit ( 15 ) [compile] (wlit)
( 16 ) [compile] (') ( 17 ) [compile] (of)
( 18 ) [compile] (endof) ( 19 ) [compile] (endcase)
- ( 20 ) [compile] ("s) ( 21 ) [compile] (is)
+ ( 20 ) [compile] (p") ( 21 ) [compile] (is)
( 22 ) [compile] (dlit) ( 23 ) [compile] (llit)
( 24 ) [compile] (n") ( 25 ) [compile] isdefer
( 26 ) [compile] isuser ( 27 ) [compile] isvalue
@@ -365,7 +372,7 @@
( 14 ) .unnest ( 15 ) .wlit
( 16 ) .(') ( 17 ) .of
( 18 ) .endof ( 19 ) .endcase
- ( 20 ) .pstring ( 21 ) .is
+ ( 20 ) .string ( 21 ) .is
( 22 ) .dlit ( 23 ) .llit
( 24 ) .nstring ( 25 ) .is
( 26 ) .is ( 27 ) .is
@@ -447,36 +454,38 @@
: .immediate ( acf -- ) immediate? if .." immediate" then ;
-: .definer ( acf definer-acf -- acf ) .name dup .name ;
+: .definer ( acf definer-acf -- acf )
+ magenta-letters .name dup blue-letters .name cancel
+;
: dump-body ( pfa -- )
push-hex
- dup @ n. 2 spaces 8 emit.ln
+ dup @ pretty-n. 2 spaces 8 emit.ln
pop-base
;
\ Display category of word
: .: ( acf definer -- ) .definer space space >body .pf ;
-: .constant ( acf definer -- ) over >data ? .definer drop ;
-: .2constant ( acf definer -- ) over >data dup ? na1+ ? .definer drop ;
+: .constant ( acf definer -- ) over >data @ pretty-n. .definer drop ;
+: .2constant ( acf definer -- ) over >data dup @ pretty-n. na1+ @ pretty-n. .definer drop ;
: .vocabulary ( acf definer -- ) .definer drop ;
: .code ( acf definer -- ) .definer >code disassemble ;
: .variable ( acf definer -- )
- over >data n. .definer .." value = " >data ?
+ over >data n. .definer ." value = " >data @ pretty-n.
;
: .create ( acf definer -- )
- over >body n. .definer .." value = " >body dump-body
+ over >body n. .definer ." value = " >body dump-body
;
: .user ( acf definer -- )
- over >body ? .definer .." value = " >data ?
+ over >body @ n. .definer ." value = " >data @ pretty-n.
;
: .defer ( acf definer -- )
- .definer .." is " cr >data token@ (see)
+ .definer ." is " cr >data token@ (see)
;
: .alias ( acf definer -- )
.definer >body token@ .name
;
: .value ( acf definer -- )
- swap >data ? .definer
+ swap >data @ pretty-n. .definer
;
@@ -487,7 +496,6 @@
.definer >body ." (Body: " dump-body ." ) " cr
;
-
\ Classify a word based on its acf
alias isalias noop
create iscreate
More information about the openfirmware
mailing list