Annotation of gforth/fsl-util.fs, revision 1.1
1.1 ! pazsan 1: \ fsl-utilg.fth An auxiliary file for the Forth Scientific Library
! 2: \ For GForth
! 3:
! 4: \ Contains commonly needed definitions for the FSL modules.
! 5:
! 6: \ S>F F>S conversion between (single) integer and float
! 7: \ -FROT reverse the effect of FROT
! 8: \ cell- back up one cell
! 9: \ F2DUP FDUP two floats
! 10: \ F2DROP FDROP two floats
! 11: \ PI F1.0 floating point constants
! 12: \ dxor, dor, dand double xor, or, and
! 13: \ sd* single * double = double_product
! 14: \ % parse next token as a FLOAT
! 15: \ v: defines use( & for defining and settting execution vectors
! 16: \ Public: Private: Reset_Search_Order control the visibility of words
! 17: \ INTEGER, DOUBLE for setting up array types
! 18: \ ARRAY DARRAY for declaring static and dynamic arrays
! 19: \ } for getting an ARRAY or DARRAY element address
! 20: \ &! for storing ARRAY aliases in a DARRAY
! 21: \ PRINT-WIDTH number of elements per line for printing arrays
! 22: \ }IPRINT }FPRINT print out integer or fp arrays
! 23: \ }FCOPY copy one array into another
! 24: \ }FPUT move values from fp stack into an array
! 25: \ MATRIX DMATRIX for declaring a static or dynamic 2-D array
! 26: \ }} gets a Matrix element address
! 27: \ }}IPRINT }}FPRINT print out an integer or fp matrix
! 28: \ }}FCOPY copy one matrix into another
! 29: \ }}FPUT move values from fp stack into a matrix
! 30: \ FRAME| |FRAME set up/remove a local variable frame
! 31: \ a b c d e f g h local FVARIABLE values
! 32: \ &a &b &c &d &e &f &g &h local FVARIABLE addresses
! 33: \ The words F, F= F2* F2/ PI FLOAT are already present in Gforth
! 34:
! 35: \ This code is released to the public domain Everett Carter July 1994
! 36:
! 37: \ CR .( FSL-UTILG.FTH V1.17 12 Jun 1996 10:13:12 EFC )
! 38: CR .( fsl-utilg.fth V2.0 Thursday 16 October 2008 )
! 39: \ cgm: reorganized file,
! 40: \ removed words already in Gforth,
! 41: \ Gforth DEFER and IS used for vectoring,
! 42: \ alternative definition for fp locals.
! 43:
! 44: \ The code conforms with ANS requiring:
! 45: \ 1. Words from the wordsets CORE, CORE-EXT, BLOCK-EXT, EXCEPTION-EXT,
! 46: \ FILE, FLOAT, FLOAT-EXT, LOCAL, SEARCH, SEARCH-EXT, and TOOLS-EXT
! 47: \ 2. Gforth words Defer Alias -rot float f,
! 48: \
! 49:
! 50: BASE @ DECIMAL
! 51:
! 52: \ ================= compilation control =============================
! 53:
! 54: \ for control of conditional compilation of test code
! 55: FALSE VALUE TEST-CODE?
! 56: FALSE VALUE ?TEST-CODE \ obsolete, for backward compatibility
! 57:
! 58: \ for control of conditional compilation of Dynamic memory
! 59: TRUE CONSTANT HAS-MEMORY-WORDS?
! 60:
! 61: \ ================= FSL NonANS words ================================
! 62:
! 63: : -frot FROT FROT ;
! 64: : cell- [ 1 CELLS ] LITERAL - ; \ back up one cell
! 65: : F2DUP FOVER FOVER ;
! 66: : F2DROP FDROP FDROP ;
! 67: 1.0E0 FCONSTANT F1.0
! 68:
! 69: : dxor ( d1 d2 -- d ) ROT XOR >R XOR R> ; \ double xor
! 70: : dor ( d1 d2 -- d ) ROT OR >R OR R> ; \ double or
! 71: : dand ( d1 d2 -- d ) ROT AND >R AND R> ; \ double and
! 72:
! 73: : sd* ( multiplicand multiplier_double -- product_double )
! 74: 2 PICK * >R UM* R> + ; \ single * double = double
! 75:
! 76: : % BL WORD COUNT >FLOAT 0= ABORT" NAN"
! 77: STATE @ IF POSTPONE FLITERAL THEN ; IMMEDIATE
! 78:
! 79: \ ================= function vector definition ======================
! 80: \ use Forth200x words DEFER and IS for FSL words v: and defines
! 81: \ defines is already a synonym for IS in Gforth
! 82:
! 83: ' Defer Alias v:
! 84:
! 85: : use( STATE @ IF POSTPONE ['] ELSE ' THEN ; IMMEDIATE
! 86: : & POSTPONE use( ; IMMEDIATE
! 87:
! 88: \ ================= vocabulary management ===========================
! 89:
! 90: WORDLIST CONSTANT hidden-wordlist
! 91:
! 92: : Reset-Search-Order
! 93: FORTH-WORDLIST 1 SET-ORDER
! 94: FORTH-WORDLIST SET-CURRENT
! 95: ;
! 96:
! 97: : Public:
! 98: FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
! 99: FORTH-WORDLIST SET-CURRENT
! 100: ;
! 101:
! 102: : Private:
! 103: FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
! 104: hidden-wordlist SET-CURRENT
! 105: ;
! 106:
! 107: : Reset_Search_Order Reset-Search-Order ; \ for backward compatibility
! 108:
! 109: \ ================= array words =====================================
! 110:
! 111: 0 VALUE TYPE-ID \ for building structures
! 112: FALSE VALUE STRUCT-ARRAY?
! 113:
! 114: \ for dynamically allocating a structure or array
! 115: TRUE VALUE is-static? \ TRUE for statically allocated structs and arrays
! 116: : dynamic ( -- ) FALSE TO is-static? ;
! 117:
! 118: 1 CELLS CONSTANT INTEGER \ size of a regular integer
! 119: 2 CELLS CONSTANT DOUBLE \ size of a double integer
! 120: \ 1 FLOATS CONSTANT FLOAT \ size of a regular float
! 121: 1 CELLS CONSTANT POINTER \ size of a pointer (for readability)
! 122:
! 123: \ 1-D array definition
! 124: \ -----------------------------
! 125: \ | cell_size | data area |
! 126: \ -----------------------------
! 127:
! 128: : MARRAY ( n cell_size -- | -- addr ) \ monotype array
! 129: CREATE
! 130: DUP , * ALLOT
! 131: DOES> CELL+
! 132: ;
! 133:
! 134: \ -----------------------------
! 135: \ | id | cell_size | data area |
! 136: \ -----------------------------
! 137:
! 138: : SARRAY ( n cell_size -- | -- id addr ) \ structure array
! 139: CREATE
! 140: TYPE-ID ,
! 141: DUP , * ALLOT
! 142: DOES> DUP @ SWAP [ 2 CELLS ] LITERAL +
! 143: ;
! 144:
! 145: : ARRAY
! 146: STRUCT-ARRAY? IF SARRAY FALSE TO STRUCT-ARRAY?
! 147: ELSE MARRAY
! 148: THEN
! 149: ;
! 150:
! 151: \ word for creation of a dynamic array (no memory allocated)
! 152:
! 153: \ Monotype
! 154: \ ------------------------
! 155: \ | data_ptr | cell_size |
! 156: \ ------------------------
! 157:
! 158: : DMARRAY ( cell_size -- ) CREATE 0 , ,
! 159: DOES>
! 160: @ CELL+
! 161: ;
! 162:
! 163: \ Structures
! 164: \ ----------------------------
! 165: \ | data_ptr | cell_size | id |
! 166: \ ----------------------------
! 167:
! 168: : DSARRAY ( cell_size -- ) CREATE 0 , , TYPE-ID ,
! 169: DOES>
! 170: DUP [ 2 CELLS ] LITERAL + @ SWAP
! 171: @ CELL+
! 172: ;
! 173:
! 174: : DARRAY ( cell_size -- )
! 175: STRUCT-ARRAY? IF DSARRAY FALSE TO STRUCT-ARRAY?
! 176: ELSE DMARRAY
! 177: THEN
! 178: ;
! 179:
! 180: \ word for aliasing arrays,
! 181: \ typical usage: a{ & b{ &! sets b{ to point to a{'s data
! 182:
! 183: : &! ( addr_a &b -- )
! 184: SWAP cell- SWAP >BODY !
! 185: ;
! 186:
! 187:
! 188: : } ( addr n -- addr[n]) \ word that fetches 1-D array addresses
! 189: OVER [ 1 CELLS ] LITERAL - @ * +
! 190: ;
! 191:
! 192: VARIABLE print-width 6 print-width !
! 193:
! 194: : }iprint ( n addr -- ) \ print n elements of an integer array
! 195: SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
! 196: DUP I } @ . LOOP
! 197: DROP
! 198: ;
! 199:
! 200: : }fprint ( n addr -- ) \ print n elements of a float array
! 201: SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
! 202: DUP I } F@ F. LOOP
! 203: DROP
! 204: ;
! 205:
! 206: : }fcopy ( 'src 'dest n -- ) \ copy one array into another
! 207: 0 DO OVER I } F@ DUP I } F! LOOP
! 208: 2DROP
! 209: ;
! 210:
! 211: : }fput ( r1 ... r_n n 'a -- ) \ store r1 ... r_n into array of size n
! 212: SWAP DUP 0 ?DO 1- 2DUP 2>R } F! 2R> LOOP 2DROP ;
! 213:
! 214: \ 2-D array definition,
! 215:
! 216: \ Monotype
! 217: \ ------------------------------
! 218: \ | m | cell_size | data area |
! 219: \ ------------------------------
! 220:
! 221: : MMATRIX ( n m size -- ) \ defining word for a 2-d matrix
! 222: CREATE
! 223: OVER , DUP ,
! 224: * * ALLOT
! 225: DOES> [ 2 CELLS ] LITERAL +
! 226: ;
! 227:
! 228: \ Structures
! 229: \ -----------------------------------
! 230: \ | id | m | cell_size | data area |
! 231: \ -----------------------------------
! 232:
! 233: : SMATRIX ( n m size -- ) \ defining word for a 2-d matrix
! 234: CREATE TYPE-ID ,
! 235: OVER , DUP ,
! 236: * * ALLOT
! 237: DOES> DUP @ TO TYPE-ID
! 238: [ 3 CELLS ] LITERAL +
! 239: ;
! 240:
! 241:
! 242: : MATRIX ( n m size -- ) \ defining word for a 2-d matrix
! 243: STRUCT-ARRAY? IF SMATRIX FALSE TO STRUCT-ARRAY?
! 244: ELSE MMATRIX
! 245: THEN
! 246: ;
! 247:
! 248: : DMATRIX ( size -- ) DARRAY ;
! 249:
! 250: : }} ( addr i j -- addr[i][j] ) \ word to fetch 2-D array addresses
! 251: >R >R
! 252: DUP cell- cell- 2@ \ &a[0][0] size m
! 253: R> * R> + *
! 254: +
! 255: ;
! 256:
! 257: : }}iprint ( n m addr -- ) \ print nXm elements of an integer 2-D array
! 258: ROT ROT SWAP 0 DO DUP 0 DO OVER J I }} @ .
! 259: LOOP
! 260: CR
! 261: LOOP
! 262: 2DROP
! 263: ;
! 264:
! 265:
! 266: : }}fprint ( n m addr -- ) \ print nXm elements of a float 2-D array
! 267: ROT ROT SWAP 0 DO DUP 0 DO OVER J I }} F@ F.
! 268: LOOP
! 269: CR
! 270: LOOP
! 271: 2DROP
! 272: ;
! 273:
! 274: : }}fcopy ( 'src 'dest n m -- ) \ copy nXm elements of 2-D array src to dest
! 275: SWAP 0 DO DUP 0 DO 2 PICK J I }} F@
! 276: OVER J I }} F!
! 277: LOOP
! 278: LOOP
! 279: DROP 2DROP
! 280: ;
! 281:
! 282: : }}fput ( r11 r12 ... r_nm n m 'A -- | store r11 ... r_nm into nxm matrix )
! 283: -ROT 2DUP * >R 1- SWAP 1- SWAP }} R>
! 284: 0 ?DO DUP >R F! R> FLOAT - LOOP DROP ;
! 285:
! 286: \ ================= Floating-point local variables ==================
! 287: (
! 288: loosely based upon Wil Baden's idea presented at FORML 1992.
! 289: The idea is to have a fixed number of variables with fixed names.
! 290:
! 291: example: : test 2e 3e FRAME| a b | a F. b F. |FRAME ;
! 292: test <cr> 3.0000 2.0000 ok
! 293:
! 294: Don't forget to use |FRAME before leaving a word that uses FRAME|.
! 295: )
! 296:
! 297: 8 CONSTANT /FLOCALS \ number of variables provided
! 298:
! 299: : (frame) ( n -- ) FLOATS ALLOT ;
! 300: : (unframe) ( addr -- ) HERE - ALLOT ;
! 301:
! 302: : FRAME|
! 303: POSTPONE HERE POSTPONE FALIGN POSTPONE >R
! 304: 0 >R
! 305: BEGIN BL WORD COUNT 1 =
! 306: SWAP C@ [CHAR] | =
! 307: AND 0=
! 308: WHILE POSTPONE F, R> 1+ >R
! 309: REPEAT
! 310: /FLOCALS R> - DUP 0< ABORT" too many flocals"
! 311: POSTPONE LITERAL POSTPONE (frame) ; IMMEDIATE
! 312:
! 313: : |FRAME ( -- ) POSTPONE R> POSTPONE (unframe) ; IMMEDIATE
! 314:
! 315: \ use a defining word to build locals cgm
! 316: : lcl ( n -- ) CREATE ,
! 317: DOES> @ FLOATS NEGATE HERE +
! 318: ;
! 319:
! 320: 8 lcl &a 7 lcl &b 6 lcl &c 5 lcl &d
! 321: : a &a F@ ; : b &b F@ ; : c &c F@ ; : d &d F@ ;
! 322: 4 lcl &e 3 lcl &f 2 lcl &g 1 lcl &h
! 323: : e &e F@ ; : f &f F@ ; : g &g F@ ; : h &h F@ ;
! 324:
! 325: BASE !
! 326: \ end of file
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fsl-util.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth