Commit a0bf65ea authored by pazsan's avatar pazsan

Thrown out static vocabulary stack

Changed cross to make mixed threading workable
parent 99a0a501
......@@ -902,7 +902,9 @@ Defer is-forward
Defer do-refered
: prim-forward ( ghost -- )
colonmark, 1 do-refered ; \ compile space for call
colonmark, 0 do-refered ; \ compile space for call
: doer-forward ( ghost -- )
colonmark, 2 do-refered ; \ compile space for doer
' prim-forward IS is-forward
: (ghostheader) ( -- )
......@@ -1068,8 +1070,6 @@ Ghost branch Ghost ?branch 2drop
Ghost unloop Ghost ;S 2drop
Ghost lit Ghost ! 2drop
Ghost noop drop
Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop
Ghost :dovar drop
Ghost over Ghost = Ghost drop 2drop drop
Ghost 2drop drop
Ghost 2dup drop
......@@ -1085,6 +1085,13 @@ Ghost lit-perform drop
Ghost lit+ drop
Ghost does-exec drop
' doer-forward IS is-forward
Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop
Ghost :dovar drop
' prim-forward IS is-forward
\ \ Parameter for target systems 06oct92py
......@@ -2183,13 +2190,14 @@ Defer setup-prim-semantics
Ghost tuck swap resolve <do:> swap tuck >magic !
asmprimname, ;
: Alias: ( cfa -- ) \ name
: Doer: ( cfa -- ) \ name
>in @ skip? IF 2drop EXIT THEN >in !
dup 0< s" prims" T $has? H 0= and
IF
.sourcepos ." needs doer: " >in @ bl word count type >in ! cr
THEN
Ghost tuck swap resolve <do:> swap >magic ! ;
Ghost
tuck swap resolve <do:> swap >magic ! ;
Variable prim#
: first-primitive ( n -- ) prim# ! ;
......@@ -2199,11 +2207,9 @@ Variable prim#
IF
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr
THEN
\ ['] prim-forward IS is-forward
prim# @ (THeader ( S xt ghost )
dup >ghost-flags <primitive> set-flag
over resolve T A, H alias-mask flag!
\ ['] call-forward IS is-forward
-1 prim# +! ;
>CROSS
......@@ -2287,10 +2293,10 @@ T 2 cells H Value xt>body
there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim,
: (doeshandler,) ( -- )
T cfalign H compile :doesjump T 0 , H ; ' (doeshandler,) plugin-of doeshandler,
T cfalign H [G'] :doesjump addr, T 0 , H ; ' (doeshandler,) plugin-of doeshandler,
: (dodoes,) ( does-action-ghost -- )
]comp [G'] :dodoes gexecute comp[
]comp [G'] :dodoes addr, comp[
addr,
\ the relocator in the c engine, does not like the
\ does-address to marked for relocation
......@@ -2505,7 +2511,6 @@ Defer instant-interpret-does>-hook
: does-resolved ( ghost -- )
compile does-exec g>xt T a, H ;
\ dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;
: resolve-does>-part ( -- )
\ resolve words made by builders
......@@ -2796,7 +2801,7 @@ T has? peephole H [IF]
: (callc) compile call T >body a, H ; ' (callc) plugin-of colon,
: (call-res) >tempdp resolved gexecute tempdp> drop ;
' (call-res) plugin-of colon-resolve
: (prim) dup 0< IF ( $4000 - ) ELSE
: (prim) dup 0< IF $4000 - ELSE
." wrong usage of (prim) "
dup gdiscover IF .ghost ELSE . THEN cr -2 throw THEN
T a, H ; ' (prim) plugin-of prim,
......
......@@ -177,6 +177,10 @@ void relocate(Cell *image, const char *bitstring,
default :
/* printf("Code field generation image[%x]:=CA(%x)\n",
i, CF(image[i])); */
#if !defined(DOUBLY_INDIRECT)
if (((token | 0x4000) >= CF(DODOES)) && (token < -0x4000))
fprintf(stderr,"Doer %d used in this image at $%lx is marked as Xt; executing this code will crash.\n",CF((token | 0x4000)),(long)&image[i],VERSION);
#endif
token |= 0x4000; /* only meaningful for hybrid engines */
if (CF(token)<max_symbols)
image[i]=(Cell)CA(CF(token));
......
......@@ -367,8 +367,8 @@ void install_signal_handlers(void)
for (i = 0; i < DIM (sigs_to_quit); i++)
bsd_signal(sigs_to_quit [i], graceful_exit);
#ifdef SA_SIGINFO
install_signal_handler(SIGFPE, fpe_handler);
install_signal_handler(SIGSEGV, segv_handler);
install_signal_handler(SIGFPE, die_on_signal ? graceful_exit : fpe_handler);
install_signal_handler(SIGSEGV, die_on_signal ? graceful_exit : segv_handler);
#endif
#ifdef SIGCONT
bsd_signal(SIGCONT, termprep);
......
......@@ -18,12 +18,12 @@
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
-2 Alias: :docol
-3 Alias: :docon
-4 Alias: :dovar
-5 Alias: :douser
-6 Alias: :dodefer
-7 Alias: :dofield
-8 Alias: :dodoes
-9 Alias: :doesjump
-2 Doer: :docol
-3 Doer: :docon
-4 Doer: :dovar
-5 Doer: :douser
-6 Doer: :dodefer
-7 Doer: :dofield
-8 Doer: :dodoes
-9 Doer: :doesjump
-&10 first-primitive
......@@ -2427,9 +2427,14 @@ does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec
a_pfa = PFA(a_cfa);
nest = (Cell)ip;
IF_spTOS(spTOS = sp[0]);
SUPER_END;
#ifdef DEBUG
{
CFA_TO_NAME(a_cfa);
fprintf(stderr,"%08lx: does %08lx %.*s\n",
(Cell)ip,(Cell)a_cfa,len,name);
}
#endif
SET_IP(DOES_CODE1(a_cfa));
SUPER_END;
include(peeprules.vmg)
......
......@@ -18,13 +18,9 @@
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
$10 value maxvp \ current size of search order stack
$400 constant maxvp-limit \ upper limit for resizing search order stack
Variable static-vp
0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
0 Value vp
static-vp ' vp >body A!
$10 Value maxvp \ current size of search order stack
$400 Value maxvp-limit \ upper limit for resizing search order stack
0 AValue vp \ will be initialized later (dynamic)
: get-current ( -- wid ) \ search
\G @i{wid} is the identifier of the current compilation word list.
......@@ -76,21 +72,10 @@ Variable slowvoc 0 slowvoc !
: check-maxvp ( n -- )
dup maxvp-limit > -49 and throw
dup maxvp > IF
vp static-vp = -49 and throw
BEGIN dup maxvp 2* dup TO maxvp > 0= UNTIL
BEGIN dup maxvp 2* dup TO maxvp <= UNTIL
vp maxvp 1+ cells resize throw TO vp
THEN drop ;
: init-vp ( n -- )
$10 TO maxvp
maxvp 1+ cells allocate throw TO vp
static-vp dup @ 1+ cells vp swap move ;
:noname
DEFERS 'cold
init-vp ;
IS 'cold
: >order ( wid -- ) \ gforth to-order
\g Push @var{wid} on the search order.
vp @ 1+ dup check-maxvp vp! context ! ;
......@@ -164,12 +149,21 @@ Vocabulary Root ( -- ) \ gforth
\G order (for Gforth, this is the word list @code{Root}).
1 vp! Root also ;
: init-vp ( -- )
$10 TO maxvp
maxvp 1+ cells allocate throw TO vp
Only Forth also definitions ;
:noname
init-vp DEFERS 'cold ;
IS 'cold
init-vp
\ set initial search order 14may93py
Forth-wordlist wordlist-id @ ' Forth >body wordlist-id !
0 vp! also Root also definitions
Only Forth also definitions
lookup ! \ our dictionary search order becomes the law ( -- )
' Forth >body to Forth-wordlist \ "forth definitions get-current" and "forth-wordlist" should produce the same wid
......
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