--- gforth/glocals.fs 1995/01/30 18:47:50 1.9 +++ gforth/glocals.fs 1995/11/07 18:06:43 1.15 @@ -1,3 +1,24 @@ +\ 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. + + \ 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 +82,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 -- ) +: compile-@local ( n -- ) \ gforth compile-fetch-local case 0 of postpone @local0 endof 1 cells of postpone @local1 endof @@ -73,7 +94,7 @@ include float.fs ( 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 1 floats of postpone f@local1 endof @@ -137,7 +158,7 @@ variable locals-dp \ so here's the speci \ 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 ) @@ -153,52 +174,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 +259,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 +269,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 +283,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 +394,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 +470,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 @@ -475,13 +496,13 @@ 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" -- ) +: 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 @@ -498,21 +519,23 @@ forth definitions 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" + -&32 throw endcase else [ ' locals-wordlist >definer ] literal = if >body ! else - abort" can only store TO value" + -&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 + drop 0 (local) ; immediate restrict