/
rc.4
1381 lines (1189 loc) · 30.4 KB
/
rc.4
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
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
: 2DROP DROP DROP ;
: \ 10 PARSE 2DROP ; IMMEDIATE \ CORE-EXT
: '
\ Avoid using IF, which is not defined yet
parse-word findword DUP 0= ?DUP 2DROP ;
: COMPILE, , ; \ CORE-EXT
: [COMPILE] ' COMPILE, ; IMMEDIATE \ CORE-EXT
: CHAR parse-word DROP C@ ;
: [CHAR] CHAR [COMPILE] LITERAL ; IMMEDIATE
: ( [CHAR] ) PARSE 2DROP ; IMMEDIATE
( Now we have round bracket comments )
\ Using the definition in [FORTH1994] A.6.1.2033
: compile R> DUP @ , CELL+ >R ;
: ['] ' [COMPILE] LITERAL ; IMMEDIATE
: [ 0 STATE ! ; IMMEDIATE
: RECURSE
last name>
COMPILE,
; IMMEDIATE
: 2DUP ( x x' -- x x' x x' ) OVER OVER ;
: TUCK ( a b -- b a b ) SWAP OVER ; \ CORE-EXT
: .( [CHAR] ) PARSE TYPE ; IMMEDIATE \ CORE-EXT
: S>D ( n -- d ) DUP 0< ;
: 2R> ( R: x1 x2 -- ) ( -- x1 x2 ) \ CORE-EXT
R> R> R> ( ret x2 x1 )
ROT >R ( x2 x1 )
SWAP ( x1 x2 )
;
: 2ROT ( p q r s t u -- r s t u p q ) \ DOUBLE-EXT
2>R 2SWAP 2R> 2SWAP ;
: /MOD ( n1 n2 -- rem quot ) >R S>D R> SM/REM ;
: */MOD ( n1 n2 n3 -- rem quot ) >R M* R> SM/REM ;
: */ ( n1 n2 n3 -- quot ) */MOD NIP ;
: / ( n1 n2 -- n3 ) /MOD NIP ;
: 2* ( x -- x' ) 2 * ;
: 2/ ( x -- x' ) 2 / ;
: signum ( x -- -1/0/1 )
DUP 0< SWAP 0> - ;
: U> ( u1 u2 -- flag ) SWAP U< ; \ CORE-EXT
: DEPTH ( -- +n )
stack DROP - 1 CELLS / ;
: VARIABLE CREATE 1 CELLS ALLOT ;
: 2VARIABLE CREATE 2 CELLS ALLOT ; \ DOUBLE
: WORDLIST ( -- wid ) HERE 1 CELLS ALLOT ; \ SEARCH
: MOD ( n1 n2 -- n3 )
\ Implementation as per [std1994]
>R S>D R> SM/REM DROP
;
: 2! ( x1 x2 addr -- ) TUCK ! CELL+ ! ;
: 2@ ( addr -- x1 x2 )
DUP CELL+ @ SWAP @ ;
: D0= ( xd -- flag ) OR 0= ; \ DOUBLE
: COUNT ( addr -- addr' ch ) DUP 1+ SWAP C@ ;
: WORD ( char "<chars>ccc<char>" -- c-addr )
DUP DUP 1+ skip
DUP 1+ SWAP partok ( addr u )
>R HERE 1+ R@ CMOVE ( addr ) ( r: u )
R> HERE C!
HERE
;
: /STRING ( addr u n -- addr' u' ) \ STRING
TUCK - ( addr n u' )
>R + R> ( addr' u' )
;
\ ## Control Flow
: BEGIN ( -- token / at compile time )
HERE
; IMMEDIATE
: UNTIL ( token -- / at compile time )
compile 0branch
HERE ( token here )
- ( byte-offset )
,
; IMMEDIATE
: WHILE ( token -- token w-token )
compile 0branch
HERE ( token w-token )
TRUE ,
; IMMEDIATE
: REPEAT ( b-token w-token -- )
SWAP ( w-token b-token )
compile branch
HERE - ( w-token offset )
, ( w-token )
HERE ( w-token here )
OVER - ( w-token offset )
SWAP !
; IMMEDIATE
: IF ( -- token / at compile time )
compile 0branch
HERE ( token )
\ compile dummy offset
TRUE ,
; IMMEDIATE
: ELSE ( token -- newtoken / at compile time )
compile branch
HERE ( token newtoken )
( compile dummy offset )
TRUE ,
SWAP ( newtoken token )
HERE OVER - ( newtoken token offset )
SWAP ( newtoken offset token )
! ( newtoken )
; IMMEDIATE
: THEN
HERE OVER - SWAP ! ; IMMEDIATE
: POSTPONE
parse-word findword ( 0 | xt 1 | xt -1 )
?DUP 0= ABORT" Postpone not"
( xt +-1 )
0> IF
\ immediate case
COMPILE,
ELSE
\ non-immediate case
[ ' LITERAL COMPILE, ]
['] COMPILE, COMPILE,
THEN
; IMMEDIATE
CREATE do-stack 3 CELLS ALLOT
VARIABLE do-sp 0 do-sp !
: do-addr do-stack do-sp @ CELLS + ;
: >do do-addr ! 1 do-sp +! ;
: do> -1 do-sp +! do-addr @ ;
: DO ( limit base -- )
( C: -- do-token )
( do-stack: -- leave-token )
POSTPONE 2>R
0 >do HERE ( do-token )
; IMMEDIATE
: UNLOOP ( R: limit index -- )
R> 2R> 2DROP >R
;
\ Push the current-leave token (on the do-stack)
\ onto the leave linked-list at HERE.
\ Replace current-leave token with HERE.
\ Factor of LEAVE and ?DO .
: push-leave ( -- )
HERE do> ( new-token leave-token )
, >do
;
: ?DO ( limit base -- ) \ CORE-EXT
( C: -- do-token )
( do-stack: -- leave-token )
\ Use DO to setup a DO LOOP,
\ but adjust the do-token so that the LOOP returns
\ to a point after the equalty test implied by ?DO .
POSTPONE 2DUP
[COMPILE] DO
POSTPONE <>
POSTPONE 0branch
push-leave
DROP HERE
; IMMEDIATE
\ Implements the test part of a DO LOOP,
\ leaving a flag on the stack.
: looptest ( -- flag / R: limit index -- limit index' )
R> ( ret )
2R@ ( ret limit index )
1+ ( ret limit index' )
R> DROP ( r: limit )
DUP >R ( r: limit index' )
= ( ret flag )
SWAP >R ( flag )
;
\ Add inc to index and convert inc to flag;
\ flag is true iff index crosses boundary between
\ limit-1 and limit.
: +test ( inc limit index -- flag index' )
SWAP >R ( inc index ) ( r: limit )
2DUP + ( inc index index' )
DUP R@ - ( inc index index' o' )
ROT R> - ( inc index' o' o )
OVER XOR ( inc index' o' x )
ROT 2SWAP ( x index' inc o' )
XOR INVERT ( x index' q )
ROT AND ( index' sflag )
0< SWAP ( flag index' )
;
: +looptest ( inc -- flag ) ( r: limit index -- limit index' )
R> SWAP ( ret inc )
2R@ ( ret inc limit index )
+test ( ret flag index' )
R> DROP ( r: limit )
>R ( ret flag ) ( r: limit index' )
SWAP >R ( flag )
;
: LEAVE
POSTPONE branch
push-leave
; IMMEDIATE
\ Fix the leave token.
\ Fetch the previous leave token in the linked-list,
\ and store offset to HERE at that address.
: fix-leave ( leave-token -- leave-token' )
DUP @ SWAP ( leave-token' leave-token )
HERE OVER ( leave-token' leave-token here leave-token )
- SWAP ! ( leave-token' )
;
: loopy
POSTPONE 0branch
HERE ( do-token here )
- ( byte-offset )
,
\ fix the linked-list of leave-tokens up
do> ( leave-token )
BEGIN
?DUP WHILE
fix-leave ( leave-token' )
REPEAT
compile 2R> compile 2DROP
;
: LOOP ( R: limit base -- limit base+1 | )
( C: do-token -- )
POSTPONE looptest
loopy
; IMMEDIATE
: +LOOP ( inc -- )
( R: limit base -- limit base' | )
( C: do-token -- )
POSTPONE +looptest
loopy
; IMMEDIATE
: I ( -- index )
2R@ DROP
;
: J ( -- index ) ( R: lj bj li bi ret )
2R> 2R@ DROP ROT ROT 2>R
;
\ ##
: FIND ( c-addr -- c-addr 0 | xt 1 | xt -1 )
>R R@ COUNT ( addr u )
findword ( 0 | xt 1 | xt -1 )
DUP 0= IF
R> SWAP ( c-addr 0 )
ELSE
R> DROP ( xt 1 | xt -1 )
THEN
;
: MAX 2DUP < IF SWAP THEN DROP ;
: ABS DUP NEGATE MAX ;
: FM/MOD ( d1 n1 -- n2 n3 )
DUP >R ( r: n1 )
SM/REM ( rem quot )
OVER signum ( rem quot s-rem )
R@ signum ( rem quot s-rem s-n1 )
NEGATE = ( rem quot adjust? )
IF
1- ( rem quot' )
SWAP R> + SWAP ( rem' quot' )
ELSE
R> DROP
THEN
;
\ Fixes the CFA of the last defined word
\ to point to address following call to *fix-cfa
\ in the calling word;
\ and terminate excution of calling word.
: *fix-cfa R> last name> ! ;
: DOES> POSTPONE *fix-cfa codedoes ( addr n )
HERE OVER ALLOT ( from n to )
SWAP CMOVE ; IMMEDIATE
: CONSTANT ( x -- / -- x )
VARIABLE last name> >BODY ! DOES> @ ;
: VALUE CONSTANT ; \ CORE-EXT
: TO ( x -- ) \ CORE-EXT
' >BODY
STATE @ IF
[COMPILE] LITERAL
POSTPONE !
ELSE
!
THEN
; IMMEDIATE
: ALIGN ( -- )
HERE ALIGNED HERE - ALLOT
;
: CHAR+ ( addr -- addr' ) 1+ ;
: CHARS ( n1 -- n1 ) ;
: C, ( char -- ) HERE 1 ALLOT C! ;
: MOVE ( from to u -- )
>R 2DUP U< R> ( from to up? u )
SWAP IF
CMOVE>
ELSE
CMOVE
THEN
;
\ Map Anonymous
\ Request freshly allocated memory.
: map-anon ( sz -- addr ior )
0 SWAP ( 0 sz )
3 34 ( 0 sz prot flags )
-1 0 ( 0 sz prot flags fd offset )
9 syscall6 ( res )
-4096 OVER U< ( res flag )
OVER AND ( addr ior )
;
\ ## Pad
84 CONSTANT pad-size
pad-size map-anon DROP VALUE PAD \ CORE-EXT
\ ## Number Printing
: SPACE BL EMIT ;
: SPACES ( n -- ) DUP 0> IF 0 DO SPACE LOOP THEN ;
300 CONSTANT pic-size
pic-size map-anon DROP pic-size +
VALUE picend
VARIABLE pic
\ double to double division
\ used in printing numbers
: uml/mod ( ud u -- u-rem ud-quot )
>R R@
0 SWAP UM/MOD ( L Mrem Mquot )
R> SWAP >R ( L Mrem u )
UM/MOD ( Lrem Lquot )
R> ( Lrem ud-quot )
;
: HOLD ( ch -- )
pic @ ( ch addr )
1- ( ch addr' )
TUCK ( addr' ch addr' )
C! ( addr' )
pic !
;
: <# ( -- )
picend
pic !
;
: # ( ud -- ud' )
BASE @
uml/mod ( r ud )
ROT ( ud r )
digit HOLD ( ud )
;
: #S ( ud -- 0. )
BEGIN
#
2DUP ( ud ud )
D0= ( ud flag )
UNTIL
;
: SIGN ( n -- )
0< IF
[CHAR] -
HOLD
THEN
;
: #> ( ud -- addr u )
2DROP
pic @
picend ( addr end )
OVER - ( addr u )
;
\ Using <#, type out double with sign of n.
: .sign ( n du -- )
<#
BL HOLD
#S
ROT SIGN
#>
TYPE
;
: U. ( u -- )
0 TUCK ( 0 du )
.sign ;
: . ( n -- )
DUP ABS 0 ( n du ) \ du same magnitude as n
.sign ;
: D. ( d -- ) \ DOUBLE
TUCK DABS ( n du ) \ n same sign as d
.sign ;
: DECIMAL ( -- ) 10 BASE ! ;
: HEX ( -- ) 16 BASE ! ; \ CORE-EXT
: .S ( -- ) \ TOOLS
stack DROP
?DO
I @ .
1 CELLS +LOOP
;
\ ## String
: ." ( compile: "ccc<quote>" -- )
[COMPILE] S" POSTPONE TYPE
; IMMEDIATE
\ 3-way comparison
\ result is -1 when u1 < u2
\ +1 when u2 < u1
\ 0 when u1 = u2
: cmp ( u1 u2 -- -1|0|1 )
2DUP U< ( u1 u2 flag< )
SWAP ROT ( flag< u2 u1 )
U< ( flag< flag> )
-
;
: COMPARE ( c-addr1 u1 c-addr2 u2 -- n ) \ STRING
ROT 2DUP 2>R
MIN ( c-addr1 c-addr2 n )
FALSE
BEGIN
DROP
DUP 0= IF
\ identical up to common part
DROP 2DROP
R> R> cmp
EXIT
THEN
( c-addr1 c-addr2 n )
1-
ROT COUNT >R ( c-addr2 n c-addr1' ) ( r: ch1 )
ROT COUNT >R ( n c-addr1' c-addr2' ) ( r: ch1 ch2 )
ROT 2R> ( c-addr1' c-addr2' n ch1 ch2 )
cmp ( c-addr1' c-addr2' n -1|0|1 )
DUP
UNTIL
2R> 2DROP
NIP NIP NIP
;
\ print name of word given its LFA
: .lfa ( lfa -- lfa 0 )
( lfa -- 1 )
DUP 0= IF
DROP
1
EXIT
THEN
DUP ( lfa lfa )
CELL+ ( lfa nfa )
DUP @ ( lfa nfa u-bits )
4294967295 AND ( lfa nfa u )
SWAP CELL+ SWAP ( lfa c-addr u )
HERE OVER [CHAR] ? ( lfa c-addr u here u ? )
FILL ( lfa c-addr u )
DUP >R ( lfa c-addr u ) ( r: u )
8 MIN ( lfa c-addr 8|u )
HERE SWAP ( lfa c-addr here 8|u )
CMOVE
HERE R>
TYPE CR
FALSE
;
: WORDS \ TOOLS
['] .lfa thewl exec-wordlist
;
\ ##
\ Convert from C string, by pushing its length.
: c> ( addr -- addr u )
-1 ( addr i )
BEGIN
1+ ( addr i )
2DUP + ( addr i p )
C@ ( addr i ch )
0= ( addr i flag )
UNTIL
;
\ ARGC and ARG modelled after gforth implementation.
\ The initial RSP register is the address of ARGC
\ (in the Linux ABI).
rsp CONSTANT argc
: arg ( i -- i-addr i-len )
1+ CELLS
\ Following ARGC are the pointers to C strings.
argc
+ @ ( addr )
DUP IF
c> ( addr u )
ELSE
0 ( 0 0 )
THEN
;
: arg-pop ( -- )
argc @ 2 < IF EXIT THEN
argc 2 CELLS + ( addr-from )
argc CELL+ ( addr-from addr-to )
-1 argc +!
argc @ CELLS ( addr-from addr-to u )
CMOVE
;
: getpid ( -- u-pid ) 39 syscall ;
: sysread ( fd addr u )
0 \ number for read() syscall
syscall3 ;
\ see note/fstat.md
CREATE fstatbuf 144 ALLOT ALIGN
\ Modelled after ANSI `file-status`.
: file*status ( n -- addr ior )
\ Leaves result in `fstatbuf` which is left on stack.
fstatbuf TUCK 0 5 syscall3 ;
: FILE-SIZE ( fileid -- ud ior ) \ FILE
file*status
?DUP IF
0 SWAP ( x 0 ior )
ELSE
48 + @ 0 ( ud )
0 ( ud 0 )
THEN
;
\ File Map for Reading
\ Map fildes fd into memory for reading.
\ Address and length of mapping are left on stack.
: fmapr ( fd -- addr u )
DUP FILE-SIZE ( fd ud ior )
ABORT" File cannot be mapped" ( fd ud )
D>S ( fd u )
DUP 1 < IF
DROP DROP
0 0
ELSE
( n sz )
TUCK ( sz n sz )
0 ROT ROT SWAP ( sz 0 sz n )
\ For #defines, see /usr/include/asm-generic/mman-common.h
\ PROT_READ 1
\ PROT_WRITE 2
\ MAP_PRIVATE 2
\ MAP_ANONYMOUS 32
1 2 ROT ( sz 0 sz 1 2 n )
0 ( sz 0 sz 1 2 n 0 )
9 syscall6 ( sz addr )
SWAP
THEN
;
4096 map-anon DROP
CONSTANT openbuf ( buffer for open pathname )
: R/O \ FILE
\ Modelled after the `flags` argument to open()
\ See /usr/include/asm-generic/fcntl.h defines O_RDONLY
0 ;
: OPEN-FILE ( c-addr u fam -- fileid ior ) \ FILE
>R >R ( c-addr ) ( r: fam u )
openbuf R@ ( c-addr path u )
CMOVE ( )
0 R> ( 0 u ) ( r: fam )
openbuf 1+ + ( 0 p )
!
openbuf ( openbuf )
R> 0 ( openbuf fam 0 )
\ For syscall numbers, see
\ http://blog.rchapman.org/posts/Linux_System_Call_Table_for_x86_64/
2 syscall3 ( fileid )
DUP 0 MIN ( fileid 0 | ior ior )
;
: READ-FILE ( c-addr u1 fileid -- u2 ior ) \ FILE
ROT ROT sysread ( res )
DUP 0< IF
0 SWAP ( 0 ior )
ELSE
0 ( u2 0 )
THEN
;
\ Open file for reading.
: openr ( c-addr u -- fileid ior )
R/O OPEN-FILE ;
\ ##
\ Fetch byte C from addr,
\ then compute C M AND X XOR
\ and store at addr.
: c!xa ( X M addr -- )
DUP >R C@ AND XOR R> C! ;
VARIABLE chbuf
\ Read single byte.
: fgetc ( fd -- c/-9999999/-ve )
chbuf 1 ROT READ-FILE ( u2 ior )
?DUP IF
( 0 ior )
NIP
ELSE
( u2 )
0= IF -9999999
ELSE
chbuf C@
THEN
THEN
;
\ Read single byte from stdin
: getc ( -- c )
( -- -9999999 / on End of File )
( -- -ve / on os error )
0 fgetc ;
\ Fetch and print 8 hex digits.
: @.8 ( addr -- )
@ 4294967295 ( 2**32 - 1 ) AND ( w )
BASE @ >R
16 BASE !
0 ( ud )
<# BL HOLD
# # # # # # # #
#>
TYPE
R> BASE !
;
\ ioctl(fd, TCGETS, p)
: tcgets ( fd p -- res )
\ TCGETS according to /usr/include/asm-generic/ioctls.h
21505 SWAP ( fd 0x5401 p )
16 syscall3
;
\ ioctl(fd, TCSETS, p)
: tcsets ( fd p -- res )
\ TCSETS according to /usr/include/asm-generic/ioctls.h
21506 SWAP ( fd 0x5402 p )
16 syscall3
;
\ True if file descriptor fd refers to a TTY.
: isatty ( fd -- flag )
HERE \ dummy-buffer
tcgets
0= \ 0 is success; convert to true/false
;
\ Get TTY settings, from TCGETS ioctl, and dump to stdout.
: tcgets. ( fd -- res )
HERE DUP tcgets ( here res )
OVER @.8
OVER 4 + @.8
OVER 8 + @.8
OVER 12 + @.8
CR
OVER 16 +
20 DUMP ( res )
NIP
;
CREATE tty.buffer 36 ALLOT ALIGN
\ Store TTY settings.
: tty.store ( fd -- )
tty.buffer tcgets DROP
;
\ Put TTY in keypress mode.
: tty.keypress ( fd -- )
\ Fetch and modify TTY settings...
DUP HERE tcgets DROP ( fd )
\ Clear ICANON and ECHO bits.
0 10 INVERT HERE 12 + c!xa ( fd )
HERE tcsets DROP
;
\ Restore TTY settings.
: tty.restore ( fd -- )
tty.buffer tcsets DROP
;
CREATE tty.szbuf 8 ALLOT
: tiocgwinsz ( fd p -- res )
\ 0x5413, TIOCGWINSZ according to /usr/include/asm-generic/ioctls.h
21523 ( fd p 0x5413 )
SWAP ( fd 0x5413 p )
( ioctl )
16 syscall3 ( res )
;
VARIABLE tty.vbuf
-1 tty.vbuf !
\ Number of columns in TTY.
: tty.cols ( -- cols )
0 tty.szbuf
tiocgwinsz
0= IF
tty.szbuf 2 + ( a+2 )
DUP 1+ ( a+2 a+3 )
C@ SWAP C@ ( b1 b0 )
SWAP ( b0 b1 )
256 * + ( cols )
tty.vbuf !
THEN
tty.vbuf @
;
\ Put the TTY into keypress mode to get a single keypress.
\ Required by ANSI, but so ill-specified as to be useless.
: KEY
0 tty.store
0 tty.keypress
getc
0 tty.restore
;
\ ## Environment
: SET-CURRENT ( wid -- ) current ! ; \ SEARCH
GET-CURRENT CONSTANT FORTH-WORDLIST \ SEARCH
WORDLIST CONSTANT environment
environment SET-CURRENT
: /COUNTED-STRING 255 ;
: /HOLD pic-size ;
: /PAD pad-size ;
: ADDRESS-UNIT-BITS 8 ;
: CORE TRUE ;
: CORE-EXT FALSE ;
: FLOORED FALSE ;
: MAX-CHAR 255 ;
: MAX-D -1 -1 1 RSHIFT ;
: MAX-N 9223372036854775807 ;
: MAX-U -1 ;
: MAX-UD -1 -1 ;
: RETURN-STACK-CELLS returnstack NIP NIP 1 CELLS / ;
: STACK-CELLS stack NIP NIP 1 CELLS / ;
FORTH-WORDLIST SET-CURRENT
: ENVIRONMENT? ( c-addr u -- false | i*x true )
environment SEARCH-WORDLIST IF
EXECUTE
TRUE
ELSE
FALSE
THEN
;
\ ## Key Input
\ type on stderr.
: etype ( addr u -- ) 2 ftype ;
\ emit on stderr.
: eemit ( ch -- ) 2 femit ;
96 CONSTANT ki.buflen \ size
CREATE ki.buf ki.buflen ALLOT \ buffer
ki.buf VALUE ki.a \ address of buffer to use
ki.buflen VALUE ki.z \ size of buffer in use
VARIABLE ki.> \ point, 0 <= ki.> < ki.n
VARIABLE ki.n \ validity
VARIABLE ki.>save
VARIABLE ki.k \ small buffer for key input
VARIABLE ki.fixk \ small buffer used for findword
\ Reset key variables to create a fresh buffer
: ki.reset
0 ki.> ! 0 ki.n ! 0 ki.>save ! ;
ki.reset
: ki.buffer
ki.buf TO ki.a
ki.buflen TO ki.z
ki.reset ;
: ki.input ( -- addr u ) ki.a ki.n @ ;
\ ## Historic Lines
\ Memory block for all strings in history.
VARIABLE hl.block
1000000000 map-anon DROP hl.block !
\ history-pointer
VARIABLE hl.p
hl.block @ hl.p !
: hl.n 999 ;
CREATE hl.array hl.n 2* CELLS ALLOT
VARIABLE hl.next 0 hl.next !
VARIABLE hl.cursor 0 hl.cursor !
\ Index of earliest history element.
: hl.base ( -- base )
hl.n hl.next @ MAX
hl.n -
;
: hl.curprev ( -- flag )
hl.cursor @ hl.base > IF
-1 hl.cursor +!
TRUE
ELSE
0
THEN
;
: hl.curnext ( -- flag )
hl.cursor @ hl.next @ 1- ( c end )
< IF
1 hl.cursor +!
TRUE
ELSE
0
THEN
;
\ Return address of uth double-world entry in hl.array.
: hl.a& ( u -- addr )
2* CELLS ( byte-offset )
hl.array ( byte-offset hl.array )
+ ( array-address )
;
\ Store addr u into the ith double-world entry in hl.array.
: hl.a! ( u addr i -- )
hl.a& ( u addr array-addr )
2! ( )
;
\ Replace i with the address of the double word
\ for history element i;
\ 0 if invalid index.
: hl& ( i -- addr )
DUP ( i i )
hl.base ( i i base )
hl.next @ ( i i base limit )
WITHIN IF
hl.n MOD ( array-index )
hl.a& ( addr )
ELSE
DROP
0
THEN
;
\ Fetch string from history; 0 0 if invalid index.
: hl@ ( i -- addr u )
hl& ( addr )
DUP IF
2@ ( u a )
SWAP ( a u )
ELSE
DROP
0 0
THEN
;
\ Save the string into most recent element of history;
\ modifying it.
: hl.save ( from u -- )
hl.next @ 1- ( from u i )
hl& ( from u h-addr )
DUP 0= IF
ABORT" hl.save problem"
THEN
\ :todo: check lengths here
2DUP ( from u h-addr u h-addr )
CELL+ ! ( from u h-addr )
@ ( from u to )
\ calculate a new value for hl.p
2DUP ( from u to u to )
+ ( from u to new-p )
hl.p ! ( from u to )
SWAP CMOVE
;
\ Create a new history entry.
: hl.new ( -- )
0 hl.p @ ( 0 p )
hl.next @ ( 0 p i )
\ increment hl.next
1 hl.next +! ( 0 p i )
\ set cursor
DUP hl.cursor ! ( 0 p i )
hl& ( 0 p addr )
2!
;
: hl.
hl.base ( i )
BEGIN
DUP hl.next @ ( i i n )
< ( i flag )
WHILE
DUP .
DUP hl@ ( i addr u )
TYPE CR ( i )
1+ ( i+1 )
REPEAT
DROP
;
\ hl.cursor - which history element we are currently showing.
\ hl.next - number of next history element to be created.
\ hl.next only ever increments.
\ The counterpart, hl.earliest, the earliest history element,
\ is not explicitly stored. It is computed by hl.base.
\ ^P and ^N move the history cursor up and down,
\ and as long as there is a history element in memory,
\ it is copied to the ki buffer.
\ History is a copy on write affair.
\ Modifying the ki buffer marks it as modified,
\ ^J saves the ki buffer to history, and marks it as frozen.
\ ^N, or ^P saves the ki buffer to history only if
\ the ki buffer is modified.
\ The most recent history element has associated with it,
\ a "frozen" flag, which is unset until enter is pressed.
\ It is used to control saving.