\ 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