1 |
/* |
2 |
* PearPC |
3 |
* forth.cc |
4 |
* |
5 |
* Copyright (C) 2003 Sebastian Biallas (sb@biallas.net) |
6 |
* |
7 |
* This program is free software; you can redistribute it and/or modify |
8 |
* it under the terms of the GNU General Public License version 2 as |
9 |
* published by the Free Software Foundation. |
10 |
* |
11 |
* This program is distributed in the hope that it will be useful, |
12 |
* but WITHOUT ANY WARRANTY; without even the implied warranty of |
13 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
14 |
* GNU General Public License for more details. |
15 |
* |
16 |
* You should have received a copy of the GNU General Public License |
17 |
* along with this program; if not, write to the Free Software |
18 |
* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
19 |
*/ |
20 |
|
21 |
#include <cstdlib> |
22 |
#include <cstring> |
23 |
#include <cstdarg> |
24 |
|
25 |
#include "system/display.h" |
26 |
#include "tools/snprintf.h" |
27 |
#include "prommem.h" |
28 |
#include "forth.h" |
29 |
#include "forthtable.h" |
30 |
|
31 |
ForthPos::ForthPos() |
32 |
{ |
33 |
mFpm = fpmLinePos; |
34 |
mLine = 1; |
35 |
mPos = 1; |
36 |
mOffset = 0; |
37 |
} |
38 |
|
39 |
void ForthPos::copy(ForthPos &p) |
40 |
{ |
41 |
mFpm = p.mFpm; |
42 |
mLine = p.mLine; |
43 |
mPos = p.mPos; |
44 |
mOffset = p.mOffset; |
45 |
} |
46 |
|
47 |
int ForthPos::toString(char *buf, int buflen) const |
48 |
{ |
49 |
if (mFpm == fpmOffset) { |
50 |
return ht_snprintf(buf, buflen, "%08x", mOffset); |
51 |
} else { |
52 |
return ht_snprintf(buf, buflen, "%d:%d", mLine, mPos); |
53 |
} |
54 |
} |
55 |
|
56 |
void ForthPos::clearPos() |
57 |
{ |
58 |
mPos = 0; |
59 |
} |
60 |
|
61 |
void ForthPos::setMode(ForthPosMode fpm) |
62 |
{ |
63 |
mFpm = fpm; |
64 |
} |
65 |
|
66 |
void ForthPos::setLinePos(int line, int pos) |
67 |
{ |
68 |
mLine = line; |
69 |
mPos = pos; |
70 |
} |
71 |
|
72 |
void ForthPos::setOffset(uint32 offset) |
73 |
{ |
74 |
mOffset = offset; |
75 |
} |
76 |
|
77 |
void ForthPos::inc() |
78 |
{ |
79 |
if (mFpm == fpmOffset) { |
80 |
mOffset++; |
81 |
} else { |
82 |
mPos++; |
83 |
} |
84 |
} |
85 |
|
86 |
void ForthPos::inc(int n) |
87 |
{ |
88 |
if (mFpm == fpmOffset) { |
89 |
mOffset+=n; |
90 |
} else { |
91 |
mPos+=n; |
92 |
} |
93 |
} |
94 |
|
95 |
void ForthPos::incLine() |
96 |
{ |
97 |
mLine++; |
98 |
} |
99 |
|
100 |
ForthException::ForthException() |
101 |
{ |
102 |
} |
103 |
|
104 |
ForthInterpreterException::ForthInterpreterException(ForthPos &pos, const char *msg, ...) |
105 |
{ |
106 |
char estr2[120]; |
107 |
va_list va; |
108 |
va_start(va, msg); |
109 |
ht_vsnprintf(estr2, sizeof estr2, msg, va); |
110 |
va_end(va); |
111 |
ht_snprintf(estr, sizeof estr, "%s: %s at %y", "Interpreter Exception", estr2, &pos); |
112 |
} |
113 |
|
114 |
ForthRunException::ForthRunException(ForthPos &pos, const char *msg, ...) |
115 |
{ |
116 |
char estr2[120]; |
117 |
va_list va; |
118 |
va_start(va, msg); |
119 |
ht_vsnprintf(estr2, sizeof estr2, msg, va); |
120 |
va_end(va); |
121 |
ht_snprintf(estr, sizeof estr, "%s: %s at %y", "Run Exception", estr2, &pos); |
122 |
} |
123 |
|
124 |
/* |
125 |
* |
126 |
*/ |
127 |
#define STRING_BUFFER_SIZE 120 |
128 |
ForthVM::ForthVM() |
129 |
{ |
130 |
codestack = new Stack(true); |
131 |
datastack = new Stack(true); |
132 |
mGlobalVocalbulary = new AVLTree(true); |
133 |
promMalloc(STRING_BUFFER_SIZE, mStringBufferEA[0], (void**)&(mStringBuffer[0])); |
134 |
promMalloc(STRING_BUFFER_SIZE, mStringBufferEA[1], (void**)&(mStringBuffer[1])); |
135 |
mStringBufferIdx = 0; |
136 |
mFCodeBuffer = new String(); |
137 |
mFCodeBufferIdx = 0; |
138 |
forth_build_vocabulary(*mGlobalVocalbulary, *this); |
139 |
|
140 |
forth_disassemble(*this); |
141 |
} |
142 |
|
143 |
ForthVM::~ForthVM() |
144 |
{ |
145 |
delete datastack; |
146 |
delete codestack; |
147 |
delete mGlobalVocalbulary; |
148 |
} |
149 |
|
150 |
void ForthVM::emitFCode(uint32 fcode) |
151 |
{ |
152 |
if (fcode > 0xfff || (fcode >= 0x01 && fcode <= 0x0f)) { |
153 |
throw ForthInterpreterException(mErrorPos, "internal: broken fcode %x", fcode); |
154 |
} |
155 |
if (fcode > 0xff) { |
156 |
emitFCodeByte(fcode>>8); |
157 |
} |
158 |
emitFCodeByte(fcode); |
159 |
} |
160 |
|
161 |
void ForthVM::emitFCodeByte(byte b) |
162 |
{ |
163 |
*mFCodeBuffer += (char)b; |
164 |
} |
165 |
|
166 |
byte ForthVM::getFCodeByte() |
167 |
{ |
168 |
if (mFCodeBufferIdx >= mFCodeBuffer->length()) throw ForthRunException(mErrorPos, "unexpected end of program"); |
169 |
return (*mFCodeBuffer)[mFCodeBufferIdx++]; |
170 |
} |
171 |
|
172 |
uint32 ForthVM::getFCode() |
173 |
{ |
174 |
uint32 fcode = getFCodeByte(); |
175 |
if (fcode >= 0x01 && fcode <= 0x0f) { |
176 |
fcode <<= 8; |
177 |
fcode |= getFCodeByte(); |
178 |
} |
179 |
return fcode; |
180 |
} |
181 |
|
182 |
int ForthVM::outf(const char *m, ...) |
183 |
{ |
184 |
char b[1024]; |
185 |
va_list va; |
186 |
va_start(va, m); |
187 |
int a = ht_vsnprintf(b, sizeof b, m, va); |
188 |
va_end(va); |
189 |
gDisplay->print(b); |
190 |
return a; |
191 |
} |
192 |
|
193 |
bool ForthVM::getChar() |
194 |
{ |
195 |
if (input->read(¤tChar, 1) != 1) { |
196 |
// ht_printf("getChar: false\n"); |
197 |
return false; |
198 |
} |
199 |
if (currentChar == 10) { |
200 |
mPos.incLine(); |
201 |
mPos.clearPos(); |
202 |
} |
203 |
mPos.inc(); |
204 |
// ht_printf("getChar: %d '%c'\n", currentChar, currentChar); |
205 |
return true; |
206 |
} |
207 |
|
208 |
String &ForthVM::getToken(const String &delimiters) |
209 |
{ |
210 |
|
211 |
} |
212 |
|
213 |
bool ForthVM::consumeSpace(bool except) |
214 |
{ |
215 |
return false; |
216 |
} |
217 |
|
218 |
bool ForthVM::skipWhite() |
219 |
{ |
220 |
do { |
221 |
switch (currentChar) { |
222 |
case 9: |
223 |
case ' ': |
224 |
if (!getChar()) return false; |
225 |
continue; |
226 |
} |
227 |
} while (0); |
228 |
return true; |
229 |
} |
230 |
|
231 |
bool ForthVM::skipWhiteCR() |
232 |
{ |
233 |
while (currentChar == ' ' || currentChar == 10 || currentChar == 13 || currentChar == 9) { |
234 |
if (!getChar()) return false; |
235 |
} |
236 |
return true; |
237 |
} |
238 |
|
239 |
void ForthVM::interprete(Stream &in, Stream &out) |
240 |
{ |
241 |
input = ∈ |
242 |
output = &out; |
243 |
mPos.setLinePos(1, 1); |
244 |
mPos.setMode(fpmLinePos); |
245 |
if (!getChar()) return; |
246 |
mMode = fmInterprete; |
247 |
while (1) { |
248 |
// get a token |
249 |
if (!skipWhiteCR()) break; |
250 |
int i=0; |
251 |
mErrorPos.copy(mPos); |
252 |
do { |
253 |
if (i==sizeof mCurToken) throw ForthInterpreterException(mErrorPos, "token too long"); |
254 |
mCurToken[i++] = currentChar; |
255 |
if (!getChar()) break; |
256 |
if (currentChar==9 || currentChar==10 || currentChar==13 || currentChar==' ') { |
257 |
break; |
258 |
} |
259 |
} while (1); |
260 |
mCurToken[i] = 0; |
261 |
ForthWordBuildIn fwbi(mCurToken, 0, NULL); |
262 |
ForthWord *fw = (ForthWord*)mGlobalVocalbulary->get(mGlobalVocalbulary->find(&fwbi)); |
263 |
if (fw) { |
264 |
if (mMode == fmCompile) { |
265 |
fw->compile(*this); |
266 |
} else { |
267 |
fw->interprete(*this); |
268 |
} |
269 |
} else { |
270 |
throw ForthInterpreterException(mErrorPos, "unkown word '%s'", mCurToken); |
271 |
} |
272 |
} |
273 |
} |
274 |
|
275 |
/* |
276 |
* data stack |
277 |
*/ |
278 |
void ForthVM::dataPush(uint32 value) |
279 |
{ |
280 |
datastack->push(new UInt(value)); |
281 |
} |
282 |
|
283 |
uint32 ForthVM::dataPop() |
284 |
{ |
285 |
UInt *u = (UInt*)datastack->pop(); |
286 |
if (!u) { |
287 |
throw ForthRunException(mErrorPos, "Stack underflow"); |
288 |
} |
289 |
return u->value; |
290 |
} |
291 |
|
292 |
bool ForthVM::dataEmpty() |
293 |
{ |
294 |
return datastack->isEmpty(); |
295 |
} |
296 |
|
297 |
uint32 ForthVM::dataGet(uint n) |
298 |
{ |
299 |
UInt *u; |
300 |
if (datastack->isEmpty() || !((u = (UInt*)(*datastack)[datastack->count() - n - 1]))) { |
301 |
throw ForthRunException(mErrorPos, "Stack underflow"); |
302 |
} |
303 |
return u->value; |
304 |
} |
305 |
|
306 |
void ForthVM::dataClear() |
307 |
{ |
308 |
datastack->delAll(); |
309 |
} |
310 |
|
311 |
uint32 ForthVM::dataDepth() |
312 |
{ |
313 |
return datastack->count(); |
314 |
} |
315 |
|
316 |
void *ForthVM::dataStr(uint32 u, bool exc) |
317 |
{ |
318 |
void *p = NULL;//prom_mem_eaptr(u); |
319 |
if (!p) throw ForthRunException(mErrorPos, "invalid address"); |
320 |
return p; |
321 |
} |
322 |
|
323 |
/* |
324 |
* code stack |
325 |
*/ |
326 |
void ForthVM::codePush(uint32 value) |
327 |
{ |
328 |
codestack->push(new UInt(value)); |
329 |
} |
330 |
|
331 |
uint32 ForthVM::codePop() |
332 |
{ |
333 |
UInt *u = (UInt*)codestack->pop(); |
334 |
if (!u) { |
335 |
throw ForthRunException(mErrorPos, "Codestack underflow"); |
336 |
} |
337 |
return u->value; |
338 |
} |
339 |
|
340 |
bool ForthVM::codeEmpty() |
341 |
{ |
342 |
return codestack->isEmpty(); |
343 |
} |
344 |
|
345 |
uint32 ForthVM::codeGet(uint n) |
346 |
{ |
347 |
UInt *u; |
348 |
if (codestack->isEmpty() || !((u = (UInt*)(*codestack)[codestack->count() - n - 1]))) { |
349 |
throw ForthRunException(mErrorPos, "Codestack underflow"); |
350 |
} |
351 |
return u->value; |
352 |
} |
353 |
|
354 |
void ForthVM::codeClear() |
355 |
{ |
356 |
codestack->delAll(); |
357 |
} |
358 |
|
359 |
uint32 ForthVM::codeDepth() |
360 |
{ |
361 |
return codestack->count(); |
362 |
} |
363 |
|
364 |
/* |
365 |
* memory |
366 |
*/ |
367 |
void ForthVM::promMalloc(uint32 size, uint32 &ea, void **p) |
368 |
{ |
369 |
// ea = prom_mem_malloc(size); |
370 |
// *p = prom_mem_ptr(ea); |
371 |
// ea = prom_mem_phys_to_virt(ea); |
372 |
} |
373 |
|
374 |
/* |
375 |
* |
376 |
*/ |
377 |
ForthWord::ForthWord(const char *n) |
378 |
:Object() |
379 |
{ |
380 |
mName = strdup(n); |
381 |
} |
382 |
|
383 |
ForthWord::~ForthWord() |
384 |
{ |
385 |
free(mName); |
386 |
} |
387 |
|
388 |
int ForthWord::compareTo(const Object *obj) const |
389 |
{ |
390 |
return strcmp(mName, ((ForthWord*)obj)->mName); |
391 |
} |
392 |
|
393 |
void ForthWord::compile(ForthVM &vm) |
394 |
{ |
395 |
throw ForthInterpreterException(vm.mErrorPos, "internal: no compile method for '%s'", mName); |
396 |
} |
397 |
|
398 |
uint32 ForthWord::getExecToken(ForthVM &vm) |
399 |
{ |
400 |
throw ForthInterpreterException(vm.mErrorPos, "cannot tick '%s'", mName); |
401 |
} |
402 |
|
403 |
void ForthWord::interprete(ForthVM &vm) |
404 |
{ |
405 |
throw ForthInterpreterException(vm.mErrorPos, "internal: no interprete method for %s", mName); |
406 |
} |
407 |
|
408 |
int ForthWord::toString(char *buf, int buflen) const |
409 |
{ |
410 |
return ht_snprintf(buf, buflen, "[WORD:'%s']", mName); |
411 |
} |
412 |
|
413 |
ForthWordBuildIn::ForthWordBuildIn(const char *name, uint32 fcode, FCodeFunction func) |
414 |
:ForthWord(name) |
415 |
{ |
416 |
mFCode = fcode; |
417 |
mFunc = func; |
418 |
} |
419 |
|
420 |
void ForthWordBuildIn::compile(ForthVM &vm) |
421 |
{ |
422 |
vm.emitFCode(mFCode); |
423 |
} |
424 |
|
425 |
uint32 ForthWordBuildIn::getExecToken(ForthVM &vm) |
426 |
{ |
427 |
return mFCode; |
428 |
} |
429 |
|
430 |
void ForthWordBuildIn::interprete(ForthVM &vm) |
431 |
{ |
432 |
mFunc(vm); |
433 |
} |
434 |
|
435 |
/* |
436 |
* |
437 |
*/ |
438 |
|
439 |
ForthWordAlias::ForthWordAlias(const char *name, int n, ...) |
440 |
:ForthWord(name) |
441 |
{ |
442 |
va_list ap; |
443 |
mFCodes = (uint16*)malloc(n*sizeof (uint16)); |
444 |
for (int i=0; i<n; i++) { |
445 |
mFCodes[i] = va_arg(ap, int); |
446 |
} |
447 |
va_end(ap); |
448 |
mNumFCodes = n; |
449 |
} |
450 |
|
451 |
void ForthWordAlias::compile(ForthVM &vm) |
452 |
{ |
453 |
for (int i=0; i<mNumFCodes; i++) { |
454 |
vm.emitFCode(mFCodes[i]); |
455 |
} |
456 |
} |
457 |
|
458 |
void ForthWordAlias::interprete(ForthVM &vm) |
459 |
{ |
460 |
} |
461 |
|
462 |
/* |
463 |
* |
464 |
*/ |
465 |
ForthWordString::ForthWordString(const char *name, ForthWordStringType fwst) |
466 |
:ForthWord(name) |
467 |
{ |
468 |
mFwst = fwst; |
469 |
} |
470 |
|
471 |
void ForthWordString::compile(ForthVM &vm) |
472 |
{ |
473 |
} |
474 |
|
475 |
String &ForthWordString::get(ForthVM &vm, String &s) |
476 |
{ |
477 |
s = ""; |
478 |
if (vm.currentChar == 10 || vm.currentChar == 13) return s; |
479 |
while (1) { |
480 |
if (!vm.getChar()) throw ForthInterpreterException(vm.mErrorPos, "unterminated string"); |
481 |
switch (mFwst) { |
482 |
case fwstString: |
483 |
case fwstStringPrint: |
484 |
if (vm.currentChar=='"') { |
485 |
vm.getChar(); |
486 |
return s; |
487 |
} |
488 |
break; |
489 |
case fwstStringWithHex: |
490 |
if (vm.currentChar=='"') { |
491 |
if (!vm.getChar()) return s; |
492 |
if (vm.currentChar=='(') { |
493 |
// start hex mode and wait for ')' |
494 |
} else { |
495 |
return s; |
496 |
} |
497 |
} |
498 |
break; |
499 |
case fwstStringPrintBracket: |
500 |
if (vm.currentChar==')') { |
501 |
vm.getChar(); |
502 |
return s; |
503 |
} |
504 |
break; |
505 |
} |
506 |
s += vm.currentChar; |
507 |
} |
508 |
} |
509 |
|
510 |
void ForthWordString::interprete(ForthVM &vm) |
511 |
{ |
512 |
String s; |
513 |
get(vm, s); |
514 |
switch (mFwst) { |
515 |
case fwstString: |
516 |
case fwstStringWithHex: { |
517 |
int len = s.length(); |
518 |
memmove(vm.mStringBuffer[vm.mStringBufferIdx], s.content(), MIN(len, STRING_BUFFER_SIZE)); |
519 |
vm.dataPush(vm.mStringBufferEA[vm.mStringBufferIdx]); |
520 |
vm.dataPush(len); |
521 |
vm.mStringBufferIdx ^= 1; |
522 |
break; |
523 |
} |
524 |
case fwstStringPrint: |
525 |
case fwstStringPrintBracket: |
526 |
vm.outf("%y", &s); |
527 |
break; |
528 |
} |
529 |
} |
530 |
|
531 |
ForthVar::ForthVar(const char *name, uint32 address) |
532 |
: ForthWord(name) |
533 |
{ |
534 |
} |
535 |
|
536 |
void ForthVar::compile(ForthVM &vm) |
537 |
{ |
538 |
} |
539 |
|
540 |
uint32 ForthVar::getExecToken(ForthVM &vm) |
541 |
{ |
542 |
} |
543 |
|
544 |
void ForthVar::interprete(ForthVM &vm) |
545 |
{ |
546 |
} |
547 |
|