(       Title:  Floating-Point Locals
         File:  fslflocals.fs
       Author:  Everett Carter
  Modified by:  David N. Williams
      License:  Public Domain

CHANGES
 7Feb03  * Modified FRAME| and |FRAME to avoid alignment memory
           leak.  [dnw]

From fsl_util.seq:

  Code for local fvariables, loosely based upon Wil Baden's idea
  presented at FORML 1992.

  The idea is to have a fixed number of variables with fixed names.
  
  I believe the code shown here will work with any, case
  insensitive, ANS Forth.

  i/tForth users are advised to use FLOCALS| instead.

  example:  : test  2e 3e FRAME| a b |  a f. b f. |FRAME ;
            test <cr> 3.0000 2.0000 ok

  PS: Don't forget to use |FRAME before an EXIT .
)

s" FLOATING-EXT"   ENVIRONMENT? [IF] ( flag) DROP
s" FLOATING-STACK" ENVIRONMENT? [IF] ( maxdepth) DROP

s" [UNDEFINED]" PAD C! PAD CHAR+ PAD C@ MOVE 
PAD FIND NIP 0=
[IF]
: [UNDEFINED]  ( "name" -- flag )
  BL WORD FIND NIP 0= ; IMMEDIATE
[THEN]

[UNDEFINED] F, [IF]
: F,  ( f: x -- )   FALIGN HERE   1 FLOATS ALLOT   F! ;
[THEN]

8 CONSTANT /flocals

: (frame) ( n -- ) FLOATS ALLOT ;

: FRAME|  ( -- )
        POSTPONE HERE POSTPONE >R POSTPONE FALIGN  \ dnw

        0 >R
        BEGIN   BL WORD  COUNT  1 =
                SWAP C@  [CHAR] | =
                AND 0=
        WHILE   POSTPONE F,  R> 1+ >R
        REPEAT
        /FLOCALS R> - DUP 0< ABORT" too many flocals"
        POSTPONE LITERAL  POSTPONE (frame)
; IMMEDIATE

: |FRAME  ( -- )
      \ [ /FLOCALS NEGATE ] LITERAL (FRAME) ;
        POSTPONE R> POSTPONE HERE POSTPONE - POSTPONE ALLOT
; IMMEDIATE

: &h            HERE [ 1 FLOATS ] LITERAL - ;
: &g            HERE [ 2 FLOATS ] LITERAL - ;
: &f            HERE [ 3 FLOATS ] LITERAL - ;
: &e            HERE [ 4 FLOATS ] LITERAL - ;
: &d            HERE [ 5 FLOATS ] LITERAL - ;
: &c            HERE [ 6 FLOATS ] LITERAL - ;
: &b            HERE [ 7 FLOATS ] LITERAL - ;
: &a            HERE [ 8 FLOATS ] LITERAL - ;

: a             &a F@ ;
: b             &b F@ ;
: c             &c F@ ;
: d             &d F@ ;
: e             &e F@ ;
: f             &f F@ ;
: g             &g F@ ;
: h             &h F@ ;

[ELSE] .( ***Separate floating point stack not available.) [THEN]
[ELSE] .( ***Floating point not available.)                [THEN]