Verified Commit 43588838 authored by Bernd Paysan's avatar Bernd Paysan
Browse files

Make closures work with extraxt:

parent bc203740

closures.fs

+15 −15
Changes for closures.fs: 15 added lines, 15 removed lines.
Original line number Diff line number Diff line
@@ -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

+1 −1
Changes for comp-i.fs: 1 added line, 1 removed line.
Original line number Diff line number Diff line
@@ -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

+5 −19
Changes for cross.fs: 5 added lines, 19 removed lines.
Original line number Diff line number Diff line
@@ -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

+1 −1
Changes for engine/forth.h: 1 added line, 1 removed line.
Original line number Diff line number Diff line
@@ -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

+1 −1
Changes for engine/main.c: 1 added line, 1 removed line.
Original line number Diff line number Diff line
@@ -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]);