Commit 3ef8d7b7 authored by Bernd Paysan's avatar Bernd Paysan

Cleanup and rename doextra->dodoes

parent eb175ade
Pipeline #667 passed with stage
in 8 minutes and 22 seconds
......@@ -101,7 +101,7 @@ forth definitions
: (closure-;]) ( closure-sys lastxt -- )
>r r@ dup >namevt @ >vtextra !
['] extraxt, set-optimizer
['] does, set-optimizer
vt,
postpone THEN
orig? r> >namevt @ swap ! drop
......@@ -116,7 +116,7 @@ forth definitions
: closure> ( body -- addr ) \ gforth-experimental closure-end
\G create trampoline head
doextraxt: >l >l lp@ cell+ ;
dodoes: >l >l lp@ cell+ ;
: end-dclosure ( unravel-xt -- closure-sys )
>r wrap@
postpone lit >mark
......
......@@ -20,7 +20,7 @@
require sections.fs
s" address-unit-bits" environment? drop constant bits/au
11 constant maxdoer-tag
9 constant maxdoer-tag
0 value image1
0 value size1
......
......@@ -1190,16 +1190,12 @@ Ghost hex drop
Ghost lit@ drop
Ghost lit-perform drop
Ghost lit+ drop
Ghost does-exec drop
Ghost extra-exec drop
Ghost extra-xt drop
Ghost does-xt drop
Ghost no-to drop
Ghost refill drop
Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop
Ghost :docol Ghost :dodoes 2drop
Ghost :dovar drop
Ghost :doextraxt drop
\ \ Parameter for target systems 06oct92py
......@@ -1832,7 +1828,7 @@ Ghost (+do) Ghost (-do) Ghost (u-do) 2drop drop
Ghost (for) drop
Ghost (loop) Ghost (+loop) Ghost (-loop) 2drop drop
Ghost (next) drop
Ghost !does Ghost !extraxt 2drop
Ghost set-does> drop
Ghost compile, drop
Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop
Ghost (C") Ghost c(abort") Ghost type 2drop drop
......@@ -2583,9 +2579,9 @@ T 1 cells H Value xt>body
Defer gset-extra
: doextraxt, ( does-action-ghost -- )
]comp [G'] :doextraxt addr, comp[
gset-extra ; ' doextraxt, plugin-of dodoes,
: (dodoes,) ( does-action-ghost -- )
]comp [G'] :dodoes addr, comp[
gset-extra ; ' (dodoes,) plugin-of dodoes,
: (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit,
......@@ -2833,14 +2829,10 @@ Defer instant-interpret-does>-hook ' noop IS instant-interpret-does>-hook
X has? new-does [IF]
X has? primcentric [IF]
: does-resolved ( ghost -- )
compile does-exec g>xt T a, H ;
: extra-resolved ( ghost -- )
compile extra-xt g>xt T a, H ;
compile does-xt g>xt T a, H ;
[ELSE]
: does-resolved ( ghost -- )
g>xt T a, H ;
: extra-resolved ( ghost -- )
g>xt T a, H ;
[THEN]
: resolve-does>-part ( -- )
......@@ -2850,14 +2842,14 @@ X has? primcentric [IF]
Cond: DOES>
T here cfaligned H [ T has? primcentric H [IF] ] 8 [ [ELSE] ] 7 [ [THEN] ] T cells
H + alit, compile !extraxt compile ;
H + alit, compile set-does> compile ;
Last-Header-Ghost @ >do:ghost @ >r
T :noname H
r> ?dup IF swap resolve ELSE drop THEN
;Cond
: DOES>
['] extra-resolved created >comp !
['] does-resolved created >comp !
T here cfaligned #10 cells H \ includes noname header+vtable
+ !newdoes
T :noname H 2drop
......@@ -2867,7 +2859,7 @@ T :noname H
T has? primcentric H [IF]
: does-resolved ( ghost -- )
\ g>xt dup T >body H alit, compile call T cell+ @ a, H ;
compile does-exec g>xt T a, H ;
compile does-xt g>xt T a, H ;
[ELSE]
: does-resolved ( ghost -- )
g>xt T a, H ;
......@@ -3014,7 +3006,7 @@ Ghost docol-vt drop
ghost :,
ghost peephole-compile,
2drop
ghost extraxt,
ghost set-does>
drop
ghost value,
ghost constant,
......@@ -3187,11 +3179,11 @@ variable cross-boot[][]
:noname ( doesxt -- )
tlastcfa @ [G'] :dovar killref
[G'] extraxt, gset-optimizer
[G'] does, gset-optimizer
>space here >r ghostheader space>
['] colon-resolved r@ >comp !
r@ created >do:ghost ! r@ swap resolve
r> tlastcfa @ >tempdp doextraxt, tempdp> ;
r> tlastcfa @ >tempdp dodoes, tempdp> ;
IS !newdoes
: ;DO ( [xt] [colon-sys] -- )
......@@ -3228,11 +3220,6 @@ by: :dodoes ;DO
vt: [G'] does, gset-optimizer ;vt
\ vtghost: dodoes-vt
Builder extraxt>-dummy
Build: ;Build
by: :doextraxt ;DO
vt: [G'] extraxt, gset-optimizer ;vt
\ Variables and Constants 05dec92py
Builder (Constant)
......
......@@ -114,12 +114,10 @@ extern void* (*realloc_l)(void* addr, size_t size);
#define DODEFER 4
#define DOFIELD 5
#define DOVAL 6
#define DODOES 7
#define DODOES 7
#define DOABICODE 8
#define DOSEMIABICODE 9
#define DOEXTRAXT 10
#define DODOESXT 11
#define DOER_MAX 11
#define DOER_MAX 9
#include "machine.h"
......
......@@ -27,8 +27,6 @@
-9 Doer: :dodoes
-&10 Doer: :doabicode
-&11 Doer: :do;abicode
-&12 Doer: :doextraxt
-&13 Doer: :dodoesxt
-&2 first-primitive
\ this does not work for (at least) (DODOES),
\ so the following routines are commented out
......@@ -522,13 +522,6 @@ opt: drop ( xt -- )
[ has? peephole [IF] ] finish-code [ [THEN] ]
defstart ;
: !extraxt ( addr -- ) \ gforth store-extra
created?
IF
['] extraxt, set-optimizer
THEN
latestxt extra-xt! ;
\ call with locals - unused
\ docolloc-dummy (docolloc-dummy)
......@@ -594,7 +587,9 @@ Create vttemplate
: set-defer@ ( defer@-xt -- ) vttemplate >vtdefer@ ! ;
: set->int ( xt -- ) vttemplate >vt>int ! ;
: set->comp ( xt -- ) vttemplate >vt>comp ! ;
: set-does> ( xt -- ) !extraxt ; \ more work than the aboves
: set-does> ( xt -- ) vttemplate >vtextra !
created? IF ['] does, set-optimizer THEN
dodoes: latestxt ! ;
:noname ( -- colon-sys ) start-xt set-optimizer ;
:noname ['] set-optimizer start-xt-like ;
......@@ -740,13 +735,7 @@ defer 0-adjust-locals-size ( -- )
\ does>
: created? ( -- flag )
vttemplate >vtcompile, @ ['] udp >namevt @ >vtcompile, @ = ;
: !does ( addr -- ) \ gforth store-does
created? IF
['] does, set-optimizer
THEN
latestxt does-code! ;
vttemplate >vtcompile, @ ['] variable, = ;
: comp-does>; ( some-sys flag lastxt -- )
\ used as colon-sys xt; this is executed after ";" has removed the
......
......@@ -23,16 +23,13 @@
\ \ input stream primitives 23feb93py
has? new-does [IF]
: extra, ['] extra-exec peephole-compile, , ;
: extraxt, ['] extra-xt peephole-compile, , ;
: >comp ( xt -- ) name>comp execute ;
: no-to ( xt -- )
\ default to action: report an error ASAP (even right when COMPILE,ing)
#-12 throw ;
opt: #-12 throw ; \
: no-defer@ ( xt -- ) #-2055 throw ;
[THEN]
: >comp ( xt -- ) name>comp execute ;
: no-to ( xt -- )
\ default to action: report an error ASAP (even right when COMPILE,ing)
#-12 throw ;
opt: #-12 throw ; \
: no-defer@ ( xt -- ) #-2055 throw ;
opt: #-2055 throw ;
require ./basics.fs \ bounds decimal hex ...
require ./io.fs \ type ...
......@@ -539,7 +536,7 @@ cell% -1 * 0 0 field body> ( xt -- a_addr )
\G If @i{xt} is the execution token of a child of a @code{DOES>} word,
\G @i{a-addr} is the start of the Forth code after the @code{DOES>};
\G Otherwise @i{a-addr} is 0.
dup @ doextraxt: = if
dup @ dodoes: = if
>namevt @ >vtextra @ >body
else
drop 0
......@@ -552,18 +549,11 @@ cell% -1 * 0 0 field body> ( xt -- a_addr )
\ for implementing DOES> and ;ABI-CODE, maybe :
\ code-address is stored at cfa, a-addr at cfa+cell
over ! >namevt @ >vtextra ! ;
: does-code! ( a-addr xt -- ) \ gforth
\G Create a code field at @i{xt} for a child of a @code{DOES>}-word;
\G @i{a-addr} is the start of the Forth code after @code{DOES>}.
dodoes: over ! cell+ ! ;
\ after eliminating dodoes:, this changes to
\ body> extra-xt! ;
: extra-xt! ( xt1 xt2 -- ) \ gforth
: does-code! ( xt1 xt2 -- ) \ gforth
\G Create a code field at @i{xt2} for a child of a @code{DOES>}-word;
\G @i{xt1} is the execution token of the assigned Forth code.
doextraxt: any-code! ;
dodoes: any-code! ;
2 cells constant /does-handler ( -- n ) \ gforth
\G The size of a @code{DOES>}-handler (includes possible padding).
......@@ -889,7 +879,7 @@ defer reset-dpp
: gforth ( -- )
." Gforth " version-string type
." , Copyright (C) 1995-2017,2018 Free Software Foundation, Inc." cr
." , Copyright (C) 1995-2018 Free Software Foundation, Inc." cr
." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
[ has? os [IF] ]
cr ." Type `help' for basic help"
......
......@@ -29,7 +29,7 @@
: field+, >body @ ['] lit+ peephole-compile, , ;
: abi-code, >body ['] abi-call peephole-compile, , ;
: ;abi-code, ['] ;abi-code-exec peephole-compile, , ;
: does, ['] does-exec peephole-compile, , ;
: does, ['] does-xt peephole-compile, , ;
: umethod, >body cell+ 2@ ['] u#exec peephole-compile, , , ;
: uvar, >body cell+ 2@ ['] u#+ peephole-compile, , , ;
\ : :loc, >body ['] call-loc peephole-compile, , ;
......
......@@ -916,7 +916,7 @@ tmp$ $execstr-ptr !
noname Create
\ can not be named due to rebind-libcc
' cfun, set-optimizer
' rt-does> !extraxt
' rt-does> set-does>
latestxt to rt-vtable
......
......@@ -217,24 +217,13 @@ INST_TAIL;
goto *next_code;
#endif /* defined(NO_IP) */
(dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes
""run-time routine for @code{does>}-defined words""
#ifdef NO_IP
a_retaddr = next_code;
(dodoes) ( -- a_body ) gforth-internal paren_dodoes
a_body = PFA(CFA);
INST_TAIL;
#ifdef DEBUG
debugp(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body);
#endif
goto **(Label *)DOES_CODE1(CFA);
#else /* !defined(NO_IP) */
a_retaddr = (Cell *)IP;
a_body = PFA(CFA);
#ifdef DEBUG
debugp(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body);
#endif
SET_IP(DOES_CODE1(CFA));
#ifndef NO_IP
ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
#endif /* !defined(NO_IP) */
SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
VM_JUMP(EXEC1(EXTRA_CODEXT(CFA)));
(doabicode) ( ... -- ...) gforth-internal paren_doabicode
""run-time routine for @code{ABI-code} definitions""
......@@ -259,22 +248,6 @@ INST_TAIL;
goto *next_code;
#endif /* defined(NO_IP) */
(doextraxt) ( -- a_body ) gforth-internal paren_doextraxt
a_body = PFA(CFA);
#ifndef NO_IP
ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
#endif /* !defined(NO_IP) */
SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
VM_JUMP(EXEC1(EXTRA_CODEXT(CFA)));
(dodoesxt) ( -- a_body ) gforth-internal paren_dodoesxt
a_body = PFA(CFA);
#ifndef NO_IP
ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
#endif /* !defined(NO_IP) */
SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
VM_JUMP(EXEC1(DOES_CODEXT(CFA)));
\F [endif]
\g control
......@@ -353,58 +326,7 @@ ip=IP;
SUPER_END;
VM_JUMP(EXEC1(*(Xt *)a_addr));
does-exec ( #a_cfa -- R:a_retaddr a_body ) new does_exec
#ifdef NO_IP
/* compiled to LIT CALL by compile_prim */
assert(0);
#else
a_body = PFA(a_cfa);
a_retaddr = (Cell *)IP;
#ifdef DEBUG
{
CFA_TO_NAME(a_cfa);
debugp(stderr,"%08lx: does %08lx %.*s\n",
(Cell)ip,(Cell)a_cfa,len,name);
}
#endif
SET_IP(DOES_CODE1(a_cfa));
#endif
extra-exec ( #a_cfa -- R:a_retaddr a_body ) new extra_exec
#ifdef NO_IP
/* compiled to LIT CALL by compile_prim */
assert(0);
#else
a_body = PFA(a_cfa);
a_retaddr = (Cell *)IP;
#ifdef DEBUG
{
CFA_TO_NAME(a_cfa);
debugp(stderr,"%08lx: does %08lx %.*s\n",
(Cell)ip,(Cell)a_cfa,len,name);
}
#endif
SET_IP(EXTRA_CODE(a_cfa));
#endif
does-xt ( #a_cfa -- a_body ) new does_xt
#ifdef NO_IP
/* compiled to LIT CALL by compile_prim */
assert(0);
#else
a_body = PFA(a_cfa);
#ifdef DEBUG
{
CFA_TO_NAME(a_cfa);
debugp(stderr,"%08lx: does %08lx %.*s exec %p\n",
(Cell)ip,(Cell)a_cfa,len,name,DOES_CODEXT(a_cfa));
}
#endif
SUPER_END;
VM_JUMP(EXEC1(DOES_CODEXT(a_cfa)));
#endif
extra-xt ( #a_cfa -- a_body ) new extra_xt
does-xt ( #a_cfa -- a_body ) new extra_xt
#ifdef NO_IP
/* compiled to LIT CALL by compile_prim */
assert(0);
......
......@@ -371,7 +371,7 @@ VARIABLE C-Pass
over 1 cells + @ decompile-prim ['] call xt= >r
over 3 cells + @ decompile-prim ['] ;S xt=
r> and if
over 2 cells + @ ['] !extraxt >body = if drop
over 2 cells + @ ['] set-does> >body = if drop
S" DOES> " Com# ?.string 4 cells + EXIT endif
endif
[IFDEF] !;abi-code
......@@ -706,7 +706,7 @@ VARIABLE C-Pass
CREATE C-Table \ primitives map to code only
' lit A, ' c-lit A,
' does-exec A, ' c-callxt A,
[IFDEF] does-exec ' does-exec A, ' c-callxt A, [THEN]
[IFDEF] does-xt ' does-xt A, ' c-callxt A, [THEN]
[IFDEF] extra-exec ' extra-exec A, ' c-callxt A, [THEN]
[IFDEF] extra-xt ' extra-xt A, ' c-callxt A, [THEN]
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment