Annotation of gforth/fsl-util.4th, revision 1.1
1.1 ! anton 1: \ fsl-utilg.fth An auxiliary file for the Forth Scientific Library
! 2: \ For GForth
! 3: \
! 4: \ contains commonly needed definitions.
! 5: \ Revisions:
! 6: \ 2003-11-16 Fixed bug in }}, added }}FCOPY KM
! 7: \ 2004-02-12 Applied fixes to } and }} given by Marcel Hendrix
! 8: \
! 9: \ dxor, dor, dand double xor, or, and
! 10: \ sd* single * double = double_product
! 11: \ v: defines use( & For defining and settting execution vectors
! 12: \ % Parse next token as a FLOAT
! 13: \ S>F F>S Conversion between (single) integer and float
! 14: \ F, Store FLOAT at (aligned) HERE
! 15: \ F= Test for floating point equality
! 16: \ -FROT Reverse the effect of FROT
! 17: \ F2* F2/ Multiply and divide float by two
! 18: \ F2DUP FDUP two floats
! 19: \ F2DROP FDROP two floats
! 20: \ INTEGER, DOUBLE, FLOAT For setting up ARRAY types
! 21: \ ARRAY DARRAY For declaring static and dynamic arrays
! 22: \ } For getting an ARRAY or DARRAY element address
! 23: \ &! For storing ARRAY aliases in a DARRAY
! 24: \ PRINT-WIDTH The number of elements per line for printing arrays
! 25: \ }FPRINT Print out a given array
! 26: \ Matrix For declaring a 2-D array
! 27: \ }} gets a Matrix element address
! 28: \ Public: Private: Reset_Search_Order controls the visibility of words
! 29: \ frame unframe sets up/removes a local variable frame
! 30: \ a b c d e f g h local FVARIABLE values
! 31: \ &a &b &c &d &e &f &g &h local FVARIABLE addresses
! 32:
! 33:
! 34: \ This code conforms with ANS requiring:
! 35: \ 1. The Floating-Point word set
! 36: \ 2. The words umd* umd/mod and d* are implemented
! 37: \ for ThisForth in the file umd.fo
! 38:
! 39: \ This code is released to the public domain Everett Carter July 1994
! 40:
! 41: \ CR .( FSL-UTILG.FTH $Revision: 1.17 $ $Date: 12 Jun 1996 10:13:12 $ EFC )
! 42:
! 43: CR .( FSL-UTIL V1.17c 12 February 2004 EFC, KM )
! 44:
! 45: \ ================= compilation control ==============================
! 46:
! 47: \ for control of conditional compilation of test code
! 48: FALSE VALUE TEST-CODE?
! 49: FALSE VALUE ?TEST-CODE \ obsolete, for backward compatibility
! 50:
! 51:
! 52: \ for control of conditional compilation of Dynamic memory
! 53: TRUE CONSTANT HAS-MEMORY-WORDS?
! 54:
! 55: \ ====================================================================
! 56:
! 57:
! 58:
! 59: \ FSL NonANS words
! 60:
! 61: : S>F S>D D>F ;
! 62:
! 63: \ Words to control nested includes. Use as follows:
! 64: \ C" filename" ~INCLUDED [IF]
! 65: \ FILE: filename
! 66: \ ......the file contents...
! 67: \ [THEN]
! 68:
! 69: TRUE VALUE verbose_file? \ true to echo comment string on load
! 70:
! 71: WORDLIST CONSTANT <file-list>
! 72:
! 73: \ file name in <file-list>
! 74: : FILE: <file-list> SET-CURRENT CREATE FORTH DEFINITIONS
! 75: [CHAR] ) WORD
! 76: verbose_file? IF COUNT DUP IF CR TYPE ELSE 2DROP THEN
! 77: ELSE DROP THEN
! 78: ;
! 79:
! 80: \ check for included file name
! 81: : ~INCLUDED COUNT <file-list> SEARCH-WORDLIST
! 82: IF DROP FALSE ELSE TRUE THEN
! 83: ;
! 84:
! 85:
! 86: WORDLIST CONSTANT hidden-wordlist
! 87:
! 88: : Reset-Search-Order
! 89: FORTH-WORDLIST 1 SET-ORDER
! 90: FORTH-WORDLIST SET-CURRENT
! 91: ;
! 92:
! 93: : Public:
! 94: FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
! 95: FORTH-WORDLIST SET-CURRENT
! 96: ;
! 97:
! 98: : Private:
! 99: FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
! 100: hidden-wordlist SET-CURRENT
! 101: ;
! 102:
! 103: : Reset_Search_Order Reset-Search-Order ; \ these are
! 104: \ : reset-search-order Reset-Search-Order ; \ for backward compatibility
! 105:
! 106:
! 107: CREATE fsl-pad 84 CHARS ( or more ) ALLOT
! 108:
! 109: : dxor ( d1 d2 -- d ) \ double xor
! 110: ROT XOR >R XOR R>
! 111: ;
! 112:
! 113: : dor ( d1 d2 -- d ) \ double or
! 114: ROT OR >R OR R>
! 115: ;
! 116:
! 117: : dand ( d1 d2 -- d ) \ double and
! 118: ROT AND >R AND R>
! 119: ;
! 120:
! 121: \ : >= < 0= ; \ greater than or equal to
! 122:
! 123: \ : <= > 0= ; \ less than or equal to
! 124:
! 125: \ single * double = double
! 126: : sd* ( multiplicand multiplier_double -- product_double )
! 127: 2 PICK * >R UM* R> +
! 128: ;
! 129:
! 130:
! 131: : CELL- [ 1 CELLS ] LITERAL - ; \ backup one cell
! 132:
! 133:
! 134: 0 VALUE TYPE-ID \ for building structures
! 135: FALSE VALUE STRUCT-ARRAY?
! 136:
! 137: \ for dynamically allocating a structure or array
! 138:
! 139: TRUE VALUE is-static? \ TRUE for statically allocated structs and arrays
! 140: : dynamic ( -- ) FALSE TO is-static? ;
! 141:
! 142: \ size of a regular integer
! 143: 1 CELLS CONSTANT INTEGER
! 144:
! 145: \ size of a double integer
! 146: 2 CELLS CONSTANT DOUBLE
! 147:
! 148: \ size of a regular float
! 149: \ 1 FLOATS CONSTANT FLOAT
! 150:
! 151: \ size of a pointer (for readability)
! 152: 1 CELLS CONSTANT POINTER
! 153:
! 154: : % BL WORD COUNT >FLOAT 0= ABORT" NAN"
! 155: STATE @ IF POSTPONE FLITERAL THEN ; IMMEDIATE
! 156:
! 157: \ 3.1415926536E0 FCONSTANT PI
! 158: 1.0E0 FCONSTANT F1.0
! 159:
! 160: \ 1-D array definition
! 161: \ -----------------------------
! 162: \ | cell_size | data area |
! 163: \ -----------------------------
! 164:
! 165: : MARRAY ( n cell_size -- | -- addr ) \ monotype array
! 166: CREATE
! 167: DUP , * ALLOT
! 168: DOES> CELL+
! 169: ;
! 170:
! 171: \ -----------------------------
! 172: \ | id | cell_size | data area |
! 173: \ -----------------------------
! 174:
! 175: : SARRAY ( n cell_size -- | -- id addr ) \ structure array
! 176: CREATE
! 177: TYPE-ID ,
! 178: DUP , * ALLOT
! 179: DOES> DUP @ SWAP [ 2 CELLS ] LITERAL +
! 180: ;
! 181:
! 182: : ARRAY
! 183: STRUCT-ARRAY? IF SARRAY FALSE TO STRUCT-ARRAY?
! 184: ELSE MARRAY
! 185: THEN
! 186: ;
! 187:
! 188:
! 189: \ : Array ARRAY ;
! 190:
! 191: \ word for creation of a dynamic array (no memory allocated)
! 192:
! 193: \ Monotype
! 194: \ ------------------------
! 195: \ | data_ptr | cell_size |
! 196: \ ------------------------
! 197:
! 198: : DMARRAY ( cell_size -- ) CREATE 0 , ,
! 199: DOES>
! 200: @ CELL+
! 201: ;
! 202:
! 203: \ Structures
! 204: \ ----------------------------
! 205: \ | data_ptr | cell_size | id |
! 206: \ ----------------------------
! 207:
! 208: : DSARRAY ( cell_size -- ) CREATE 0 , , TYPE-ID ,
! 209: DOES>
! 210: DUP [ 2 CELLS ] LITERAL + @ SWAP
! 211: @ CELL+
! 212: ;
! 213:
! 214:
! 215: : DARRAY ( cell_size -- )
! 216: STRUCT-ARRAY? IF DSARRAY FALSE TO STRUCT-ARRAY?
! 217: ELSE DMARRAY
! 218: THEN
! 219: ;
! 220:
! 221:
! 222: \ word for aliasing arrays,
! 223: \ typical usage: a{ & b{ &! sets b{ to point to a{'s data
! 224:
! 225: : &! ( addr_a &b -- )
! 226: SWAP CELL- SWAP >BODY !
! 227: ;
! 228:
! 229:
! 230: : } ( addr n -- addr[n]) \ word that fetches 1-D array addresses
! 231: OVER CELL- @
! 232: * SWAP + ( ALIGNED FALIGNED )
! 233: \ ^^^^^^ commented out per bug fix of Marcel Hendrix 2/12/04
! 234: ;
! 235:
! 236: VARIABLE print-width 6 print-width !
! 237:
! 238: : }fprint ( n addr -- ) \ print n elements of a float array
! 239: SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
! 240: DUP I } F@ F. LOOP
! 241: DROP
! 242: ;
! 243:
! 244: : }iprint ( n addr -- ) \ print n elements of an integer array
! 245: SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
! 246: DUP I } @ . LOOP
! 247: DROP
! 248: ;
! 249:
! 250: : }fcopy ( 'src 'dest n -- ) \ copy one array into another
! 251:
! 252: 0 DO
! 253: OVER I } F@
! 254: DUP I } F!
! 255: LOOP
! 256:
! 257: 2DROP
! 258: ;
! 259:
! 260: \ 2-D array definition,
! 261:
! 262: \ Monotype
! 263: \ ------------------------------
! 264: \ | m | cell_size | data area |
! 265: \ ------------------------------
! 266:
! 267: : MMATRIX ( n m size -- ) \ defining word for a 2-d matrix
! 268: CREATE
! 269: OVER , DUP ,
! 270: * * ALLOT
! 271: DOES> [ 2 CELLS ] LITERAL +
! 272: ;
! 273:
! 274: \ Structures
! 275: \ -----------------------------------
! 276: \ | id | m | cell_size | data area |
! 277: \ -----------------------------------
! 278:
! 279: : SMATRIX ( n m size -- ) \ defining word for a 2-d matrix
! 280: CREATE TYPE-ID ,
! 281: OVER , DUP ,
! 282: * * ALLOT
! 283: DOES> DUP @ TO TYPE-ID
! 284: [ 3 CELLS ] LITERAL +
! 285: ;
! 286:
! 287:
! 288: : MATRIX ( n m size -- ) \ defining word for a 2-d matrix
! 289: STRUCT-ARRAY? IF SMATRIX FALSE TO STRUCT-ARRAY?
! 290: ELSE MMATRIX
! 291: THEN
! 292:
! 293: ;
! 294:
! 295:
! 296: : DMATRIX ( size -- ) DARRAY ;
! 297:
! 298:
! 299: : }} ( addr i j -- addr[i][j] ) \ word to fetch 2-D array addresses
! 300: \ 2>R \ indices to return stack temporarily
! 301: \ ^^^ above is bug in v1.17; replaced with line below KM
! 302: >R >R
! 303: DUP CELL- CELL- 2@ \ &a[0][0] size m
! 304: R> * R> + *
! 305: +
! 306: ( ALIGNED FALIGNED ) \ <-- MH bug fix 2/12/04
! 307: ;
! 308:
! 309:
! 310: : }}fprint ( n m addr -- ) \ print nXm elements of a float 2-D array
! 311: ROT ROT SWAP 0 DO
! 312: DUP 0 DO
! 313: OVER J I }} F@ F.
! 314: LOOP
! 315:
! 316: CR
! 317: LOOP
! 318: 2DROP
! 319: ;
! 320:
! 321:
! 322: : }}fcopy ( 'src 'dest n m -- ) \ copy n×m elements of 2-D array src to dest
! 323: SWAP 0 DO
! 324: DUP 0 DO
! 325: 2 PICK J I }} F@
! 326: OVER J I }} F!
! 327: LOOP
! 328: LOOP
! 329: DROP 2DROP
! 330: ;
! 331:
! 332:
! 333: \ function vector definition
! 334:
! 335: \ : noop ;
! 336:
! 337: : v: CREATE ['] noop , DOES> @ EXECUTE ;
! 338: : defines ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE !
! 339: ELSE ! THEN ; IMMEDIATE
! 340:
! 341: : use( STATE @ IF POSTPONE ['] ELSE ' THEN ; IMMEDIATE
! 342: : & POSTPONE use( ; IMMEDIATE
! 343:
! 344:
! 345:
! 346: (
! 347: CODE for local fvariables, loosely based upon Wil Baden's idea presented
! 348: at FORML 1992.
! 349: The idea is TO have a fixed number OF variables with fixed names.
! 350: I believe the CODE shown HERE will work with any, CASE insensitive,
! 351: ANS Forth.
! 352:
! 353: i/tForth users are advised TO use FLOCALS| instead.
! 354:
! 355: example: : test 2e 3e FRAME| a b | a F. b F. |FRAME ;
! 356: test <cr> 3.0000 2.0000 ok
! 357:
! 358: PS: Don't FORGET TO use |FRAME before an EXIT .
! 359: )
! 360:
! 361: 8 CONSTANT /flocals
! 362:
! 363: : (frame) ( n -- ) FLOATS ALLOT ;
! 364:
! 365: : FRAME|
! 366: 0 >R
! 367: BEGIN BL WORD COUNT 1 =
! 368: SWAP C@ [CHAR] | =
! 369: AND 0=
! 370: WHILE POSTPONE F, R> 1+ >R
! 371: REPEAT
! 372: /FLOCALS R> - DUP 0< ABORT" too many flocals"
! 373: POSTPONE LITERAL POSTPONE (frame) ; IMMEDIATE
! 374:
! 375: : |FRAME ( -- ) [ /FLOCALS NEGATE ] LITERAL (FRAME) ;
! 376:
! 377: : &h HERE [ 1 FLOATS ] LITERAL - ;
! 378: : &g HERE [ 2 FLOATS ] LITERAL - ;
! 379: : &f HERE [ 3 FLOATS ] LITERAL - ;
! 380: : &e HERE [ 4 FLOATS ] LITERAL - ;
! 381: : &d HERE [ 5 FLOATS ] LITERAL - ;
! 382: : &c HERE [ 6 FLOATS ] LITERAL - ;
! 383: : &b HERE [ 7 FLOATS ] LITERAL - ;
! 384: : &a HERE [ 8 FLOATS ] LITERAL - ;
! 385:
! 386: : a &a F@ ;
! 387: : b &b F@ ;
! 388: : c &c F@ ;
! 389: : d &d F@ ;
! 390: : e &e F@ ;
! 391: : f &f F@ ;
! 392: : g &g F@ ;
! 393: : h &h F@ ;
! 394:
! 395: \ stuff from jvn-util.fo
! 396:
! 397: : FINIT ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fsl-util.4th CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth