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
|
// ---- operator tables ----
// a sequence is written like asm: one-char mnemonics, numbers, and names
// (resolved when the operator is used, so image builds stay self-contained)
int seqasm(char* s) {
int start = seqtop, n, neg, v, k, c;
while (1) {
while (*s == 32) s++;
if (!*s) break;
n = 0;
while (s[n] && s[n] != 32) { n = token_char(n, s[n]); }
tbuf[n] = 0;
s = s + n;
reserve_R_SEQ(seqtop + 2);
neg = tbuf[0] == '-' && isdig(tbuf[1]);
if (isdig(tbuf[neg])) {
v = 0; k = neg;
while (tbuf[k]) { v = v * 10 + tbuf[k] - '0'; k++; }
if (neg) v = 0 - v;
if ((v >> 62) != 0 && (v >> 62) != -1) { R_SEQ[seqtop] = SEQWORD; R_SEQ[seqtop + 1] = v; seqtop = seqtop + 2; }
else { R_SEQ[seqtop] = v + v + 1; seqtop++; }
} else if (n == 1 && (c = mnemidx(tbuf[0])) >= 0) {
R_SEQ[seqtop] = c + c; seqtop++;
} else {
R_SEQ[seqtop] = SEQREF; R_SEQ[seqtop + 1] = intern(tbuf); seqtop = seqtop + 2;
}
}
return start;
}
// the index of an assembler mnemonic in the table, or -1 when there is none.
int mnemidx(int c) {
int i = 0;
while (mnem[i]) {
if (mnem[i] == c) return i;
i++;
}
return -1;
}
// emit n words of a stored sequence, resolving its references.
int emitseq(int a, int n) {
int e = a + n, s;
while (a < e) {
if (R_SEQ[a] == SEQWORD) { lit(R_SEQ[a + 1]); a = a + 2; }
else if (R_SEQ[a] == SEQREF) {
s = lookup(R_SEQ[a + 1]);
if (s < 0) s = fwdfn(R_SEQ[a + 1]);
if (skind[s] == K_FN) {
fnref(s);
} else if (skind[s] == K_ENH) op(XOP0 + sval[s]); else lit(sval[s]);
a = a + 2;
} else { emit(R_SEQ[a]); a++; }
}
return 0;
}
// add an operator name to the table of known operators, once.
int addkop(int p) {
int i = 0;
while (i < nkop) {
if (kops[i] == p) return 0;
i++;
}
reserve_operators(nkop + 1);
kops[nkop] = p;
nkop++;
return 0;
}
// find a binary operator by its name.
int binfind(int p) {
int i = nbin;
while (i) {
i--;
if (bname[i] == p) return i;
}
return -1;
}
// find a unary operator by its name.
int unfind(int p) {
int i = nun;
while (i) {
i--;
if (uname[i] == p) return i;
}
return -1;
}
// find an assignment operator by its name.
int asgfind(int p) {
int i = nasg;
while (i) {
i--;
if (aname[i] == p) return i;
}
return -1;
}
// add or replace a binary operator. code is a sequence string, or 0 for the
// built-in && (prec 2) and || (prec 1) behaviour, chosen by -1 / -2 in prec.
int add_binop(char* nm, int prec, char* code) {
int p = intern(nm), i = binfind(p), a, n;
if (i < 0) { reserve_binary(nbin + 1); i = nbin; nbin++; }
bname[i] = p; bprec[i] = prec;
// && (-1) and || (-2) short-circuit: they bind below |, and && above ||, as in c
if (prec < 0) { bprec[i] = 3 + prec; blen[i] = prec; bseq[i] = 0; addkop(p); return i; }
bseq[i] = seqasm(code); blen[i] = seqtop - bseq[i];
addkop(p);
// and its compound assignment, x op= y
n = rt.len_w(nm);
while (1002 + n > tbufcap) { tbuf = chk_resize(tbuf, 0, tbufcap * 2); tbufcap = tbufcap * 2; }
rt.copy_w(tbuf + 1000, nm, n);
tbuf[1000 + n] = '='; tbuf[1001 + n] = 0;
a = intern(tbuf + 1000);
if (prec >= 8 || prec == 5 || prec == 4 || prec == 3) {
if (asgfind(a) < 0) { reserve_assignment(nasg + 1); aname[nasg] = a; nasg++; }
abin[asgfind(a)] = i;
addkop(a);
}
return i;
}
// register a unary operator and the sequence it expands to.
int add_unop(char* nm, char* code) {
int p = intern(nm), i = unfind(p);
if (i < 0) { reserve_unary(nun + 1); i = nun; nun++; }
uname[i] = p; useq[i] = seqasm(code); ulen[i] = seqtop - useq[i];
addkop(p);
return i;
}
// register a keyword with its handler and flags.
int add_kw(char* nm, int handler, int flags) {
int s = addsym(intern(nm), K_KW, handler);
sflag[s] = F_DEF | flags;
return s;
}
// register a library function as a receiver method. its first parameter
// determines the receiver type; remaining parameters follow the member name.
word receiver_methods, closure_expected;
int add_method(char* member, char* function_name) {
int s = lookup_raw(intern(function_name)); word link;
if (s < 0 || skind[s] != K_FN || !stype[s] || !stype[s][3]) {
serr("a receiver method requires a function with at least one typed parameter"); return -1;
}
link = chk_resize(0, 0, 3);
link[0] = receiver_methods; link[1] = intern(member); link[2] = s; receiver_methods = link;
return s;
}
int receiver_method(word receiver_type, int member) {
word link = receiver_methods, ft, actual; word[8] bs; int found = -1, s;
while (link) {
s = link[2];
if (s < nsym && link[1] == member) {
ft = stype[s]; actual = receiver_type;
if (actual[0] == TY_ARR && ft[7][0] == TY_DYN && ft[7][3]) actual = tdyn(actual[4], 1);
rt.fill_w(bs, 0, 8);
if (unify(ft[7], actual, bs)) { if (found >= 0 && found != s) return -2; found = s; }
}
link = link[0];
}
return found;
}
// run.method("member", function) registers a receiver extension while parsing
// the importing source, including when its code is emitted into an image.
int kw_method() {
char* member; int s;
stmtonly(); next(); expect(s_lp);
if (tk != T_STR) { die("a receiver method name must be a character string"); return 0; }
member = tv; next(); expect(s_comma);
s = -1; if (tk == T_ID) s = source_lookup(tv);
if (s < 0 || skind[s] != K_FN) serr("a receiver extension requires a function name");
next(); expect(s_rp); expect(s_semi);
if (s >= 0) add_method(member, sname[s]);
return 0;
}
// publish a reference for shallow copies while preserving its declared type.
// scalar values are unchanged; in-place aggregates require explicit copying.
int kw_share_value() {
int c; word t;
next(); expect(s_lp); c = expr(); rval(); plainuse(c); t = xty; expect(s_rp);
if (isagg(t)) serr("sharing an aggregate requires sharing its pointer fields explicitly");
else if (isptr(t) || t[0] == TY_DYN || t[0] == TY_FN || t == tword) callname(intern("rt.share"));
xbor = -1; xaf = 0; effect_value = 0; xty = t; xconst = 0; xvk = 0;
return C_PLAIN;
}
word statement_hooks;
// source libraries can register syntax without emitting a runtime registration call.
int kw_syntax() {
char* keyword; int handler, entry = -1;
stmtonly(); next(); expect(s_lp);
if (tk != T_STR) { die("a syntax keyword must be a character string"); return 0; }
keyword = tv; next(); expect(s_comma); handler = -1;
if (tk == T_ID) handler = source_lookup(tv);
if (handler < 0 || skind[handler] != K_FN) serr("a syntax extension requires a function name");
next(); expect(s_rp); expect(s_semi);
if (handler >= 0) {
if (hdelta && handler >= ubase) entry = syntax_resident(handler); else entry = sval[handler];
if (entry >= 0) add_kw(keyword, entry, F_TOP | F_STMT);
}
return 0;
}
int kw_statement_hook() {
int handler = -1; word link;
stmtonly(); next(); expect(s_lp); if (tk == T_ID) handler = source_lookup(tv);
if (handler < 0 || skind[handler] != K_FN) serr("a statement hook requires a function name");
next(); expect(s_rp); expect(s_semi);
if (handler >= 0) { link = chk_resize(0, 0, 3); link[0] = statement_hooks; link[1] = handler; link[2] = 1; statement_hooks = link; }
return 0;
}
// optional statement callbacks installed by source extensions at include time.
// callbacks execute at ordinary vm call boundaries and must guard reentrancy.
int add_statement_hook(int callback) {
word link = chk_resize(0, 0, 3); link[0] = statement_hooks; link[1] = callback; link[2] = 0; statement_hooks = link;
return 0;
}
int emit_statement_hooks() {
word link = statement_hooks;
if (dry || o3on || cmode || incdepth || !infn) return 0;
while (link) { if (link[2]) fnref(link[1]); else lit(link[1]); op(O_CALL); op(O_DROP); link = link[0]; }
return 0;
}
|
