More work on replacing DOES> with EXTRA>

cross.fs

@@ -830,7 +830,6 @@ Plugin doer,
 Plugin fini,      \ compiles end of definition ;s
 Plugin doeshandler,
 Plugin dodoes,
-Plugin dodoesxt,
 
 Plugin colon-start
 ' noop plugin-of colon-start
@@ -1193,13 +1192,14 @@ Ghost lit-perform drop
 Ghost lit+ drop
 Ghost does-exec drop
 Ghost extra-exec drop
+Ghost extra-xt drop
 Ghost does-xt drop
 Ghost no-to drop
 Ghost refill drop
 
 Ghost :docol    Ghost :doesjump Ghost :dodoes   2drop drop
 Ghost :dovar	drop
-Ghost :dodoesxt Ghost :doextraxt 2drop
+Ghost :doextraxt drop
 
 \ \ Parameter for target systems                         06oct92py
 
@@ -2592,11 +2592,6 @@ T 2 cells H Value xt>body
   addr,
   2 fillcfa ;						' (dodoes,) plugin-of dodoes,
 
-: (dodoesxt,) ( does-action-ghost -- )
-  ]comp [G'] :dodoesxt addr, comp[
-  addr,
-  2 fillcfa ;						' (dodoesxt,) plugin-of dodoesxt,
-
 : doextraxt, ( -- )
   ]comp [G'] :doextraxt addr, comp[
   0 addr,
@@ -2828,10 +2823,10 @@ Cond: [ ( -- ) interpreting-state ;Cond
 0 Value created
 
 Ghost does, drop
-Ghost doesxt, drop
 
 Defer gset-optimizer
-	
+Defer gset-extra
+
 : !does ( does-action -- )
     tlastcfa @ [G'] :dovar killref
     [G'] does, gset-optimizer
@@ -2851,7 +2846,7 @@ X has? primcentric [IF]
 : does-resolved ( ghost -- )
     compile does-exec g>xt T a, H ;
 : extra-resolved ( ghost -- )
-    compile extra-exec g>xt T a, H ;
+    compile extra-xt g>xt T a, H ;
 [ELSE]
 : does-resolved ( ghost -- )
     g>xt T a, H ;
@@ -2871,17 +2866,17 @@ Cond: DOES>
 ;Cond
 Cond: EXTRA>
     T here cfaligned H [ T has? primcentric H [IF] ] 8 [ [ELSE] ] 7 [ [THEN] ] T cells
-    H + alit, compile !extraxt [compile] ;
-    T :noname H resolve-does>-part
+    H + alit, compile !extraxt compile ;
+    T :noname H 2drop depth resolve-does>-part
 ;Cond
 
-: DOES>
+: oldDOES>
     ['] does-resolved created >comp !
     switchrom doeshandler, T here H !does 
     instant-interpret-does>-hook
     depth ;Resolve off  T ] H ;
 
-: EXTRA>
+: DOES>
     ['] extra-resolved created >comp !
     T here cfaligned #10 cells H \ includes noname header+vtable
     + !newdoes
@@ -3146,7 +3141,7 @@ End-Struct vtable-struct
 : gset-to ( ghost -- )        vttemplate >vtto ! ;
 : gset-defer@   ( ghost -- )  vttemplate >vtdefer@ ! ;
 : gset->comp ( ghost -- )     vttemplate >vt>comp ! ;
-: gset-extra ( ghost -- )     vttemplate >vtextra ! ;
+:noname ( ghost -- )     vttemplate >vtextra ! ; is gset-extra
 
 : set-optimizer ( xt -- )  xt>ghost vttemplate >vtcompile, ! ;
 : set-to       ( xt -- )  xt>ghost vttemplate >vtto ! ;
@@ -3258,12 +3253,6 @@ by: :dodoes ;DO
 vt: [G'] does, gset-optimizer ;vt
 \ vtghost: dodoes-vt
 
-Builder doesxt>-dummy
-Build: ;Build
-by: :dodoesxt ;DO
-vt: [G'] doesxt, gset-optimizer ;vt
-\ vtghost: dodoesxt-vt
-
 Builder extraxt>-dummy
 Build: ;Build
 by: :doextraxt ;DO

kernel/comp.fs

@@ -544,7 +544,6 @@ opt: drop ( xt -- )
     [ has? peephole [IF] ] finish-code [ [THEN] ]
     defstart ;
 
-extraxt>-dummy (doextraxt-dummy)
 : !extraxt   ( addr -- ) \ gforth store-extra
     created?
     IF
@@ -618,7 +617,6 @@ Create vttemplate
 : set->int      ( xt -- ) vttemplate >vt>int ! ;
 : set->comp     ( xt -- ) vttemplate >vt>comp ! ;
 : set-does>     ( xt -- ) !extraxt ; \ more work than the aboves
-: set-doesxt>   ( xt -- ) !doesxt ; \ more work than the aboves
 
 :noname ( -- colon-sys ) start-xt  set-optimizer ;
 :noname ['] set-optimizer start-xt-like ;
@@ -763,19 +761,12 @@ defer 0-adjust-locals-size ( -- )
 
 \ does>
 
-: doesxt, ( xt -- )  postpone does-xt , ;
-\    dup >body postpone literal  cell+ @ compile, ;
-
-: !doesxt ( xt -- ) \ gforth store-doesxt
-    latestxt doesxt-code!
-    ['] doesxt, set-optimizer ;
-
 : created? ( -- flag )
     vttemplate >vtcompile, @ ['] udp >namevt @ >vtcompile, @ = ;
 
 : !does    ( addr -- ) \ gforth	store-does
     created? IF
-	['] spaces >namevt @ >vtcompile, @ set-optimizer
+	['] does, set-optimizer
     THEN
     latestxt does-code! ;
 

kernel/copydoers.fs

@@ -59,10 +59,10 @@ doer? :dofield [IF]
     ['] >body vtcopy, ;
 [THEN]
 
-true [IF] \ !! don't know what to put here
+doer? :dodoes [IF]
 : dodoes: ( -- addr )	\ gforth
     \G The code address of a @code{DOES>}-defined word.
-    ['] spaces >code-address ;
+    ['] (does-dummy) >code-address ;
 [THEN]
 
 doer? :doabicode [IF]

kernel/getdoers.fs

@@ -61,19 +61,13 @@ doer? :dofield [IF]
     ['] >body >code-address ;
 [THEN]
 
-true [IF] \ !! don't know what to put here
+doer? :dodoes [IF]
+does>-dummy (does-dummy)
 : dodoes: ( -- addr )	\ gforth
 \G The code address of a @code{DOES>}-defined word.
-    ['] spaces >code-address ;
+    ['] (does-dummy) >code-address ;
 [THEN]
 
-doer? :dodoesxt [if]
-    doesxt>-dummy (doesxt>-dummy)
-    : dodoesxt: ( -- addr )
-        \G the code address of a @code{set-does>}-defined word.
-        ['] (doesxt>-dummy) >code-address ;
-[then]
-
 doer? :doabicode [IF]
 (ABI-CODE) (abi-code-dummy)
 : doabicode: ( -- addr )	\ gforth
@@ -87,14 +81,8 @@ doer? :do;abicode [IF]
     ['] (;abi-code-dummy) >code-address ;
 [THEN]
 
-doer? :doextra [IF]
-\ extra>-dummy (doextra-dummy)
-: doextra: ( -- addr )
-    ['] (doextra-dummy) >code-address ;
-[THEN]
-
 doer? :doextraxt [IF]
-\ extra>-dummy (doextra-dummy)
+extraxt>-dummy (doextraxt-dummy)
 : doextraxt: ( -- addr )
     ['] (doextraxt-dummy) >code-address ;
 [THEN]

kernel/int.fs

@@ -541,14 +541,11 @@ cell% -2 * 0 0 field body> ( xt -- a_addr )
 \G Otherwise @i{a-addr} is 0.
     dup @ dodoes: = if
 	cell+ @
-    else dup @ dodoesxt: = if
-            cell+ @ >body
-        else
-            dup @ doextraxt: = IF
-                >namevt @ >vtextra @ >body
-            ELSE
-                drop 0
-            THEN
+    else
+	dup @ doextraxt: = if
+	    >namevt @ >vtextra @ >body
+	else
+	    drop 0
         then
     endif ;
 
@@ -565,14 +562,7 @@ cell% -2 * 0 0 field body> ( xt -- a_addr )
 \G @i{a-addr} is the start of the Forth code after @code{DOES>}.
     dodoes: over ! cell+ ! ;
 \ after eliminating dodoes:, this changes to
-\   body> doesxt-code! ;
-
-: doesxt-code! ( xt1 xt2 -- ) \ gforth
-\G Create a code field at @i{xt2} for a child of a
-\G @code{SET-DOES>}-word; afterwards, when @i{xt2} is run, its body
-\G address is pushed and @i{xt1} is run.  Note: This changes only the
-\G code field, for correctness you also need to change the compiler
-    dodoesxt: over ! cell+ ! ;
+\   body> extra-xt! ;
 
 : extra-xt! ( xt1 xt2 -- ) \ gforth
 \G Create a code field at @i{xt2} for a child of a @code{DOES>}-word;

kernel/io.fs

@@ -183,7 +183,7 @@ bl 80 times \ times from target compiler! 11may93jaw
 DOES>   ( u -- ) spaces-loop ;
 Create backspaces
 08 80 times \ times from target compiler! 11may93jaw
-EXTRA>   ( u -- ) over 2* negate out +! spaces-loop ;
+DOES>   ( u -- ) over 2* negate out +! spaces-loop ;
 hex
 
 Defer deadline ( d -- )

kernel/kernel.fs

@@ -21,8 +21,8 @@ require ./vars.fs
 include ./input-class.fs
 include ./int.fs
 has? compiler [IF]
-    include ./comp.fs
     include ./vtables.fs
+    include ./comp.fs
 [THEN]
 include ./accept.fs
 include ./input.fs

kernel/vtables.fs

@@ -40,13 +40,13 @@
     \ cross-compiler does not implement them).
     >body cell+ (uv) ! ;
 opt: ( xt-method xt-to -- )
-    drop >body cell+ postpone Aliteral postpone (uv) postpone ! ;
+    drop >body cell+ lit, postpone (uv) postpone ! ;
 
 : umethod@ ( addr -- xt )
     \ this is not a proper word, but a DEFER@: OPT-DEFER@: word (but
     \ the cross-compiler does not implement them).
     >body cell+ (uv) @ ;
 opt: ( xt-method xt-defer@ -- )
-    drop >body cell+ postpone Aliteral postpone (uv) postpone @ ;
+    drop >body cell+ lit, postpone (uv) postpone @ ;
 
 AVariable vtable-list

see.fs

@@ -707,8 +707,9 @@ VARIABLE C-Pass
 CREATE C-Table \ primitives map to code only
 	        ' lit A,            ' c-lit A,
 		' does-exec A,	    ' c-callxt A,
-[IFDEF] does-xt ' does-xt A,        ' c-callxt A,
-                ' extra-exec A,	    ' c-callxt A,
+[IFDEF] does-xt ' does-xt A,        ' c-callxt A, [THEN]
+[IFDEF] extra-exec ' extra-exec A,	    ' c-callxt A, [THEN]
+[IFDEF] extra-xt ' extra-xt A,	    ' c-callxt A, [THEN]
 		' lit@ A,	    ' c-call A,
 [IFDEF] call	' call A,           ' c-call A, [THEN]
 [IFDEF] call-loc ' call-loc A,      ' c-call A, [THEN]