--- gforth/glocals.fs	1995/04/29 14:51:19	1.12
+++ gforth/glocals.fs	1996/05/09 18:12:59	1.21
@@ -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,10 +85,10 @@
 \ Currently locals may only be
 \ defined at the outer level and TO is not supported.
 
-include search-order.fs
-include float.fs
+require search-order.fs
+require float.fs
 
-: compile-@local ( n -- ) \ new compile-fetch-local
+: compile-@local ( n -- ) \ gforth compile-fetch-local
  case
     0       of postpone @local0 endof
     1 cells of postpone @local1 endof
@@ -73,7 +97,7 @@ include float.fs
    ( otherwise ) dup postpone @local# ,
  endcase ;
 
-: compile-f@local ( n -- ) \ new compile-f-fetch-local
+: compile-f@local ( n -- ) \ gforth compile-f-fetch-local
  case
     0        of postpone f@local0 endof
     1 floats of postpone f@local1 endof
@@ -153,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, ;
@@ -238,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
@@ -248,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
@@ -262,7 +286,7 @@ locals-types definitions
     previous previous
     locals-list TO locals-wordlist ;
 
-: -- ( addr wid 0 ... -- )
+: -- ( addr wid 0 ... -- ) \ gforth dash-dash
     }
     [char] } parse 2drop ;
 
@@ -373,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
@@ -449,7 +473,7 @@ 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
@@ -464,7 +488,7 @@ forth definitions
     \ 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 =
+    dup >code-address [ ' spaces >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
@@ -475,44 +499,41 @@ forth definitions
 : definer! ( definer xt -- )
     \ gives the word represented by xt the behaviour associated with definer
     over 1 and if
-	does-code!
+	swap [ 1 invert ] literal and does-code!
     else
 	code-address!
     then ;
 
-\ !! 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
-     -&32 throw
-   endcase
- else
-   [ ' locals-wordlist >definer ] literal =
-   if
-     >body !
-   else
-     -&32 throw
-   endif
- endif ; immediate
+: TO ( c|w|d|r "name" -- ) \ core-ext,local
+    0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
+    ' dup >definer
+    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 2! ENDOF
+	[ ' flocal >definer ] literal
+	OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
+	-&32 throw
+    endcase ; immediate
+interpretation:
+    ' dup >definer [ ' locals-wordlist >definer ] literal =
+    if
+	>body !
+    else
+	-&32 throw
+    endif ;
 
 : locals|
+    \ don't use 'locals|'! use '{'! A portable and free '{'
+    \ implementation is compat/anslocals.fs
     BEGIN
 	name 2dup s" |" compare 0<>
     WHILE
 	(local)
     REPEAT
-    drop 0 (local) ;  immediate restrict
+    drop 0 (local) ; immediate restrict