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

version 1.20, 1996/05/03 13:05:05 version 1.27, 1996/09/24 19:15:02
Line 104  require float.fs Line 104  require float.fs
    ( 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  variable locals-dp \ so here's the speci Line 157  variable locals-dp \ so here's the speci
     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  previous Line 318  previous
 : 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,
   
   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  forth definitions Line 448  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 kernal.fs  \ Implementation: migrated to kernel.fs
   
 \ THEN (another control flow from before joins the current one):  \ THEN (another control flow from before joins the current one):
 \ The new locals-list is the intersection of the current locals-list and  \ The new locals-list is the intersection of the current locals-list and
Line 427  forth definitions Line 495  forth definitions
     lastcfa ! last !      lastcfa ! last !
     DEFERS ;-hook ;      DEFERS ;-hook ;
   
   : (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 504  forth definitions Line 634  forth definitions
         code-address!          code-address!
     then ;      then ;
   
 : TO ( c|w|d|r "name" -- ) \ core-ext,local  :noname
  0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }      ' dup >definer [ ' locals-wordlist >definer ] literal =
  ' dup >definer      if
  state @           >body !
  if      else
    case          -&32 throw
      [ ' locals-wordlist >definer ] literal \ value      endif ;
      OF >body POSTPONE Aliteral POSTPONE ! ENDOF  :noname
      [ ' clocal >definer ] literal      0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
      OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF      ' dup >definer
      [ ' wlocal >definer ] literal      case
      OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF          [ ' locals-wordlist >definer ] literal \ value
      [ ' dlocal >definer ] literal          OF >body POSTPONE Aliteral POSTPONE ! ENDOF
      OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF          [ comp' clocal drop >definer ] literal
      [ ' flocal >definer ] literal          OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
      OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF          [ comp' wlocal drop >definer ] literal
      -&32 throw          OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
    endcase          [ comp' dlocal drop >definer ] literal
  else          OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
    [ ' locals-wordlist >definer ] literal =          [ comp' flocal drop >definer ] literal
    if          OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
      >body !          -&32 throw
    else      endcase ;
      -&32 throw  interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local
    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

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


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