alx/ueforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Adding floating point.

Browse Source
This commit is contained in:
Brad Nelson
2021-09-17 21:57:21 -07:00
parent aae4aba3a2
commit 86a46396f9
15 changed files with 240 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
ueforth/Makefile
View File

@ -149,7 +149,7 @@ $(GEN):
mkdir -p $@
POSIX_BOOT = common/boot.fs common/conditionals.fs common/vocabulary.fs \
common/hide_calls.fs common/ansi.fs \
common/hide_calls.fs common/ansi.fs common/floats.fs \
posix/posix.fs posix/posix_highlevel.fs posix/termios.fs \
common/tasks.fs common/utils.fs common/highlevel.fs common/filetools.fs \
common/locals.fs posix/posix_desktop.fs \
@ -161,7 +161,7 @@ $(GEN)/posix_boot.h: common/source_to_string.js $(POSIX_BOOT) | $(GEN)
echo "ok" | cat $(POSIX_BOOT) - | cat | $< boot $(VERSION) $(REVISION) >$@
WINDOWS_BOOT = common/boot.fs common/conditionals.fs common/vocabulary.fs \
common/hide_calls.fs common/ansi.fs \
common/hide_calls.fs common/ansi.fs common/floats.fs \
windows/windows.fs windows/windows_highlevel.fs common/highlevel.fs \
common/tasks.fs common/utils.fs common/filetools.fs common/streams.fs \
common/blocks.fs common/locals.fs \
@ -171,7 +171,7 @@ $(GEN)/windows_boot.h: common/source_to_string.js $(WINDOWS_BOOT) | $(GEN)
ESP32_BOOT = common/boot.fs common/conditionals.fs common/vocabulary.fs \
common/tasks.fs esp32/platform.fs esp32/highlevel.fs \
esp32/bindings.fs common/highlevel.fs \
esp32/bindings.fs common/highlevel.fs common/floats.fs \
common/filetools.fs common/utils.fs common/locals.fs \
common/streams.fs posix/httpd.fs posix/web_interface.fs esp32/web_interface.fs \
esp32/registers.fs esp32/timers.fs \
@ -245,6 +245,8 @@ $(POSIX):
$(POSIX)/ueforth: \
posix/posix_main.c \
common/opcodes.h \
common/floats.h \
common/calls.h \
common/interp.h \
common/core.h \
$(GEN)/posix_boot.h | $(POSIX)
@ -259,6 +261,8 @@ $(WINDOWS):
$(WINDOWS)/uEf32.obj: \
windows/windows_main.c \
common/opcodes.h \
common/floats.h \
common/calls.h \
common/core.h \
windows/windows_interp.h \
$(GEN)/windows_boot.h | $(WINDOWS)
@ -272,6 +276,8 @@ $(WINDOWS)/uEf32.exe: \
$(WINDOWS)/uEf64.obj: \
windows/windows_main.c \
common/opcodes.h \
common/floats.h \
common/calls.h \
common/core.h \
windows/windows_interp.h \
$(GEN)/windows_boot.h | $(WINDOWS)
@ -289,6 +295,7 @@ $(ESP32)/ESP32forth:
ESP32_PARTS = esp32/template.ino \
common/opcodes.h \
common/floats.h \
common/calling.h \
common/core.h \
common/interp.h \

1
ueforth/common/all_tests.fs
View File

@ -20,4 +20,5 @@ include common/vocabulary_tests.fs
include common/locals_tests.fs
include common/doloop_tests.fs
include common/conditionals_tests.fs
include common/float_tests.fs
run-tests

2
ueforth/common/boot.fs
View File

@ -119,7 +119,9 @@
( Stack Convience )
sp@ constant sp0
rp@ constant rp0
fp@ constant fp0
: depth ( -- n ) sp@ sp0 - cell/ ;
: fdepth ( -- n ) fp@ fp0 - 4 / ;
( Rstack nest depth )
variable nest-depth

77
ueforth/common/core.h
View File

@ -35,18 +35,17 @@ static struct {
char **argv;
cell_t *(*runner)(cell_t *rp); // pointer to forth_run
cell_t *rp; // spot to park main thread
cell_t DOLIT_XT, DOEXIT_XT, YIELD_XT;
cell_t DOLIT_XT, DOFLIT_XT, DOEXIT_XT, YIELD_XT;
} g_sys;
static cell_t convert(const char *pos, cell_t n, cell_t *ret) {
static cell_t convert(const char *pos, cell_t n, cell_t base, cell_t *ret) {
*ret = 0;
cell_t negate = 0;
cell_t base = g_sys.base;
if (!n) { return 0; }
if (pos[0] == '-') { negate = -1; ++pos; --n; }
if (pos[0] == '$') { base = 16; ++pos; --n; }
if (*pos == '-') { negate = -1; ++pos; --n; }
if (*pos == '$') { base = 16; ++pos; --n; }
for (; n; --n) {
uintptr_t d = UPPER(pos[0]) - '0';
uintptr_t d = UPPER(*pos) - '0';
if (d > 9) {
d -= 7;
if (d < 10) { return 0; }
@ -59,6 +58,42 @@ static cell_t convert(const char *pos, cell_t n, cell_t *ret) {
return -1;
}
static cell_t fconvert(const char *pos, cell_t n, float *ret) {
*ret = 0;
cell_t negate = 0;
cell_t has_dot = 0;
cell_t exp = 0;
float shift = 1.0;
if (!n) { return 0; }
if (*pos == '-') { negate = -1; ++pos; --n; }
for (; n; --n) {
if (*pos >= '0' && *pos <= '9') {
if (has_dot) {
shift = shift * 0.1f;
*ret = *ret + (*pos - '0') * shift;
} else {
*ret = *ret * 10 + (*pos - '0');
}
} else if (*pos == 'e' || *pos == 'E') {
break;
} else if (*pos == '.') {
if (has_dot) { return 0; }
has_dot = -1;
}
++pos;
}
if (!n) { return 0; } // must have E
++pos; --n;
if (n) {
if (!convert(pos, n, 10, &exp)) { return 0; }
}
if (exp < -128 || exp > 128) { return 0; }
for (;exp < 0; ++exp) { *ret *= 0.1f; }
for (;exp > 0; --exp) { *ret *= 10.0f; }
if (negate) { *ret = -*ret; }
return -1;
}
static cell_t same(const char *a, const char *b, cell_t len) {
for (;len && UPPER(*a) == UPPER(*b); --len, ++a, ++b);
return len == 0;
@ -106,7 +141,7 @@ static cell_t parse(cell_t sep, cell_t *ret) {
return len;
}
static cell_t *evaluate1(cell_t *sp) {
static cell_t *evaluate1(cell_t *sp, float **fp) {
cell_t call = 0;
cell_t name;
cell_t len = parse(' ', &name);
@ -120,8 +155,7 @@ static cell_t *evaluate1(cell_t *sp) {
}
} else {
cell_t n;
cell_t ok = convert((const char *) name, len, &n);
if (ok) {
if (convert((const char *) name, len, g_sys.base, &n)) {
if (g_sys.state) {
*g_sys.heap++ = g_sys.DOLIT_XT;
*g_sys.heap++ = n;
@ -129,14 +163,24 @@ static cell_t *evaluate1(cell_t *sp) {
*++sp = n;
}
} else {
float f;
if (fconvert((const char *) name, len, &f)) {
if (g_sys.state) {
*g_sys.heap++ = g_sys.DOFLIT_XT;
*(float *) g_sys.heap++ = f;
} else {
*++(*fp) = f;
}
} else {
#if PRINT_ERRORS
write(2, (void *) name, len);
write(2, "\n", 1);
write(2, (void *) name, len);
write(2, "\n", 1);
#endif
*++sp = name;
*++sp = len;
*++sp = -1;
call = g_sys.notfound;
*++sp = name;
*++sp = len;
*++sp = -1;
call = g_sys.notfound;
}
}
}
*++sp = call;
@ -150,6 +194,7 @@ static void forth_init(int argc, char *argv[], void *heap,
g_sys.heap = ((cell_t *) heap) + 4; // Leave a little room.
cell_t *sp = g_sys.heap + 1; g_sys.heap += STACK_SIZE;
cell_t *rp = g_sys.heap + 1; g_sys.heap += STACK_SIZE;
float *fp = (float *) (g_sys.heap + 1); g_sys.heap += STACK_SIZE;
// FORTH vocabulary
*g_sys.heap++ = 0; cell_t *forth = g_sys.heap;
@ -163,6 +208,7 @@ static void forth_init(int argc, char *argv[], void *heap,
forth_run(0);
(*g_sys.current)[-1] = IMMEDIATE; // Make last word ; IMMEDIATE
g_sys.DOLIT_XT = FIND("DOLIT");
g_sys.DOFLIT_XT = FIND("DOFLIT");
g_sys.DOEXIT_XT = FIND("EXIT");
g_sys.YIELD_XT = FIND("YIELD");
g_sys.notfound = FIND("DROP");
@ -176,6 +222,7 @@ static void forth_init(int argc, char *argv[], void *heap,
g_sys.tib = src;
g_sys.ntib = src_len;
*++rp = (cell_t) sp;
*++rp = (cell_t) fp;
*++rp = (cell_t) start;
g_sys.rp = rp;
g_sys.runner = forth_run;

57
ueforth/common/float_tests.fs Normal file
View File

@ -0,0 +1,57 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
e: test-f.
123e f. cr
out: 123.000000
123.123e f. cr
out: 123.123000
-123.123e f. cr
out: -123.123000
;e
e: test-f+
123e 11e f+ f. cr
out: 134.000000
;e
e: test-f*
123e 10e f* f. cr
out: 1230.000000
;e
e: test-1/f
100e 1/f f. cr
out: 0.009999
;e
e: test-f/
1000e 4e f/ f. cr
out: 250.000000
;e
e: test-fsqrt
256e fsqrt f. cr
out: 16.000000
;e
e: test-fswap
123e 234e fswap f. f. cr
out: 123.000000 234.000000
;e
e: test-fover
123e 234e fover f. f. f. cr
out: 123.000000 234.000000 123.000000
;e

47
ueforth/common/floats.fs Normal file
View File

@ -0,0 +1,47 @@
\ Copyright 2021 Bradley D. Nelson
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
6 value precision
: set-precision ( n -- ) to precision ;
internals definitions
: #f+s ( r -- ) fdup precision 0 ?do 10e f* loop
precision 0 ?do fdup f>s 10 mod [char] 0 + hold 0.1e f* loop
[char] . hold fdrop f>s #s ;
forth definitions internals
: #fs ( r -- ) fdup f0< if fnegate #f+s [char] - hold else #f+s then ;
: f. ( r -- ) <# #fs #> type space ;
: fnip ( ra rb -- rb ) fswap fdrop ;
internals definitions
: 1/f' ( r -- r )
2.82352941176e fover 1.88235294118e f* f-
20 0 do fover fover f* 2e fswap f- f* loop fnip ;
$80000000 constant sign-mask
$7f800000 constant exp-mask
$3f000000 constant half-mask
$007fffff constant mantissa-mask
: fsplit ( r -- r f n )
fdup fp@ l@ dup mantissa-mask and half-mask or fp@ l!
dup 0< swap exp-mask and 23 rshift 126 - fdrop ;
: fjoin ( r f n -- r )
127 + 23 lshift swap $80000000 and or
1e fswap fp@ @ mantissa-mask and or fp@ ! f* ;
forth definitions internals
: 1/f ( r -- r ) fsplit negate 1/f' fjoin ;
: f/ ( r r -- r ) 1/f f* ;
: fsqrt ( r -- r ) 1e 20 0 do fover fover f/ f+ 0.5e f* loop fnip ;
forth

35
ueforth/common/floats.h Normal file
View File

@ -0,0 +1,35 @@
// Copyright 2021 Bradley D. Nelson
//
// Licensed under the Apache License, Version 2.0 (the "License");
// you may not use this file except in compliance with the License.
// You may obtain a copy of the License at
//
// http://www.apache.org/licenses/LICENSE-2.0
//
// Unless required by applicable law or agreed to in writing, software
// distributed under the License is distributed on an "AS IS" BASIS,
// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
// See the License for the specific language governing permissions and
// limitations under the License.
#define FDUP (*++fp = ftos)
#define FDROP (ftos = *fp--)
#define FLOATING_POINT_LIST \
Y(DOFLIT, FDUP; ftos = *(float *) ip++) \
X("FP@", FPAT, DUP; tos = (cell_t) fp) \
X("FP!", FPSTORE, fp = (float *) tos; DROP) \
X("SF@", FAT, FDUP; ftos = *(float *) tos; DROP) \
X("SF!", FSTORE, *(float *) tos = ftos; FDROP; DROP) \
X("FDUP", FDUP, FDUP) \
X("FDROP", FDROP, FDROP) \
X("FOVER", FOVER, FDUP; ftos = fp[-1]) \
X("FSWAP", FSWAP, float ft = ftos; ftos = *fp; *fp = ft) \
X("FNEGATE", FNEGATE, ftos = -ftos) \
X("F0<", FZLESS, DUP; tos = ftos < 0 ? -1 : 0; FDROP) \
X("F+", FPLUS, ftos += *fp--) \
X("F-", FMINUS, ftos = (*fp--) - ftos) \
X("F*", FSTAR, ftos *= *fp--) \
X("S>F", STOF, FDUP; ftos = (float) tos; DROP) \
X("F>S", FTOS, DUP; tos = (cell_t) ftos; FDROP) \

4
ueforth/common/interp.h
View File

@ -27,8 +27,10 @@ static cell_t *forth_run(cell_t *init_rp) {
return 0;
}
register cell_t *ip, *rp, *sp, tos, w;
register float ftos, *fp;
rp = init_rp; ip = (cell_t *) *rp--; sp = (cell_t *) *rp--;
DROP; NEXT;
fp = (float *) *rp--;
DROP; FDROP; NEXT;
#define X(name, op, code) OP_ ## op: { code; } NEXT;
PLATFORM_OPCODE_LIST
OPCODE_LIST

8
ueforth/common/opcodes.h
View File

@ -84,8 +84,10 @@ typedef int64_t dcell_t;
Y(CELL, DUP; tos = sizeof(cell_t)) \
Y(FIND, tos = find((const char *) *sp, tos); --sp) \
Y(PARSE, DUP; tos = parse(tos, sp)) \
X("S>NUMBER?", CONVERT, tos = convert((const char *) *sp, tos, sp); \
X("S>NUMBER?", CONVERT, tos = convert((const char *) *sp, tos, g_sys.base, sp); \
if (!tos) --sp) \
X("F>NUMBER?", FCONVERT, FDUP; tos = fconvert((const char *) *sp, tos, fp); \
--sp; FDROP) \
Y(CREATE, DUP; DUP; tos = parse(32, sp); \
create((const char *) *sp, tos, 0, ADDR_DOCREATE); \
COMMA(0); DROPn(2)) \
@ -96,7 +98,9 @@ typedef int64_t dcell_t;
X(":", COLON, DUP; DUP; tos = parse(32, sp); \
create((const char *) *sp, tos, SMUDGE, ADDR_DOCOLON); \
g_sys.state = -1; --sp; DROP) \
Y(EVALUATE1, DUP; sp = evaluate1(sp); w = *sp--; DROP; if (w) JMPW) \
Y(EVALUATE1, DUP; FDUP; float *tfp = fp; \
sp = evaluate1(sp, &tfp); \
fp = tfp; FDROP; w = *sp--; DROP; if (w) JMPW) \
Y(EXIT, ip = (cell_t *) *rp--) \
X(";", SEMICOLON, UNSMUDGE(); COMMA(g_sys.DOEXIT_XT); g_sys.state = 0) \

1
ueforth/common/utils.fs
View File

@ -42,6 +42,7 @@ internals definitions
: see-one ( xt -- xt+1 )
dup cell+ swap @
dup ['] DOLIT = if drop dup @ . cell+ exit then
dup ['] DOFLIT = if drop dup sf@ <# [char] e hold #fs #> type space cell+ exit then
dup ['] $@ = if drop ['] s" see.
dup @ dup >r >r dup cell+ r> type cell+ r> aligned +
[char] " emit space exit then

12
ueforth/esp32/fuse_ino.js
View File

@ -33,15 +33,17 @@ function DropCopyright(source) {
var version = process.argv[2];
var revision = process.argv[3];
var code = fs.readFileSync(process.argv[4]).toString();
var opcodes = DropCopyright(fs.readFileSync(process.argv[5]).toString());
var calling = DropCopyright(fs.readFileSync(process.argv[6]).toString());
var core = DropCopyright(fs.readFileSync(process.argv[7]).toString());
var interp = DropCopyright(fs.readFileSync(process.argv[8]).toString());
var boot = DropCopyright(fs.readFileSync(process.argv[9]).toString());
var floats = DropCopyright(fs.readFileSync(process.argv[5]).toString());
var opcodes = DropCopyright(fs.readFileSync(process.argv[6]).toString());
var calling = DropCopyright(fs.readFileSync(process.argv[7]).toString());
var core = DropCopyright(fs.readFileSync(process.argv[8]).toString());
var interp = DropCopyright(fs.readFileSync(process.argv[9]).toString());
var boot = DropCopyright(fs.readFileSync(process.argv[10]).toString());
code = code.replace('{{VERSION}}', function() { return version; });
code = code.replace('{{REVISION}}', function() { return revision; });
code = code.replace('{{opcodes}}', function() { return opcodes; });
code = code.replace('{{floats}}', function() { return floats; });
code = code.replace('{{calling}}', function() { return calling; });
code = code.replace('{{boot}}', function() { return boot; });
code = code.replace('{{core}}', function() { return core; });

2
ueforth/esp32/template.ino
View File

@ -20,6 +20,7 @@
*/
{{opcodes}}
{{floats}}
{{calling}}
// For now, default on several options.
@ -80,6 +81,7 @@
#endif
#define PLATFORM_OPCODE_LIST \
FLOATING_POINT_LIST \
/* Memory Allocation */ \
Y(MALLOC, SET malloc(n0)) \
Y(SYSFREE, free(a0); DROP) \

2
ueforth/posix/posix_main.c
View File

@ -16,6 +16,7 @@
#include <sys/mman.h>
#include "common/opcodes.h"
#include "common/floats.h"
#include "common/calling.h"
#include "common/calls.h"
@ -24,6 +25,7 @@
#define PLATFORM_OPCODE_LIST \
Y(DLSYM, tos = (cell_t) dlsym(a1, a0); --sp) \
FLOATING_POINT_LIST \
CALLING_OPCODE_LIST \
#include "common/core.h"

4
ueforth/windows/windows_interp.h
View File

@ -38,8 +38,10 @@ static cell_t *forth_run(cell_t *init_rp) {
return 0;
}
register cell_t *ip, *rp, *sp, tos, w;
register float ftos, *fp;
rp = init_rp; ip = (cell_t *) *rp--; sp = (cell_t *) *rp--;
DROP;
fp = (float *) *rp--;
DROP; FDROP;
for (;;) {
next:
w = *ip++;

2
ueforth/windows/windows_main.c
View File

@ -28,6 +28,7 @@
#endif
#include "common/opcodes.h"
#include "common/floats.h"
#include "common/calling.h"
#include "common/calls.h"
@ -39,6 +40,7 @@
tos = (cell_t) GetProcAddress((HMODULE) *sp, (LPCSTR) tos); --sp) \
Y(LOADLIBRARYA, \
tos = (cell_t) LoadLibraryA((LPCSTR) tos)) \
FLOATING_POINT_LIST \
CALLING_OPCODE_LIST \
#include "common/core.h"