Merge branch 'symbolic-xt'

basis/tools/disassembler/udis/udis.factor

@@ -3,7 +3,8 @@
 USING: tools.disassembler namespaces combinators
 alien alien.syntax alien.c-types lexer parser kernel
 sequences layouts math math.order alien.libraries
-math.parser system make fry arrays libc destructors ;
+math.parser system make fry arrays libc destructors
+tools.disassembler.utils splitting ;
 IN: tools.disassembler.udis
 
 <<
@@ -103,19 +104,21 @@ FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
     dup UD_SYN_INTEL ud_set_syntax ;
 
 : with-ud ( quot: ( ud -- ) -- )
-    [ [ <ud> ] dip call ] with-destructors ; inline
+    [ [ [ <ud> ] dip call ] with-destructors ] with-words-xt ; inline
 
 SINGLETON: udis-disassembler
 
 : buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
 
+: resolve-call ( str -- str' ) "0x" split1-last [ resolve-xt append ] when* ;
+
 : format-disassembly ( lines -- lines' )
     dup [ second length ] [ max ] map-reduce
     '[
         [
             [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]
             [ second _ CHAR: \s pad-tail % "  " % ]
-            [ third % ]
+            [ third resolve-call % ]
             tri
         ] "" make
     ] map ;

basis/tools/disassembler/utils/utils.factor

@@ -0,0 +1,41 @@
+USING: accessors arrays binary-search kernel math math.order
+math.parser namespaces sequences sorting splitting vectors vocabs words ;
+IN: tools.disassembler.utils
+
+SYMBOL: words-xt
+SYMBOL: smallest-xt
+SYMBOL: greatest-xt
+
+: (words-xt) ( -- assoc )
+    vocabs [ words ] map concat [ [ word-xt ] keep 3array ] map
+    [ [ first ] bi@ <=> ] sort >vector ;
+
+: complete-address ( n seq -- str )
+    [ first - ] [ third name>> ] bi
+    over zero? [ nip ] [ swap 16 >base "0x" prepend "+" glue ] if ;
+
+: search-xt ( n -- str/f )
+    dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [
+        drop f
+    ] [
+        words-xt get over [ swap first <=> ] curry search nip
+        2dup second <= [
+            [ complete-address ] [ drop f ] if*
+        ] [
+            2drop f
+        ] if
+    ] if ;
+
+: resolve-xt ( str -- str' )
+    [ "0x" prepend ] [ 16 base> ] bi
+    [ search-xt [ " (" ")" surround append ] when* ] when* ;
+
+: resolve-call ( str -- str' )
+    "0x" split1-last [ resolve-xt "0x" glue ] when* ;
+
+: with-words-xt ( quot -- )
+    [ (words-xt)
+      [ words-xt set ]
+      [ first first smallest-xt set ]
+      [ last second greatest-xt set ] tri
+    ] prepose with-scope ; inline