\ fsl_util.seq An auxilliary file for the Forth Scientific Library \ contains commonly needed definitions for F-PC. \ dxor, dor, dand double xor, or, and \ sd* single * double = double_product \ v: defines use( & For defining and settting execution vectors \ % Parse next token as a FLOAT \ S>F F>S Conversion between (single) integer and float \ F, Store FLOAT at (aligned) HERE \ INTEGER, DOUBLE, FLOAT 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 The number of elements per line for printing arrays \ }FPRINT Print out a given array \ Matrix For declaring a 2-D array \ }} gets a Matrix element address \ Public: Private: Reset_Search_Order controls the visibility of words \ |frame frame| sets up/removes 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 \ This code conforms with ANS requiring: \ 1. The Floating-Point word set \ 2. The words umd* umd/mod and d* are implemented \ for F-PC in the file dmuldiv.seq \ 3. The word VOCABULARY is defined \ This code is released to the public domain Everett Carter July 1994 CR .( FSL_UTIL.SEQ V1.20 17 April 1995 EFC ) \ ====================== compilation control =========================== \ for control of conditional compilation test code FALSE VALUE TEST-CODE? FALSE VALUE ?TEST-CODE \ obsolete, for backward compatiblity \ for control of conditional compilation of Dynamic Memory FALSE CONSTANT HAS-MEMORY-WORDS? \ ======================================================================= \ FSL Non ANS words \ umd/mod ( uquad uddiv -- udquot udmod ) unsigned quad divided by double \ umd* ( ud1 ud2 -- qprod ) unsigned double multiply \ d* ( d1 d2 -- dprod ) double multiply \ For F-PC the above three are already defined in DMULDIV.SEQ needs dmuldiv.seq \ needs definitions of umd* umd/mod and d* : dxor ( d1 d2 -- d ) \ double xor ROT XOR -ROT XOR SWAP ; : dor ( d1 d2 -- d ) \ double or ROT OR -ROT OR SWAP ; : dand ( d1 d2 -- d ) \ double and ROT AND -ROT AND SWAP ; \ single * double = double : sd* ( multiplicand multiplier_double -- product_double ) 2 PICK * >R UM* R> + ; : D0< NIP 0< ; : T* TUCK UM* 2SWAP UM* SWAP >R 0 D+ R> ROT ROT ; : T/ DUP >R UM/MOD ROT ROT R> UM/MOD NIP SWAP ; : m*/ >R T* R> T/ ; \ function vector definition : v: CREATE ['] noop , DOES> @ EXECUTE ; : defines ' >BODY STATE @ IF [COMPILE] LITERAL COMPILE ! ELSE ! THEN ; IMMEDIATE : use( STATE @ IF [COMPILE] ['] ELSE ' THEN ; IMMEDIATE : & [COMPILE] use( ; IMMEDIATE \ pushes following value to the float stack : % BL WORD COUNT >FLOAT 0= ABORT" NAN" STATE @ IF POSTPONE FLITERAL THEN ; IMMEDIATE : S>F ( n -- | f: -- x ) \ integer to float S>D D>F ; : F>S ( -- n | f: x -- ) \ float to integer F>D DROP ; \ Store float at (aligned) HERE \ already defined in F-PC \ : F, ( -- | f: x -- ) FALIGN HERE 1 FLOATS ALLOT F! ; \ : F= F- F0= ; : -FROT FROT FROT ; \ : F2* % 2.0e0 F* ; \ : F2/ % 2.0e0 F/ ; \ : F2DUP FOVER FOVER ; : F2DROP FDROP FDROP ; : CELL- [ 1 CELLS ] LITERAL - ; \ backup one cell 0 VALUE TYPE-ID \ for building structures FALSE VALUE STRUCT-ARRAY? \ size of a regular integer 1 cells CONSTANT INTEGER \ size of a double integer 2 cells CONSTANT DOUBLE \ size of a regular float 1 floats CONSTANT FLOAT \ 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 ; v: do-align v: do-aligned : default-alignments & ALIGN defines do-align & ALIGNED defines do-aligned ; : float-alignments & FALIGN defines do-align & FALIGNED defines do-aligned ; : XINTEGER 1 CELLS default-alignments ; : XDOUBLE 2 CELLS default-alignments ; : XFLOAT 1 FLOATS float-alignments ; : XARRAY ( n size -- | -- addr ) \ experimental array with alignment CREATE DUP , DO-ALIGN * ALLOT DOES> CELL+ DO-ALIGNED ; \ 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 CELL- @ * SWAP + ; VARIABLE print-width 6 print-width ! : }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 ; : }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 ; : }fcopy ( 'src 'dest n -- ) \ copy one array into another 0 DO OVER I } F@ DUP I } F! 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 ; : }} ( addr i j -- addr[i][j] ) \ word to fetch 2-D array addresses 2>R \ indices to return stack temporarily DUP CELL- CELL- 2@ \ &a[0][0] size m R> * R> + * + ; \ Dynamic 2-D array definition, \ ------------------------------ \ | data_ptr | cell_size | (id) | \ ------------------------------ : DMATRIX ( cell_size -- ) \ defining word for a 2-d matrix DARRAY ; : }}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 ; \ Code for hiding words that the user does not need to access \ into a hidden wordlist. \ Private: \ will add HIDDEN to the search order and make HIDDEN \ the compilation wordlist. Words defined after this will \ compile into the HIDDEN vocabulary. \ Public: \ will restore the compilation wordlist to what it was before \ HIDDEN got added, it will leave HIDDEN in the search order \ if it was already there. Words defined after this will go \ into whatever the original vocabulary was, but HIDDEN words \ are accessable for compilation. \ Reset_Search_Order \ This will restore the compilation wordlist and search order \ to what they were before HIDDEN got added. HIDDEN words will \ no longer be visible. \ These three words can be invoked in any order, multiple times, in a \ file, but Reset_Search_Order should finally be called last in order to \ restore things back to the way they were before the file got loaded. \ WARNING: you can probably break this code by setting vocabularies while \ Public: or Private: are still active. \ the Vocabulary HIDDEN is already defined in F-PC \ Vocabulary HIDDEN variable HIDDEN_SET HIDDEN_SET Off variable Private_Used Private_Used Off variable OLD_CURRENT 0 OLD_CURRENT ! \ These definitions may require modification for non F-PC systems. : Public: ( -- ) HIDDEN_SET @ IF HIDDEN_SET OFF PREVIOUS ALSO HIDDEN OLD_CURRENT @ 0= NOT IF OLD_CURRENT @ SET-CURRENT THEN THEN ; : Private: ( -- ) HIDDEN_SET @ 0= IF HIDDEN_SET ON GET-CURRENT OLD_CURRENT ! Private_Used @ IF PREVIOUS THEN ALSO HIDDEN DEFINITIONS Private_Used On THEN ; : Reset_Search_Order ( -- ) \ invoke when there will be no more \ mucking with vocabularies in a file HIDDEN_SET @ IF Public: THEN PREVIOUS Private_Used Off 0 OLD_CURRENT ! ; \ Code for local fvariables, loosely based upon Wil Baden's idea presented \ at FORML 1992. \ The idea is to have a fixed number of variables with fixed names. \ I believe the code shown here will work with any, case insensitive, \ ANS Forth. \ i/tForth users are advised to use FLOCALS| instead. \ example: : test 2e 3e FRAME| a b | a f. b f. |FRAME ; \ test 3.0000 2.0000 ok \ PS: Don't forget to use |FRAME before an EXIT . 8 CONSTANT /flocals : (frame) ( n -- ) FLOATS ALLOT ; : FRAME| 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 ( -- ) [ /FLOCALS NEGATE ] LITERAL (FRAME) ; : &h HERE [ 1 FLOATS ] LITERAL - ; : &g HERE [ 2 FLOATS ] LITERAL - ; : &f HERE [ 3 FLOATS ] LITERAL - ; : &e HERE [ 4 FLOATS ] LITERAL - ; : &d HERE [ 5 FLOATS ] LITERAL - ; : &c HERE [ 6 FLOATS ] LITERAL - ; : &b HERE [ 7 FLOATS ] LITERAL - ; : &a HERE [ 8 FLOATS ] LITERAL - ; : a &a F@ ; : b &b F@ ; : c &c F@ ; : d &d F@ ; : e &e F@ ; : f &f F@ ; : g &g F@ ; : h &h F@ ; : F~ FRAME| a b c | c F0= IF a b = ELSE c F0< IF a FABS b FABS F+ c FABS F* a b F- FABS F< ELSE a b F- FABS c FSWAP F< THEN THEN |FRAME ;