Diff for /gforth/glocals.fs between versions 1.27 and 1.36

version 1.27, 1996/09/24 19:15:02 version 1.36, 1998/10/10 10:28:34
Line 85 Line 85
 \ Currently locals may only be  \ Currently locals may only be
 \ defined at the outer level and TO is not supported.  \ defined at the outer level and TO is not supported.
   
 require search-order.fs  require search.fs
 require float.fs  require float.fs
   
 : compile-@local ( n -- ) \ gforth compile-fetch-local  : compile-@local ( n -- ) \ gforth compile-fetch-local
Line 183  variable locals-dp \ so here's the speci Line 183  variable locals-dp \ so here's the speci
  = ;   = ;
   
 : list-size ( list -- u ) \ gforth-internal  : list-size ( list -- u ) \ gforth-internal
 \ size of the locals frame represented by list      \ size of the locals frame represented by list
  0 ( list n )      0 ( list n )
  begin      begin
    over 0<>          over 0<>
  while      while
    over          over
    ((name>)) >body @ max          ((name>)) >body @ max
    swap @ swap ( get next )          swap @ swap ( get next )
  repeat      repeat
  faligned nip ;      faligned nip ;
   
 : set-locals-size-list ( list -- )  : set-locals-size-list ( list -- )
  dup locals-list !      dup locals-list wordlist-id !
  list-size locals-size ! ;      list-size locals-size ! ;
   
 : check-begin ( list -- )  : check-begin ( list -- )
 \ warn if list is not a sublist of locals-list  \ warn if list is not a sublist of locals-list
  locals-list @ sub-list? 0= if   locals-list wordlist-id @ sub-list? 0= if
    \ !! print current position     \ !! print current position
    ." compiler was overly optimistic about locals at a BEGIN" cr     ." compiler was overly optimistic about locals at a BEGIN" cr
    \ !! print assumption and reality     \ !! print assumption and reality
Line 319  previous Line 319  previous
   true abort" this should not happen: new-locals-reveal" ;    true abort" this should not happen: new-locals-reveal" ;
   
 create new-locals-map ( -- wordlist-map )  create new-locals-map ( -- wordlist-map )
 ' new-locals-find A, ' new-locals-reveal A,  ' new-locals-find A,
   ' new-locals-reveal A,
   ' drop A, \ rehash method
   ' drop A,
   
 slowvoc @  slowvoc @
 slowvoc on  slowvoc on
 vocabulary new-locals  vocabulary new-locals
 slowvoc !  slowvoc !
 new-locals-map ' new-locals >body cell+ A! \ !! use special access words  new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words
   
 variable old-dpp  variable old-dpp
   
 \ and now, finally, the user interface words  \ and now, finally, the user interface words
 : { ( -- addr wid 0 ) \ gforth open-brace  : { ( -- lastxt wid 0 ) \ gforth open-brace
     dp old-dpp !      dp old-dpp !
     locals-dp dpp !      locals-dp dpp !
       lastxt get-current
     also new-locals      also new-locals
     also get-current locals definitions  locals-types      also locals definitions locals-types
     0 TO locals-wordlist      0 TO locals-wordlist
     0 postpone [ ; immediate      0 postpone [ ; immediate
   
 locals-types definitions  locals-types definitions
   
 : } ( addr wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace  : } ( lastxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
     \ ends locals definitions      \ ends locals definitions
     ] old-dpp @ dpp !      ] old-dpp @ dpp !
     begin      begin
Line 350  locals-types definitions Line 354  locals-types definitions
     repeat      repeat
     drop      drop
     locals-size @ alignlp-f locals-size ! \ the strictest alignment      locals-size @ alignlp-f locals-size ! \ the strictest alignment
     set-current  
     previous previous      previous previous
       set-current lastcfa !
     locals-list TO locals-wordlist ;      locals-list TO locals-wordlist ;
   
 : -- ( addr wid 0 ... -- ) \ gforth dash-dash  : -- ( addr wid 0 ... -- ) \ gforth dash-dash
Line 448  forth definitions Line 452  forth definitions
   
 \ If this assumption is too optimistic, the compiler will warn the user.  \ If this assumption is too optimistic, the compiler will warn the user.
   
 \ Implementation: migrated to kernel.fs  \ Implementation:
   
 \ THEN (another control flow from before joins the current one):  
 \ The new locals-list is the intersection of the current locals-list and  
 \ the orig-local-list. The new locals-size is the (alignment-adjusted)  
 \ size of the new locals-list. The following code is generated:  
 \ lp+!# (current-locals-size - orig-locals-size)  
 \ <then>:  
 \ lp+!# (orig-locals-size - new-locals-size)  
   
 \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit  
 \ inefficient, e.g. if there is a locals declaration between IF and  
 \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the  
 \ branch, there will be none after the target <then>.  
   
 \ explicit scoping  \ explicit scoping
   
 : scope ( compilation  -- scope ; run-time  -- ) \ gforth  : scope ( compilation  -- scope ; run-time  -- ) \ gforth
  cs-push-part scopestart ; immediate      cs-push-part scopestart ; immediate
   
   : adjust-locals-list ( wid -- )
       locals-list wordlist-id @ common-list
       dup list-size adjust-locals-size
       locals-list wordlist-id ! ;
   
 : endscope ( compilation scope -- ; run-time  -- ) \ gforth  : endscope ( compilation scope -- ; run-time  -- ) \ gforth
  scope?      scope?
  drop      drop  adjust-locals-list ; immediate
  locals-list @ common-list  
  dup list-size adjust-locals-size  
  locals-list ! ; immediate  
   
 \ adapt the hooks  \ adapt the hooks
   
Line 484  forth definitions Line 477  forth definitions
     clear-leave-stack      clear-leave-stack
     0 locals-size !      0 locals-size !
     locals-buffer locals-dp !      locals-buffer locals-dp !
     0 locals-list !      0 locals-list wordlist-id !
     dead-code off      dead-code off
     defstart ;      defstart ;
   
Line 495  forth definitions Line 488  forth definitions
     lastcfa ! last !      lastcfa ! last !
     DEFERS ;-hook ;      DEFERS ;-hook ;
   
 : (then-like) ( orig -- addr )  \ THEN (another control flow from before joins the current one):
     swap -rot dead-orig =  \ The new locals-list is the intersection of the current locals-list and
   \ the orig-local-list. The new locals-size is the (alignment-adjusted)
   \ size of the new locals-list. The following code is generated:
   \ lp+!# (current-locals-size - orig-locals-size)
   \ <then>:
   \ lp+!# (orig-locals-size - new-locals-size)
   
   \ Of course "lp+!# 0" is not generated. Still this is admittedly a bit
   \ inefficient, e.g. if there is a locals declaration between IF and
   \ ELSE. However, if ELSE generates an appropriate "lp+!#" before the
   \ branch, there will be none after the target <then>.
   
   : (then-like) ( orig -- )
       dead-orig =
     if      if
         drop          >resolve drop
     else      else
         dead-code @          dead-code @
         if          if
             set-locals-size-list dead-code off              >resolve set-locals-size-list dead-code off
         else \ both live          else \ both live
             dup list-size adjust-locals-size              over list-size adjust-locals-size
             locals-list @ common-list dup list-size adjust-locals-size              >resolve
             locals-list !              adjust-locals-list
         then          then
     then ;      then ;
   
Line 570  forth definitions Line 576  forth definitions
 \ things above are not control flow joins. Everything should be taken  \ things above are not control flow joins. Everything should be taken
 \ over from the live flow. No lp+!# is generated.  \ over from the live flow. No lp+!# is generated.
   
 \ !! The lp gymnastics for UNTIL are also a real problem: locals cannot be  
 \ used in signal handlers (or anything else that may be called while  
 \ locals live beyond the lp) without changing the locals stack.  
   
 \ About warning against uses of dead locals. There are several options:  \ About warning against uses of dead locals. There are several options:
   
 \ 1) Do not complain (After all, this is Forth;-)  \ 1) Do not complain (After all, this is Forth;-)
Line 618  forth definitions Line 620  forth definitions
     \ this gives a unique identifier for the way the xt was defined      \ this gives a unique identifier for the way the xt was defined
     \ words defined with different does>-codes have different definers      \ words defined with different does>-codes have different definers
     \ the definer can be used for comparison and in definer!      \ the definer can be used for comparison and in definer!
     dup >code-address [ ' spaces >code-address ] Literal =      dup >does-code
     \ !! this definition will not work on some implementations for `bits'      ?dup-if
     if  \ if >code-address delivers the same value for all does>-def'd words          nip 1 or
         >does-code 1 or \ bit 0 marks special treatment for does codes  
     else      else
         >code-address          >code-address
     then ;      then ;
Line 635  forth definitions Line 636  forth definitions
     then ;      then ;
   
 :noname  :noname
     ' dup >definer [ ' locals-wordlist >definer ] literal =      ' dup >definer [ ' locals-wordlist ] literal >definer =
     if      if
         >body !          >body !
     else      else
Line 643  forth definitions Line 644  forth definitions
     endif ;      endif ;
 :noname  :noname
     0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }      0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
     ' dup >definer      comp' drop dup >definer
     case      case
         [ ' locals-wordlist >definer ] literal \ value          [ ' locals-wordlist ] literal >definer \ value
         OF >body POSTPONE Aliteral POSTPONE ! ENDOF          OF >body POSTPONE Aliteral POSTPONE ! ENDOF
           \ !! dependent on c: etc. being does>-defining words
           \ this works, because >definer uses >does-code in this case,
           \ which produces a relocatable address
         [ comp' clocal drop >definer ] literal          [ comp' clocal drop >definer ] literal
         OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF          OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
         [ comp' wlocal drop >definer ] literal          [ comp' wlocal drop >definer ] literal

Removed from v.1.27  
changed lines
  Added in v.1.36


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>