[gforth] / gforth / glocals.fs  

gforth: gforth/glocals.fs

Diff for /gforth/glocals.fs between version 1.19 and 1.29

version 1.19, Fri Feb 9 17:34:10 1996 UTC version 1.29, Wed Jan 1 16:26:02 1997 UTC
Line 104 
Line 104 
    ( otherwise ) dup postpone f@local# ,     ( otherwise ) dup postpone f@local# ,
  endcase ;   endcase ;
   
   \ locals stuff needed for control structures
   
   : compile-lp+! ( n -- ) \ gforth        compile-l-p-plus-store
       dup negate locals-size +!
       0 over = if
       else -1 cells  over = if postpone lp-
       else  1 floats over = if postpone lp+
       else  2 floats over = if postpone lp+2
       else postpone lp+!# dup ,
       then then then then drop ;
   
   : adjust-locals-size ( n -- ) \ gforth
       \ sets locals-size to n and generates an appropriate lp+!
       locals-size @ swap - compile-lp+! ;
   
 \ the locals stack grows downwards (see primitives)  \ the locals stack grows downwards (see primitives)
 \ of the local variables of a group (in braces) the leftmost is on top,  \ of the local variables of a group (in braces) the leftmost is on top,
 \ i.e. by going onto the locals stack the order is reversed.  \ i.e. by going onto the locals stack the order is reversed.
Line 142 
Line 157 
     swap !      swap !
     postpone >l ;      postpone >l ;
   
   \ locals list operations
   
   : common-list ( list1 list2 -- list3 ) \ gforth-internal
   \ list1 and list2 are lists, where the heads are at higher addresses than
   \ the tail. list3 is the largest sublist of both lists.
    begin
      2dup u<>
    while
      2dup u>
      if
        swap
      then
      @
    repeat
    drop ;
   
   : sub-list? ( list1 list2 -- f ) \ gforth-internal
   \ true iff list1 is a sublist of list2
    begin
      2dup u<
    while
      @
    repeat
    = ;
   
   : list-size ( list -- u ) \ gforth-internal
   \ size of the locals frame represented by list
    0 ( list n )
    begin
      over 0<>
    while
      over
      ((name>)) >body @ max
      swap @ swap ( get next )
    repeat
    faligned nip ;
   
   : set-locals-size-list ( list -- )
    dup locals-list !
    list-size locals-size ! ;
   
   : check-begin ( list -- )
   \ warn if list is not a sublist of locals-list
    locals-list @ sub-list? 0= if
      \ !! print current position
      ." compiler was overly optimistic about locals at a BEGIN" cr
      \ !! print assumption and reality
    then ;
   
 : compile-pushlocal-f ( a-addr -- ) ( run-time: f -- )  : compile-pushlocal-f ( a-addr -- ) ( run-time: f -- )
     locals-size @ alignlp-f float+ dup locals-size !      locals-size @ alignlp-f float+ dup locals-size !
     swap !      swap !
Line 254 
Line 318 
 : new-locals-reveal ( -- )  : new-locals-reveal ( -- )
   true abort" this should not happen: new-locals-reveal" ;    true abort" this should not happen: new-locals-reveal" ;
   
 create new-locals-map ' new-locals-find A, ' new-locals-reveal A,  create new-locals-map ( -- wordlist-map )
   ' new-locals-find A,
   ' new-locals-reveal A,
   ' drop A, \ rehash method
   
   slowvoc @
   slowvoc on
 vocabulary new-locals  vocabulary new-locals
   slowvoc !
 new-locals-map ' new-locals >body cell+ A! \ !! use special access words  new-locals-map ' new-locals >body cell+ A! \ !! use special access words
   
 variable old-dpp  variable old-dpp
Line 380 
Line 450 
   
 \ 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 kernal.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
   
Line 427 
Line 484 
     lastcfa ! last !      lastcfa ! last !
     DEFERS ;-hook ;      DEFERS ;-hook ;
   
   \ 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>.
   
   : (then-like) ( orig -- addr )
       swap -rot dead-orig =
       if
           drop
       else
           dead-code @
           if
               set-locals-size-list dead-code off
           else \ both live
               dup list-size adjust-locals-size
               locals-list @ common-list dup list-size adjust-locals-size
               locals-list !
           then
       then ;
   
   : (begin-like) ( -- )
       dead-code @ if
           \ set up an assumption of the locals visible here.  if the
           \ users want something to be visible, they have to declare
           \ that using ASSUME-LIVE
           backedge-locals @ set-locals-size-list
       then
       dead-code off ;
   
   \ AGAIN (the current control flow joins another, earlier one):
   \ If the dest-locals-list is not a subset of the current locals-list,
   \ issue a warning (see below). The following code is generated:
   \ lp+!# (current-local-size - dest-locals-size)
   \ branch <begin>
   
   : (again-like) ( dest -- addr )
       over list-size adjust-locals-size
       swap check-begin  POSTPONE unreachable ;
   
   \ UNTIL (the current control flow may join an earlier one or continue):
   \ Similar to AGAIN. The new locals-list and locals-size are the current
   \ ones. The following code is generated:
   \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
   
   : (until-like) ( list addr xt1 xt2 -- )
       \ list and addr are a fragment of a cs-item
       \ xt1 is the conditional branch without lp adjustment, xt2 is with
       >r >r
       locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
           r> drop r> compile,
           swap <resolve ( list adjustment ) ,
       else ( list dest-addr adjustment )
           drop
           r> compile, <resolve
           r> drop
       then ( list )
       check-begin ;
   
   : (exit-like) ( -- )
       0 adjust-locals-size ;
   
 ' locals-:-hook IS :-hook  ' locals-:-hook IS :-hook
 ' locals-;-hook IS ;-hook  ' locals-;-hook IS ;-hook
   
   ' (then-like)  IS then-like
   ' (begin-like) IS begin-like
   ' (again-like) IS again-like
   ' (until-like) IS until-like
   ' (exit-like)  IS exit-like
   
 \ The words in the locals dictionary space are not deleted until the end  \ The words in the locals dictionary space are not deleted until the end
 \ of the current word. This is a bit too conservative, but very simple.  \ of the current word. This is a bit too conservative, but very simple.
   
Line 440 
Line 572 
 \ 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 504 
Line 632 
         code-address!          code-address!
     then ;      then ;
   
 : TO ( c|w|d|r "name" -- ) \ core-ext,local  :noname
 \ !! state smart      ' dup >definer [ ' locals-wordlist >definer ] literal =
  0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }  
  ' dup >definer  
  state @  
  if   if
           >body !
       else
           -&32 throw
       endif ;
   :noname
       0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
       comp' drop dup >definer
    case     case
      [ ' locals-wordlist >definer ] literal \ value       [ ' locals-wordlist >definer ] literal \ value
      OF >body POSTPONE Aliteral POSTPONE ! ENDOF       OF >body POSTPONE Aliteral POSTPONE ! ENDOF
      [ ' clocal >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
      [ ' wlocal >definer ] literal          [ comp' wlocal drop >definer ] literal
      OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF       OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
      [ ' dlocal >definer ] literal          [ comp' dlocal drop >definer ] literal
      OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF       OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
      [ ' flocal >definer ] literal          [ comp' flocal drop >definer ] literal
      OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF       OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
      -&32 throw       -&32 throw
    endcase      endcase ;
  else  interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local
    [ ' locals-wordlist >definer ] literal =  
    if  
      >body !  
    else  
      -&32 throw  
    endif  
  endif ; immediate  
   
 : locals|  : locals|
     \ don't use 'locals|'! use '{'! A portable and free '{'      \ don't use 'locals|'! use '{'! A portable and free '{'
     \ implementation is anslocals.fs      \ implementation is compat/anslocals.fs
     BEGIN      BEGIN
         name 2dup s" |" compare 0<>          name 2dup s" |" compare 0<>
     WHILE      WHILE

Generate output suitable for use with a patch program
Legend:
Removed from v.1.19  
changed lines
  Added in v.1.29
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help