Remove immediate-flag, replace with new header construct (ea7f41f4) · Commits · Bernd Paysan / gforth

cross.fs

+13 −9

Original line number	Diff line number	Diff line
		@@ -2173,10 +2173,6 @@ dup constant immediate-mask 2/
		constant restrict-mask

		>TARGET
		: immediate immediate-mask flag!
		^imm @ @ dup <imm> = IF drop EXIT THEN
		<res> <> ABORT" CROSS: Cannot immediate a unresolved word"
		<imm> ^imm @ ! ;
		: restrict restrict-mask flag! ;
		: compile-only restrict-mask flag! ;

		@@ -2960,8 +2956,8 @@ Cond: DOES>

		: create-resolve ( -- )
		created createhere resolve ( 0 ;Resolve ! ) ;
		: create-resolve-immediate ( -- )
		create-resolve T immediate H ;
		\ : create-resolve-immediate ( -- )
		\ create-resolve T immediate H ;

		: TCreate ( <name> -- )
		create-forward-warn
		@@ -3000,9 +2996,9 @@ Cond: DOES>
		: ;Build
		postpone create-resolve postpone ; built >exec ! ; immediate

		: ;Build-immediate
		postpone create-resolve-immediate
		postpone ; built >exec ! ; immediate
		\ : ;Build-immediate
		\ postpone create-resolve-immediate
		\ postpone ; built >exec ! ; immediate

		: gdoes> ( ghost -- addr flag )
		executed-ghost @ g>body ;
		@@ -3142,6 +3138,7 @@ End-Struct vtable-struct
		:noname ( ghost -- ) vttemplate >vtcompile, ! ; IS gset-optimizer
		: gset-to ( ghost -- ) vttemplate >vtto ! ;
		: gset-defer@ ( ghost -- ) vttemplate >vtdefer@ ! ;
		: gset->comp ( ghost -- ) vttemplate >vt>comp ! ;

		: set-optimizer ( xt -- ) xt>ghost vttemplate >vtcompile, ! ;
		: set-to ( xt -- ) xt>ghost vttemplate >vtto ! ;
		@@ -3154,6 +3151,13 @@ End-Struct vtable-struct
		postpone ; built >do:ghost @ >exec2 ! ; immediate

		>TARGET
		ghost imm>comp

		: immediate ( immediate-mask flag! )
		[G'] imm>comp gset->comp
		^imm @ @ dup <imm> = IF drop EXIT THEN
		<res> <> ABORT" CROSS: Cannot immediate a unresolved word"
		<imm> ^imm @ ! ;

		ghost a>int drop
		ghost a>comp drop

debugs.fs

+11 −0

Original line number	Diff line number	Diff line
		@@ -303,3 +303,14 @@ Variable rec'
		['] prompt-text success-color color-execute ;

		' color-prompt is prompt

		\ print name vtable

		: .vt ( nt -- )
		>namevt @ cr
		." opt: " dup >vtcompile, @ .name cr
		." to: " dup >vtto @ .name cr
		." >int: " dup >vt>int @ .name cr
		." >comp: " dup >vt>comp @ .name cr
		." defer@: " dup >vtdefer@ @ .name cr
		." extra: " >vtextra @ hex. ;

kernel/comp.fs

+15 −16

Original line number	Diff line number	Diff line
		@@ -156,8 +156,10 @@ Defer check-shadow ( addr u wid -- )
		r> 1 or A, 0 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] ]
		cfalign ;

		defer record-name ( -- )
		@@ -300,12 +302,7 @@ has? primcentric [IF]

		: default-name>comp ( nt -- w xt ) \ gforth name-to-comp
		\G @i{w xt} is the compilation token for the word @i{nt}.
		(name>x) (x>comp)
		1 = if
		['] execute
		else
		['] compile,
		then ;
		name>int ['] compile, ;

		: [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick
		(') postpone ALiteral ; immediate restrict
		@@ -368,10 +365,11 @@ include ./recognizer.fs
		latest dup 0= abort" last word was headerless"
		>f+c ;

		: imm>comp name>int ['] execute ;
		: immediate ( -- ) \ core
		\G Make the compilation semantics of a word be to @code{execute}
		\G the execution semantics.
		immediate-mask lastflags cset ;
		['] imm>comp set->comp ;

		: restrict ( -- ) \ gforth
		\G A synonym for @code{compile-only}
		@@ -393,8 +391,9 @@ include ./recognizer.fs
		dup >namevt @ >vtdefer@ @ opt-something, ;

		: a>int ( nt -- ) >body @ ;
		: a>comp ( nt -- xt1 xt2 ) dup >r >body @
		['] execute ['] compile, r> immediate? select ;
		: a>comp ( nt -- xt1 xt2 ) name>int ['] compile, ;
		\ dup >r >body @
		\ ['] execute ['] compile, r> >f+c @ immediate-mask and select ;

		: s>int ( nt -- xt ) >body @ name>int ;
		: s>comp ( nt -- xt1 xt2 ) >body @ name>comp ;
		@@ -409,10 +408,10 @@ opt: drop >body @ defer@, ;
		: s-compile, ( xt -- ) >body @ compile, ;

		: Alias ( xt "name" -- ) \ gforth
		Header reveal ['] on vtcopy
		Header reveal ['] on vtcopy dodefer,
		['] a>int set->int ['] a>comp set->comp ['] s-to set-to
		['] s-defer@ set-defer@ ['] s-compile, set-optimizer
		dodefer, dup A, lastcfa ! ;
		dup A, lastcfa ! ;

		: alias? ( nt -- flag )
		>namevt @ >vt>int 2@ ['] a>comp ['] a>int d= ;
		@@ -684,12 +683,12 @@ opt: drop ( value-xt -- ) \ run-time: ( n -- )

		: <IS> ( "name" xt -- ) \ gforth
		\g Changes the @code{defer}red word @var{name} to execute @var{xt}.
		record-name (') (name>x) drop (int-to) ;
		record-name (') (int-to) ;

		: [IS] ( compilation "name" -- ; run-time xt -- ) \ gforth bracket-is
		\g At run-time, changes the @code{defer}red word @var{name} to
		\g execute @var{xt}.
		record-name (') (name>x) drop (comp-to) ; immediate restrict
		record-name (') (comp-to) ; immediate restrict

		' <IS> ' [IS] interpret/compile: TO ( value "name" -- ) \ core-ext
		\g changes the value of @var{name} to @var{value}

kernel/int.fs

+9 −16

Original line number	Diff line number	Diff line
		@@ -336,18 +336,18 @@ forth-wordlist current !
		\ 1 bits/char 1 - lshift
		\ -1 cells allot bigendian [IF] c, 0 1 cells 1- times
		\ [ELSE] 0 1 cells 1- times c, [THEN]
		$80000000 constant immediate-mask
		1 bits/char 1 - lshift
		-1 cells allot bigendian [IF] c, 0 1 cells 1- times
		[ELSE] 0 1 cells 1- times c, [THEN]
		\ $80000000 constant immediate-mask
		\ 1 bits/char 1 - lshift
		\ -1 cells allot bigendian [IF] c, 0 1 cells 1- times
		\ [ELSE] 0 1 cells 1- times c, [THEN]
		$40000000 constant restrict-mask
		1 bits/char 2 - lshift
		-1 cells allot bigendian [IF] c, 0 1 cells 1- times
		[ELSE] 0 1 cells 1- times c, [THEN]
		$20000000 constant prelude-mask
		1 bits/char 3 - lshift
		-1 cells allot bigendian [IF] c, 0 1 cells 1- times
		[ELSE] 0 1 cells 1- times c, [THEN]
		\ $20000000 constant prelude-mask
		\ 1 bits/char 3 - lshift
		\ -1 cells allot bigendian [IF] c, 0 1 cells 1- times
		\ [ELSE] 0 1 cells 1- times c, [THEN]
		\ $01000000 constant unused-mask \ defined in locate1.fs, used only temporarily
		\ reserve 8 bits for all possible flags in total
		$00ffffff constant lcount-mask
		@@ -426,7 +426,7 @@ defer compile, ( xt -- )
		\G Reserve data space for one cell and store @i{w} in the space.
		cell small-allot ! ;

		: immediate? ( nt -- flag ) >f+c @ immediate-mask and 0<> ;
		: immediate? ( nt -- flag ) name>comp nip ['] execute = ;
		: compile-only? ( nt -- flag ) >f+c @ restrict-mask and 0<> ;
		: ?compile-only ( nt -- nt )
		dup compile-only? IF
		@@ -447,10 +447,6 @@ defer compile, ( xt -- )
		: name>view ( nt -- addr ) \ gforth name-to-view
		name>string drop cell negate and cell- ;

		: (name>x) ( nfa -- cfa w )
		\ cfa is an intermediate cfa and w is the flags cell of nfa
		dup >f+c @ ;

		: default-name>int ( nt -- xt ) \ gforth paren-name-to-int
		\G @i{xt} represents the interpretation semantics of the word
		\G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
		@@ -458,9 +454,6 @@ defer compile, ( xt -- )
		\G @code{ticking-compile-only-error}, which performs @code{-2048 throw}.
		;

		: (x>comp) ( xt w -- xt +-1 )
		immediate-mask and flag-sign ;

		: (name>intn) ( nfa -- xt +-1 )
		dup name>int swap name>comp nip ['] execute = flag-sign ;

see.fs

+2 −2

Original line number	Diff line number	Diff line
		@@ -329,9 +329,9 @@ VARIABLE C-Pass
		EXIT
		then
		THEN
		nip dup >f+c @ immediate-mask and
		nip dup immediate?
		IF
		bl cemit ." POSTPONE "
		bl cemit ." [COMPILE] "
		THEN
		dup name>string rot wordinfo .string
		;