--- gforth/glocals.fs	1994/06/17 12:35:03	1.3
+++ gforth/glocals.fs	1995/12/23 16:21:58	1.17
@@ -1,3 +1,27 @@
+\ A powerful locals implementation
+
+\ Copyright (C) 1995 Free Software Foundation, Inc.
+
+\ This file is part of Gforth.
+
+\ Gforth is free software; you can redistribute it and/or
+\ modify it under the terms of the GNU General Public License
+\ as published by the Free Software Foundation; either version 2
+\ of the License, or (at your option) any later version.
+
+\ This program is distributed in the hope that it will be useful,
+\ but WITHOUT ANY WARRANTY; without even the implied warranty of
+\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+\ GNU General Public License for more details.
+
+\ You should have received a copy of the GNU General Public License
+\ along with this program; if not, write to the Free Software
+\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+\ More documentation can be found in the manual and in
+\ http://www.complang.tuwien.ac.at/papers/ertl94l.ps.gz
+
 \ Local variables are quite important for writing readable programs, but
 \ IMO (anton) they are the worst part of the standard. There they are very
 \ restricted and have an ugly interface.
@@ -61,22 +85,22 @@
 \ Currently locals may only be
 \ defined at the outer level and TO is not supported.
 
-include float.fs
-include search-order.fs
+require search-order.fs
+require float.fs
 
-: compile-@local ( n -- )
+: compile-@local ( n -- ) \ gforth compile-fetch-local
  case
-    0 of postpone @local0 endof
-    4 of postpone @local4 endof
-    8 of postpone @local8 endof
-   12 of postpone @local12 endof
+    0       of postpone @local0 endof
+    1 cells of postpone @local1 endof
+    2 cells of postpone @local2 endof
+    3 cells of postpone @local3 endof
    ( otherwise ) dup postpone @local# ,
  endcase ;
 
-: compile-f@local ( n -- )
+: compile-f@local ( n -- ) \ gforth compile-f-fetch-local
  case
-    0 of postpone f@local0 endof
-    8 of postpone f@local8 endof
+    0        of postpone f@local0 endof
+    1 floats of postpone f@local1 endof
    ( otherwise ) dup postpone f@local# ,
  endcase ;
 
@@ -87,8 +111,11 @@ include search-order.fs
 \ lp must have the strictest alignment (usually float) across calls;
 \ for simplicity we align it strictly for every group.
 
+slowvoc @
+slowvoc on \ we want a linked list for the vocabulary locals
 vocabulary locals \ this contains the local variables
 ' locals >body ' locals-list >body !
+slowvoc !
 
 create locals-buffer 1000 allot \ !! limited and unsafe
     \ here the names of the local variables are stored
@@ -131,9 +158,10 @@ variable locals-dp \ so here's the speci
     postpone lp@ postpone c! ;
 
 : create-local ( " name" -- a-addr )
-	\ defines the local "name"; the offset of the local shall be stored in a-addr
+    \ defines the local "name"; the offset of the local shall be
+    \ stored in a-addr
     create
-	immediate
+	immediate restrict
 	here 0 , ( place for the offset ) ;
 
 : lp-offset ( n1 -- n2 )
@@ -149,52 +177,52 @@ variable locals-dp \ so here's the speci
 vocabulary locals-types \ this contains all the type specifyers, -- and }
 locals-types definitions
 
-: W:
-    create-local ( "name" -- a-addr xt )
+: W: ( "name" -- a-addr xt ) \ gforth w-colon
+    create-local
 	\ xt produces the appropriate locals pushing code when executed
 	['] compile-pushlocal-w
     does> ( Compilation: -- ) ( Run-time: -- w )
         \ compiles a local variable access
 	@ lp-offset compile-@local ;
 
-: W^
-    create-local ( "name" -- a-addr xt )
+: W^ ( "name" -- a-addr xt ) \ gforth w-caret
+    create-local
 	['] compile-pushlocal-w
     does> ( Compilation: -- ) ( Run-time: -- w )
 	postpone laddr# @ lp-offset, ;
 
-: F:
-    create-local ( "name" -- a-addr xt )
+: F: ( "name" -- a-addr xt ) \ gforth f-colon
+    create-local
 	['] compile-pushlocal-f
     does> ( Compilation: -- ) ( Run-time: -- w )
 	@ lp-offset compile-f@local ;
 
-: F^
-    create-local ( "name" -- a-addr xt )
+: F^ ( "name" -- a-addr xt ) \ gforth f-caret
+    create-local
 	['] compile-pushlocal-f
     does> ( Compilation: -- ) ( Run-time: -- w )
 	postpone laddr# @ lp-offset, ;
 
-: D:
-    create-local ( "name" -- a-addr xt )
+: D: ( "name" -- a-addr xt ) \ gforth d-colon
+    create-local
 	['] compile-pushlocal-d
     does> ( Compilation: -- ) ( Run-time: -- w )
 	postpone laddr# @ lp-offset, postpone 2@ ;
 
-: D^
-    create-local ( "name" -- a-addr xt )
+: D^ ( "name" -- a-addr xt ) \ gforth d-caret
+    create-local
 	['] compile-pushlocal-d
     does> ( Compilation: -- ) ( Run-time: -- w )
 	postpone laddr# @ lp-offset, ;
 
-: C:
-    create-local ( "name" -- a-addr xt )
+: C: ( "name" -- a-addr xt ) \ gforth c-colon
+    create-local
 	['] compile-pushlocal-c
     does> ( Compilation: -- ) ( Run-time: -- w )
 	postpone laddr# @ lp-offset, postpone c@ ;
 
-: C^
-    create-local ( "name" -- a-addr xt )
+: C^ ( "name" -- a-addr xt ) \ gforth c-caret
+    create-local
 	['] compile-pushlocal-c
     does> ( Compilation: -- ) ( Run-time: -- w )
 	postpone laddr# @ lp-offset, ;
@@ -234,7 +262,7 @@ new-locals-map ' new-locals >body cell+
 variable old-dpp
 
 \ and now, finally, the user interface words
-: { ( -- addr wid 0 )
+: { ( -- addr wid 0 ) \ gforth open-brace
     dp old-dpp !
     locals-dp dpp !
     also new-locals
@@ -244,7 +272,7 @@ variable old-dpp
 
 locals-types definitions
 
-: } ( addr wid 0 a-addr1 xt1 ... -- )
+: } ( addr wid 0 a-addr1 xt1 ... -- ) \ gforth close-brace
     \ ends locals definitions
     ] old-dpp @ dpp !
     begin
@@ -258,9 +286,9 @@ locals-types definitions
     previous previous
     locals-list TO locals-wordlist ;
 
-: -- ( addr wid 0 ... -- )
+: -- ( addr wid 0 ... -- ) \ gforth dash-dash
     }
-    [char] } word drop ;
+    [char] } parse 2drop ;
 
 forth definitions
 
@@ -369,10 +397,10 @@ forth definitions
 
 \ explicit scoping
 
-: scope ( -- scope )
+: scope ( compilation  -- scope ; run-time  -- ) \ gforth
  cs-push-part scopestart ; immediate
 
-: endscope ( scope -- )
+: endscope ( compilation scope -- ; run-time  -- ) \ gforth
  scope?
  drop
  locals-list @ common-list
@@ -445,9 +473,10 @@ forth definitions
 
 \ And here's finally the ANS standard stuff
 
-: (local) ( addr u -- )
+: (local) ( addr u -- ) \ local paren-local-paren
     \ a little space-inefficient, but well deserved ;-)
     \ In exchange, there are no restrictions whatsoever on using (local)
+    \ as long as you use it in a definition
     dup
     if
 	nextname POSTPONE { [ also locals-types ] W: } [ previous ]
@@ -455,34 +484,60 @@ forth definitions
 	2drop
     endif ;
 
-\ \ !! untested
-\ : TO ( c|w|d|r "name" -- )
-\ \ !! state smart
-\  0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
-\  ' dup >definer
-\  state @ 
-\  if
-\    case
-\      [ ' locals-wordlist >definer ] literal \ value
-\      OF >body POSTPONE Aliteral POSTPONE ! ENDOF
-\      [ ' clocal >definer ] literal
-\      OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
-\      [ ' wlocal >definer ] literal
-\      OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
-\      [ ' dlocal >definer ] literal
-\      OF POSTPONE laddr# >body @ lp-offset, POSTPONE d! ENDOF
-\      [ ' flocal >definer ] literal
-\      OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
-\      abort" can only store TO value or local value"
-\    endcase
-\  else
-\    [ ' locals-wordlist >definer ] literal =
-\    if
-\      >body !
-\    else
-\      abort" can only store TO value"
-\    endif
-\  endif ;   
+: >definer ( xt -- definer )
+    \ this gives a unique identifier for the way the xt was defined
+    \ words defined with different does>-codes have different definers
+    \ the definer can be used for comparison and in definer!
+    dup >code-address [ ' bits >code-address ] Literal =
+    \ !! this definition will not work on some implementations for `bits'
+    if  \ if >code-address delivers the same value for all does>-def'd words
+	>does-code 1 or \ bit 0 marks special treatment for does codes
+    else
+	>code-address
+    then ;
+
+: definer! ( definer xt -- )
+    \ gives the word represented by xt the behaviour associated with definer
+    over 1 and if
+	swap [ 1 invert ] literal and does-code!
+    else
+	code-address!
+    then ;
 
-\ : locals|
-\ !! should lie around somewhere
+: TO ( c|w|d|r "name" -- ) \ core-ext,local
+\ !! state smart
+ 0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
+ ' dup >definer
+ state @ 
+ if
+   case
+     [ ' locals-wordlist >definer ] literal \ value
+     OF >body POSTPONE Aliteral POSTPONE ! ENDOF
+     [ ' clocal >definer ] literal
+     OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
+     [ ' wlocal >definer ] literal
+     OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
+     [ ' dlocal >definer ] literal
+     OF POSTPONE laddr# >body @ lp-offset, POSTPONE d! ENDOF
+     [ ' flocal >definer ] literal
+     OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
+     -&32 throw
+   endcase
+ else
+   [ ' locals-wordlist >definer ] literal =
+   if
+     >body !
+   else
+     -&32 throw
+   endif
+ endif ; immediate
+
+: locals|
+    \ don't use 'locals|'! use '{'! A portable and free '{'
+    \ implementation is anslocals.fs
+    BEGIN
+	name 2dup s" |" compare 0<>
+    WHILE
+	(local)
+    REPEAT
+    drop 0 (local) ; immediate restrict