-
Notifications
You must be signed in to change notification settings - Fork 113
/
nucleus.fth
161 lines (132 loc) · 3.38 KB
/
nucleus.fth
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
\ -*- forth -*- Copyright 2013, 2015-2017 Lars Brinkhoff
code cold \ int main (void)
extern struct word dp0_word, sp0_word, rp0_word, SP_word, RP_word,
limit_word, latest0_word, turnkey_word;
static cell data_stack[110];
static cell return_stack[256];
static cell dictionary[19000];
xt_t *IP = 0, xt = &turnkey_word;
sp0_word.param[0] = (cell)(&data_stack[100]);
rp0_word.param[0] = (cell)(&return_stack[256]);
dp0_word.param[0] = (cell)dictionary;
limit_word.param[0] = (cell)dictionary + sizeof dictionary;
latest0_word.param[0] = (cell)(&turnkey_word);
SP_word.param[0] = sp0_word.param[0];
RP_word.param[0] = rp0_word.param[0];
for (;;)
{
EXECUTE (xt);
xt = NEXT_XT;
}
return 0;
end-code
code exit ( R: ret -- )
IP = RPOP (xt_t *);
end-code
code dodoes ( -- addr ) ( R: -- ret )
PUSH (word->param);
RPUSH (IP);
IP = (xt_t *)(word->does);
end-code
\ Possible, but slow, implementation of 0branch.
\ : select 0= dup invert swap rot nand invert rot rot nand invert + ;
\ : 0branch r> dup cell+ swap @ rot select >r ;
code 0branch ( x -- )
xt_t *addr = *(xt_t **)IP;
cell x = POP (cell);
if (!x)
IP = addr;
else
IP++;
end-code
\ This works, but is too slow.
\ create 'cell cell ,
\ variable temp
\ : (literal) r> temp ! temp @ temp @ 'cell @ + >r @ ;
code (literal) ( -- n )
PUSH (*(cell *)IP);
IP++;
end-code
code ! ( x addr -- )
cell *addr = POP (cell *);
cell x = POP (cell);
*addr = x;
end-code
code @ ( addr -- x )
cell *addr = POP (cell *);
PUSH (*addr);
end-code
\ : + begin ?dup while 2dup xor -rot and 2* repeat ;
code + ( x y -- x+y )
cell y = POP (cell);
cell x = POP (cell);
PUSH (x + y);
end-code
\ This works, but is too slow.
\ : >r r@ rp@ -4 + rp! rp@ ! rp@ 4 + ! ;
code >r ( x -- ) ( R: -- x )
cell x = POP (cell);
RPUSH (x);
end-code
\ This works, but is too slow.
\ : r> rp@ 4 + @ r@ rp@ 4 + rp! rp@ ! ;
code r> ( -- x ) ( R: x -- )
cell x = RPOP (cell);
PUSH (x);
end-code
code nand ( x y -- ~(x&y) )
cell y = POP (cell);
cell x = POP (cell);
PUSH (~(x & y));
end-code
code c! ( c addr -- )
char_t *addr = POP (char_t *);
cell c = POP (cell);
*addr = c;
end-code
code c@ ( addr -- c )
uchar_t *addr = POP (uchar_t *);
PUSH (*addr);
end-code
code emit ( c -- )
cell c = POP (cell);
putchar (c);
end-code
code bye ( ... -- <no return> )
exit (0);
end-code
code close-file ( fileid -- ior )
FILE *fileid = POP (FILE *);
PUSH (fclose (fileid) == 0 ? 0 : errno);
end-code
code open-file ( addr u mode -- fileid ior )
char *mode = POP (char *);
int i, u = POP (cell);
char_t *addr = POP (char_t *);
char *name = malloc (u + 1);
FILE *fileid;
for (i = 0; i < u; i++)
name[i] = *addr++;
name[i] = 0;
fileid = fopen (name, mode);
free (name);
PUSH (fileid);
PUSH (fileid == 0 ? errno : 0 );
end-code
code read-file ( addr u1 fileid -- u2 ior )
static char buffer[1024];
FILE *fileid = POP (FILE *);
cell u1 = POP (cell);
char_t *addr = POP (char_t *);
size_t u2;
int i;
if (fileid == 0)
fileid = stdin;
if (u1 > sizeof buffer)
u1 = sizeof buffer;
u2 = fread (buffer, 1, u1, fileid);
for (i = 0; i < u2; i++)
addr[i] = buffer[i];
PUSH (u2);
PUSH (ferror (fileid) ? errno : 0);
end-code