Reorder fields to xt-related and nt-related

parent ebe10cd2
Pipeline #802 failed with stage
in 5 minutes and 30 seconds
......@@ -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 ;
......
......@@ -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]))
......
......@@ -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
......
......@@ -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
......
......@@ -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- ;
......
......@@ -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 ;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment