Make closures work with extraxt:

closures.fs

@@ -22,15 +22,6 @@
 $10 stack: locals-sizes
 $10 stack: locals-lists
 
-: doesxt, ( xt -- )  postpone does-xt , ;
-
-Create do-closure \G vtable prototype for closures
-dodoes: latestxt !
-' doesxt, set-optimizer
-' noop set->int            \ closures don't have a full header, so the default
-' (noname->comp) set->comp \ actions (that check flags) don't work
-
-
 Defer end-d ( ... xt -- ... )
 \ is either EXECUTE (for {: ... :}*) or END-DCLOSURE (for [{: ... :}*).
 \ xt is either ' NOOP or [: ]] r> lp! [[ ;], which restores LP.
@@ -109,25 +100,34 @@ locals-types definitions
 forth definitions
 
 : (closure-;]) ( closure-sys lastxt -- )
-    ]
+    >r r@ dup >namevt @ >vtextra ! vt,
     postpone THEN
+    orig? r> >namevt @ swap ! drop
     wrap! pop-locals ;
 
+: closure-:-hook ( sys -- sys addr xt n )
+    \ addr is the nfa of the defined word, xt its xt
+    latest latestxt
+    clear-leave-stack
+    dead-code off
+    defstart ;
+
 : closure> ( body -- addr ) \ gforth-experimental closure-end
     \G create trampoline head
-    >l dodoes: >l lp@
-    [ ' do-closure cell- @ ]L >l
-    [ cell maxaligned cell <> ] [IF] 0 >l [THEN] ;
+    doextraxt: >l >l lp@ cell+ ;
 : end-dclosure ( unravel-xt -- closure-sys )
     >r wrap@
     postpone lit >mark
-    ]] closure> [[ r> execute ]] AHEAD BUT THEN [[
+    ]] closure> [[ r> execute ]] AHEAD [[
+    action-of :-hook >r  ['] closure-:-hook is :-hook
+    :noname
+    r> is :-hook
     case locals-size @ \ special optimizations for few locals
 	cell    of ]] @ >l   [[ endof
 	2 cells of ]] 2@ 2>l [[ endof
 	]] lp+!# [[ dup negate , ]] laddr# [[ 0 , dup ]] literal move [[
     endcase
-    ['] (closure-;]) defstart  last @ lastcfa @ defstart ;
+    ['] (closure-;]) colon-sys-xt-offset stick ;
 
 : [{: ( -- vtaddr u latest latestxt wid 0 ) \ gforth-experimental start-closure
     \G starts a closure.  Closures first declare the locals frame they are

comp-i.fs

@@ -186,7 +186,7 @@ synonym section-offset section-end
 
 : comp-image ( "image-file1" "image-file2" "new-image" -- )
     name slurp-file { file1 fsize1 }
-    file1 fsize1 s" Gforth5" search 0= abort" not a Gforth image"
+    file1 fsize1 s" Gforth6" search 0= abort" not a Gforth image"
     drop 8 + file1 - { header-offset }
     file1 fsize1 header-offset /string to size1 to image1
     size1 aligned size1 <> abort" unaligned image size"

cross.fs

@@ -2563,42 +2563,29 @@ Cond: [']  T ' H alit, ;Cond
 \ \ threading model					13dec92py
 \ modularized						14jun97jaw
 
-T 2 cells H Value xt>body
+T 1 cells H Value xt>body
 
 : (>body)   ( cfa -- pfa ) 
   xt>body + ;						' (>body) plugin-of t>body
 
-: fillcfa   ( usedcells -- )
-  T cells H xt>body swap -
-  assert1( dup 0 >= )
-  0 ?DO 0 X c, tchar +LOOP ;
-
 : (doer,)   ( ghost -- ) 
-  addr, 1 fillcfa ;   					' (doer,) plugin-of doer,
+  addr, ;   					' (doer,) plugin-of doer,
 
 : (docol,)  ( -- ) [G'] :docol (doer,) ;		' (docol,) plugin-of docol,
 
                                                         ' NOOP plugin-of ca>native
 
 : (doprim,) ( -- )
-  there xt>body + ca>native T a, H 1 fillcfa ;		' (doprim,) plugin-of doprim,
+  there xt>body + ca>native T a, H ;		' (doprim,) plugin-of doprim,
 
 : (doeshandler,) ( -- ) 
     T H ; 					' (doeshandler,) plugin-of doeshandler,
 
 Defer gset-extra
 
-: (dodoes,) ( does-action-ghost -- )
-    ]comp [G'] :dodoes addr, comp[
-    dup gset-extra
-    addr,
-    2 fillcfa ;
-
 : doextraxt, ( does-action-ghost -- )
     ]comp [G'] :doextraxt addr, comp[
-    0 addr,
-    gset-extra
-    2 fillcfa ;						' doextraxt, plugin-of dodoes,
+    gset-extra ;					' doextraxt, plugin-of dodoes,
 
 : (dlit,) ( n -- ) compile lit td, ;			' (dlit,) plugin-of dlit,
 
@@ -2932,7 +2919,6 @@ Cond: DOES>
 \  compile :dodoes gexecute
 \  T here H tcell - reloff 
   2 refered 
-  0 fillcfa
   ;
 
 : takeover-x-semantics ( S constructor-ghost new-ghost -- )
@@ -3891,7 +3877,7 @@ Cond: postpone ( -- ) \ name
 hex
 
 >CROSS
-Create magic  s" Gforth5x" here over allot swap move
+Create magic  s" Gforth6x" here over allot swap move
 
 bigendian 1+ \ strangely, in magic big=0, little=1
 tcell 1 = 0 and or

engine/forth.h

@@ -303,7 +303,7 @@ typedef union {
 typedef Label *Xt;
 
 /* PFA gives the parameter field address corresponding to a cfa */
-#define PFA(cfa)	(((Cell *)cfa)+2)
+#define PFA(cfa)	(((Cell *)cfa)+1)
 /* PFA1 is a special version for use just after a NEXT1 */
 #define PFA1(cfa)	PFA(cfa)
 /* CODE_ADDRESS is the address of the code jumped to through the code field */

engine/main.c

@@ -1994,7 +1994,7 @@ static FILE *checkimage(char *path, int len, char *imagename)
       return NULL;
     }
     preamblesize+=8;
-  } while(memcmp(magic,"Gforth5",7));
+  } while(memcmp(magic,"Gforth6",7));
   if (debug) {
     fprintf(stderr,"Magic found: %*s ", 6, magic);
     print_sizes(magic[7]);

kernel/comp.fs

@@ -151,7 +151,7 @@ Defer check-shadow ( addr u wid -- )
     [ [IFDEF] prelude-mask ] prelude, [ [THEN] ]
     dup aligned here + dup maxaligned >align
     view,
-    dup cell+ here + dup maxaligned >align
+    dup here + dup maxaligned >align
     nlstring,
     r> 1 or A, 0 A, here last !  \ link field; before revealing, it contains the
     \ tagged reveal-into wordlist
@@ -159,8 +159,7 @@ Defer check-shadow ( addr u wid -- )
     [ [IFDEF] prelude-mask ]
 	next-prelude @ 0<> prelude-mask and lastflags cset
 	next-prelude off
-    [ [THEN] ]
-    cfalign ;
+    [ [THEN] ] ;
 
 defer record-name ( -- )
 ' noop is record-name
@@ -196,7 +195,7 @@ defer header ( -- ) \ gforth
     ['] nextname-header IS (header) ;
 
 : noname, ( -- )
-    0 last ! vt,  here cell+ dup cfaligned >align 0 ( alias-mask ) , 0 , 0 , ;
+    0 last ! vt,  here dup cfaligned >align 0 ( alias-mask ) , 0 , 0 , ;
 : noname-header ( -- )
     noname, input-stream ;
 
@@ -255,7 +254,7 @@ Defer char@ ( addr u -- char addr' u' )
 ' noop Alias recurse
 \g Alias to the current definition.
 
-unlock tlastcfa @ >body lock AConstant lastcfa
+unlock tlastcfa @ lock >body AConstant lastcfa
 \ this is the alias pointer in the recurse header, named lastcfa.
 \ changing lastcfa now changes where recurse aliases to
 \ it's always an alias of the current definition
@@ -265,7 +264,7 @@ unlock tlastcfa @ >body lock AConstant lastcfa
 : cfa,     ( code-address -- )  \ gforth	cfa-comma
     here
     dup lastcfa !
-    0 A, 0 ,
+    0 A,
     code-address! ;
 
 defer basic-block-end ( -- )

kernel/int.fs

@@ -524,12 +524,12 @@ const Create ???
     \ also heuristic
     dup head? 0= IF  drop ['] ???  THEN ;
 
-cell% 2* 0 0 field >body ( xt -- a_addr ) \ core to-body
+cell% 0 0 field >body ( xt -- a_addr ) \ core to-body
 \G Get the address of the body of the word represented by @i{xt} (the
 \G address of the word's data field).
 drop drop
 
-cell% -2 * 0 0 field body> ( xt -- a_addr )
+cell% -1 * 0 0 field body> ( xt -- a_addr )
     drop drop
 
 ' @ alias >code-address ( xt -- c_addr ) \ gforth
@@ -539,15 +539,11 @@ cell% -2 * 0 0 field body> ( xt -- a_addr )
 \G If @i{xt} is the execution token of a child of a @code{DOES>} word,
 \G @i{a-addr} is the start of the Forth code after the @code{DOES>};
 \G Otherwise @i{a-addr} is 0.
-    dup @ dodoes: = if
-	cell+ @
+    dup @ doextraxt: = if
+	>namevt @ >vtextra @ >body
     else
-	dup @ doextraxt: = if
-	    >namevt @ >vtextra @ >body
-	else
-	    drop 0
-        then
-    endif ;
+	drop 0
+    then ;
 
 ' ! alias code-address! ( c_addr xt -- ) \ gforth
 \G Create a code field with code address @i{c-addr} at @i{xt}.