Changeset 2610


Ignore:
Timestamp:
Oct 15, 2011, 10:23:26 PM (4 years ago)
Author:
wmb
Message:

Core - added voc>phandle and phandle>voc defer words, defaulting to noop, to decouple the representation of a phandle from the implementation choice of the address of a Forth wordlist. There is no current need for that decoupling, but the implementation is cleaner with the change. The change should have no functional impact.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • ofw/core/ofwcore.fth

    r2588 r2610  
    674674headers
    675675
     676defer voc>phandle ' noop to voc>phandle
     677defer phandle>voc ' noop to phandle>voc
     678
    676679\ TODO
    677680\ Don't use the system search order; use a private stack
     
    681684
    6826852 actions
    683 action: drop context token@  ;
    684 action: drop context token!  definitions  ;
     686action: drop context token@  voc>phandle  ;
     687action: drop phandle>voc  context token!  definitions  ;
    685688create current-device  use-actions
    686689
     
    688691: ufield  \ name  ( offset size -- offset' )
    689692   create  over ,   +
    690    does>  @  current-device  >body >user +
     693   does>  @  current-device  phandle>voc  >body >user +
    691694;
    692695
     
    716719
    717720headers
    718 : >parent  ( node -- parent-node )  >voc-link  link@ ;
     721: >parent  ( node -- parent-node )  >voc-link  link@ voc>phandle ;
    719722: parent-device  ( -- parent-node )  current-device >parent  ;
    720723
     724: (select-package)  ( phandle -- )  phandle>voc execute  ;
     725: (push-package)  ( phandle -- )  also (select-package)  ;
     726: (pop-package)  ( phandle -- )  previous  ;
    721727: push-package  ( phandle -- )
    722728   dup  0=  if  ." Attempting to push null package!!!" abort  then
    723    also  execute  definitions
    724 ;
    725 : pop-package  ( -- )  previous definitions  ;
     729   (push-package)  definitions
     730;
     731: pop-package  ( -- )  (pop-package) definitions  ;
    726732: push-device  ( acf -- )  to current-device  ;
    727733
     
    946952   @
    947953   my-self  if  \ Use current instance's package if there is a current instance
    948       my-voc also execute  initial-values  previous
     954      my-voc (push-package)  initial-values  (pop-package)
    949955   else         \ Otherwise use the active package
    950956      initial-values
     
    10461052
    10471053: destroy-instance  ( -- )
    1048    also  my-voc execute               ( )
     1054   my-voc (push-package)              ( )
    10491055   '#values @  '#buffers @  negate    ( value-size variable-size )
    1050    previous                           ( value-size variable-size )
     1056   (pop-package)                      ( value-size variable-size )
    10511057   deallocate-instance
    10521058
     
    11501156: $vexecute?  ( adr len voc-acf -- true | ??? false)
    11511157   (search-wordlist)  if  execute false  else  true  then
     1158;
     1159: $package-execute?  ( adr len phandle -- true | ??? false)
     1160   phandle>voc (search-wordlist)  if  execute false  else  true  then
    11521161;
    11531162: $vexecute  ( adr len voc-acf -- ?? )  $vexecute? drop  ;
     
    12281237: my-#adr-cells  ( -- n )
    12291238   my-self  if  \ Use current instance's package if there is a current instance
    1230       my-voc also execute  '#adr-cells @  previous
     1239      my-voc (push-package)  '#adr-cells @  (pop-package)
    12311240   else         \ Otherwise use the active package
    12321241      '#adr-cells @
     
    13601369: property  ( value-adr,len  name-adr,len  -- )
    13611370   my-self if
    1362       context token@ >r my-voc execute
     1371      context token@ >r my-voc (select-package)
    13631372      (property)
    13641373      r> context token!
     
    15161525headers
    15171526: package-execute  ( ?? adr len -- ?? )
    1518    current-device $vexecute?  abort" Package method not found"
     1527   current-device $package-execute?  abort" Package method not found"
    15191528;
    15201529headerless
     
    17891798      ." @"
    17901799      unit-str>phys                           ( phys.lo .. phys.hi )
    1791       " encode-unit"  parent-device           ( phys.lo .. phys.hi adr,len ph )
    1792       $vexecute?  if                          ( phys.lo .. phys.hi )
     1800      " encode-unit"  parent-device           ( phys.lo .. phys.hi adr,len phandle )
     1801      $package-execute?  if                   ( phys.lo .. phys.hi )
    17931802         '#adr-cells @  if  .nh  then         ( phys.lo .. phys.next )
    17941803         '#adr-cells @ 1-  0 max  0  ?do  ." ,"  .nh  loop  ( )
     
    21332142
    21342143: get-package-property  ( adr len phandle -- true | adr' len' false )
    2135    also execute  get-property  previous
     2144   (push-package)  get-property  (pop-package)
    21362145;
    21372146
     
    22742283
    22752284: apply-method  ( adr len -- no-such-method? )
    2276    my-voc fm-hook  ['] $vexecute?  catch  ?dup  if  ( x x x errno )
     2285   my-voc fm-hook  ['] $package-execute?  catch  ?dup  if  ( x x x errno )
    22772286      \ executing method caused an error
    22782287      nip nip nip                                   ( errno )
     
    27722781
    27732782   " encode-unit"  parent-device           ( phys .. adr,len phandle ) ( R: $ )
    2774    $vexecute?  if                          ( phys .. )          ( R: $ )
     2783   $package-execute?  if                       ( phys .. )          ( R: $ )
    27752784
    27762785      2r>                                      ( phys .. adr,len )  ( R: )
     
    31653174: (trace)  ( adr len phandle -- adr len phandle )
    31663175   >r  >r >r  .s  r> r>           ( adr len )  ( r: phandle )
    3167    also  r@ execute               ( adr len )  ( r: phandle )
     3176   r@ (push-package)              ( adr len )  ( r: phandle )
    31683177   " name" get-property           ( adr len value-str false )  ( r: phandle )
    3169    previous                       ( adr len value-str false )  ( r: phandle )
     3178   (pop-package)                  ( adr len value-str false )  ( r: phandle )
    31703179   drop get-encoded-string  type  ( adr len )  ( r: phandle )
    31713180   ." : "  2dup type space  cr    ( adr len )  ( r: phandle )
     
    40524061
    40534062: setnode  ( nodeid | 0 -- )
    4054    dup 0=  if  drop ['] root-node  then  also execute
     4063   dup 0=  if  drop ['] root-node  then  (push-package)
    40554064;
    40564065
     
    41254134      then
    41264135   then                              ( cstr )
    4127    previous
     4136   (pop-package)
    41284137;
    41294138: .cstr  ( cstr -- )  begin  dup c@ ?dup  while  emit 1+  repeat  drop  ;
     
    41514160   0  'child                         ( last-nodeid &next-nodeid )
    41524161   begin  get-token?  while          ( last-nodeid next-nodeid )
    4153       nip  dup execute               ( next-nodeid )
     4162      nip  dup (select-package)      ( next-nodeid )
    41544163      'peer                          ( last-nodeid' &next-nodeid )
    41554164   repeat                            ( last-nodeid' )
    4156    previous                          ( nodeid )
     4165   (pop-package)                     ( nodeid )
    41574166;
    41584167
     
    41674176
    41684177   \ Select the first child of our parent
    4169    dup >parent also execute          ( nodeid )
    4170    'child token@ execute             ( nodeid )
     4178   dup >parent (push-package)        ( nodeid )
     4179   'child token@ (select-package)    ( nodeid )
    41714180
    41724181   dup current-device  =  if         ( nodeid )
     
    41824191      2drop current-device           ( nodeid' )
    41834192   then                              ( nodeid | 0 )
    4184    previous                          ( nodeid | 0 )
     4193   (pop-package)                     ( nodeid | 0 )
    41854194;
    41864195
     
    42044213      then                                     ( len | -1 )
    42054214   then                                        ( len | -1 )
    4206    previous                                    ( len | -1 )
     4215   (pop-package)                               ( len | -1 )
    42074216;
    42084217
     
    42294238      then                                                ( len|-1 )
    42304239   then                                                   ( len|-1 )
    4231    previous                                               ( len|-1 )
     4240   (pop-package)                                          ( len|-1 )
    42324241;
    42334242
     
    42604269      then                              ( len|-1 )
    42614270   then                                 ( len|-1 )
    4262    previous
     4271   (pop-package)
    42634272;
    42644273
     
    43264335: append-my-unit  ( phys.. -- )
    43274336   " @" canon+
    4328    " encode-unit"  parent-device              ( phys.. adr,len ph )
    4329    $vexecute?  if                             ( phys.. )
     4337   " encode-unit"  parent-device              ( phys.. adr,len phandle )
     4338   $package-execute?  if                      ( phys.. )
    43304339      '#adr-cells @  if  (nh.) canon+  then   ( phys.lo .. phys.next )
    43314340      '#adr-cells @ 1-  0 max  0  ?do         ( phys.lo .. phys.next )
     
    44254434: ?delete-address  ( adr len -- adr len )
    44264435   my-self  if                                       ( adr len )
    4427       also  my-voc execute                           ( adr len )
     4436      my-voc (push-package)                          ( adr len )
    44284437      " address" get-property  0=  if                ( adr len value-adr,len )
    44294438         get-encoded-int  2 pick  =  if              ( adr len )
     
    44314440         then                                        ( adr len )
    44324441      then                                           ( adr len )
    4433       previous                                       ( adr len )
     4442      (pop-package)                                  ( adr len )
    44344443   then                                              ( adr len )
    44354444;
Note: See TracChangeset for help on using the changeset viewer.