Reorder fields to xt-related and nt-related (e4bcfaa9) · Commits · Bernd Paysan / gforth

cross.fs

+48 −27

Changes for cross.fs: 48 added lines, 27 removed lines.
Original line number	Diff line number	Diff line
		@@ -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

+6 −4

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

+5 −5

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

+31 −19

Changes for kernel/comp.fs: 31 added lines, 19 removed lines.
Original line number	Diff line number	Diff line
		@@ -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

+27 −13

Changes for kernel/int.fs: 27 added lines, 13 removed lines.
Original line number	Diff line number	Diff line
		@@ -375,10 +375,12 @@ $00ffffff constant lcount-mask
		(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) >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- ;