Diff for /gforth/glocals.fs between versions 1.41 and 1.70

version 1.41, 1999/05/03 09:46:20 version 1.70, 2012/12/31 15:25:18
Line 1 Line 1
 \ A powerful locals implementation  \ A powerful locals implementation
   
 \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2007,2011,2012 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ modify it under the terms of the GNU General Public License
 \ as published by the Free Software Foundation; either version 2  \ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 15 Line 15
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program. If not, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  
   
   
 \ More documentation can be found in the manual and in  \ More documentation can be found in the manual and in
Line 80 Line 79
 \ aligned correctly, but our locals stack must be float-aligned between  \ aligned correctly, but our locals stack must be float-aligned between
 \ words.  \ words.
   
 \ Other things about the internals are pretty unclear now.  
   
 \ Currently locals may only be  
 \ defined at the outer level and TO is not supported.  
   
 require search.fs  require search.fs
 require float.fs  require float.fs
   require extend.fs \ for case
   
 : compile-@local ( n -- ) \ gforth compile-fetch-local  : compile-@local ( n -- ) \ gforth compile-fetch-local
  case   case
Line 132  vocabulary locals \ this contains the lo Line 127  vocabulary locals \ this contains the lo
 ' locals >body wordlist-id ' locals-list >body !  ' locals >body wordlist-id ' locals-list >body !
 slowvoc !  slowvoc !
   
 create locals-buffer 1000 allot \ !! limited and unsafe  variable locals-mem-list \ linked list of all locals name memory in
     \ here the names of the local variables are stored  0 locals-mem-list !      \ the current (outer-level) definition
     \ we would have problems storing them at the normal dp  
   
 variable locals-dp \ so here's the special dp for locals.  : free-list ( addr -- )
       \ free all members of a linked list (link field is first)
       begin
           dup while
               dup @ swap free throw
       repeat
       drop ;
   
   : prepend-list ( addr1 addr2 -- )
       \ addr1 is the address of a list element, addr2 is the address of
       \ the cell containing the address of the first list element
       2dup @ swap ! \ store link to next element
       ! ; \ store pointer to new first element
   
 : alignlp-w ( n1 -- n2 )  : alignlp-w ( n1 -- n2 )
     \ cell-align size and generate the corresponding code for aligning lp      \ cell-align size and generate the corresponding code for aligning lp
Line 159  variable locals-dp \ so here's the speci Line 165  variable locals-dp \ so here's the speci
   
 \ locals list operations  \ locals list operations
   
 : common-list ( list1 list2 -- list3 ) \ gforth-internal  : list-length ( list -- u )
 \ list1 and list2 are lists, where the heads are at higher addresses than      0 swap begin ( u1 list1 )
 \ the tail. list3 is the largest sublist of both lists.          dup while
  begin              @ swap 1+ swap
    2dup u<>      repeat
  while      drop ;
    2dup u>  
    if  : /list ( list1 u -- list2 )
      swap      \ list2 is list1 with the first u elements removed
    then      0 ?do
    @          @
  repeat      loop ;
  drop ;  
   : common-list ( list1 list2 -- list3 )
 : sub-list? ( list1 list2 -- f ) \ gforth-internal      \ list3 is the largest common tail of both lists.
 \ true iff list1 is a sublist of list2      over list-length over list-length - dup 0< if
  begin          negate >r swap r>
    2dup u<      then ( long short u )
  while      rot swap /list begin ( list3 list4 )
    @          2dup u<> while
  repeat              @ swap @
  = ;      repeat
       drop ;
   
   : sub-list? ( list1 list2 -- f )
       \ true iff list1 is a sublist of list2
       over list-length over list-length swap - 0 max /list = ;
   
   \ : ocommon-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 ;
   
   \ : osub-list? ( list1 list2 -- f ) \ gforth-internal
   \ \ true iff list1 is a sublist of list2
   \  begin
   \    2dup u<
   \  while
   \    @
   \  repeat
   \  = ;
   
   \ defer common-list
   \ defer sub-list?
   
   \ ' ocommon-list is common-list
   \ ' osub-list?   is sub-list?
   
 : 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
Line 202  variable locals-dp \ so here's the speci Line 242  variable locals-dp \ so here's the speci
 \ 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 @ sub-list? 0= if
    \ !! print current position     \ !! print current position
    ." compiler was overly optimistic about locals at a BEGIN" cr       >stderr ." compiler was overly optimistic about locals at a BEGIN" cr
    \ !! print assumption and reality     \ !! print assumption and reality
  then ;   then ;
   
Line 221  variable locals-dp \ so here's the speci Line 261  variable locals-dp \ so here's the speci
     locals-size @ swap !      locals-size @ swap !
     postpone lp@ postpone c! ;      postpone lp@ postpone c! ;
   
   7 cells 32 + constant locals-name-size \ 32-char name + fields + wiggle room
   
   : create-local1 ( "name" -- a-addr )
       create
       immediate restrict
       here 0 , ( place for the offset ) ;
   
   variable dict-execute-dp \ the special dp for DICT-EXECUTE
   
   0 value dict-execute-ude \ USABLE-DICTIONARY-END during DICT-EXECUTE
   
   : dict-execute1 ( ... addr1 addr2 xt -- ... )
       \ execute xt with HERE set to addr1 and USABLE-DICTIONARY-END set to addr2
       dict-execute-dp @ dp 2>r
       dict-execute-ude ['] usable-dictionary-end defer@ 2>r
       swap to dict-execute-ude
       ['] dict-execute-ude is usable-dictionary-end
       swap to dict-execute-dp
       dict-execute-dp dpp !
       catch
       2r> is usable-dictionary-end to dict-execute-ude
       2r> dpp ! dict-execute-dp !
       throw ;
   
   defer dict-execute ( ... addr1 addr2 xt -- ... )
   
   :noname ( ... addr1 addr2 xt -- ... )
       \ first have a dummy routine, for SOME-CLOCAL etc. below
       nip nip execute ;
   is dict-execute
   
 : create-local ( " name" -- a-addr )  : create-local ( " name" -- a-addr )
     \ defines the local "name"; the offset of the local shall be      \ defines the local "name"; the offset of the local shall be
     \ stored in a-addr      \ stored in a-addr
     create      locals-name-size allocate throw
         immediate restrict      dup locals-mem-list prepend-list
         here 0 , ( place for the offset ) ;      locals-name-size cell /string over + ['] create-local1 dict-execute ;
   
   variable locals-dp \ so here's the special dp for locals.
   
 : lp-offset ( n1 -- n2 )  : lp-offset ( n1 -- n2 )
 \ converts the offset from the frame start to an offset from lp and  \ converts the offset from the frame start to an offset from lp and
Line 292  locals-types definitions Line 365  locals-types definitions
         postpone laddr# @ lp-offset, ;          postpone laddr# @ lp-offset, ;
   
 \ you may want to make comments in a locals definitions group:  \ you may want to make comments in a locals definitions group:
 ' \ alias \ ( -- ) \ core-ext,block-ext backslash  ' \ alias \ ( compilation 'ccc<newline>' -- ; run-time -- ) \ core-ext,block-ext backslash
 \G Line comment: if @code{BLK} contains 0, parse and discard the remainder  \G Comment till the end of the line if @code{BLK} contains 0 (i.e.,
 \G of the parse area. Otherwise, parse and discard all subsequent characters in the  \G while not loading a block), parse and discard the remainder of the
 \G parse area corresponding to the current line.  \G parse area. Otherwise, parse and discard all subsequent characters
 immediate   \G in the parse area corresponding to the current line.
   immediate
   
 ' ( alias ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  ' ( alias ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren
 \G Comment: parse and discard all subsequent characters in the parse  \G Comment, usually till the next @code{)}: parse and discard all
 \G area until ")" is encountered. During interactive input, an end-of-line  \G subsequent characters in the parse area until ")" is
 \G also acts as a comment terminator. For file input, it does not; if the  \G encountered. During interactive input, an end-of-line also acts as
 \G end-of-file is encountered whilst parsing for the ")" delimiter, Gforth  \G a comment terminator. For file input, it does not; if the
 \G will generate a warning.  \G end-of-file is encountered whilst parsing for the ")" delimiter,
   \G Gforth will generate a warning.
 immediate  immediate
   
 forth definitions  forth definitions
   also locals-types
       
   \ these "locals" are used for comparison in TO
   c: some-clocal 2drop
   d: some-dlocal 2drop
   f: some-flocal 2drop
   w: some-wlocal 2drop
   
   ' dict-execute1 is dict-execute \ now the real thing
       
 \ the following gymnastics are for declaring locals without type specifier.  \ the following gymnastics are for declaring locals without type specifier.
 \ we exploit a feature of our dictionary: every wordlist  \ we exploit a feature of our dictionary: every wordlist
 \ has it's own methods for finding words etc.  \ has it's own methods for finding words etc.
 \ So we create a vocabulary new-locals, that creates a 'w:' local named x  \ So we create a vocabulary new-locals, that creates a 'w:' local named x
 \ when it is asked if it contains x.  \ when it is asked if it contains x.
   
 also locals-types  
   
 : new-locals-find ( caddr u w -- nfa )  : new-locals-find ( caddr u w -- nfa )
 \ this is the find method of the new-locals vocabulary  \ this is the find method of the new-locals vocabulary
 \ make a new local with name caddr u; w is ignored  \ make a new local with name caddr u; w is ignored
 \ the returned nfa denotes a word that produces what W: produces  \ the returned nfa denotes a word that produces what W: produces
 \ !! do the whole thing without nextname  \ !! do the whole thing without nextname
     drop nextname      drop nextname
     ['] W: >name ;      ['] W: >head-noprim ;
   
 previous  previous
   
Line 343  new-locals-map mappedwordlist Constant n Line 425  new-locals-map mappedwordlist Constant n
 \ slowvoc !  \ slowvoc !
 \ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words  \ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words
   
 variable old-dpp  
   
 \ and now, finally, the user interface words  \ and now, finally, the user interface words
 : { ( -- lastxt wid 0 ) \ gforth open-brace  : { ( -- latestxt wid 0 ) \ gforth open-brace
     dp old-dpp !      latestxt get-current
     locals-dp dpp !  
     lastxt get-current  
     get-order new-locals-wl swap 1+ set-order      get-order new-locals-wl swap 1+ set-order
     also locals definitions locals-types      also locals definitions locals-types
     0 TO locals-wordlist      0 TO locals-wordlist
Line 357  variable old-dpp Line 435  variable old-dpp
   
 locals-types definitions  locals-types definitions
   
 : } ( lastxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace  : } ( latestxt wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
     \ ends locals definitions      \ ends locals definitions
     ] old-dpp @ dpp !      ]
     begin      begin
         dup          dup
     while      while
Line 486  forth definitions Line 564  forth definitions
 : locals-:-hook ( sys -- sys addr xt n )  : locals-:-hook ( sys -- sys addr xt n )
     \ addr is the nfa of the defined word, xt its xt      \ addr is the nfa of the defined word, xt its xt
     DEFERS :-hook      DEFERS :-hook
     last @ lastcfa @      latest latestxt
     clear-leave-stack      clear-leave-stack
     0 locals-size !      0 locals-size !
     locals-buffer locals-dp !  
     0 locals-list !      0 locals-list !
     dead-code off      dead-code off
     defstart ;      defstart ;
   
   [IFDEF] free-old-local-names
   :noname ( -- )
       locals-mem-list @ free-list
       0 locals-mem-list ! ;
   is free-old-local-names
   [THEN]
   
 : locals-;-hook ( sys addr xt sys -- sys )  : locals-;-hook ( sys addr xt sys -- sys )
     def?      def?
     0 TO locals-wordlist      0 TO locals-wordlist
Line 573  forth definitions Line 657  forth definitions
 ' locals-:-hook IS :-hook  ' locals-:-hook IS :-hook
 ' locals-;-hook IS ;-hook  ' locals-;-hook IS ;-hook
   
   
 ' (then-like)  IS then-like  ' (then-like)  IS then-like
 ' (begin-like) IS begin-like  ' (begin-like) IS begin-like
 ' (again-like) IS again-like  ' (again-like) IS again-like
Line 629  forth definitions Line 714  forth definitions
         2drop          2drop
     endif ;      endif ;
   
 : >definer ( xt -- definer )  : >definer ( xt -- definer ) \ gforth
     \ this gives a unique identifier for the way the xt was defined      \G @var{Definer} is a unique identifier for the way the @var{xt}
     \ words defined with different does>-codes have different definers      \G was defined.  Words defined with different @code{does>}-codes
     \ the definer can be used for comparison and in definer!      \G have different definers.  The definer can be used for
       \G comparison and in @code{definer!}.
     dup >does-code      dup >does-code
     ?dup-if      ?dup-if
         nip 1 or          nip 1 or
Line 640  forth definitions Line 726  forth definitions
         >code-address          >code-address
     then ;      then ;
   
 : definer! ( definer xt -- )  : definer! ( definer xt -- ) \ gforth
     \ gives the word represented by xt the behaviour associated with definer      \G The word represented by @var{xt} changes its behaviour to the
       \G behaviour associated with @var{definer}.
     over 1 and if      over 1 and if
         swap [ 1 invert ] literal and does-code!          swap [ 1 invert ] literal and does-code!
     else      else
         code-address!          code-address!
     then ;      then ;
   
 :noname  : (int-to) ( xt -- ) dup >definer
     ' dup >definer [ ' locals-wordlist ] literal >definer =      case
     if          [ ' locals-wordlist ] literal >definer \ value
         >body !          of  >body ! endof
     else          [ ' parse-name ] literal >definer \ defer
           of  defer! endof
         -&32 throw          -&32 throw
     endif ;      endcase ;
 :noname  
     0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }  : (comp-to) ( xt -- ) dup >definer
     comp' drop dup >definer  
     case      case
         [ ' locals-wordlist ] literal >definer \ value          [ ' locals-wordlist ] literal >definer \ value
         OF >body POSTPONE Aliteral POSTPONE ! ENDOF          OF >body POSTPONE Aliteral POSTPONE ! ENDOF
           [ ' parse-name ] literal >definer \ defer
           OF POSTPONE Aliteral POSTPONE defer! ENDOF
         \ !! dependent on c: etc. being does>-defining words          \ !! dependent on c: etc. being does>-defining words
         \ this works, because >definer uses >does-code in this case,          \ this works, because >definer uses >does-code in this case,
         \ which produces a relocatable address          \ which produces a relocatable address
         [ comp' clocal drop >definer ] literal          [ comp' some-clocal drop ] literal >definer
         OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF          OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
         [ comp' wlocal drop >definer ] literal          [ comp' some-wlocal drop ] literal >definer
         OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF          OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
         [ comp' dlocal drop >definer ] literal          [ comp' some-dlocal drop ] literal >definer
         OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF          OF POSTPONE laddr# >body @ lp-offset, POSTPONE 2! ENDOF
         [ comp' flocal drop >definer ] literal          [ comp' some-flocal drop ] literal >definer
         OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF          OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
         -&32 throw          -&32 throw
     endcase ;      endcase ;
   
   :noname
       ' (int-to) ;
   :noname
       comp' drop (comp-to) ;
 interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local  interpret/compile: TO ( c|w|d|r "name" -- ) \ core-ext,local
   
 : locals|  : locals| ( ... "name ..." -- ) \ local-ext locals-bar
     \ don't use 'locals|'! use '{'! A portable and free '{'      \ don't use 'locals|'! use '{'! A portable and free '{'
     \ implementation is compat/anslocals.fs      \ implementation is compat/anslocals.fs
     BEGIN      BEGIN
         name 2dup s" |" compare 0<>          name 2dup s" |" str= 0=
     WHILE      WHILE
         (local)          (local)
     REPEAT      REPEAT

Removed from v.1.41  
changed lines
  Added in v.1.70


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