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