forked from dan4thewin/FreeForth2
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathfull.ff
562 lines (507 loc) · 24.9 KB
/
full.ff
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
\ full.ff load with needs or -f
\ --------------------------------------------------------------------
[1] [IF] "_stat&mmap" features append
\ st_dev 0 st_ino 12 st_mode 16 st_nlink 20 st_uid 24 st_gid 28 st_rdev 32
\ st_size 44 st_blksize 48 st_blocks 52 st_atim 56 st_mtim 64 st_ctim 72
create st_buf 98 allot
: stat zt st_buf tuck 98 0 fill 2 195 syscall ; \ stat64
: st_size st_buf 44+ @ ;
\ void *mmap(void *addr, size_t length, int prot, int flags, int fd, off_t offset);
\ Protections are chosen from these bits, OR'd together.
1 equ PROT_READ 2 equ PROT_WRITE 4 equ PROT_EXEC
\ Sharing types (must choose one and only one of these).
1 equ MAP_SHARED 2 equ MAP_PRIVATE
\ useful flags
$20 equ MAP_ANON $100 equ MAP_GROWSDOWN $4000 equ MAP_NORESERVE
: mkmm` create` 0 , 0 , -1 , PROT_READ , MAP_SHARED , anon:` ;
: mm.sz 4+ ;
: mm.fd 8+ ;
: mm.prot 12+ ;
: mm.flags 16+ ;
( @ # mm xt -- @ | -n )
: mmap_ swap >r -rot 2dup stat 0- 0< IF nip nip nip rdrop ;THEN drop st_size r mm.sz !
rot execute 0- 0< IF rdrop ;THEN dup r mm.fd !
0 swap r mm.flags @ r mm.prot @ r mm.sz @ 0 6 192 syscall dup r> ! ; \ mmap2
( @ # mm -- @ | -n )
: mmapr PROT_READ over mm.prot ! openr ' mmap_ ;
: mmapw PROT_READ PROT_WRITE | over mm.prot ! openw ' mmap_ ;
( @ # n mm -- @ | -n )
: mmapwt PROT_READ PROT_WRITE | over mm.prot !
>r -rot openw0 0- 0< IF rdrop ;THEN dup r mm.fd !
2dup 2 93 syscall 0- 0< IF nip nip rdrop ;THEN drop swap r mm.sz ! \ ftruncate
0 swap r mm.flags @ r mm.prot @ r mm.sz @ 0 6 192 syscall dup r> ! ; \ mmap2
( mm -- ior ior )
: munmap dup dup mm.sz @ swap @ 2 91 syscall swap mm.fd @ close ;
[THEN]
\ --------------------------------------------------------------------
\ call back
: 'callback:` '` :` \ xt <name> -- ; .. arg1 arg0 ret -C- .. arg1 arg0 ; 28/
\ 5A(pop edx)8D8424.00FFFFFF(lea eax,[esp-256])94(xchg eax,esp)
\ 52(push edx)60(pusha) \ -- ret eax ecx edx ebx esp ebp esi edi
\ 94(xchg eax,esp)5B(pop ebx)5A(pop edx)94(xchg eax,esp)E8.long(call xt)
$24848D5A, ,4 $FFFF'FF00, ,4 $94605294, ,4 $E8945A5B, ,4 here 4+ - ,
\ 895C24.1C(mov[esp+28],ebx)61(popa)C2.0001(ret 256)
$1C245C89, ,4 $0100C261, ,4 anon:`
;
: stopdump? key 10- drop ;
: ;dump` ;` BEGIN 16 bounds under 2dump stopdump? UNTIL drop ; \ @ --
: .dec base@ 10 base! swap . base! ; \ n -- ; display in decimal
: .dec\ base@ 10 base! swap .\ base! ; \ n -- ; display in decimal
\ --------------------------------------------------------------------
\ console display control (topleft=0,0)
: cls` ( -- ) ."^[[2J"
: home ( -- ) 0 dup
: atxy ( xCol yRow -- ) ."^[[" 1+ .\ .";" 1+ .\ ."H" ;
[1] [IF] "_normal" features append \ symbolic attributes and color names
: `color ( n -- ) ."^[[" .\ ."m" ;
: normal 0 `color ; : bold 1 `color ; : dim 2 `color ;
: underline 4 `color ; : blink 5 `color ; : inverse 7 `color ;
: concealed 8 `color ; : foreground 30+ `color ; : background 40+ `color ;
0 constant black 1 constant red 2 constant green 3 constant yellow
4 constant blue 5 constant magenta 6 constant cyan 7 constant white
[THEN]
\ --------------------------------------------------------------------
[1] [IF] "_.now" features append \ Calendar date and time display
: `leap .dec\ ."-2-29" drop ;
: .d ( n -- ; display days since 0-0-0 as gregorian date )
146097 /% 400* swap 146096 = drop IF swap 400+ `leap ;THEN
36524 /% 100* rot + swap
1461 /% 4* rot + swap 1460 = drop IF swap 4+ `leap ;THEN
365 /% rot + swap \ -- y rem
dup 31+ 5* 153/ 2+ tuck 1+ 153* 5/ 123- - -rot \ -- d y m
12 > drop IF 12- swap 1+ swap THEN swap \ -- d m y
.dec\ ."-" .dec\ ."-" .dec\ ;
: .wd ( n -- ) 7% 3* "wedthufrisatsunmontue" drop + 3 type ;
: now \ -- n ; returns number of seconds since 2000-3-1_0:0:0
0 1 13 syscall [ 1970-1-1 2000-3-1- 24:0:0* 1:0:0+ ] lit + ;
: .now` ( -- ) now dup 24:0:0/ .wd space \ display current date&time
: .dt ( n -- ) 24:0:0 /% 2000-3-1+ .d ."\_" \ display seconds as date&time
: .t ( n -- ) 60 /% 60 /% .dec\ .":" .dec\ .":" .dec ; \ display seconds as time
[THEN]
\ --------------------------------------------------------------------
[1] [IF] "_{{{" features append \ Performance measurement: {{{ sample code }}}
\ First try "{{{ }}}" to measure the measurement overhead
\ 50(push eax)0F31(rdtsc)89C2(mov edx,eax)58(pop eax)
: rdtsc` over` >S1 $89310F50, ,4 $58C2, ,2 ; \ read i386 time-stamp counter
create ts 64 allot
: {{{` ( -- ) "ts_16_TIMES_dup>r_rdtsc_swap_!" eval ;
: }}}` ( -- ) "rdtsc_r>_tuck-!_4+_REPEAT_drop_;" eval
ts 16 TIMES @+ negate . REPEAT drop cr ;
[THEN]
: ms@ \ -- n ; get current milliseconds count
eob 0 over 2 78 syscall drop 2@ 1000* swap 1000/ + ;
: ms \ n -- ; wait n milliseconds
1000 /% swap 1'000'000* swap eob 2! 0 eob 2 162 syscall drop ;
\ --------------------------------------------------------------------
[1] [IF] "_+longconds" features append \ long conditionals
\ ff.boot default conditionals are limited to byte offsets for forward jumps
\ (backward jumps use byte offsets when possible, otherwise long offsets):
\ this is efficient and encourages programmers to write small definitions.
\ Would you ever need to write bigger definitions requiring long offsets,
\ this is for you: type "+longconds" to switch to long forward conditionals;
\ you can also type "-longconds" to switch back to byte forward conditionals;
\ WARNING: DON'T switch forth or back in the middle of a control structure!
\ 72:bc/aenc 74:z/nz 76:be/a 78:s/ns 7C:l/ge 7E:le/g (long:+0F10)
\ E0:loopnz/loopz E2:loop/jecxz(byte) E8:call/jmp(long) EB:jmp(byte)
: `then here over- 4- swap ! ;
: IF' `cond $0F c, $10+ c, here SC c@ , ;
: SKIP' $E9 c, here SC c@ , ;
: ELSE' SKIP' swap dupc@ SC c!
: THEN' dupc@ >SC `then ;
: ;THEN' ;;` dupc@ SC c! `then ;
: START' $90 c, align` $E9 here 1- c! 0 , BEGIN` ;
: TIMES' >r`
: RTIMES' BEGIN` $880F08FF , 0 , ; \ dec[eax] js.l
: ENTER' `mrk@ dup 3& >SC -4& 4- `then ;
: WHILE' `mrk 2@ 3& >SC `cond $0F c, $10+ c, here `mrk 4+ ! , ;
: BREAK' `mrk 2@ 3& >SC $E9 c, here `mrk 4+ ! , THEN' ;
: CASE' =` drop` IF' drop` ;
: AGAIN' $EB `-jmp THEN' ;
: UNTIL' TILL`
: END' `mrk 2@ dup 3& >SC -4& swap \ -mrk +mrk
START dup@ swap `then ENTER = UNTIL \ -mrk -mrk
@ $880F08FF- 0= drop IF under 4+ `then rdrop` THEN \ balance RTIMES
drop `mrk 2! ;
: REPEAT' $EB `-jmp END' ;
: -longconds' \ -- ; remove headers -longconds`..IF`
[ "`then" find 2drop which@ H@ - constant `size ]
"-longconds`" find IF !"-longconds`_not_found" ;THEN 2drop
H@ which@ START 1- dupc@ over `size+ c! ENTER = UNTIL drop `size+ H! ;
: +longconds` \ -- ; copy headers -longconds'..IF' -> -longconds`..IF`
"-longconds'" find 2drop which@ `size H@ dup>r over- place dup H!
'`' swap BEGIN 5+ dupc@ + 2dupc! 2+ r = drop UNTIL 2drop rdrop ;
[THEN]
\ --------------------------------------------------------------------
[0] [IF] "_compat" features append \ RetroForth/Reva/HelFORTH compatibility words
\ RetroForth/Reva control structures (see also "help conditionals")
\ 72:bc/aenc 74:z/nz 76:be/a 78:s/ns 7C:l/ge 7E:le/g (long:+0F10)
\ E2:loop/jecxz(byte) E8:call/jmp(long) EB:jmp(byte)
: if` $840F : `if1 $DB09, s09 : `ifx drop` w, here SC c@ , ;
: 0=if` $850F `if1 ;
: 0<if` $890F `if1 ;
: 0>=if` $880F `if1 ;
: =if` $850F : `if2 $DA39, s09 drop` `ifx ;
: <>if` $840F `if2 ;
: <if` $8D0F `if2 ;
: <=if` $8F0F `if2 ;
: u<if` $830F `if2 ;
: u<=if` $870F `if2 ;
: ;then` ;;` dupc@ SC c!
: then` dupc@ >SC here over- 4- swap ! 0 callmark ! ;
: else` $E9 c, here SC c@ , swap then` ;
: for` >r`
: repeat` here SC c@ ;
: again` >SC 0 SC c! here - dup -$7E <if $E9 c, 5- , ;then
$EB c, 2- c, ;
: while` $DB09, s09 drop` >SC here - dup -$7E <if $850F w, 6- , ;then
$75 c, 2- c, ;
: next` >SC here - dup -$7C <if $8F0F08FF , 8- , rdrop` ;then
$FC7F08FF , here 1- +! rdrop` ;
: `;loc which@ 5+ c@+ + 1+ H! ; \ -- ; restore H after last found header
: loc:` ";loc`" `;loc ' 0 header ; \ -- ; see also FreeForth hid'm
[THEN]
\ --------------------------------------------------------------------
[1] [IF] "_f." features append \ Uses FPU hardware stack: 8-cells * 80-bits(tword)
\ Stack notation: "f:x" represents 80-bits float "x" on FPU stack
10 constant fcell \ fcell+ fcell- fcell* fcell/ (see literalcompiler)
\ FPU Status-Word(ro) and Control-Word(rw) access:
\ 8D40FC(eax-=4)DD38(fnstsw[eax])871087DA(xchg edx,[eax] xchg ebx,edx)
: fsw@ ,"^M~@|~]~8^G~^P^G~Z~" ; \ -- w ; don't care MSword: use .w
\ 8D40FC(eax-=4)D938(fnstcw[eax])871087DA(xchg edx,[eax] xchg ebx,edx)
: fcw@ ,"^M~@|~Y~8^G~^P^G~Z~" ; \ -- w ; don't care MSword: use .w
\ 87DA8710(xchg ebx,edx xchg edx,[eax])D928(fldcw[eax])8D4004(eax+=4)
: fcw! ,"^G~Z~^G~^PY~(^M~@^D" ; \ w -- ; don't care MSword
\ C740FC.7F07'7F03(mov[eax-4],$037F'077F) nearest'-infinity '0F7F=truncate
\ D968FC(fldcw[eax-4])D9FC(frndint)D968FE(fldcw[eax-2])
: floor ,"G~@|~^?^G^?^CY~h|~Y~|~Y~h\~~" ; \ f:i.f -- f:i.0 ; integer part
\ Convert between 32-bits integer on DATAstack and 80-bits float on FPU stack
\ 8D40FC(eax-=4)DB18(fistp dw[eax])871087DA(xchg edx,[eax] xchg ebx,edx)
: f>s ,"^M~@|~[~^X^G~^P^G~Z~" ; \ f:n -- n ; convert float to single int
\ 87DA8710(xchg ebx,edx xchg edx,[eax])DB00(fild dw[eax])8D4004(eax+=4)
: s>f ,"^G~Z~^G~^P[~^@^M~@^D" ; \ n -- f:n ; convert single int to float
\ Convert between 64-bits C-double on DATAstack and 80-bits float on FPU stack
\ (for interfacing with C dynamic libraries using double floats)
\ 8D40F8(eax-=8)DD18(fstp qw[eax])8718875004(xchg ebx,[eax] xch edx,[eax-4])
: f>df ,"^M~@x~]~^X^G~^X^G~P^D" ; \ f:df -- df ; convert float to C-double
\ 8718875004(xchg ebx,[eax] xchg edx,[eax-4])DD00(fld qw[eax])8D4008(eax+=8)
: df>f ,"^G~^X^G~P^D]~^@^M~@^H" ; \ df -- f:df ; convert C-double to float
\ Class2 = FPU macro, inlines 1 or 2 FPU instructions embedded in its header:
: `f:` ;` wsparse rot 2 header ; \ FPUinstr <name> -- ; class2 definer
: `f, dup lit` $FFFF0000& drop IF ,` ;THEN w,` ; \ postpone, immediate;
: `f; dup $FFFF0000& drop IF , ;THEN w, ; `f, ' `f; ' classes &20+ 2! ;
$E3DB `f: finit` \ fninit initialize FPU cw=$037F sw=$0000
$EED9 `f: 0.` \ fldz
$E8D9 `f: 1.` \ fld1
$EBD9 `f: fpi` \ fldpi
$C0D9 `f: fdup` \ fld st0
$C1D9 `f: fover` \ fld st1
$D8DD `f: fdrop` \ fstp st0
$D9DD `f: fnip` \ fstp st1
$C9D9 `f: fswap` \ fxch st1
$C1D9C9D9 `f: ftuck` \ fswap` fover`
$C9D9C1D9 `f: funder` \ fover` fswap`
$CAD9C9D9 `f: frot` \ fswap` fxch st2
$C9D9CAD9 `f: f-rot` \ fxch st2 fswap`
$C1D9C1D9 `f: f2dup` \ fover` fover`
$D8DDD8DD `f: f2drop` \ fdrop` fdrop`
$C1DAF1DB `f: `fmax` \ fcomi fcmovb st1
$D1DBF1DB `f: `fmin` \ fcomi fcmovnbe st1
: fmax` `fmax` fnip` ;
: fmin` `fmin` fnip` ;
$E0D9 `f: fnegate` \ fchs
$E1D9 `f: fabs`
$C1DE `f: f+` $C1D8 `f: fover+` \ faddp fadd st0,st1
$E9DE `f: f-` $E1D8 `f: fover-` \ fsubp fsub st0,st1
$E1DE `f: fswap-` \ fsubrp
$C9DE `f: f*` $C9D8 `f: fover*` \ fmulp fmul st0,st1
$F9DE `f: f/` $F1D8 `f: fover/` \ fdivp fdiv st0,st1
$F1DE `f: fswap/` \ fdivrp
: f1/` 1.` fswap/` ;
$FAD9 `f: fsqrt`
$EDD9 `f: `fldln2`
$ECD9 `f: `fldlg2`
$EAD9 `f: `fldl2e`
$E9D9 `f: `fldl2t`
$F0D9 `f: `f2xm1` \ f:x -- f:2**x-1 ; |x|<=1
$F4D9 `f: `fxtract` \ f:x -- f:e=floor(lb(x)) f:x/2^e
$D9DDFDD9 `f: `fscale` \ f:e f:m -- f:m*2^trunc(e) ; (with fnip)
$F1D9C9D9 `f: `fxl2y` \ fxch fyl2x
$F9D9C9D9 `f: `fxl2yp1` \ fxch fyl2xp1
: fln` `fldln2` SKIP
: flog` `fldlg2` THEN `fxl2y` ; \ lgX=lbX/lb10 lg2=lb2/lb10 => lgX=lbX*lg2
: fasinh fdup fover* 1. f+ SKIP \ ln(x+sqrt(x*x+1))
: facosh fdup fover* 1. f- THEN \ ln(x+sqrt(x*x-1))
fsqrt f+ fln ;
: fatanh 1. fover- fln fswap `fldln2 `fxl2yp1 fswap- \ (ln(1+x)-ln(1-x))/2
: f2/ 1. fnegate fswap `fscale ;
: f2* 1. fswap `fscale ;
: f** `fxl2y SKIP
: faln `fldl2e SKIP
: falog `fldl2t THEN f* THEN \ -- f:x*l2(y)
fdup floor fswap fover- `f2xm1 1. f+ `fscale ;
: fsinh faln 1. fover/ f- f2/ ; \ (e(x)-e(-x))/2
: fcosh faln 1. fover/ f+ f2/ ; \ (e(x)+e(-x))/2
: ftanh f2* faln 1. fover- fswap 1. f+ f/ ; \ (e(2x)-1)/(e(2x)+1)
$FED9 `f: fsin`
$FFD9 `f: fcos`
$FBD9 `f: fsincos` \ f:x -- f:sin f:cos
$D8DDF2D9 `f: ftan` \ fptan(-- f:tan f:1) fdrop`
$F3D9E8D9 `f: fatan` \ fld1 fpatan
$F3D9 `f: fatan2` \ f:y f:x -- f:atan(y/x) ; fpatan
: facos fdup fover* 1. fswap- fsqrt fswap fatan2 ; \ fatan(sqrt(1-x*x)/x)
: fasin fdup fover* 1. fswap- fsqrt fatan2 ; \ fatan(x/sqrt(1-x*x))
\ 72:bc/aenc 74:z/nz 76:be/a
: f0<` $77 : `f?1 $F1DFEED9 , `?1 ; \ fld0 fcomip st0,st1
: f0>=` $76 `f?1 ;
: f0<>` $75 `f?1 ;
: f0=` $74 `f?1 ;
: f0<=` $73 `f?1 ;
: f0>` $72 `f?1 ;
: f<` $77 : `f?2 $F1DB w, `?1 ; \ fcomi st0,st1
: f>=` $76 `f?2 ;
: f<>` $75 `f?2 ;
: f=` $74 `f?2 ;
: f<=` $73 `f?2 ;
: f>` $72 `f?2 ;
: f~ \ f:y f:x f:t -- f:y f:x ; nz? t>0:|y-x|<t, t=0:y==x, t<0:|y-x|<|t*(y+x)|
f0= IF fdrop f= nzTRUE ? zFALSE ;THEN \ bitwise comparison
f0< IF fover ,"X~C~" f* fabs \ D8C3(fadd st0,st3)
THEN fover ,"X~c~" fabs f> f2drop nzTRUE ? zFALSE ; \ D8E3(fsub st0,st3)
: dupf!` $3BDB, s01 ; \ f:n @ -- @ ; fstp tw[ebx]
: dupf@` $2BDB, s01 ; \ @ -- @ f:n ; fld tw[ebx]
: f+!` dupf@` f+`
: f!` dupf!` drop` ;
: f@` dupf@` drop` ;
: f,` $7DDB w, $0A6D8D00 , ; \ DB7D00(fstp[ebp])8D6D0A(lea ebp,[ebp+10])
: fvariable` create` 0. f, anon:` ;
: flit` $0AEB w, here >r f, \ jmp+10 fliteral
: `fcst $2DDB w, r> , ; \ fld tw[@]
: fconstant` \ f:n <name> -- ; -- f:n ; compiles a macro compiling "fld tw[@]"
;` wsparse 2dup+ dupc@ >r dup>r '`' swap c! 1+ \ append `
here 0 header 2r> c! `fcst ' call, f, anon:` ;
variable f# 4 f#! \ number of displayed digits < 20
$E5D9 `f: `fxam` \ sw&4500= 4000:ZERO 0500:INF 0100:NaN
: `fdigit fdup floor fdup f>s '0'+ emit f- fover* ; \ f:10 f:x -- f:10 f:x
: f. \ f:n -- ; display float in scientific format with f# significant digits
f0< IF ."-" THEN fabs `fxam fsw@ $4500& $4000 CASE ."0._" fdrop ;THEN
$500 CASE ."INF_" fdrop ;THEN $100 CASE ."NaN_" fdrop ;THEN drop
fdup flog floor f#@ 1- s>f f- falog f2/ f+ \ round LSdigit, may carry up
fdup flog floor fdup f>s falog f/ \ -- exp f:mant
10 s>f fswap `fdigit ."." f#@ 1- TIMES `fdigit REPEAT f2drop \ -- exp
."e" .dec ; \ display exponent in decimal
: f.s` \ -- ; display full stack (uses eob)
[ $35DD w, eob , ] \ fnsave[eob] cw[4],sw[4],env[20],stack[8*10]
eob 4+ w@ 11 >> negate 7& \ -- #items
[0] [IF] \ minimum display, TOS last on right:
dup .\ .":_" eob 28+ over 10* + swap TIMES 10- dupf@ f. REPEAT drop cr
[ELSE] \ full binary display, TOS first on top:
eob 7 TIMES @+ .l space REPEAT cr \ FPU-environment: 7 dwords
swap TIMES 10 TIMES r over+ c@ .b REPEAT space dupf@ f. cr 10+ REPEAT drop
[THEN]
[ $25DD w, eob , ] ; \ frstor[eob]
:^ `ferror !"???" \ vectorizable float-parsing-error handler
: fnumber \ @ # -- f:n ; converts string to float
dup 2- 0< drop `ferror ? 10 s>f 0.
bounds dupc@ '-'- >r 0= IF 1+ THEN swap dup>r swap \ sign dpl@end
BEGIN c@+ BEGIN \ -- @end @ c
'.' CASE r> u> drop `ferror ? dup>r BREAK \ dpl@
'e' CASE r> 1+ over- 0> IF 0_ THEN -rot swap over- \ -- expn @ #
0= `ferror ? number 0- `ferror ? -rot + >r dup BREAK \ -- 0 0
'0'- 9 u> drop `ferror ? fover* s>f f+
END u<= UNTIL drop fnip r> swap - s>f falog f*
r> 0- 0= drop IF fnegate THEN ;
\ link float-literal-compiler to "notfound" and redefine "notfound":
: `f# fnumber flit` ; `f# ' notfound !^ `ferror ' alias notfound
finit ; \ comment this line to disable FPU initialization when loading ff.ff
[THEN] \ 7.5Ksource = 1.6Kcode + 1.3Kheaders
\ --------------------------------------------------------------------------
[1] [IF] "_sqrt" features append \ integer square root (bit per bit algorithm, see Wikipedia)
: sqrt \ u -- sqrt(u) ; unsigned input, rounded (or truncated [*]) output
0 $4000'0000 \ -- u sqrt one ; u = remainder, one = current bit
BEGIN dup>r + \ -- u sqrt+one | == one
u< IF r - ELSE swap over- swap r + THEN \ undo(bit=0), or reduce u(bit=1)
1 >> r> 4/ \ -- u sqrt/2 one/4 ; (note: "1 >>" doesn't propagate MSBit)
0= UNTIL drop \ -- u sqrt ; final remainder and truncated square root
\ [*] (un)comment the following line for a (rounded)truncated result: [*]
u> IF 1+ THEN \ -- u sqrt ; round to nearest integer
nip \ -- sqrt
;
[THEN]
\ --------------------------------------------------------------------------
[1] [IF] "_uart!" features append \ Serial interface
\ HOWTO:
\ + list all available comm-ports: .ports` \ Lin:ttyS0..ttyUSB0.. Win:COM1..
\ + select one of 4 UART contexts: 3 uart! \ default: 0 uart! 0 port!
\ + select context comport number: 1 port! \ max=63, Linux:32-63=ttyUSB0..31
\ + select speed and open comport: 115200 bps \ no default speed
\ + select parity (default=none) : evenParity \ oddParity noParity
\ + display current context conf.: .bps` \ macro-executes previous anon-def
\ + receive/send 1 byte, a buffer: RX(--c) TX(c--) XRECV(@ #--) XSEND(@ #--)
\ + trace received and sent bytes: utrace on \ trace off (disable)
\ + emulate a very dumb terminal: dumbterm \ dumpterm (hexa)
create COM \ UART current context
-1 , \ file-descriptor (-1=invalid)
0 , \ bps<<8, USB<<7, port<<2 (/dev/ttyS0=COM1 /dev/ttyUSB0=USB1), context#
-1 , 0 , -1 , 1 , -1 , 2 , -1 , 3 , \ 4 contexts
: uart! \ n -- ; switch UART context
COM 2@ over 3& 1+ 8* COM+ 2! 3& 1+ 8* COM+ 2@ COM 2!
;
\ Linux implementation requires: asroot> chmod o+rw /dev/ttyS?
\ Note: /bin/stty is used to configure "raw" access to /dev/ttyS?;
\ using /bin/setserial to setup the speed allows all 115200 submultiples.
\ http://ftdi-usb-sio.sourceforge.net USB-TO-SERIAL "FTDI" converter cable:
\ - set tty->termios->c_cflag speed to B38400
\ - set your real speed in tty->alt_speed; it gets ignored when alt_speed==0
: port! \ n -- ; setup port no: 0=/dev/ttyS0 31=ttyS31 32=ttyUSB0 63=ttyUSB31
$3F& 4* COM 4+ @ 3& + COM 4+ !
;
: .ports` \ -- ; displays all available ttyS* or ttyUSB* ports
"/dev/ttyUSB0^@" "/dev/ttyS0^@"
2 BEGIN >r 32 BEGIN >r 2dup+ 1- \ -- @ # @+#-1
r ~ $1F& 10 /% swap '0'+ swap 0- IF '0'+ swap THEN rot tuckc! 1- c!
2dup openr dup eob $5401 rot ioctl swap close drop 0- drop \ -- @ #
0= IF over 5+ over 5- type space THEN
r> 1- 0= UNTIL drop 2drop r> 1- 0= UNTIL drop
;
: bpsx COM 2@ SKIP \ to skip "close"
: bps \ bps -- ; open UART r/w at bps bits-per-second in raw mode[n,8,1]
COM 2@ close THEN drop $FF& \ -- bps s ; flush serial, s with speed null
"/bin/stty___38400_raw_-echo_cs8_-parenb_-cstopb_</dev/ttyUSB0_"
\ 123456789012345^ ^1098^65432^0
dup>r swap dup>r + 1- >r \ -- bps s | == # @ @+#-1 ; setup port type&number:
dup $80& drop IF "ttyUSB" ELSE "./ttyS" THEN r 7- place drop
dup 4/ $1F& 10 /% 0- 0= IF $10- swap THEN '0'+ swap '0'+ r tuckc! 1- c!
\ '0'+ r 1- c! '0'+ r c!
\ -- bps s | == # @ @+#-1
[1] [IF] \ with /bin/stty only, for standard baudrates:
over $100* + swap r> swap r 16+ swap \ -- s @+#-1 @+16 bps | == # @
7 TIMES 0- IF 10 /% >r '0'+ ELSE >r $20 THEN overc! 1- r> REPEAT 2drop
\ -- s @+#-1 | == # @ ; /bin/stty command ready
[ELSE] \ with /bin/setserial (to be installed), for custom baudrates:
tuck $80& 115'200_ IF 24'000'000_ THEN \ -- s bps clk | -- # @ @+#-1
swap under / tuck / $100* rot + \ -- div s ; s with bps
\ man setserial: gives 115200/divisor bps when 38400 bps asked
"/bin/setserial_/dev/ttyUSB0__spd\_cust_divisor_______3" \ -- div s @ #
\ 123456789ABCDE^
over $F+ r 12- swap 13 cmove \ copy port type/number from /bin/stty command
dup>r swap dup>r + 1- rot \ -- s @+#-1 div | -- # @ @+# # @ ; setup divisor:
7 TIMES 0- IF 10 /% >r '0'+ ELSE >r $20 THEN overc! 1- r> REPEAT 2drop
r> r> shell r> \ -- s @+# | == # @ ; execute /bin/setserial command
[THEN] \ -- s @+#-1 | == # @
r> r> shell \ -- s @+#-1 ; execute /bin/stty command
dupc@ $20- 12_ IF 1+ THEN swap 12- swap openw tuck COM 2! ?ior
;
\ variable `fdset 0 , 0 , \ the 2 zeros are a null timeval
\ : select 5 142 syscall ; \ timeval* exceptfds* writefds* readfds* n -- ?
\ : TX? \ -- ; nz? ; returns zFALSE if TX would wait for available space
\ 1 COM@ << `fdset! \ fd_set WRITE; select will return 0 or 1 (or 0<)
\ `fdset 4+ 0 `fdset 0 $20 select dup ?ior 0- drop
\ ;
: RX? \ -- ; nz? ; returns zFALSE if RX would wait for available data
COM@ `fdin?
;
: `waitRX \ -- c ; waits until RX? or throws KBDirq/RX when key?
1 COM@ << 1+ `fdset! \ fd_set READ([n]=uart,[0]=stdin)
0 0 0 `fdset $20 select ?ior \ -- ; sleep until key? or RX?
`fdset@ 1& IF !"KBDirq/RX" ;THEN
`io_ 1 under COM@ read ?ior c@
;
\ Linux functions for UART signals control:
\ DB9-25: 1<DCD<8 2<RD<3 3>TD>2 4>DTR>20 5-GND-7 6<DSR<6 7>RTS>4 8<CTS<5 9<RI<22
\ DB9F-0: 1<DCD<4 2<RD<1 3>TD>7 4>DTR>9 5-GND-5 6<DSR<3 7>RTS>8 8<CTS<2 9<RI<6
\ DB9F-1: 2<RD<10 3>TD>12 5-GND<5 3V3<15 7>RTS>13 8<CTS<11
\ C02kbd: 8<BLTX 7>BLRX 2>RST 1-GND 3>TCK 3>3V
\ C03kbd: 3<UTX1 2>URX1 1-GND 8>3V3 7>3V
\ see Linux Serial Programming HOWTO
\ - ioctl requests from /usr/include/asm/ioctls.h:
\ . TCGETS 5401 GETStruct termios
\ . TCSETS 5402 SETStruct termios
\ . TCSBRK 5409 SendBReaK during (int)arg*100ms
\ . TIOCMGET 5415 ModemGET signals
\ . TIOCMBIS 5416 ModemBItSet
\ . TIOCMBIC 5417 ModemBItClear
\ . TIOCMSET 5418 ModemSET signals
\ . TIOCGSERIAL 541E GetSERIAL
\ . TIOCSSERIAL 541F SetSERIAL
\ - TCGETS/TCSETS (struct*termios)arg bits from /usr/include/asm/termbits.h:
\ . c_cflag:
\ CBAUD $100F \ &10017 struct termios { // 25 bytes:
\ B4800 $000C \ &00014 uint c_iflag; // input mode flags
\ B9600 $000D \ &00015 uint c_oflag; // output mode flags
\ B38400 $000F \ &00017 uint c_cflag; // control mode flags
\ B115200 $1002 \ &10002 uint c_lflag; // local mode flags
\ CS8 $0030 \ &00060 uchar c_line; // line discipline
\ PARENB $0100 \ &00400 uchar c_cc[8]; // control characters
\ PARODD $0200 \ &01000 };
\ - TIOCM (int*)arg bits from /usr/include/asm/termios.h:
\ TIOCM_LOOP 8000 16: struct winsize { // 8 bytes:
\ TIOCM_OUT2 4000 15> ushort ws_row, ws_col;
\ TIOCM_OUT1 2000 14> ushort ws_xpixel, ws_ypixel;
\ TIOCM_DSR 0100 8< DataSetReady };
\ TIOCM_RI 0080 7< RingIndicator struct termio { // 17 bytes: obsolete
\ TIOCM_CD 0040 6< CarrierDetect ushort c_iflag; // input mode flags
\ TIOCM_CTS 0020 5< ClearToSend ushort c_oflag; // output mode flags
\ TIOCM_SR 0010 4: SecondaryReceive ushort c_cflag; // control mode flags
\ TIOCM_ST 0008 3: SecondaryTransmit ushort c_lflag; // local mode flags
\ TIOCM_RTS 0004 2> RequestToSend uchar c_line; // line discipline
\ TIOCM_DTR 0002 1> DataTerminalReady uchar c_cc[8]; // control characters
\ TIOCM_LE 0001 0: LineEnable }; // struct termios: s/ushort/uint/
: DSR? $100 SKIP
: RI? $080 SKIP
: CD? $040 SKIP
: CTS? $020 THEN THEN THEN
eob $5415 COM@ ioctl ?ior \ 5415=TIOCMGET
eob@ & drop ; \ -- z?
: DTR1 $5416 SKIP \ 5416=TIOCMBIS 5417=TIOCMBIC
: DTR0 $5417 THEN 2 SKIP \ 2=TIOCM_DTR.4 4=TIOCM_RTS.7
: RTS1 $5416 SKIP \ MSP:~DTR=RST/NMI,~RTS=TCK/TST-VPP
: RTS0 $5417 THEN 4 THEN
eob tuck! swap COM@ ioctl ?ior ;
: UBREAK 1 $5409 COM@ ioctl ?ior ; \ 1=100ms
: `TCGETS $5401 SKIP \ termios@ --
: `TCSETS $5402 THEN COM@ ioctl ?ior ;
: noParity $0000 SKIP \ default
: oddParity $0300 SKIP
: evenParity $0100 THEN THEN $FCFF
eob `TCGETS eob 8+ @ & | eob 8+ ! eob `TCSETS
;
: .bps` \ -- ; display current context
;` COM 4+ @ ."uart" dup 3& .\ dup $80& drop IF .":ttyUSB" ELSE .":ttyS" THEN
dup 4/ $1F& .dec eob `TCGETS $100/ .dec ."bps_8bits_" eob 8+ @ $300&
BEGIN IF $200& IF ."odd" BREAK ."even" BREAK ."no" END drop ."Parity_1stop^J"
;
variable utrace \ default 0: no trace
: RX \ -- c ; receive one byte
`waitRX \ wait aborted by throwing "KBDirq/RX" exception when "key?"
utrace@ 0- drop IF ."<" dup .b THEN
;
: TX \ c -- ; send one byte
utrace@ 0- drop IF .">" dup .b THEN
`io tuckc! 1 COM@ write ?ior
;
: XRECV TIMES RX overc! 1+ REPEAT drop ; \ @ # -- ; receive # bytes at @
: XSEND TIMES c@+ TX REPEAT drop ; \ @ # -- ; send # bytes starting from @
: dumbterm` 1 SKIP \ hexa[00..1F]ascii[20..7E]hexa[7F..FF]CR[0D]LF[0A]
: dumpterm` 0 THEN >r \ hexa[00..FF]
BEGIN normal RX ' catch 0- drop 0= IF \ (nz when key?)
inverse r 0- IF \ dumbterm:
$7E_ <= IF $20_ >= IF : `e drop emit AGAIN 13_ = `e ? 10_ = `e ? THEN
THEN '\'_ emit .b AGAIN
here dup 256 accept \ -- here n ; Lin:here+n-1:^J Win:here+n-2:^M^J
over+ 1- 13 swap ! \ EOL:^M^@^@^@
BEGIN c@+ 0- WHILE \ -- @ c
'^' CASE c@+ $40^ ELSE \ -- @ c ; "^c":control-char
'\' CASE dup 2+ swap 1- '$' overc! 3 number \ -- @+2 n 0 ; "\xx":hexa
0- drop IF swap 1- nipdup 1- c@ \ -- @+1 c
13 <> drop WHILE \ -- @+1 c ; "\EOL":zapCR
'q' = drop IF 2drop rdrop ;THEN \ "\q":quit.
THEN THEN THEN TX \ -- @+1
REPEAT 2drop \ --
REPEAT
;
[THEN] \ 10Ksource = 2Kcode + 0.4Kheaders
\ --------------------------------------------------------------------------
\ uncomment the following line to remove all headers with initial backquote:
hid'm "_hid'm" features append ;
EOF skips to End-Of-File, so everything after EOF is ignored.
This may be a good place for any comment about the file.