[openfirmware] [commit] r2914 - forth/lib ofw/core

[repository service]

Author: wmb
Date: Thu Mar 22 02:13:14 2012
New Revision: 2914
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2914

Log:
Debugger - improved the "down" command so it will skip past the method call machinery to find the callee that the user cares about.  You can now use 'd' on $call-method, $call-parent, etc.

Modified:
   forth/lib/debug.fth
   ofw/core/ofwcore.fth

Modified: forth/lib/debug.fth
==============================================================================
--- forth/lib/debug.fth	Thu Mar 22 01:21:57 2012	(r2913)
+++ forth/lib/debug.fth	Thu Mar 22 02:13:14 2012	(r2914)
@@ -155,8 +155,11 @@
 : try  ( n acf -- okay? )
    catch  ?dup if  .error drop false  else  true  then
 ;
+defer resolve-method
+' noop to resolve-method
 : executer  ( xt -- xt' )
    dup ['] execute =  over ['] catch =  or  if  drop dup  then
+   resolve-method
 ;
 d# 72 constant /#buf
 /#buf buffer: #buf-save

Modified: ofw/core/ofwcore.fth
==============================================================================
--- ofw/core/ofwcore.fth	Thu Mar 22 01:21:57 2012	(r2913)
+++ ofw/core/ofwcore.fth	Thu Mar 22 02:13:14 2012	(r2914)
@@ -4789,4 +4789,71 @@
    drop false
 ;
 ' method-call? to indirect-call?
+
+create not-colon
+: ?not-colon  ( false | xt true -- xt ) 
+   0=  if  ['] not-colon  then
+;
+: resolve-ih-method  ( adr len ihandle -- xt )
+   dup 0=  if  3drop ['] not-colon exit  then         ( adr len ihandle )
+   package(  my-voc $find-word  )package  ?not-colon  ( xt )
+;
+: resolve-voc-method  ( adr len voc -- xt )
+   (search-wordlist)  ?not-colon
+;
+: resolve-ph-method  ( adr len ph -- xt )
+   phandle>voc resolve-voc-method
+;
+   
+: (resolve-method) ( xt -- xt' )
+   dup ['] $call-self =  if     ( [ adr len ] xt )
+      drop  2dup my-self        ( adr len ih )
+      resolve-ih-method exit    ( -- xt' )
+   then
+
+   dup ['] $call-method =  if   ( [ adr len ih ] xt )
+      drop  3dup                ( adr len ih )
+      resolve-ih-method exit    ( -- xt' )
+   then
+
+   dup ['] $call-parent =  if   ( [ adr len ] xt )
+      drop  2dup my-parent      ( adr len ih )
+      resolve-ih-method exit    ( -- xt' )
+   then                         ( xt )
+
+   dup ['] call-package =  if   ( [ xt ih ] xt )
+      drop over exit            ( -- xt' )
+   then
+
+   dup ['] $vexecute? =  if     ( [ adr len voc ] xt )
+      drop  3dup                ( adr len voc )
+      resolve-voc-method exit   ( -- xt )
+   then
+
+   dup ['] $vexecute =  if      ( [ adr len voc ] xt )
+      drop  3dup                ( adr len voc )
+      resolve-voc-method exit   ( -- xt )
+   then
+
+   dup ['] $package-execute? =  if  ( [ adr len ph ] xt )
+      drop  3dup                    ( adr len voc )
+      resolve-ph-method exit        ( -- xt )
+   then                             ( xt )
+
+   dup ['] package-execute =  if  ( [ adr len ] xt )
+      drop  2dup current-device   ( adr len voc )
+      resolve-ph-method exit      ( -- xt )
+   then                           ( xt )
+
+   dup ['] apply-method =  if     ( [ adr len ] xt )
+      drop  2dup my-voc           ( adr len voc )
+      resolve-voc-method exit     ( -- xt )
+   then                           ( xt )
+
+   dup ['] (apply-method) =  if   ( [ adr len ] xt )
+      drop  2dup my-voc           ( adr len voc )
+      resolve-voc-method exit     ( -- xt )
+   then                           ( xt )
+;
+also bug  ' (resolve-method) to resolve-method  previous
 previous