Remove immediate-flag, replace with new header construct

cross.fs

@@ -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

debugs.fs

@@ -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. ;

kernel/comp.fs

@@ -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}

kernel/int.fs

@@ -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 ;
 

see.fs

@@ -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
     ;

stuff.fs

@@ -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}.