fcc/twin.fth at main · CCurl/fcc · GitHub

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
// Test file for the Windows version

var base

: @a  a@ @ ;				: !a  a@ ! ;
: @a+ @a  a@ 4 + a! ;		: !a+ !a  a@ 4 + a! ;
: @a- @a  a@ 4 - a! ;		: !a- !a  a@ 4 - a! ;

: c@a   a@ c@ ;				: c!a   a@ c! ;
: c@a+  c@a  a+ ;			: c!a+  c!a  a+ ;
: c@a-  c@a  a- ;			: c!a-  c!a  a- ;

: +L +locs  a@ l0 ! ;
: -L l0 @ a!  -locs ;

: 0= 0 = ;
: ztype ( a-- ) +L  a!
	begin
		c@a+ dup 0=
		if drop -L exit then
		emit
	again ;

: Mil ( n--m ) 1000 dup * * ;
: cr 10 emit ;
: space 32 emit ;
: negate 0 swap - ;

var buf 3 allot
var #n
: (.) ( n-- )
	+L #n a! 0 dup c!a- c!a-
	dup 0 < if 1 #n c! negate then
	begin
		base @ /mod swap '0' +
		dup '9' > if 7 + then
		c!a- dup
	while drop
	#n c@ if '-' c!a- then
	a@ 1+ ztype -L ;
: . (.) space ;

: strlen ( a--n )
	+locs  a@ l0 !  a!
	0  begin  1+  a@ c@  a+  while
	1-  l0 @ a!  -locs ;

var x
: x++ x @ 1+ x ! ;
: x-- x @ 1- x ! ;
: x+4 x @ 4 + x ! ;
: x-4 x @ 4 - x ! ;

: t0 cr 't' emit . ;
: t1   1 t0 s" hello world!" ztype ;
: t2   2 t0 1234 s" hello" strlen . . ;
: t4   4 t0 0= if 'n' emit exit then 'y' emit ;
: t5   5 t0 buf a! 'h' c!a+ 'i' c!a+ 0 c!a buf ztype space ;
: t6   6 t0 666 222 ->reg2  333 ->reg3  444 ->reg4 . s" (should print 666)" ztype ;
: t7   7 t0 s" test ztype ..." ztype ;
: t8   8 t0 3344 . -3344 . $1234 . 1234 #16 base ! . #10 base ! ;
: t9   9 t0 999 123 100 /mod . . . ;
: t10 10 t0 'g' x c! x c@ dup . emit ;
: t11 11 t0 's' emit 999 Mil dup (.) begin 1- dup while 'e' emit ;
: t12 12 t0 +locs s" -L3-" l3 ! +locs 17 l3 ! l3 @ . -locs l3 @ ztype -locs ;
: t999 s" bye" ztype cr bye ;

: main
	10 base !
	t1 t2 0 t4 1 t4 t5 t6 t7 t8 t9 t10 t11 t12
	cr t999 cr
	s" still here? s" ztype ;