In a last mail, I sended a program to have local float values.

This program can generate very subtle bugs, because I used h-coded table.
In rare case, but possibly, h-coded symbol can confict with standard
dictionary words.

To be right, I send now the following program, that resolve this problem
(it use a true symbol table).

Expecting some idea exchange on this subject,
Charles Melice

(
====================================================================
Local floats numerics values see example bottom of file
----------------------------
FLOCS|
    3,1416e FLOCS| alpha beta x y pi |
    Prepare and initialize local float FVALUES in a definition.
    Not case sensitive.

FTO
   3.14e FTO pi
   Store float value.

FADR>
    FADR> alfa
    Returns the float variable address.

ENDFLOCS
    To use when exiting definition before semi-colon ;
====================================================================
)

REQUIRES FPMATH

(
====================================================================
I{
    c-addr-end xt-consume I{
    Local interpret.
    xt is the token-interpreter execution address
    c-addr-end is the token used to end interpretation
====================================================================
)

\ ----------------
\ Symbol table
\ ----------------

INTERNAL

16 constant MAX-SYMBOL
32 constant SYMBOL-MAXLEN

Create ^SymTab MAX-SYMBOL SYMBOL-MAXLEN * allot

0 value nSym

Create EndToken$ SYMBOL-MAXLEN allot

: >Token$ ( n -- c-addr )
    SYMBOL-MAXLEN * ^SymTab + ;

: cplace ( c-addr to -- )
>r count
    dup SYMBOL-MAXLEN >= abort" token length too long"
    r> place ;

: AddToken ( c-addr -- )
    nSym MAX-SYMBOL >= abort" symbol table full!"
    nSym >Token$ cplace
    1 +to nSym ;

\ ------------------
\ Local interpreter
\ ------------------

INTERNAL

DEFER InterpretToken ( c-addr -- end? )

:noname ( c-addr -- flag ) true abort" not found" ; IS InterpretToken

: InterpretWord ( c-addr -- the-end? )
    dup count EndToken$ count compare(nc) 0= IF drop true EXIT THEN
    dup InterpretToken
    IF
        drop
        false EXIT
    THEN
    find dup
    IF
        0< STATE @ AND IF compile, ELSE execute THEN
    ELSE
        drop count Evaluate \ last chance (number?)
    THEN
    false ;

: GetToken ( -- c-addr )
    bl word dup c@ ?EXIT
    drop refill 0= abort" EOF!" recurse ;

EXTERNAL

: I{ ( c-addrend xt-hinterpreter -- nSymbol ) \ interpret sequence
    0 to nSym
    IS InterpretToken
    EndToken$ cplace
    BEGIN GetToken InterpretWord UNTIL
    nSym ;

\ ---------------------------------------------
\ Local float variables on private float stack
\ NB: speed critical sequence marked **
\ ---------------------------------------------

INTERNAL

64 constant MAX-VAR \ float stack depth
0 value SP \ float stack pointer

falign HERE MAX-VAR floats allot
CONSTANT FLOAT-ARRAY

FLOAT-ARRAY MAX-VAR 2 - floats + Constant FSTACK-LIMIT

: ParseVar> ( c-addr -- consumed? )
    AddToken true ;

: Preambule ( n -- ) \ **
    SP swap 0 \ s: SP n 0
    DO dup f! float+ LOOP \ s: SP+
    dup FSTACK-LIMIT >= abort" flocal stack overflow"
    SP over ! float+ to SP ; \ s: -

EXTERNAL

: ENDFLOCS ( -- ) \ **
    SP [ 1 floats ] literal - @ to SP ;

INTERNAL

: CheckCollision ( -- )
    SP 1- 0 ?DO SP i 1+ ?DO
        i >Token$ count j >Token$ count compare(nc)
        0= abort" h-code collision"
    LOOP LOOP ;

: FDECLARE| ( -- ) \ only local float values on this line !
    c" |" ['] ParseVar> I{ to SP
    CheckCollision
    SP postpone literal
    postpone Preambule ;

: >offset ( i -- offset ) 2 + floats negate ;

: find-offset ( c-addr -- offset -1 | 0 )
    SP 0 ?DO
        dup count i >Token$ count compare(nc) 0=
        IF
            drop
            i >offset true
            unloop
            EXIT
        THEN
    LOOP
    drop false ;

\ Floats locals compilation

INTERNAL

: (FADR) ( c-addr -- flag ) \ RUN: ( n: -- val )
    find-offset 0= IF false EXIT THEN
    ?dup IF
        postpone literal \ **
        postpone SP \ **
        postpone + \ **
    ELSE \ optimize 0 offset case
        postpone SP \ **
    THEN
    true ;

: (FVAL) ( hcode -- flag ) ( n: -- val ) \ **
    (FADR) dup IF postpone f@ THEN ;

EXTERNAL

: FLOCS| ( <<f0>> <<f1>> <<f2>> ... -- )
    FDECLARE|
    c" ;" ['] (FVAL) I{ drop
    postpone ENDFLOCS
    FLOAT-ARRAY to SP ;
    postpone ; ; IMMEDIATE

: FTO ( n: val <<flocal>> -- )
    bl word (FADR) 0= abort" value not found"
    postpone f! ;
                 IMMEDIATE

: FADR>
    bl word (FADR)
    0= abort" value not found" ;
                                IMMEDIATE

MODULE

0 [IF]
\ ------------------------------------------------
\ Example : (^) ( n: x y z u v w -- a b c )
\ -------
\ where a b c is the vector product
\ a = y*w - v*z
\ b = z*u - w*x
\ c = x*v - u*y

: (^) ( f: x y z u v w -- a b c )
    FLOCS| x y z u v w |
    y w f* v z f* f- \ f: a
    z u f* w x f* f- \ f: a b
    x v f* u y f* f- ; \ f: a b c

\ a = 2*4 - 3*3 = -1
\ b = 3*2 - 4*1 = +2
\ c = 1*3 - 2*2 = -1

1e 2e 3e 2e 3e 4e (^)
cr .( c b a = )
cr f.
cr f.
cr f.

( comparaison with "traditional" method )

fvariable x fvariable y fvariable z
fvariable u fvariable v fvariable w

: ((^)) ( n: x y z u v w -- a b c )
    w f! v f! u f!
    z f! y f! x f!
    y f@ w f@ f* v f@ z f@ f* f- \ n: a
    z f@ u f@ f* w f@ x f@ f* f- \ n: b
    x f@ v f@ f* u f@ y f@ f* f- ; \ n: c

: Test ( ntest -- )
>R COUNTER
    R@ 0 DO
     1e 2e 3e 2e 3e 4e (^) fdrop fdrop fdrop
    LOOP
    TIMER COUNTER
    R> 0 DO
     1e 2e 3e 2e 3e 4e ((^)) fdrop fdrop fdrop
    LOOP
    TIMER ;

\ 2000000 Test
\ 9143 with flocals>
\ 10946 with normal method

cr
..( Example pass value to other word )

: FSUM ( f: a b -- a+b ) FLOCS| a b | a b f+ ;

: WA ( f: a b c -- c*{a+b}+a*{b+c}+b*{a+c} )
    FLOCS| a b c |
    a b FSUM c f*
    b c FSUM a f* f+
    a c FSUM b f* f+ ;

cr
cr .( result= 5*4 + 7*2 + 6*3 = 52 = )
2e 3e 4e WA f.

cr
..( Example pass adress to other word 6+13= )

: ADRSUM ( ^a ^b -- a+b ) f@ f@ f+ ;

: WB ( f: a b -- a+b )
    FLOCS| a b |
    fadr> a
    fadr> b
    ADRSUM ;

6e 13e WB f.

\ ------------------------------------------------
[THEN]

\ EOF

.
Received on Wed May 26 1999 - 19:10:59 PDT