\ fsl-util.4th
\ An auxiliary file for the Forth Scientific Library
\ For 4tH
\ Contains commonly needed definitions for the FSL modules.
\ -FROT reverse the effect of FROT
\ F2DUP FDUP two floats
\ F2DROP FDROP two floats
\ F1.0 floating point constant
\ dxor, dor, dand double xor, or, and
\ sd* single * double = double_product
\ INTEGER, DOUBLE, FLOAT for setting up array types
\ FSL-ARRAY for declaring FSL arrays
\ } for getting an FSL ARRAY element address
\ PRINT-WIDTH number of elements per line for printing arrays
\ }IPRINT }FPRINT print out integer or fp arrays
\ }FCOPY copy one array into another
\ }FPUT move values from fp stack into an array
\ FSL-MATRIX for declaring an FSL 2-D array
\ }} gets a Matrix element address
\ }}IPRINT }}FPRINT print out an integer or fp matrix
\ }}FCOPY copy one matrix into another
\ }}FPUT move values from fp stack into a matrix
\ This file is based on the file "fsl-util.fth" written by Skip Carter
\ in 1994 and released by him to the public domain. It has been revised
\ to work with both Gforth (0.6.2) and PFE (0.33.69) by Krishna Myneni
\ with contributions from David Williams and Guido Draheim. It has been
\ revised to work with 4tH (3.5d) by Hans Bezemer.
\ This file is released to the public domain.
\ Revisions:
\ 1995-07-07 efc; Revision 1.15
\ 1996-06-12 efc; Revision 1.17
\ 2003-11-16 km; Fixed bug in }}, added }}FCOPY
\ 2004-02-12 mh; Applied fixes to } and }} given by Marcel Hendrix
\ 2007-10-27 km; save base, switch to decimal, and restore base;
\ also defined S>F here, and added note about deprecated
\ words V: and DEFINES
\ 2008-09-18 km; conditional definitions of cell-, FLOAT, and F,
\ 2008-09-22 km; special handling of FORTH-WORDLIST for PFE; fix defn of PI
\ 2008-09-25 km; revised definition of F, to avoid alignment problem with
\ floating point locals --- thanks to Guido Draheim and DNW.
\ 2008-09-29 dnw;km revised defn. of F, to act on FALIGNed addresses,
\ and revised defns of FRAME! and |FRAME to deal with
\ alignment of HERE; environmental checks for
\ FLOATING-EXT (used for auto-loading fp words in PFE)
\ and FLOATING-STACK.
\ 2008-10-07 cgm; added definitions for F2* , F2/ , F= , F@DUP , F2DROP, }}IPRINT;
\ re-organized the file; alternate method of defining fp locals.
\ 2008-11-27 hb; Converted to 4tH; removed several words.
\ The code conforms with ANS requiring:
\ 1. Words from the wordsets CORE, CORE-EXT, BLOCK-EXT, EXCEPTION-EXT,
\ FILE, FLOAT, FLOAT-EXT and TOOLS-EXT
\ 2. [DEFINED] and [UNDEFINED] from the F200X Floating-Extension set
\ ( FSL-UTIL V2.0 7 October 2008 )
[UNDEFINED] fsl-array [IF]
[UNDEFINED] f. [IF] [ABORT] [THEN]
\ ================= compilation control =============================
\ for control of conditional compilation of Dynamic memory
[DEFINED] allocate CONSTANT MEMORY-WORDS?
\ ================= FSL NonANS words ================================
: -FROT FROT FROT ;
: F2DUP FOVER FOVER ;
: F2DROP FDROP FDROP ;
: F1.0 1 S>F ;
: dxor ( d1 d2 -- d ) ROT XOR >R XOR R> ; \ double xor
: dor ( d1 d2 -- d ) ROT OR >R OR R> ; \ double or
: dand ( d1 d2 -- d ) ROT AND >R AND R> ; \ double and
: sd* ( multiplicand multiplier_double -- product_double )
>R OVER R> * >R UM* R> + ; \ single * double = double
\ ================= function vector definition ======================
\ Removed for 4tH
\ ================= file and vocabulary management ==================
\ Removed for 4tH
\ ================= array words =====================================
1 CELLS CONSTANT INTEGER \ size of a regular integer
2 CELLS CONSTANT DOUBLE \ size of a double integer
1 CELLS CONSTANT POINTER \ size of a pointer (for readability)
\ Usage:
\ An FSL array of 10 FLOATs:
\ 10 FLOAT [*] 1 [+] ARRAY MyFSL ( allocation)
\ FLOAT MyFSL FSL-ARRAY ( initialization)
\ :THIS MyFSL DOES> (FSL-ARRAY) ; ( runtime behavior)
\ Original declaration:
\ 10 FLOAT MARRAY MyFSL
\ 1-D array definition
\ -----------------------------
\ | cell_size | data area |
\ -----------------------------
: FSL-ARRAY ( cell_size addr -- ) \ monotype array
!
;
: (FSL-ARRAY) CELL+ ; ( -- addr )
: } ( addr n -- addr[n]) \ word that fetches 1-D array addresses
OVER CELL- @ * +
;
VARIABLE print-width 6 print-width !
: }iprint ( n addr -- ) \ print n elements of an integer array
SWAP 0 DO I print-width @ MOD 0= I 0<> AND IF CR THEN
DUP I } @ . LOOP
DROP
;
: }fprint ( n addr -- ) \ print n elements of a float array
SWAP 0 DO I print-width @ MOD 0= I 0<> AND IF CR THEN
DUP I } F@ F. LOOP
DROP
;
: }fcopy ( 'src 'dest n -- ) \ copy one array into another
0 DO OVER I } F@ DUP I } F! LOOP
2DROP
;
: }fput ( r1 ... r_n n 'a -- ) \ store r1 ... r_n into array of size n
SWAP DUP 0 ?DO 1- 2DUP 2>R } F! 2R> LOOP 2DROP ;
\ Usage:
\ An FSL matrix of 16 by 8 FLOATs:
\ 16 8 [*] FLOAT [*] 2 [+] ARRAY MyFSL ( allocation)
\ 16 8 FLOAT MyFSL FSL-MATRIX ( initialization)
\ :THIS MyFSL DOES> (FSL-MATRIX) ; ( runtime behavior)
\ Original declaration:
\ 16 8 FLOAT MMATRIX MyFSL
\ 2-D array definition,
\ Monotype
\ ------------------------------
\ | m | cell_size | data area |
\ ------------------------------
: FSL-MATRIX ( n m size addr -- ) \ defining word for a 2-d matrix
ROT OVER ! CELL+ ! DROP
;
: (FSL-MATRIX) CELL+ CELL+ ; ( -- addr)
: }} ( addr i j -- addr[i][j] ) \ word to fetch 2-D array addresses
>R >R
DUP CELL- DUP @ SWAP CELL- @
R> * R> + * + \ &a[0][0] size m
;
: }}iprint ( n m addr -- ) \ print nXm elements of an integer 2-D array
ROT ROT SWAP 0 DO DUP 0 DO OVER J I }} @ .
LOOP
CR
LOOP
2DROP
;
: }}fprint ( n m addr -- ) \ print nXm elements of a float 2-D array
ROT ROT SWAP 0 DO DUP 0 DO OVER J I }} F@ F.
LOOP
CR
LOOP
2DROP
;
: }}fcopy ( 'src 'dest n m -- ) \ copy nXm elements of 2-D array src to dest
SWAP 0 DO DUP 0 DO >R OVER R> SWAP J I }} F@
OVER J I }} F!
LOOP
LOOP
DROP 2DROP
;
: }}fput ( r11 r12 ... r_nm n m 'A -- | store r11 ... r_nm into nxm matrix )
-ROT 2DUP * >R 1- SWAP 1- SWAP }} R>
0 ?DO DUP >R F! R> FLOAT - LOOP DROP ;
\ ================= Floating-point local variables ==================
\ Removed for 4tH
[THEN]
\ end of file
|
