Changeset 2914

Timestamp:

Mar 22, 2012 2:13:14 AM (15 months ago)

Author:

wmb

Message:

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.

Files:

• forth/lib/debug.fth (modified) (1 diff)
• ofw/core/ofwcore.fth (modified) (1 diff)

forth/lib/debug.fth

@@ -156 +156 @@
    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

ofw/core/ofwcore.fth

@@ -4790 +4790 @@
 ;
 ' 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