![[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|
Return to fsl-util.4th CVS log | Up to [gforth] / gforth |
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:
1.2 ! dbane 41: \ CR .( FSL-UTILG.FTH $Revision: 1.1 $ $Date: 2004-05-08 17:14:30 $ EFC )
1.1 anton 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:
1.2 ! dbane 61: [UNDEFINED] S>F [IF] : S>F S>D D>F ; [THEN]
1.1 anton 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 ;