> What is the more efficient sequence to define the following math word ?
>
> : (*) ( n: x y z u v w -- a b c )
> ...the stack gymnastic... ;

I have revisited the solution to have local VALUES and not local variables.
The usage is now more easy and remain "ala" Forth:

: (*) ( n: x y z u v w -- a b c )
    FVAL: x y z u v w
    N{
        y w f* v z f* f- \ n: a
        z u f* w x f* f- \ n: a b
        x v f* u y f* f- \ n: a b c
    }I
    FVAL:END ;

Also, and strangely, my local floats values are faster than normal
fvariables !?

Here is the source code. Is it ANSI complient ?

Regards,
Charles Melice

\ ===============================================

EMPTY
REQUIRES FPMATH

(
====================================================================
Local floats numerics values see example bottom of file
----------------------------
FVAL:
    FVAL: alpha beta x y u v
    or
    3,1416e FVAL: alpha beta x y u v pi
    Prepare and initialize local float FVALUES in a definition.
    All fvars -and only fvars- must be declared on this line.

FVAL:END
    To use before exiting current definition.

N{
    N{ alfa beta f* gamma f+ FTO gamma ..... }I
    Interpret local sequence until }I
    First Search local fvalues, then deleguate to standard interpreter

}I
    Ends local interpreter.

FTO
   3.14e FTO pi
   Store float value.
====================================================================
)

EXTERNAL

\ ------------------
\ H-CODE long string
\ ------------------

: 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 ;

(
====================================================================
General local h-code interpreter
--------------------------------
I{
    Local interpret until }I
    Usage:
    : N{ xt I{ ; IMMEDIATE

    Where xt is the h-code-interpreter execution address
====================================================================
)

INTERNAL

DEFER InterpretInternalToken ( hcode -- flag )

:noname true abort" not found" ; IS InterpretInternalToken

: InterpretWord ( c-addr hcode -- )
    InterpretInternalToken IF drop exit THEN
    find dup
    IF
        0< STATE @ AND IF compile, ELSE execute THEN
    ELSE
        drop count Evaluate \ interpret number else throw error
    THEN ;

: GetToken ( -- c-addr )
    bl word dup c@ ?EXIT
    drop source-id 0= IF cr THEN
    refill 0= abort" eof" recurse ;

EXTERNAL

: I{ ( xt-hinterpreter -- ) \ interpret sequence until "}I"
    ['] InterpretInternalToken >BODY @ >R
    IS InterpretInternalToken
    BEGIN
        GetToken dup count HashStr \ c-addr h-code
        [ HASHSTR> }I ] literal over <> WHILE \ s: c-addr hcode
        InterpretWord
    REPEAT
    2drop
    R> IS InterpretInternalToken ;

\ ---------------------------------------------
\ Local float variables on private float stack
\ ---------------------------------------------

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

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

: ParseVars> ( -- )
    0 to SP
    BEGIN bl word count dup WHILE
        HASHSTR SP >hash-code !
        1 +to SP
        SP MAX-VAR >= abort" too many flocals defined"
    REPEAT
    2drop ;

: 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: -

: 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 ;

EXTERNAL

: FVAL: ( -- )
    ParseVars>
    CheckHCollision
    SP postpone literal
    postpone Preambule ; IMMEDIATE

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

INTERNAL

: fvar ( offset -- addr ) postpone SP postpone + ; IMMEDIATE \ **

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

: find-offset ( hcode -- offset -1 | 0 )
    SP 0 ?DO
        i >hash-code @ over =
        IF
            drop
            i >offset true
            unloop
            EXIT
        THEN
    LOOP
    drop false ;

\ ---------------------------
\ Using the local interpreter
\ ---------------------------

INTERNAL

: (FADDR) ( hcode -- flag )
    find-offset 0= IF false EXIT THEN
    postpone literal
    postpone fvar
    true ;

: (FVAL) ( hcode -- ) ( n: -- val )
    find-offset 0= IF false EXIT THEN
    postpone literal
    postpone fvar
    postpone f@
    true ;

EXTERNAL

: N{ ( <<words}>> -- )
    ['] (FVAL) I{ ; IMMEDIATE

: FTO ( n: val <<flocal>> -- )
    HASHSTR> (FADDR) 0= abort" fvar not found"
    postpone f! ;
                IMMEDIATE

MODULE

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 )
    FVAL: x y z u v w
    N{
        y w f* v z f* f- \ n: a
        z u f* w x f* f- \ n: a b
        x v f* u y f* f- \ n: a b c
    }I
    FVAL:END ;

\ 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> ( faster !? with hardware stack )
\ 10946 with normal method

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

\ EOF

.
Received on Thu May 20 1999 - 12:46:12 PDT