Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.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 ; |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |