Changeset 2610


Ignore:
Timestamp:
Oct 16, 2011 12:23:26 AM (20 months 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.