Diff for /gforth/glocals.fs between versions 1.39 and 1.62

version 1.39, 1999/02/03 00:10:21 version 1.62, 2011/12/27 16:38:08
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 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 87 Line 86
   
 require search.fs  require search.fs
 require float.fs  require float.fs
   require extend.fs \ for case
   
   : save-mem-dict ( addr1 u -- addr2 u )
       here swap dup allot ( addr1 addr2 u )
       2dup 2>r move 2r> ;
   
 : 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 136  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 221  variable locals-dp \ so here's the speci Line 236  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 340  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 335  create new-locals-map ( -- wordlist-map Line 392  create new-locals-map ( -- wordlist-map
 ' drop A, \ rehash method  ' drop A, \ rehash method
 ' drop A,  ' drop A,
   
 slowvoc @  new-locals-map mappedwordlist Constant new-locals-wl
 slowvoc on  
 vocabulary new-locals  
 slowvoc !  
 new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words  
   
 variable old-dpp  \ slowvoc @
   \ slowvoc on
   \ vocabulary new-locals
   \ slowvoc !
   \ new-locals-map ' new-locals >body wordlist-map A! \ !! use special access words
   
 \ 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 !      get-order new-locals-wl swap 1+ set-order
     lastxt get-current  
     also new-locals  
     also 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
   
 : } ( 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 484  forth definitions Line 539  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 !      locals-mem-list @ free-list
       0 locals-mem-list !
     0 locals-list !      0 locals-list !
     dead-code off      dead-code off
     defstart ;      defstart ;
Line 627  forth definitions Line 683  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 638  forth definitions Line 695  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
Line 654  forth definitions Line 712  forth definitions
         -&32 throw          -&32 throw
     endif ;      endif ;
 :noname  :noname
     0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }  
     comp' drop dup >definer      comp' drop dup >definer
     case      case
         [ ' locals-wordlist ] literal >definer \ value          [ ' locals-wordlist ] literal >definer \ value
Line 662  forth definitions Line 719  forth definitions
         \ !! 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 ;
 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.39  
changed lines
  Added in v.1.62


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