\ fsl-utilg.fth An auxiliary file for the Forth Scientific Library
\ For GForth
\ Contains commonly needed definitions for the FSL modules.
\ S>F F>S conversion between (single) integer and float
\ -FROT reverse the effect of FROT
\ cell- back up one cell
\ F2DUP FDUP two floats
\ F2DROP FDROP two floats
\ PI F1.0 floating point constants
\ dxor, dor, dand double xor, or, and
\ sd* single * double = double_product
\ % parse next token as a FLOAT
\ v: defines use( & for defining and settting execution vectors
\ Public: Private: Reset_Search_Order control the visibility of words
\ INTEGER, DOUBLE for setting up array types
\ ARRAY DARRAY for declaring static and dynamic arrays
\ } for getting an ARRAY or DARRAY element address
\ &! for storing ARRAY aliases in a DARRAY
\ 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
\ MATRIX DMATRIX for declaring a static or dynamic 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
\ FRAME| |FRAME set up/remove a local variable frame
\ a b c d e f g h local FVARIABLE values
\ &a &b &c &d &e &f &g &h local FVARIABLE addresses
\ The words F, F= F2* F2/ PI FLOAT are already present in Gforth
\ This code is released to the public domain Everett Carter July 1994
\ CR .( FSL-UTILG.FTH V1.17 12 Jun 1996 10:13:12 EFC )
\ CR .( fsl-utilg.fth V2.0 Thursday 16 October 2008 )
\ cgm: reorganized file,
\ removed words already in Gforth,
\ Gforth DEFER and IS used for vectoring,
\ alternative definition for fp locals.
\ The code conforms with ANS requiring:
\ 1. Words from the wordsets CORE, CORE-EXT, BLOCK-EXT, EXCEPTION-EXT,
\ FILE, FLOAT, FLOAT-EXT, LOCAL, SEARCH, SEARCH-EXT, and TOOLS-EXT
\ 2. Gforth words Defer Alias -rot float f,
\
BASE @ DECIMAL
\ ================= compilation control =============================
\ for control of conditional compilation of test code
FALSE VALUE TEST-CODE?
FALSE VALUE ?TEST-CODE \ obsolete, for backward compatibility
\ for control of conditional compilation of Dynamic memory
TRUE CONSTANT HAS-MEMORY-WORDS?
\ ================= FSL NonANS words ================================
: -frot FROT FROT ;
: cell- [ 1 CELLS ] LITERAL - ; \ back up one cell
: F2DUP FOVER FOVER ;
: F2DROP FDROP FDROP ;
1.0E0 FCONSTANT F1.0
: 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 )
2 PICK * >R UM* R> + ; \ single * double = double
: % BL WORD COUNT >FLOAT 0= ABORT" NAN"
STATE @ IF POSTPONE FLITERAL THEN ; IMMEDIATE
\ ================= function vector definition ======================
\ use Forth200x words DEFER and IS for FSL words v: and defines
\ defines is already a synonym for IS in Gforth
' Defer Alias v:
: use( STATE @ IF POSTPONE ['] ELSE ' THEN ; IMMEDIATE
: & POSTPONE use( ; IMMEDIATE
\ ================= vocabulary management ===========================
WORDLIST CONSTANT hidden-wordlist
: Reset-Search-Order
FORTH-WORDLIST 1 SET-ORDER
FORTH-WORDLIST SET-CURRENT
;
: Public:
FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
FORTH-WORDLIST SET-CURRENT
;
: Private:
FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
hidden-wordlist SET-CURRENT
;
: Reset_Search_Order Reset-Search-Order ; \ for backward compatibility
\ ================= array words =====================================
0 VALUE TYPE-ID \ for building structures
FALSE VALUE STRUCT-ARRAY?
\ for dynamically allocating a structure or array
TRUE VALUE is-static? \ TRUE for statically allocated structs and arrays
: dynamic ( -- ) FALSE TO is-static? ;
1 CELLS CONSTANT INTEGER \ size of a regular integer
2 CELLS CONSTANT DOUBLE \ size of a double integer
\ 1 FLOATS CONSTANT FLOAT \ size of a regular float
1 CELLS CONSTANT POINTER \ size of a pointer (for readability)
\ 1-D array definition
\ -----------------------------
\ | cell_size | data area |
\ -----------------------------
: MARRAY ( n cell_size -- | -- addr ) \ monotype array
CREATE
DUP , * ALLOT
DOES> CELL+
;
\ -----------------------------
\ | id | cell_size | data area |
\ -----------------------------
: SARRAY ( n cell_size -- | -- id addr ) \ structure array
CREATE
TYPE-ID ,
DUP , * ALLOT
DOES> DUP @ SWAP [ 2 CELLS ] LITERAL +
;
: ARRAY
STRUCT-ARRAY? IF SARRAY FALSE TO STRUCT-ARRAY?
ELSE MARRAY
THEN
;
\ word for creation of a dynamic array (no memory allocated)
\ Monotype
\ ------------------------
\ | data_ptr | cell_size |
\ ------------------------
: DMARRAY ( cell_size -- ) CREATE 0 , ,
DOES>
@ CELL+
;
\ Structures
\ ----------------------------
\ | data_ptr | cell_size | id |
\ ----------------------------
: DSARRAY ( cell_size -- ) CREATE 0 , , TYPE-ID ,
DOES>
DUP [ 2 CELLS ] LITERAL + @ SWAP
@ CELL+
;
: DARRAY ( cell_size -- )
STRUCT-ARRAY? IF DSARRAY FALSE TO STRUCT-ARRAY?
ELSE DMARRAY
THEN
;
\ word for aliasing arrays,
\ typical usage: a{ & b{ &! sets b{ to point to a{'s data
: &! ( addr_a &b -- )
SWAP cell- SWAP >BODY !
;
: } ( addr n -- addr[n]) \ word that fetches 1-D array addresses
OVER [ 1 CELLS ] LITERAL - @ * +
;
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 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 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 ;
\ 2-D array definition,
\ Monotype
\ ------------------------------
\ | m | cell_size | data area |
\ ------------------------------
: MMATRIX ( n m size -- ) \ defining word for a 2-d matrix
CREATE
OVER , DUP ,
* * ALLOT
DOES> [ 2 CELLS ] LITERAL +
;
\ Structures
\ -----------------------------------
\ | id | m | cell_size | data area |
\ -----------------------------------
: SMATRIX ( n m size -- ) \ defining word for a 2-d matrix
CREATE TYPE-ID ,
OVER , DUP ,
* * ALLOT
DOES> DUP @ TO TYPE-ID
[ 3 CELLS ] LITERAL +
;
: MATRIX ( n m size -- ) \ defining word for a 2-d matrix
STRUCT-ARRAY? IF SMATRIX FALSE TO STRUCT-ARRAY?
ELSE MMATRIX
THEN
;
: DMATRIX ( size -- ) DARRAY ;
: }} ( addr i j -- addr[i][j] ) \ word to fetch 2-D array addresses
>R >R
DUP cell- cell- 2@ \ &a[0][0] size m
R> * R> + *
+
;
: }}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 2 PICK 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 ==================
(
loosely based upon Wil Baden's idea presented at FORML 1992.
The idea is to have a fixed number of variables with fixed names.
example: : test 2e 3e FRAME| a b | a F. b F. |FRAME ;
test <cr> 3.0000 2.0000 ok
Don't forget to use |FRAME before leaving a word that uses FRAME|.
)
8 CONSTANT /FLOCALS \ number of variables provided
: (frame) ( n -- ) FLOATS ALLOT ;
: (unframe) ( addr -- ) HERE - ALLOT ;
: FRAME|
POSTPONE HERE POSTPONE FALIGN POSTPONE >R
0 >R
BEGIN BL WORD COUNT 1 =
SWAP C@ [CHAR] | =
AND 0=
WHILE POSTPONE F, R> 1+ >R
REPEAT
/FLOCALS R> - DUP 0< ABORT" too many flocals"
POSTPONE LITERAL POSTPONE (frame) ; IMMEDIATE
: |FRAME ( -- ) POSTPONE R> POSTPONE (unframe) ; IMMEDIATE
\ use a defining word to build locals cgm
: lcl ( n -- ) CREATE ,
DOES> @ FLOATS NEGATE HERE +
;
8 lcl &a 7 lcl &b 6 lcl &c 5 lcl &d
: a &a F@ ; : b &b F@ ; : c &c F@ ; : d &d F@ ;
4 lcl &e 3 lcl &f 2 lcl &g 1 lcl &h
: e &e F@ ; : f &f F@ ; : g &g F@ ; : h &h F@ ;
BASE !
\ end of file
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>