Commit db100693 authored by Anton Ertl's avatar Anton Ertl

initial work on reconciling dual-xt with mono-xt

parent 4f4cad7b
......@@ -270,12 +270,7 @@ has? primcentric [IF]
: name>comp ( nt -- w xt ) \ gforth name-to-comp
\G @i{w xt} is the compilation token for the word @i{nt}.
(name>comp)
1 = if
['] execute
else
['] compile,
then ;
dup >namevt @ >vt>comp perform ;
: [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
(') postpone ALiteral ; immediate restrict
......@@ -525,8 +520,8 @@ comp: drop >body postpone ALiteral postpone ! ;
: (comp-to) ( xt -- ) dup >namevt @ >vtto @ compile, ;
: TO ( value "name" -- )
(') (name>x) drop (int-to) ;
comp: drop (') (name>x) drop (comp-to) ;
(') name>int (int-to) ;
comp: drop (') name>comp drop (comp-to) ;
' TO alias IS
......
......@@ -324,71 +324,45 @@ $0fffffff constant lcount-mask
drop ['] compile-only-error
then ;
has? f83headerstring [IF]
: name>string ( nt -- addr count ) \ gforth name-to-string
\g @i{addr count} is the name of the word represented by @i{nt}.
cell+ count lcount-mask and ;
: ((name>)) ( nfa -- cfa )
name>string + cfaligned ;
: (name>x) ( nfa -- cfa w )
\ cfa is an intermediate cfa and w is the flags cell of nfa
dup ((name>))
swap cell+ c@ dup alias-mask and 0=
IF
swap @ swap
THEN ;
[ELSE]
' noop Alias ((name>)) ( nfa -- cfa )
(field) >namevt -1 cells , \ virtual table for names
(field) >link -2 cells , \ link field
(field) >f+c -3 cells , \ flags+count
(field) >vtlink 0 cells ,
(field) >vtcompile, 1 cells ,
(field) >vtpostpone 2 cells ,
(field) >vtextra 3 cells ,
(field) >vtto 4 cells ,
5 cells Constant vtsize
: name>string ( nt -- addr count ) \ gforth name-to-string
\g @i{addr count} is the name of the word represented by @i{nt}.
' noop Alias ((name>)) ( nfa -- cfa )
(field) >namevt -1 cells , \ virtual table for names
(field) >link -2 cells , \ link field
(field) >f+c -3 cells , \ !! count
(field) >vtlink 0 cells ,
(field) >vtcompile, 1 cells ,
(field) >vtpostpone 2 cells , \ compile literal in recognizer
(field) >vtextra 3 cells ,
(field) >vtto 4 cells ,
(field) >vt>comp 5 cells ,
(field) >vt>int 6 cells ,
7 cells Constant vtsize
: name>string ( nt -- addr count ) \ gforth name-to-string
\g @i{addr count} is the name of the word represented by @i{nt}.
>f+c dup @ lcount-mask and tuck - swap ;
: (name>x) ( nfa -- cfa w )
\ cfa is an intermediate cfa and w is the flags cell of nfa
dup ((name>))
swap >f+c @ dup alias-mask and 0=
IF
swap @ swap
THEN ;
[THEN]
: name>int ( nt -- xt ) \ gforth name-to-int
\G @i{xt} represents the interpretation semantics of the word
\G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
\G @code{compile-only}), @i{xt} is the execution token for
\G @code{ticking-compile-only-error}, which performs @code{-2048 throw}.
(name>x) (x>int) ;
dup >namevt @ >vt>int perform ;
: name?int ( nt -- xt ) \ gforth name-question-int
\G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
\G has no interpretation semantics.
(name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
if
ticking-compile-only-error \ does not return
dup name>int tuck <> if
dup ['] ticking-compile-only-error = if execute then
then ;
: (name>comp) ( nt -- w +-1 ) \ gforth
\G @i{w xt} is the compilation token for the word @i{nt}.
(name>x) >r
r> immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign
;
: (name>comp) ( nt -- w +-1 ) \ gforth-obsolete
\G @i{w} represents the compilation semantics; with -1 it must be
\G @{compile,}d; with 1 it must be {execute}d
name>comp ['] compile, = 2* 1+ ;
: (name>intn) ( nfa -- xt +-1 )
(name>x) tuck (x>int) ( w xt )
swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ;
dup name>int swap (name>comp) nip ;
[IFDEF] prelude-mask
: name>prelude ( nt -- xt )
......@@ -541,7 +515,7 @@ alias code-address! ( c_addr xt -- ) \ gforth
if ( nt )
state @
if
(name>comp)
(name>comp)
else
(name>intn)
then
......
......@@ -38,7 +38,7 @@
: >int ( token table -- ) name>int execute ;
: >postpone ( token table -- )
dup (name>x) drop >namevt @ >vtpostpone perform ;
dup >namevt @ >vtpostpone perform ;
: word-recognizer ( addr u -- xt | r:fail )
find-name [ [IFDEF] prelude-mask ] run-prelude [ [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