Wil,

Thanks for your response.

Although my problem was related to float-stack manipulation, your solution
is very interesting when writing a lot of complex formulas.

> : (*)
> (: LET | = : | w v u z y x :)
> LET ( y*w - v*z, z*u - w*x, x*v - u*y ) :
> ;

But you must again define global fvariables to save the float-stack
content. In this case, the following become more easy (but I admit not
clear) to write.

> : (*)
> w F! v F! u F! z F! y F! x F!
> y F@ w F@ F* v F@ z F@ F* F-
> z F@ u F@ F* w F@ x F@ F* F-
> x F@ v F@ F* u F@ y F@ F* F-
> ;

Following, I expose a technique to have flocals wich enable free named
fvariables, reetrancy and recursion. The final overhead is small ( word
marked with ** are critical for speed )

Possibly this technique can be coupled with your operator precedence
grammar system.

Charles Melice
----------------------------------
EMPTY
REQUIRES FPMATH

( ====================================================================
  Local floats numerics variables see example bottom of file
  -------------------------------
  FLOCAL{
    FLOCAL{ alpha beta x y u v }
    prepare and set local variables in a definition.
    : Solve ( alfa beta c -- d ) (
        0e 0e \ init local vars u, v
        FLOCAL{ alfa beta c u v } \ declare/initialize flocals
        f@> alfa f!> u ... \ use flocals
        end-floc ; \ ! necessary before any exit !

  END-FLOCAL
    To use before exiting current definition.

  F!> F@> FVAR>
    !, @, give address, for one local.

  F2@>
    F2@ alfa beta
    Returns 2 values on the numeric stack.

  ==================================================================== )

\ __Private__

\ (defined in previous file)

: LROT ( x1 u -- x2 )
    2dup lshift >R 32 swap - rshift R> OR ;

: HASHSTR ( addr u -- uh )
        tuck over chars + swap \ len addr+len addr
        ?DO 5 lrot i c@ BL or BL xor BL 1- - xor LOOP
        dup 0> ?EXIT invert ;

: HASHSTR> ( <<var>> -- hcode ) bl word count hashstr ;

\ ---flocal stack---

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

Create FLOAT-ARRAY MAX-VAR floats allot

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

: >hash-code ( i -- addr )
    cells FLOAT-ARRAY + ;

: ParseVars{ ( -- )
    0 to SP
    BEGIN hashstr> [ hashstr> } ] literal over <> WHILE
        SP >hash-code !
        1 +to SP
        SP MAX-VAR >= abort" too many flocals defined"
    REPEAT
    drop ;

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

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

: CheckHCollision ( -- )
    SP 1- 0 ?DO SP i 1+ ?DO
        i >hash-code @
        j >hash-code @
        = abort" h-code collision"
    LOOP LOOP ;

\ __Public__

: FLOCAL{ ( -- )
    ParseVars{
    CheckHCollision
    SP postpone literal
    postpone Preambule ; IMMEDIATE

: END-FLOCAL ( -- )
    postpone Postambule
    FLOAT-ARRAY to SP ; IMMEDIATE

\ __Private__

: fvar ( offset -- addr ) SP + ; \ **
: f_at_var ( offset -- ) ( n: -- val ) SP + f@ ; \ **
: f!var ( offset -- ) ( n: val -- ) SP + f! ; \ **

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

: find-offset ( hcode -- offset )
    SP 0 ?DO
        i >hash-code @ over =
        IF
            drop
            i >offset
            unloop
            EXIT
        THEN
    LOOP
    true abort" local var not found" ;

\ __Public__

: FVAR> ( <<var>> -- addr )
    hashstr>
    find-offset
    postpone literal
    postpone fvar ; IMMEDIATE

: F@> ( n: <<var>> -- val )
    hashstr>
    find-offset
    postpone literal
    postpone f_at_var ; IMMEDIATE

: F2@> ( n: <<v1>> <<v2>> -- v1 v2 )
    postpone f@> postpone f@> ; IMMEDIATE

: F!> ( n: val <<var>> -- )
    hashstr>
    find-offset
    postpone literal
    postpone f!var ; IMMEDIATE

1 [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

: (^) ( n: x y z u v w -- a b c )
    FLOCAL{ x y z u v w }
    f2@> y w f* f2@> v z f* f- \ n: a
    f2@> z u f* f2@> w x f* f- \ n: a b
    f2@> x v f* f2@> u y f* f- \ n: a b c
    END-FLOCAL ;

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

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

( 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 -- )
    cr Time
    dup 0 DO
     1e 2e 3e 2e 3e 4e (^) fdrop fdrop fdrop
    LOOP
    cr Time
    0 DO
     1e 2e 3e 2e 3e 4e ((^)) fdrop fdrop fdrop
    LOOP
    cr Time ;

\ 2000000 Test
\ 12" with floc
\ 11" with normal method

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

\ EOF

.
Received on Sun May 16 1999 - 18:45:45 PDT