Reorder fields to xt-related and nt-related

cross.fs

@@ -2405,6 +2405,8 @@ NoHeaderFlag off
 
 Defer setup-execution-semantics  ' noop IS setup-execution-semantics
 Defer vt, \ forward rference only
+Defer vt-named
+Defer vt-noname
 0 Value lastghost
 
 : (THeader ( "name" -- ghost )
@@ -2414,6 +2416,7 @@ Defer vt, \ forward rference only
     \ build header in target
     NoHeaderFlag @
     IF  NoHeaderFlag off
+	vt-noname
     ELSE
 	[ X has? f83headerstring ] [IF]
 	    T align H tlast @ T A, H
@@ -2429,6 +2432,7 @@ Defer vt, \ forward rference only
 	[THEN]
 	there tlast !
 	1 headers-named +!	\ Statistic
+	vt-named
     THEN
     T ( cfalign ) here H tlastcfa !
     \ Old Symbol table sed-script
@@ -2790,7 +2794,7 @@ ghost :-dummy Constant :-ghost
     docol, ]comp colon-start depth ;Resolve off T ] H r> ;
 
 : :noname ( -- xt colon-sys )
-    switchrom vt,
+    switchrom vt, vt-noname
     [ X has? f83headerstring 0= ] [IF]
 	T 0 cell+ cfalign# 0 , 0 , here cell+ H
 	[IFDEF] alias-mask t>flag >r alias-mask T r@ c@ xor r> c! H
@@ -2874,7 +2878,7 @@ X has? primcentric [IF]
   IF  there resolve  THEN ;
 
 Cond: DOES>
-    T here cfaligned H [ T has? primcentric H [IF] ] 8 [ [ELSE] ] 7 [ [THEN] ] T cells
+    T here cfaligned H [ T has? primcentric H [IF] ] #8 [ [ELSE] ] #7 [ [THEN] ] T cells
     H + alit, compile set-does> compile ;
     Last-Header-Ghost @ >do:ghost @ >r
 T :noname H
@@ -2883,7 +2887,7 @@ T :noname H
 
 : DOES>
     ['] does-resolved created >comp !
-    T here cfaligned #10 cells H \ includes noname header+vtable
+    T here cfaligned #12 cells H \ includes noname header+vtable
     + !newdoes
     T :noname H 2drop
     instant-interpret-does>-hook
@@ -3031,10 +3035,10 @@ Variable gvtable-list
 Ghost docol-vt drop
 
 >TARGET
-7 T cells H Constant vtsize
+9 T cells H Constant vtsize
 >CROSS
 
-7 cells Constant gvtsize \ ghost vtables for comparison
+9 cells Constant gvtsize \ ghost vtables for comparison
 
 ghost :,
 ghost peephole-compile,
@@ -3068,6 +3072,12 @@ ghost no-to
 ghost no-defer@
 ghost defer-defer@
 2drop drop
+ghost named>string
+ghost named>link
+2drop
+ghost noname>string
+ghost noname>link
+2drop
 ghost value-to
 ghost umethod,
 2drop
@@ -3091,19 +3101,23 @@ findghost no-to ,
 findghost default-name>int ,
 findghost default-name>comp ,
 findghost no-defer@ ,
+findghost named>string ,
+findghost named>link ,
 0 ,
 
 Struct
-    cell% field >vtlink
-    cell% field >vtcompile,
-    cell% field >vtto
-    cell% field >vt>int
-    cell% field >vt>comp
-    cell% field >vtdefer@
-    cell% field >vtextra
+    cell% field g>vtlink
+    cell% field g>vtcompile,
+    cell% field g>vtto
+    cell% field g>vtdefer@
+    cell% field g>vtextra
+    cell% field g>vt>int
+    cell% field g>vt>comp
+    cell% field g>vt>string
+    cell% field g>vt>link
 End-Struct vtable-struct
 
-\ stores 7 ghosts and a link
+\ stores 8 ghosts and a link
 
 : vt= ( vt1 vt2 -- flag )
     cell+ swap gvtsize cell /string tuck compare 0= ;
@@ -3130,20 +3144,27 @@ End-Struct vtable-struct
 
 : vt-template, ( -- )
     T here 0 A, H vttemplate ! ;
+:noname ( -- )
+    [G'] named>string      vttemplate g>vt>string !
+    [G'] named>link        vttemplate g>vt>link ! ; is vt-named
+:noname ( -- )
+    [G'] noname>string     vttemplate g>vt>string !
+    [G'] noname>link       vttemplate g>vt>link ! ; is vt-noname
 : vt-populate ( -- )
-    [G'] :,                vttemplate >vtcompile, !
-    0                      vttemplate >vtextra !
-    [G'] no-to             vttemplate >vtto !
-    [G'] default-name>int  vttemplate >vt>int !
-    [G'] default-name>comp vttemplate >vt>comp !
-    [G'] no-defer@         vttemplate >vtdefer@ ! ;
-
-:noname ( ghost -- )  vttemplate >vtcompile, ! ; IS gset-optimizer
-: gset-to ( ghost -- )        vttemplate >vtto ! ;
-: gset-defer@   ( ghost -- )  vttemplate >vtdefer@ ! ;
-: gset->int ( ghost -- )      vttemplate >vt>int ! ;
-: gset->comp ( ghost -- )     vttemplate >vt>comp ! ;
-:noname ( ghost -- )     vttemplate >vtextra ! ; is gset-extra
+    [G'] :,                vttemplate g>vtcompile, !
+    0                      vttemplate g>vtextra !
+    [G'] no-to             vttemplate g>vtto !
+    [G'] default-name>int  vttemplate g>vt>int !
+    [G'] default-name>comp vttemplate g>vt>comp !
+    [G'] no-defer@         vttemplate g>vtdefer@ !
+    vt-named ;
+
+:noname ( ghost -- )  vttemplate g>vtcompile, ! ; IS gset-optimizer
+: gset-to ( ghost -- )        vttemplate g>vtto ! ;
+: gset-defer@   ( ghost -- )  vttemplate g>vtdefer@ ! ;
+: gset->int ( ghost -- )      vttemplate g>vt>int ! ;
+: gset->comp ( ghost -- )     vttemplate g>vt>comp ! ;
+:noname ( ghost -- )     vttemplate g>vtextra ! ; is gset-extra
 
 : set-optimizer ( xt -- ) xt>ghost gset-optimizer ;
 : set-to       ( xt -- )  xt>ghost gset-to ;
@@ -3190,7 +3211,7 @@ ghost ?fold-to drop
     [G'] no-to   gset-to
     [G'] no-defer@ gset-defer@
     [G'] a>int   gset->int
-    [G'] i/c>comp vttemplate >vt>comp ! ;
+    [G'] i/c>comp vttemplate g>vt>comp ! ;
 
 : opt: ( -- colon-sys )   gstart-xt set-optimizer ;
 : comp: ( -- colon-sys )  gstart-xt set-optimizer ;

engine/forth.h

@@ -320,10 +320,12 @@ typedef Label *Xt;
 #define VTLINK 0
 #define VTCOMPILE 1
 #define VTTO 2
-#define VT2INT 3
-#define VT2COMP 4
-#define VTDEFER 5
-#define VTEXTRA 6
+#define VTDEFER 3
+#define VTEXTRA 4
+#define VT2INT 5
+#define VT2COMP 6
+#define VT2STRING 7
+#define VT2LINK 8
 #define EXTRA_CODE(cfa) ((Xt *)(((Cell **)cfa)[-1][VTEXTRA]))
 #define EXTRA_CODEXT(cfa) ((Xt)(((Cell **)cfa)[-1][VTEXTRA]))
 

glocals.fs

@@ -206,14 +206,14 @@ opt: drop postpone swap postpone >l postpone >l ;
 : list-length ( list -- u )
     0 swap begin ( u1 list1 )
        dup while
-           >link @ swap 1+ swap
+           name>link swap 1+ swap
     repeat
     drop ;
 
 : /list ( list1 u -- list2 )
     \ list2 is list1 with the first u elements removed
     0 ?do
-	>link @
+	name>link
     loop ;
 
 : common-list ( list1 list2 -- list3 )
@@ -224,7 +224,7 @@ opt: drop postpone swap postpone >l postpone >l ;
     rot swap /list
     begin ( list3 list4 )
 	2dup u<> while
-	    >link @ swap >link @
+	    name>link swap name>link
     repeat
     drop ;
 
@@ -240,7 +240,7 @@ opt: drop postpone swap postpone >l postpone >l ;
     while
 	over
 	((name>)) >body @ max
-	swap >link @ swap ( get next )
+	swap name>link swap ( get next )
     repeat
     faligned nip ;
 
@@ -259,7 +259,7 @@ Defer locals-list!
    \ !! print assumption and reality
  then ;
 
-(field) locals-name-size+ 8 cells , \ fields + wiggle room, name size must be added
+(field) locals-name-size+ vtsize cell+ , \ fields + wiggle room, name size must be added
 
 : create-local1 ( "name" -- a-addr )
     create

kernel/comp.fs

@@ -154,14 +154,14 @@ Defer check-shadow ( addr u wid -- )
     dup here + dup maxaligned >align
     nlstring,
     here xt-location drop \ add location stamps on vt+cf
-    r> 1 or A, 0 A, here last !
+    r> 1 or A, vttemplate A, here last !
     \ link field; before revealing, it contains the
     \ tagged reveal-into wordlist
     \   alias-mask lastflags cset
     [ [IFDEF] prelude-mask ]
 	next-prelude @ 0<> prelude-mask and lastflags cset
 	next-prelude off
-    [ [THEN] ] ;
+    [ [THEN] ] named-vt ;
 
 defer record-name ( -- )
 ' noop is record-name
@@ -200,8 +200,8 @@ defer header ( -- ) \ gforth
     0 last ! vt,  here dup cfaligned >align 0 ( alias-mask ) ,
     0 , \ link field
     here xt-location drop \ add location stamps on vt+cf
-    0 , \ vtable field
-;
+    vttemplate , \ vtable field
+    noname-vt ;
 : noname-header ( -- )
     noname, input-stream ;
 
@@ -430,19 +430,18 @@ opt: ( xt -- ) ?fold-to >body @ defer@, ;
     >namevt @ >vt>int 2@ ['] a>comp ['] a>int d= ;
 
 : Synonym ( "name" "oldname" -- ) \ Forth200x
-    Header  ['] on vtcopy
+    Header reveal  ['] on vtcopy
     ?parse-name find-name dup 0= #-13 and throw
     dodefer, dup A,
     dup compile-only? IF  compile-only  THEN  name>int lastcfa !
     ['] s>int set->int ['] s>comp set->comp ['] s-to set-to
-    ['] s-defer@ set-defer@  ['] s-compile, set-optimizer
-    reveal ;
+    ['] s-defer@ set-defer@  ['] s-compile, set-optimizer ;
 
 : synonym? ( nt -- flag )
     >namevt @ >vt>int 2@ ['] s>comp ['] s>int d= ;
 
 : Create ( "name" -- ) \ core
-    Header reveal dovar, ?noname-vt ;
+    Header reveal dovar, ;
 
 : buffer: ( u "name" -- ) \ core ext
     Create here over 0 fill allot ;
@@ -460,14 +459,14 @@ opt: ( xt -- ) ?fold-to >body @ defer@, ;
     udp @ swap udp +! ;
 
 : User ( "name" -- ) \ gforth
-    Header reveal douser, ?noname-vt cell uallot , ;
+    Header reveal douser, cell uallot , ;
 
 : AUser ( "name" -- ) \ gforth
     User ;
 
-: (Constant)  Header reveal docon, ?noname-vt ;
+: (Constant)  Header reveal docon, ;
 
-: (Value)  Header reveal dovalue, ?noname-vt ;
+: (Value)  Header reveal dovalue, ;
 
 : Constant ( w "name" -- ) \ core
     \G Define a constant @i{name} with value @i{w}.
@@ -494,7 +493,7 @@ Variable to-style# 0 to-style# !
 
 : !!?addr!! ( -- ) to-style# @ -1 = -2056 and throw ;
 
-: (Field)  Header reveal dofield, ?noname-vt ;
+: (Field)  Header reveal dofield, ;
 
 \ IS Defer What's Defers TO                            24feb93py
 
@@ -506,7 +505,7 @@ defer defer-default ( -- )
 \G Define a deferred word @i{name}; its execution semantics can be
 \G set with @code{defer!} or @code{is} (and they have to, before first
 \G executing @i{name}.
-    Header Reveal dodefer, ?noname-vt
+    Header Reveal dodefer, 
     ['] defer-default A, ;
 
 defer@: defer-defer@ ( xt -- )
@@ -542,10 +541,12 @@ opt: ( xt -- )
 
 Create vttemplate
 0 A,                   \ link field
-' peephole-compile, A, \ compile, field
-' no-to A,             \ to field
 ' default-name>int A,  \ name>int field
 ' default-name>comp A, \ name>comp field
+' named>string A,      \ name>string field
+' named>link A,        \ name>link field
+' peephole-compile, A, \ compile, field
+' no-to A,             \ to field
 ' no-defer@ A,         \ defer@
 0 A,                   \ extra field
 
@@ -603,6 +604,8 @@ Create vttemplate
     vttemplate >vtextra !
     ['] does, set-optimizer
     dodoes: latestxt ! ;
+: set-name>string ( xt -- ) vttemplate >vt>string ! ;
+: set-name>link   ( xt -- ) vttemplate >vt>link   ! ;
 
 :noname ( -- colon-sys ) start-xt  set-optimizer ;
 :noname ['] set-optimizer start-xt-like ;
@@ -731,15 +734,24 @@ defer 0-adjust-locals-size ( -- )
 
 : : ( "name" -- colon-sys ) \ core	colon
     free-old-local-names
-    Header (:noname) ?noname-vt ;
+    Header (:noname) ;
 
 : noname-vt ( -- )
     \G modify vt for noname words
-    ['] noop set->int  ['] (noname->comp) set->comp ;
-: ?noname-vt ( -- ) last @ 0= IF  noname-vt  THEN ;
+    ['] noop set->int
+    ['] (noname->comp) set->comp
+    ['] noname>string set-name>string
+    ['] noname>link set-name>link ;
+: named-vt ( -- )
+    \G modify vt for named words
+    ['] default-name>int set->int
+    ['] default-name>comp set->comp
+    ['] named>string set-name>string
+    ['] named>link set-name>link ;
+: ?noname-vt ( -- ) last @ 0= IF  noname-vt  ELSE  named-vt  THEN ;
 
 : :noname ( -- xt colon-sys ) \ core-ext	colon-no-name
-    noname, here (:noname) noname-vt ;
+    noname, here (:noname) ;
 
 : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core	semicolon
     ;-hook [compile] exit ?colon-sys

kernel/int.fs

@@ -372,13 +372,15 @@ $00ffffff constant lcount-mask
 
 ' noop Alias ((name>)) ( nfa -- cfa )
 
-(field) >vtlink      0 cells ,
-(field) >vtcompile,  1 cells ,
-(field) >vtto        2 cells ,
-(field) >vt>int      3 cells ,
-(field) >vt>comp     4 cells ,
-(field) >vtdefer@    5 cells ,
-(field) >vtextra     6 cells ,
+(field) >vtlink        0 cells ,
+(field) >vtcompile,    1 cells ,
+(field) >vtto          2 cells ,
+(field) >vtdefer@      3 cells ,
+(field) >vtextra       4 cells ,
+(field) >vt>int        5 cells ,
+(field) >vt>comp       6 cells ,
+(field) >vt>string     7 cells ,
+(field) >vt>link       8 cells ,
 
 1 cells -3 cells \ mini-oof class declaration with methods
 \ the offsets are a bit odd to keep the xt as point of reference
@@ -395,6 +397,14 @@ method (to) ( val xt -- ) \ gforth paren-int-to
 opt: ( xt-(to -- )
     ?fold-to (to), ;
 
+method defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
+\G @i{xt} represents the word currently associated with the deferred
+\G word @i{xt-deferred}.
+opt: ( xt-defer@ -- )
+    ?fold-to defer@, ;
+
+swap cell+ swap \ vtextra
+
 method name>int ( nt -- xt ) \ gforth name-to-int
 \G @i{xt} represents the interpretation semantics of the word
 \G @i{nt}.
@@ -402,12 +412,11 @@ method name>int ( nt -- xt ) \ gforth name-to-int
 method name>comp ( nt -- w xt ) \ gforth name-to-comp
 \G @i{w xt} is the compilation token for the word @i{nt}.
 
-method defer@ ( xt-deferred -- xt ) \ gforth defer-fetch
-\G @i{xt} represents the word currently associated with the deferred
-\G word @i{xt-deferred}.
-opt: ( xt-defer@ -- )
-    ?fold-to defer@, ;
-drop cell+ Constant vtsize \ vtable size
+method name>string ( nt -- addr u ) \ gforth name-to-string
+    \g @i{addr count} is the name of the word represented by @i{nt}.
+method name>link ( nt1 -- nt2 / 0 ) \ gforth name-to-link
+
+drop Constant vtsize \ vtable size
 
 defer compile, ( xt -- )
 \G Append the semantics represented by @i{xt} to the current
@@ -432,10 +441,15 @@ defer compile, ( xt -- )
 \G compile-only
     ?compile-only name>int ;
 
-: name>string ( nt -- addr count ) \ gforth     name-to-string
-    \g @i{addr count} is the name of the word represented by @i{nt}.
-\    dup >namevt @ >vt>int @ ['] noop = IF  drop 0 0  EXIT  THEN
+: named>string ( nt -- addr count ) \ gforth     named-to-string
     >f+c dup @ lcount-mask and tuck - swap ;
+: named>link ( nt1 -- nt2 / 0 ) \ gforth	named-to-link
+    >link @ ;
+
+: noname>string ( nt -- 0 0 ) \ gforth    noname-to-string
+    drop 0 0 ;
+: noname>link ( nt -- 0 ) \ gforth    noname-to-string
+    drop 0 ;
 
 \ : name>view ( nt -- addr ) \ gforth   name-to-view
 \     name>string drop cell negate and cell- ;

kernel/tools.fs

@@ -93,7 +93,7 @@ include  ./../termsize.fs
     BEGIN
 	dup
     WHILE
-	    r@ over >r execute r> >link @
+	    r@ over >r execute r> name>link
     REPEAT  drop rdrop ;
 
 : traverse-wordlist ( ... xt wid -- ... )
@@ -103,7 +103,7 @@ include  ./../termsize.fs
     BEGIN
 	dup
     WHILE
-	    r@ over >r execute  WHILE r> >link @
+	    r@ over >r execute  WHILE r> name>link
 	REPEAT  r>
     THEN  drop rdrop ;