\ opg-extras 97.11.04 Wil Baden
\ Reformatted for Quartus Forth
\ 99.3.5 12:53 am NAB.

needs opg

\ [The following was presented at 
\ FORML by Neil Bawd and B. W. 
\ Daniel.]

( Neil Bawd -- Floating Point Local Variable Revisited )

( This provides Scratch-Set sets of Scratch-Count FVARIABLEs. )
( The values here are 6 sets of 8 FVARIABLEs.   The FVARIABLEs
( are named: a b c d w x y z )
( You can easily extend this. )

( This lets the interpreter and called routines have their 
( own variables. )

( `SCRATCH` advances a set.  `ENDSCRATCH` retreats a set. )
( If a called word doesn't use `SCRATCH` it will use the set 
( in the calling environment.  This can be used by implementation
( factors of a word.  Variables can be set in one routine and 
( used by another. )

6  CONSTANT Scratch-Set
8  CONSTANT Scratch-Count
Scratch-Count FLOATS   CONSTANT Scratch-Size
Scratch-Size Scratch-Set * CONSTANT Scratch-Spread

CREATE Scratches   0 ,
CREATE Scratching  FALIGN  Scratch-Spread ALLOT

: SCRATCH  
  Scratches @  ?DUP 0= ?? Scratch-Spread  Scratch-Size -  Scratches ! 
;
: ENDSCRATCH  Scratches @  Scratch-Size + 
  DUP Scratch-Spread = IF  DROP 0 THEN 
  Scratches ! 
;

: a  Scratching FALIGNED  Scratches @ +  ;
: b  Scratching FALIGNED FLOAT+  Scratches @ +  ;
: c  Scratching FALIGNED 2 FLOATS +  Scratches @ +  ;
: d  Scratching FALIGNED 3 FLOATS +  Scratches @ +  ;

: w  Scratching FALIGNED 4 FLOATS +  Scratches @ +  ;
: x  Scratching FALIGNED 5 FLOATS +  Scratches @ +  ;
: y  Scratching FALIGNED 6 FLOATS +  Scratches @ +  ;
: z  Scratching FALIGNED 7 FLOATS +  Scratches @ +  ;

( Formula Translation -- Appendix A. )

( Arrays of Any Number of Dimensions )
( k BY l BY m BY n ARRAY name )
( k BY l BY m BY n FARRAY name )

( Floating-Point Arrays can be addressed in Forth or Formula method. )

  VARIABLE Let-Set   Let-Set OFF
  VARIABLE By-Count  1 By-Count !
  
: SET  S" Let-Set ON " EVALUATE  POSTPONE LET ; IMMEDIATE
: BY   1 By-Count +! ;
: S>F  S>D D>F ;

: by-set ( xn ... x2 x1 -- prod )
  1 By-Count @  ( xn ... x1 size n)
  DUP ,  0 DO  OVER , *  LOOP ( size)
  1 By-Count !  Let-Set OFF
;
  
: by-get
  0 SWAP ( ... offset addr)
  DUP @ 0 DO 
  CELL+ >R  
  OVER R@ @ U< NOT ABORT" Subscript Out of Range "
  R@ @ * + 
  R>
  LOOP ( offset addr)
  CELL+ 
;

: DOES>ARRAY ( [x] ... addr -- [x] ) 
  DOES> by-get SWAP CELLS +  
  Let-Set @ IF  !  Let-Set OFF  ELSE  @  THEN
;

: ARRAY CREATE  by-set 0 DO 0 , LOOP  DOES>ARRAY ;

: DOES>FARRAY ( ... addr -- )( F: [r] -- [r] )
  DOES> by-get FALIGNED SWAP FLOATS + 
  Let-Set @ IF  F!  Let-Set OFF  ELSE  F@  THEN
;

: FARRAY CREATE  by-set  FALIGN  FLOATS ALLOT  DOES>FARRAY ;
