Commit ea7f41f4 authored by Bernd Paysan's avatar Bernd Paysan

Remove immediate-flag, replace with new header construct

parent 5d6886e8
Pipeline #648 passed with stage
in 8 minutes and 20 seconds
......@@ -2173,10 +2173,6 @@ dup constant immediate-mask 2/
constant restrict-mask
>TARGET
: immediate immediate-mask flag!
^imm @ @ dup <imm> = IF drop EXIT THEN
<res> <> ABORT" CROSS: Cannot immediate a unresolved word"
<imm> ^imm @ ! ;
: restrict restrict-mask flag! ;
: compile-only restrict-mask flag! ;
......@@ -2960,8 +2956,8 @@ Cond: DOES>
: create-resolve ( -- )
created createhere resolve ( 0 ;Resolve ! ) ;
: create-resolve-immediate ( -- )
create-resolve T immediate H ;
\ : create-resolve-immediate ( -- )
\ create-resolve T immediate H ;
: TCreate ( <name> -- )
create-forward-warn
......@@ -3000,9 +2996,9 @@ Cond: DOES>
: ;Build
postpone create-resolve postpone ; built >exec ! ; immediate
: ;Build-immediate
postpone create-resolve-immediate
postpone ; built >exec ! ; immediate
\ : ;Build-immediate
\ postpone create-resolve-immediate
\ postpone ; built >exec ! ; immediate
: gdoes> ( ghost -- addr flag )
executed-ghost @ g>body ;
......@@ -3142,6 +3138,7 @@ End-Struct vtable-struct
:noname ( ghost -- ) vttemplate >vtcompile, ! ; IS gset-optimizer
: gset-to ( ghost -- ) vttemplate >vtto ! ;
: gset-defer@ ( ghost -- ) vttemplate >vtdefer@ ! ;
: gset->comp ( ghost -- ) vttemplate >vt>comp ! ;
: set-optimizer ( xt -- ) xt>ghost vttemplate >vtcompile, ! ;
: set-to ( xt -- ) xt>ghost vttemplate >vtto ! ;
......@@ -3154,6 +3151,13 @@ End-Struct vtable-struct
postpone ; built >do:ghost @ >exec2 ! ; immediate
>TARGET
ghost imm>comp
: immediate ( immediate-mask flag! )
[G'] imm>comp gset->comp
^imm @ @ dup <imm> = IF drop EXIT THEN
<res> <> ABORT" CROSS: Cannot immediate a unresolved word"
<imm> ^imm @ ! ;
ghost a>int drop
ghost a>comp drop
......
......@@ -303,3 +303,14 @@ Variable rec'
['] prompt-text success-color color-execute ;
' color-prompt is prompt
\ print name vtable
: .vt ( nt -- )
>namevt @ cr
." opt: " dup >vtcompile, @ .name cr
." to: " dup >vtto @ .name cr
." >int: " dup >vt>int @ .name cr
." >comp: " dup >vt>comp @ .name cr
." defer@: " dup >vtdefer@ @ .name cr
." extra: " >vtextra @ hex. ;
......@@ -155,9 +155,11 @@ Defer check-shadow ( addr u wid -- )
nlstring,
r> 1 or A, 0 A, here last ! \ link field; before revealing, it contains the
\ tagged reveal-into wordlist
\ alias-mask lastflags cset
next-prelude @ 0<> prelude-mask and lastflags cset
next-prelude off
\ alias-mask lastflags cset
[ [IFDEF] prelude-mask ]
next-prelude @ 0<> prelude-mask and lastflags cset
next-prelude off
[ [THEN] ]
cfalign ;
defer record-name ( -- )
......@@ -300,12 +302,7 @@ has? primcentric [IF]
: default-name>comp ( nt -- w xt ) \ gforth name-to-comp
\G @i{w xt} is the compilation token for the word @i{nt}.
(name>x) (x>comp)
1 = if
['] execute
else
['] compile,
then ;
name>int ['] compile, ;
: [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
(') postpone ALiteral ; immediate restrict
......@@ -368,10 +365,11 @@ include ./recognizer.fs
latest dup 0= abort" last word was headerless"
>f+c ;
: imm>comp name>int ['] execute ;
: immediate ( -- ) \ core
\G Make the compilation semantics of a word be to @code{execute}
\G the execution semantics.
immediate-mask lastflags cset ;
['] imm>comp set->comp ;
: restrict ( -- ) \ gforth
\G A synonym for @code{compile-only}
......@@ -393,8 +391,9 @@ include ./recognizer.fs
dup >namevt @ >vtdefer@ @ opt-something, ;
: a>int ( nt -- ) >body @ ;
: a>comp ( nt -- xt1 xt2 ) dup >r >body @
['] execute ['] compile, r> immediate? select ;
: a>comp ( nt -- xt1 xt2 ) name>int ['] compile, ;
\ dup >r >body @
\ ['] execute ['] compile, r> >f+c @ immediate-mask and select ;
: s>int ( nt -- xt ) >body @ name>int ;
: s>comp ( nt -- xt1 xt2 ) >body @ name>comp ;
......@@ -409,10 +408,10 @@ opt: drop >body @ defer@, ;
: s-compile, ( xt -- ) >body @ compile, ;
: Alias ( xt "name" -- ) \ gforth
Header reveal ['] on vtcopy
Header reveal ['] on vtcopy dodefer,
['] a>int set->int ['] a>comp set->comp ['] s-to set-to
['] s-defer@ set-defer@ ['] s-compile, set-optimizer
dodefer, dup A, lastcfa ! ;
dup A, lastcfa ! ;
: alias? ( nt -- flag )
>namevt @ >vt>int 2@ ['] a>comp ['] a>int d= ;
......@@ -684,12 +683,12 @@ opt: drop ( value-xt -- ) \ run-time: ( n -- )
: <IS> ( "name" xt -- ) \ gforth
\g Changes the @code{defer}red word @var{name} to execute @var{xt}.
record-name (') (name>x) drop (int-to) ;
record-name (') (int-to) ;
: [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
\g At run-time, changes the @code{defer}red word @var{name} to
\g execute @var{xt}.
record-name (') (name>x) drop (comp-to) ; immediate restrict
record-name (') (comp-to) ; immediate restrict
' <IS> ' [IS] interpret/compile: TO ( value "name" -- ) \ core-ext
\g changes the value of @var{name} to @var{value}
......
......@@ -336,18 +336,18 @@ forth-wordlist current !
\ 1 bits/char 1 - lshift
\ -1 cells allot bigendian [IF] c, 0 1 cells 1- times
\ [ELSE] 0 1 cells 1- times c, [THEN]
$80000000 constant immediate-mask
1 bits/char 1 - lshift
-1 cells allot bigendian [IF] c, 0 1 cells 1- times
[ELSE] 0 1 cells 1- times c, [THEN]
\ $80000000 constant immediate-mask
\ 1 bits/char 1 - lshift
\ -1 cells allot bigendian [IF] c, 0 1 cells 1- times
\ [ELSE] 0 1 cells 1- times c, [THEN]
$40000000 constant restrict-mask
1 bits/char 2 - lshift
-1 cells allot bigendian [IF] c, 0 1 cells 1- times
[ELSE] 0 1 cells 1- times c, [THEN]
$20000000 constant prelude-mask
1 bits/char 3 - lshift
-1 cells allot bigendian [IF] c, 0 1 cells 1- times
[ELSE] 0 1 cells 1- times c, [THEN]
\ $20000000 constant prelude-mask
\ 1 bits/char 3 - lshift
\ -1 cells allot bigendian [IF] c, 0 1 cells 1- times
\ [ELSE] 0 1 cells 1- times c, [THEN]
\ $01000000 constant unused-mask \ defined in locate1.fs, used only temporarily
\ reserve 8 bits for all possible flags in total
$00ffffff constant lcount-mask
......@@ -426,7 +426,7 @@ defer compile, ( xt -- )
\G Reserve data space for one cell and store @i{w} in the space.
cell small-allot ! ;
: immediate? ( nt -- flag ) >f+c @ immediate-mask and 0<> ;
: immediate? ( nt -- flag ) name>comp nip ['] execute = ;
: compile-only? ( nt -- flag ) >f+c @ restrict-mask and 0<> ;
: ?compile-only ( nt -- nt )
dup compile-only? IF
......@@ -447,10 +447,6 @@ defer compile, ( xt -- )
: name>view ( nt -- addr ) \ gforth name-to-view
name>string drop cell negate and cell- ;
: (name>x) ( nfa -- cfa w )
\ cfa is an intermediate cfa and w is the flags cell of nfa
dup >f+c @ ;
: default-name>int ( nt -- xt ) \ gforth paren-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
......@@ -458,9 +454,6 @@ defer compile, ( xt -- )
\G @code{ticking-compile-only-error}, which performs @code{-2048 throw}.
;
: (x>comp) ( xt w -- xt +-1 )
immediate-mask and flag-sign ;
: (name>intn) ( nfa -- xt +-1 )
dup name>int swap name>comp nip ['] execute = flag-sign ;
......
......@@ -329,9 +329,9 @@ VARIABLE C-Pass
EXIT
then
THEN
nip dup >f+c @ immediate-mask and
nip dup immediate?
IF
bl cemit ." POSTPONE "
bl cemit ." [COMPILE] "
THEN
dup name>string rot wordinfo .string
;
......
......@@ -365,7 +365,7 @@ comp' sliteral drop alias postpone-sliteral
\ defer stuff
:noname ' defer@ ;
:noname (') (name>x) drop defer@, ;
:noname (') name>int defer@, ;
interpret/compile: action-of ( interpretation "name" -- xt; compilation "name" -- ; run-time -- xt ) \ core-ext
\G @i{Xt} is the XT that is currently assigned to @i{name}.
......
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