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