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

Closer still on asm.js

Browse Source 
Split apart boot.fs some more.
This commit is contained in:
Brad Nelson
2022-07-13 15:18:57 -07:00
parent 422507c072
commit 024c51ec7d
12 changed files with 248 additions and 158 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
Makefile
View File

@ -181,8 +181,24 @@ sizes: $(ESP32_SIM)/Esp32forth-sim
$(GEN):
mkdir -p $@
COMMON_PHASE1 = common/boot.fs common/conditionals.fs common/vocabulary.fs \
common/floats.fs common/structures.fs
COMMON_PHASE1 = common/comments.fs \
common/boot.fs \
common/io.fs \
common/conditionals.fs \
common/vocabulary.fs \
common/floats.fs \
common/structures.fs
COMMON_PHASE1e = common/comments.fs \
common/extra1.fs \
common/boot.fs \
common/extra2.fs \
common/io.fs \
common/conditionals.fs \
common/vocabulary.fs \
common/floats.fs \
common/extra3.fs \
common/structures.fs
COMMON_PHASE2 = common/tasks.fs common/utils.fs common/locals.fs \
common/filetools.fs common/including.fs \
@ -245,7 +261,7 @@ $(GEN)/web_dict.js: $(GEN)/dump_web_opcodes | $(GEN)
$(GEN)/web_sys.js: $(GEN)/dump_web_opcodes | $(GEN)
$< sys >$@
WEB_BOOT = $(COMMON_PHASE1) common/extra.fs \
WEB_BOOT = $(COMMON_PHASE1e) \
posix/posix.fs posix/allocation.fs posix/termios.fs \
$(COMMON_PHASE2) \
posix/autoboot.fs \

104
common/boot.fs
View File

@ -12,11 +12,6 @@
\ See the License for the specific language governing permissions and
\ limitations under the License.
: ( 41 parse drop drop ; immediate
: \ 10 parse drop drop ; immediate
: #! 10 parse drop drop ; immediate ( shebang for scripts )
( Now can do comments! )
( Stack Baseline )
sp@ constant sp0
rp@ constant rp0
@ -108,102 +103,3 @@ variable handler
( Deferred Words )
: defer ( "name" -- ) create 0 , does> @ dup 0= throw execute ;
: is ( xt "name -- ) postpone to ; immediate
( Defer I/O to platform specific )
defer type
defer key
defer key?
defer bye
: emit ( n -- ) >r rp@ 1 type rdrop ;
: space bl emit ; : cr 13 emit nl emit ;
( Numeric Output )
variable hld
: pad ( -- a ) here 80 + ;
: digit ( u -- c ) 9 over < 7 and + 48 + ;
: extract ( n base -- n c ) u/mod swap digit ;
: <# ( -- ) pad hld ! ;
: hold ( c -- ) hld @ 1 - dup hld ! c! ;
: # ( u -- u ) base @ extract hold ;
: #s ( u -- 0 ) begin # dup while repeat ;
: sign ( n -- ) 0< if 45 hold then ;
: #> ( w -- b u ) drop hld @ pad over - ;
: str ( n -- b u ) dup >r abs <# #s r> sign #> ;
: hex ( -- ) 16 base ! ; : octal ( -- ) 8 base ! ;
: decimal ( -- ) 10 base ! ; : binary ( -- ) 2 base ! ;
: u. ( u -- ) <# #s #> type space ;
: . ( w -- ) base @ 10 xor if u. exit then str type space ;
: ? ( a -- ) @ . ;
: n. ( n -- ) base @ swap decimal <# #s #> type base ! ;
( Strings )
: parse-quote ( -- a n ) [char] " parse ;
: $place ( a n -- ) for aft dup c@ c, 1+ then next drop ;
: zplace ( a n -- ) $place 0 c, align ;
: $@ r@ dup cell+ swap @ r> dup @ 1+ aligned + cell+ >r ;
: s" parse-quote state @ if postpone $@ dup , zplace
else dup here swap >r >r zplace r> r> then ; immediate
: ." postpone s" state @ if postpone type else type then ; immediate
: z" postpone s" state @ if postpone drop else drop then ; immediate
: r" parse-quote state @ if swap aliteral aliteral then ; immediate
: r| [char] | parse state @ if swap aliteral aliteral then ; immediate
: r~ [char] ~ parse state @ if swap aliteral aliteral then ; immediate
: s>z ( a n -- z ) here >r zplace r> ;
: z>s ( z -- a n ) 0 over begin dup c@ while 1+ swap 1+ swap repeat drop ;
( Better Errors )
: notfound ( a n n -- )
if cr ." ERROR: " type ." NOT FOUND!" cr -1 throw then ;
' notfound 'notfound !
( Input )
: raw.s depth 0 max for aft sp@ r@ cells - @ . then next ;
variable echo -1 echo ! variable arrow -1 arrow ! 0 value wascr
: *emit ( n -- ) dup 13 = if drop cr else emit then ;
: ?echo ( n -- ) echo @ if *emit else drop then ;
: ?arrow. arrow @ if >r >r raw.s r> r> ." --> " then ;
: *key ( -- n )
begin
key
dup nl = if
drop wascr if 0 else 13 exit then
then
dup 13 = to wascr
dup if exit else drop then
again ;
: eat-till-cr begin *key dup 13 = if ?echo exit else drop then again ;
: accept ( a n -- n ) ?arrow. 0 swap begin 2dup < while
*key
dup 13 = if ?echo drop nip exit then
dup 8 = over 127 = or if
drop over if rot 1- rot 1- rot 8 ?echo bl ?echo 8 ?echo then
else
dup ?echo
>r rot r> over c! 1+ -rot swap 1+ swap
then
repeat drop nip
eat-till-cr
;
200 constant input-limit
: tib ( -- a ) 'tib @ ;
create input-buffer input-limit allot
: tib-setup input-buffer 'tib ! ;
: refill tib-setup tib input-limit accept #tib ! 0 >in ! -1 ;
( REPL )
: prompt ." ok" cr ;
: evaluate-buffer begin >in @ #tib @ < while evaluate1 repeat ;
: evaluate ( a n -- ) 'tib @ >r #tib @ >r >in @ >r
#tib ! 'tib ! 0 >in ! evaluate-buffer
r> >in ! r> #tib ! r> 'tib ! ;
: quit begin ['] evaluate-buffer catch
if 0 state ! sp0 sp! fp0 fp! rp0 rp! ." ERROR" cr then
prompt refill drop again ;
variable boot-prompt
: free. ( nf nu -- ) 2dup swap . ." free + " . ." used = " 2dup + . ." total ("
over + 100 -rot */ n. ." % free)" ;
: raw-ok ." v{{VERSION}} - rev {{REVISION}}" cr
boot-prompt @ if boot-prompt @ execute then
." Forth dictionary: " remaining used free. cr
." 3 x Forth stacks: " 'stack-cells @ cells . ." bytes each" cr
prompt refill drop quit ;

18
common/comments.fs Normal file
View File

@ -0,0 +1,18 @@
\ Copyright 2022 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.
: ( 41 parse drop drop ; immediate
: \ 10 parse drop drop ; immediate
: #! 10 parse drop drop ; immediate ( shebang for scripts )
( Now can do comments! )

10
common/core.h
View File

@ -122,8 +122,9 @@ static cell_t find(const char *name, cell_t len) {
}
}
}
if (!(*TOFLAGS(xt) & SMUDGE) && len == *TONAMELEN(xt) &&
same(name, TONAME(xt), len)) {
if (!(*TOFLAGS(xt) & SMUDGE) &&
len == *TONAMELEN(xt) &&
same(name, TONAME(xt), len)) {
return xt;
}
xt = *TOLINK(xt);
@ -161,11 +162,12 @@ static cell_t parse(cell_t sep, cell_t *ret) {
while (g_sys->tin < g_sys->ntib &&
match(sep, g_sys->tib[g_sys->tin])) { ++g_sys->tin; }
}
*ret = (cell_t) (g_sys->tib + g_sys->tin);
cell_t start = g_sys->tin;
while (g_sys->tin < g_sys->ntib &&
!match(sep, g_sys->tib[g_sys->tin])) { ++g_sys->tin; }
cell_t len = g_sys->tin - (*ret - (cell_t) g_sys->tib);
cell_t len = g_sys->tin - start;
if (g_sys->tin < g_sys->ntib) { ++g_sys->tin; }
*ret = (cell_t) (g_sys->tib + start);
return len;
}

42
common/extra.fs → common/extra1.fs
View File

@ -12,6 +12,8 @@
\ See the License for the specific language governing permissions and
\ limitations under the License.
( Words in this file are typically implemented as opcodes in extra_opcodes.h )
( Useful Basic Compound Words )
: nip ( a b -- b ) swap drop ;
: rdrop ( r: n n -- ) r> r> drop >r ;
@ -49,17 +51,6 @@
: 2@ ( a -- lo hi ) dup @ swap cell+ @ ;
: 2! ( lo hi a -- ) dup >r cell+ ! r> ! ;
( Fill, Move )
: cmove ( a a n -- ) for aft >r dup c@ r@ c! 1+ r> 1+ then next 2drop ;
: cmove> ( a a n -- ) for aft 2dup swap r@ + c@ swap r@ + c! then next 2drop ;
: fill ( a n ch -- ) swap for swap aft 2dup c! 1 + then next 2drop ;
: erase ( a n -- ) 0 fill ; : blank ( a n -- ) bl fill ;
( Compound words requiring conditionals )
: min 2dup < if drop else nip then ;
: max 2dup < if nip else drop then ;
: abs ( n -- +n ) dup 0< if negate then ;
( Dictionary )
: here ( -- a ) 'sys @ ;
: allot ( n -- ) 'sys +! ;
@ -68,15 +59,6 @@
: , ( n -- ) here ! cell allot ;
: c, ( ch -- ) here c! 1 allot ;
( Dictionary Format )
: >flags& ( xt -- a ) cell - ; : >flags ( xt -- flags ) >flags& c@ ;
: >name-length ( xt -- n ) >flags& 1+ c@ ;
: >params ( xt -- n ) >flags& 2 + sw@ $ffff and ;
: >size ( xt -- n ) dup >params cells swap >name-length aligned + 3 cells + ;
: >link& ( xt -- a ) 2 cells - ; : >link ( xt -- a ) >link& @ ;
: >name ( xt -- a n ) dup >name-length swap >link& over aligned - swap ;
: >body ( xt -- a ) dup @ [ ' >flags @ ] literal = 2 + cells + ;
( System Variables )
: sys: ( a -- a' "name" ) dup constant cell+ ;
'sys sys: 'heap sys: current sys: 'context
@ -89,6 +71,21 @@
: context ( -- a ) 'context @ cell+ ;
: latestxt ( -- xt ) 'latestxt @ ;
( Compilation State )
: [ 0 state ! ; immediate
: ] -1 state ! ; immediate
: ' bl parse 2dup find dup >r -rot r> 0= 'notfound @ execute 2drop ;
: literal aliteral ; immediate
( Dictionary Format )
: >flags& ( xt -- a ) cell - ; : >flags ( xt -- flags ) >flags& c@ ;
: >name-length ( xt -- n ) >flags& 1+ c@ ;
: >params ( xt -- n ) >flags& 2 + sw@ $ffff and ;
: >size ( xt -- n ) dup >params cells swap >name-length aligned + 3 cells + ;
: >link& ( xt -- a ) 2 cells - ; : >link ( xt -- a ) >link& @ ;
: >name ( xt -- a n ) dup >name-length swap >link& over aligned - swap ;
: >body ( xt -- a ) dup @ [ ' >flags @ ] literal = 2 + cells + ;
: f= ( r r -- f ) f- f0= ;
: f< ( r r -- f ) f- f0< ;
: f> ( r r -- f ) fswap f< ;
@ -99,8 +96,3 @@
4 constant sfloat
: sfloats ( n -- n*4 ) sfloat * ;
: sfloat+ ( a -- a ) sfloat + ;
3.14159265359e fconstant pi
: fsqrt ( r -- r ) 1e 20 0 do fover fover f/ f+ 0.5e f* loop fnip ;

24
common/extra2.fs Normal file
View File

@ -0,0 +1,24 @@
\ Copyright 2022 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.
( Fill, Move )
: cmove ( a a n -- ) for aft >r dup c@ r@ c! 1+ r> 1+ then next 2drop ;
: cmove> ( a a n -- ) for aft 2dup swap r@ + c@ swap r@ + c! then next 2drop ;
: fill ( a n ch -- ) swap for swap aft 2dup c! 1 + then next 2drop ;
: erase ( a n -- ) 0 fill ; : blank ( a n -- ) bl fill ;
( Compound words requiring conditionals )
: min 2dup < if drop else nip then ;
: max 2dup < if nip else drop then ;
: abs ( n -- +n ) dup 0< if negate then ;

17
common/extra3.fs Normal file
View File

@ -0,0 +1,17 @@
\ Copyright 2022 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.
: fsqrt ( r -- r ) 1e 20 0 do fover fover f/ f+ 0.5e f* loop fnip ;
3.14159265359e fconstant pi

112
common/io.fs Normal file
View File

@ -0,0 +1,112 @@
\ Copyright 2022 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.
( Defer I/O to platform specific )
defer type
defer key
defer key?
defer bye
: emit ( n -- ) >r rp@ 1 type rdrop ;
: space bl emit ; : cr 13 emit nl emit ;
( Numeric Output )
variable hld
: pad ( -- a ) here 80 + ;
: digit ( u -- c ) 9 over < 7 and + 48 + ;
: extract ( n base -- n c ) u/mod swap digit ;
: <# ( -- ) pad hld ! ;
: hold ( c -- ) hld @ 1 - dup hld ! c! ;
: # ( u -- u ) base @ extract hold ;
: #s ( u -- 0 ) begin # dup while repeat ;
: sign ( n -- ) 0< if 45 hold then ;
: #> ( w -- b u ) drop hld @ pad over - ;
: str ( n -- b u ) dup >r abs <# #s r> sign #> ;
: hex ( -- ) 16 base ! ; : octal ( -- ) 8 base ! ;
: decimal ( -- ) 10 base ! ; : binary ( -- ) 2 base ! ;
: u. ( u -- ) <# #s #> type space ;
: . ( w -- ) base @ 10 xor if u. exit then str type space ;
: ? ( a -- ) @ . ;
: n. ( n -- ) base @ swap decimal <# #s #> type base ! ;
( Strings )
: parse-quote ( -- a n ) [char] " parse ;
: $place ( a n -- ) for aft dup c@ c, 1+ then next drop ;
: zplace ( a n -- ) $place 0 c, align ;
: $@ r@ dup cell+ swap @ r> dup @ 1+ aligned + cell+ >r ;
: s" parse-quote state @ if postpone $@ dup , zplace
else dup here swap >r >r zplace r> r> then ; immediate
: ." postpone s" state @ if postpone type else type then ; immediate
: z" postpone s" state @ if postpone drop else drop then ; immediate
: r" parse-quote state @ if swap aliteral aliteral then ; immediate
: r| [char] | parse state @ if swap aliteral aliteral then ; immediate
: r~ [char] ~ parse state @ if swap aliteral aliteral then ; immediate
: s>z ( a n -- z ) here >r zplace r> ;
: z>s ( z -- a n ) 0 over begin dup c@ while 1+ swap 1+ swap repeat drop ;
( Better Errors )
: notfound ( a n n -- )
if cr ." ERROR: " type ." NOT FOUND!" cr -1 throw then ;
' notfound 'notfound !
( Input )
: raw.s depth 0 max for aft sp@ r@ cells - @ . then next ;
variable echo -1 echo ! variable arrow -1 arrow ! 0 value wascr
: *emit ( n -- ) dup 13 = if drop cr else emit then ;
: ?echo ( n -- ) echo @ if *emit else drop then ;
: ?arrow. arrow @ if >r >r raw.s r> r> ." --> " then ;
: *key ( -- n )
begin
key
dup nl = if
drop wascr if 0 else 13 exit then
then
dup 13 = to wascr
dup if exit else drop then
again ;
: eat-till-cr begin *key dup 13 = if ?echo exit else drop then again ;
: accept ( a n -- n ) ?arrow. 0 swap begin 2dup < while
*key
dup 13 = if ?echo drop nip exit then
dup 8 = over 127 = or if
drop over if rot 1- rot 1- rot 8 ?echo bl ?echo 8 ?echo then
else
dup ?echo
>r rot r> over c! 1+ -rot swap 1+ swap
then
repeat drop nip
eat-till-cr
;
200 constant input-limit
: tib ( -- a ) 'tib @ ;
create input-buffer input-limit allot
: tib-setup input-buffer 'tib ! ;
: refill tib-setup tib input-limit accept #tib ! 0 >in ! -1 ;
( REPL )
: prompt ." ok" cr ;
: evaluate-buffer begin >in @ #tib @ < while evaluate1 repeat ;
: evaluate ( a n -- ) 'tib @ >r #tib @ >r >in @ >r
#tib ! 'tib ! 0 >in ! evaluate-buffer
r> >in ! r> #tib ! r> 'tib ! ;
: quit begin ['] evaluate-buffer catch
if 0 state ! sp0 sp! fp0 fp! rp0 rp! ." ERROR" cr then
prompt refill drop again ;
variable boot-prompt
: free. ( nf nu -- ) 2dup swap . ." free + " . ." used = " 2dup + . ." total ("
over + 100 -rot */ n. ." % free)" ;
: raw-ok ." v{{VERSION}} - rev {{REVISION}}" cr
boot-prompt @ if boot-prompt @ execute then
." Forth dictionary: " remaining used free. cr
." 3 x Forth stacks: " 'stack-cells @ cells . ." bytes each" cr
prompt refill drop quit ;

2
common/opcodes.h
View File

@ -33,7 +33,7 @@ typedef uintptr_t ucell_t;
#define PUSH DUP; tos = (cell_t)
#define PARK DUP; *++rp = (cell_t) fp; *++rp = (cell_t) sp; *++rp = (cell_t) ip
#define UNPARK ip = (cell_t *) *rp--; sp = (cell_t *) *rp--; fp = (float *) *rp--; DROP
#define UNPARK ip = (cell_t *) *rp--; sp = (cell_t *) *rp--; fp = (float *) *rp--; DROP
#define TOFLAGS(xt) ((uint8_t *) (((cell_t *) (xt)) - 1))
#define TONAMELEN(xt) (TOFLAGS(xt) + 1)

8
web/dump_web_opcodes.c
View File

@ -15,7 +15,7 @@
#include <stdio.h>
#include <string.h>
#define JMPW break decode
#define JMPW continue decode
#define SSMOD_FUNC SSMOD_FUNC
#define COMMA COMMA
@ -74,7 +74,7 @@ int main(int argc, char *argv[]) {
#define G_SYS 256
printf(" const g_sys = %d;\n", G_SYS);
#define EMITSYS(name) \
printf(" const g_sys_%s = %d;\n", #name, 256 + 4 * (((cell_t*) g_sys) - ((cell_t *) &g_sys->name)));
printf(" const g_sys_%s = %d;\n", #name, 256 + 4 * (((cell_t *) &g_sys->name) - (cell_t*) g_sys));
EMITSYS(heap);
EMITSYS(current);
EMITSYS(context);
@ -100,6 +100,10 @@ int main(int argc, char *argv[]) {
EMITSYS(YIELD_XT);
EMITSYS(DOCREATE_OP);
EMITSYS(builtins);
printf(" const OP_DOCREATE = %d;\n", OP_DOCREATE);
printf(" const OP_DOCOL = %d;\n", OP_DOCOL);
printf(" const OP_DOVAR = %d;\n", OP_DOVAR);
printf(" const OP_DOCON = %d;\n", OP_DOCON);
} else {
fprintf(stderr, "USAGE: %s cases/dict/sys\n", argv[1]);
return 1;

8
web/fuse_web.js
View File

@ -30,6 +30,8 @@ function ReplaceAll(haystack, needle, replacement) {
}
}
boot = boot.replace(/[\\]/g, '\\\\');
cases = ReplaceAll(cases, 'DROP;', 'tos = *sp--;');
cases = ReplaceAll(cases, 'DUP;', '*++sp = tos;');
@ -99,14 +101,10 @@ cases = ReplaceAll(cases, /[&]g_sys[-][>]([A-Za-z_]+)/, 'g_sys_$1');
cases = ReplaceAll(cases, /g_sys[-][>]([A-Za-z_]+) [=] /, 'i32[g_sys_$1>>2] = ');
cases = ReplaceAll(cases, /g_sys[-][>]([A-Za-z_]+)/, '(i32[g_sys_$1>>2]|0)');
cases = ReplaceAll(cases, 'ADDROF(DOCREATE)', '0'); // TODO: might be wrong
cases = ReplaceAll(cases, 'ADDROF(DOVAR)', '1');
cases = ReplaceAll(cases, 'ADDROF(DOCON)', '2');
cases = ReplaceAll(cases, 'ADDROF(DOCOL)', '3');
cases = ReplaceAll(cases, /ADDROF[(]([^)]+)[)]/, 'OP_$1');
cases = ReplaceAll(cases, 'return rp', 'i32[g_sys_rp>>2] = rp | 0; return');
cases = ReplaceAll(cases, 'goto **(void **) w', 'break decode');
cases = ReplaceAll(cases, 'SSMOD_FUNC', '');
// Keep Together vvv
cases = ReplaceAll(cases, /tos ([^=]?)= /, 'txx $1= ');

39
web/web.template.js
View File

@ -74,7 +74,7 @@ function UPPER(ch) {
}
function TOFLAGS(xt) { return xt - 1 * 4; }
function TONAMELEN(xt) { return xt + 1; }
function TONAMELEN(xt) { return TOFLAGS(xt) + 1; }
function TOPARAMS(xt) { return TOFLAGS(xt) + 2; }
function TOSIZE(xt) { return CELL_ALIGNED(u8[TONAMELEN(xt)>>2]) + 4 * i32[TOPARAMS(xt)>>2]; }
function TOLINK(xt) { return xt - 2 * 4; }
@ -115,6 +115,7 @@ function Find(name) {
if (BUILTIN_VOCAB(i) === vocab &&
name.length === BUILTIN_NAMELEN(i) &&
name.toUpperCase() === GetString(BUILTIN_NAME(i), name.length).toUpperCase()) {
console.log('FOUND: ' + name);
return BUILTIN_CODE(i);
}
}
@ -122,11 +123,13 @@ function Find(name) {
if (!(u8[TOFLAGS(xt)] & SMUDGE) &&
name.length === u8[TONAMELEN(xt)] &&
name.toUpperCase() === GetString(TONAME(xt), name.length).toUpperCase()) {
console.log('FOUND REGULAR: ' + name);
return xt;
}
xt = i32[TOLINK(xt)>>2];
}
}
console.log('NOT FOUND! ' + name);
return 0;
}
@ -158,6 +161,7 @@ function DOIMMEDIATE() {
}
function Create(name, flags, op) {
console.log('CREATE: ' + name);
Finish();
i32[g_sys_heap>>2] = CELL_ALIGNED(i32[g_sys_heap>>2]);
i32[g_sys_heap>>2] = Load(i32[g_sys_heap>>2], name); // name
@ -201,11 +205,13 @@ function Parse(sep, ret) {
while (i32[g_sys_tin>>2] < i32[g_sys_ntib>>2] &&
Match(sep, u8[i32[g_sys_tib>>2] + i32[g_sys_tin>>2]])) { ++i32[g_sys_tin>>2]; }
}
i32[ret>>2] = i32[g_sys_tib>>2] + i32[g_sys_tin>>2];
var start = i32[g_sys_tin>>2];
while (i32[g_sys_tin>>2] < i32[g_sys_ntib>>2] &&
!Match(sep, u8[i32[g_sys_tib>>2] + i32[g_sys_tin>>2]])) { ++i32[g_sys_tin>>2]; }
var len = i32[g_sys_tin>>2] - (i32[ret>>2] - i32[g_sys_tib>>2]);
console.log('PARSE: ' + GetString(i32[ret>>2], len));
var len = i32[g_sys_tin>>2] - start;
if (i32[g_sys_tin>>2] < i32[g_sys_ntib>>2]) { ++i32[g_sys_tin>>2]; }
i32[ret>>2] = i32[g_sys_tib>>2] + start;
console.log('PARSE: [' + GetString(i32[ret>>2], len) + ']');
return len;
}
@ -247,7 +253,7 @@ function FConvert(pos, n, ret) {
}
} else if (u8[pos] == 'e'.charCodeAt(0) || u8[pos] == 'E'.charCodeAt(0)) {
break;
} else if (u8[os] == '.'.charCodeAt(0)) {
} else if (u8[pos] == '.'.charCodeAt(0)) {
if (has_dot) { return 0; }
has_dot = -1;
} else {
@ -274,26 +280,30 @@ function Evaluate1(rp) {
var call = 0;
var tos, sp, ip, fp;
// UNPARK
ip = i32[rp>>2]; rp -= 4; fp = i32[rp>>2]; rp -= 4; sp = i32[rp>>2]; rp -= 4; tos = i32[sp>>2]; sp -= 4;
ip = i32[rp>>2]; rp -= 4; sp = i32[rp>>2]; rp -= 4; fp = i32[rp>>2]; rp -= 4; tos = i32[sp>>2]; sp -= 4;
var name = sp + 8;
var len = Parse(32, name);
if (len == 0) { // ignore empty
sp += 4; i32[sp>>2] = tos; tos = 0;
// PARK
sp += 4; i32[sp>>2] = tos; rp += 4; i32[rp>>2] = sp; rp += 4; i32[rp>>2] = fp; rp += 4; i32[rp>>2] = ip;
sp += 4; i32[sp>>2] = tos; rp += 4; i32[rp>>2] = fp; rp += 4; i32[rp>>2] = sp; rp += 4; i32[rp>>2] = ip;
return rp;
}
var xt = Find(GetString(i32[name>>2], len));
name = i32[name>>2];
var xt = Find(GetString(name, len));
if (xt) {
if (i32[g_sys_state>>2] && !(u8[TOFLAGS(xt)] & IMMEDIATE)) {
console.log('compile');
COMMA(xt);
} else {
console.log('execute');
call = xt;
}
} else {
console.log('CONVERTING: ' + GetString(name, len));
var n = sp + 16;
if (Convert(i32[name>>2], len, i32[g_sys_base>>2], n)) {
if (Convert(name, len, i32[g_sys_base>>2], n)) {
if (i32[g_sys_state>>2]) {
COMMA(i32[g_sys_DOLIT_XT>>2]);
COMMA(i32[n>>2]);
@ -301,7 +311,7 @@ function Evaluate1(rp) {
sp += 4; i32[sp>>2] = tos; tos = i32[n>>2];
}
} else {
if (FConvert(i32[name>>2], len, n)) {
if (FConvert(name, len, n)) {
if (i32[g_sys_state>>2]) {
COMMA(i32[g_sys_DOFLIT_XT>>2]);
f32[i32[g_sys_heap>>2]>>2] = f32[n>>2]; i32[g_sys_heap>>2] += 4;
@ -309,17 +319,17 @@ function Evaluate1(rp) {
fp += 4; f32[fp>>2] = f32[n>>2];
}
} else {
console.log('CANT FIND: ' + GetString(i32[name>>2], len));
sp += 4; i32[sp>>2] = i32[name>>2];
console.log('CANT FIND: ' + GetString(name, len));
sp += 4; i32[sp>>2] = name;
sp += 4; i32[sp>>2] = len;
sp += 4; i32[sp>>2] = -1;
call = i32[g_sys_notfound>>2];
}
}
}
sp += 4; i32[sp>>2] = call;
sp += 4; i32[sp>>2] = tos; tos = call;
// PARK
sp += 4; i32[sp>>2] = tos; rp += 4; i32[rp>>2] = sp; rp += 4; i32[rp>>2] = fp; rp += 4; i32[rp>>2] = ip;
sp += 4; i32[sp>>2] = tos; rp += 4; i32[rp>>2] = fp; rp += 4; i32[rp>>2] = sp; rp += 4; i32[rp>>2] = ip;
return rp;
}
@ -367,6 +377,7 @@ function Init() {
i32[g_sys_DOFLIT_XT>>2] = Find("DOFLIT");
i32[g_sys_DOEXIT_XT>>2] = Find("EXIT");
i32[g_sys_YIELD_XT>>2] = Find("YIELD");
i32[g_sys_notfound>>2] = Find("DROP");
// Init code.
var start = i32[g_sys_heap>>2];