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