Add WHERE support for words in kernel (excluding interpret/compile: for now,... (f12c8c13) · Commits · Bernd Paysan / gforth

cross.fs

+79 −42

Original line number	Diff line number	Diff line
		@@ -77,7 +77,9 @@ H

		\ find out whether we are compiling with gforth

		: defined? bl word find nip ;
		: bl-word ( -- addr )
		parse-name here place here ;
		: defined? bl-word find nip ;
		defined? emit-file defined? toupper and \ drop 0
		[IF]
		\ use this in a gforth system
		@@ -94,7 +96,7 @@ defined? emit-file defined? toupper and \ drop 0
		[IF]
		: \G postpone \ ; immediate
		: rdrop postpone r> postpone drop ; immediate
		: name bl word count ;
		: name bl-word count ;
		: bounds over + swap ;
		: scan >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN rdrop ;
		: linked here over @ , swap ! ;
		@@ -269,7 +271,7 @@ hex \ the defualt base for the cross-compiler is hex !!
		\G Same behaviour as "Value" if the <name> is not defined
		\G Same behaviour as "to" if the <name> is defined
		\G SetValue searches in the current vocabulary
		save-input bl word >r restore-input throw r> count
		save-input bl-word >r restore-input throw r> count
		get-current search-wordlist
		IF drop >r
		\ we have to set current to be topmost context wordlist
		@@ -281,9 +283,9 @@ hex \ the defualt base for the cross-compiler is hex !!
		: DefaultValue ( n -- <name> )
		\G Same behaviour as "Value" if the <name> is not defined
		\G DefaultValue searches in the current vocabulary
		save-input bl word >r restore-input throw r> count
		save-input bl-word >r restore-input throw r> count
		get-current search-wordlist
		IF bl word drop 2drop ELSE Value THEN ;
		IF bl-word drop 2drop ELSE Value THEN ;

		hex

		@@ -303,7 +305,7 @@ hex
		\G The next word in the input is a target word.
		\G Equivalent to T <name> but without permanent
		\G switch to target dictionary. Used as prefix e.g. for @, !, here etc.
		bl word count [ ' target >wordlist ] Literal search-wordlist
		bl-word count [ ' target >wordlist ] Literal search-wordlist
		IF state @ IF compile, ELSE execute THEN
		ELSE -1 ABORT" Cross: access method not supported!"
		THEN ; immediate
		@@ -342,12 +344,12 @@ set-order previous
		: D? ( <name> -- flag )
		\G return true if debug flag is defined or switched on
		\G while compiling we do not return the current value but
		bl word count debug? ;
		bl-word count debug? ;

		: [d?]
		\G compile the value-xt so the debug flag can be switched
		\G the flag must exist!
		bl word count debugflags-wl search-wordlist
		bl-word count debugflags-wl search-wordlist
		IF compile,
		ELSE -1 ABORT" unknown debug flag"
		\ POSTPONE false
		@@ -645,9 +647,9 @@ false DebugFlag showincludedfiles
		ELSE included1
		THEN ;

		: include bl word count included ;
		: include bl-word count included ;

		: require bl word count required ;
		: require bl-word count required ;

		0 [IF]

		@@ -996,7 +998,7 @@ ghosts-wordlist Value current-ghosts
		\ restore current
		r> set-current
		here (ghostheader)
		bl word count string, align
		bl-word count string, align
		space>
		\ set ghost-xt field by doing a search
		dup >ghost-name count
		@@ -1021,11 +1023,42 @@ Defer search-ghosts
		search-ghosts
		dup IF swap >body swap THEN ;

		Variable cross-wheres

		0
		cell +field gwhere-nt
		cell +field gwhere-loc
		constant gwhere-struct

		: tsourceview ( -- view )
		[IFDEF] loadfilename# loadfilename# @
		[ELSE] sourcefilename str>loadfilename# [THEN]
		sourceline#
		input-lexeme 2@ drop source drop -
		$ff min swap 8 lshift + $7fffff min swap #23 lshift or ;

		: gwhere-duplicate? ( ghost -- flag )
		cross-wheres $@ dup if
		gwhere-struct - + >r
		dup r@ gwhere-nt @ =
		r> gwhere-loc @ tsourceview = and if
		drop true exit then
		else
		2drop then
		drop false ;

		: gwhere, ( ghost -- )
		dup gwhere-duplicate? 0= IF
		gwhere-struct cross-wheres $+!len >r
		dup r@ gwhere-nt !
		tsourceview r> gwhere-loc !
		THEN drop ;

		: gfind ( string -- ghost true / string false )
		\ searches for string in word-list ghosts
		\ dup count type space
		dup >r count gsearch
		dup IF rdrop ELSE r> swap THEN ;
		dup IF rdrop over gwhere, ELSE r> swap THEN ;

		: gdiscover ( xt -- ghost true \| xt false )
		>r ghost-list
		@@ -1041,7 +1074,7 @@ Defer search-ghosts
		gdiscover 0= ABORT" CROSS: ghost not found for this xt" ;

		: Ghost ( "name" -- ghost )
		>in @ bl word gfind IF nip EXIT THEN
		>in @ bl-word gfind IF nip EXIT THEN
		drop >in ! Make-Ghost ;

		: >ghostname ( ghost -- adr len )
		@@ -1071,7 +1104,7 @@ Variable reuse-ghosts reuse-ghosts off

		: HeaderGhost ( "name" -- ghost )
		>in @
		bl word count
		bl-word count
		\ 2dup type space
		current-ghosts search-wordlist
		IF >body dup undefined? reuse-ghosts @ or
		@@ -1091,7 +1124,7 @@ Variable reuse-ghosts reuse-ghosts off
		\ ' >ghostname ALIAS @name

		: findghost ( "ghostname" -- ghost )
		bl word gfind 0= ABORT" CROSS: Ghost don't exists" ;
		bl-word gfind 0= ABORT" CROSS: Ghost don't exists" ;

		: [G'] ( -- ghost : name )
		\G ticks a ghost and returns its address
		@@ -1192,13 +1225,13 @@ Variable env-current
		: e? ( "name" -- x )
		\G returns the content of environment variable.
		\G The variable is expected to exist. If not, issue an error.
		bl word count T environment? H
		bl-word count T environment? H
		0= ABORT" environment variable not defined!" ;

		: has? ( "name" --- x \| false )
		\G returns the content of environment variable
		\G or false if not present
		bl word count T $has? H ;
		bl-word count T $has? H ;


		>ENVIRON get-order get-current swap 1+ set-order
		@@ -1351,7 +1384,7 @@ Variable mirrored-link \ linked list for mirrored regions
		: region ( addr len -- "name" )
		\G create a new region
		\ check whether predefined region exists
		save-input bl word find >r >r restore-input throw r> r> 0=
		save-input bl-word find >r >r restore-input throw r> r> 0=
		IF \ make region
		drop
		save-input create restore-input throw
		@@ -1359,9 +1392,9 @@ Variable mirrored-link \ linked list for mirrored regions
		over ( startaddr ) , ( length ) , ( dp ) ,
		region-link linked 0 , 0 , 0 , 0 ,
		['] uninitialized ,
		bl word count string,
		bl-word count string,
		ELSE \ store new parameters in region
		bl word drop
		bl-word drop
		>body (region)
		THEN ;

		@@ -2170,11 +2203,7 @@ X has? f83headerstring [IF]
		[IFDEF] replace-sourceview
		replace-sourceview 0 to replace-sourceview ?dup ?EXIT
		[THEN]
		[IFDEF] loadfilename# loadfilename# @
		[ELSE] sourcefilename str>loadfilename# [THEN]
		sourceline#
		input-lexeme 2@ drop source drop -
		$ff min swap 8 lshift + $7fffff min swap #23 lshift or ;
		tsourceview ;
		: view, ( -- ) tsourcepos1 T , H ;
		: shorten-path ( addr u -- addr' u' ) 2>r
		fpath path>string BEGIN next-path dup WHILE
		@@ -2316,7 +2345,7 @@ Defer skip? ' false IS skip?
		\G a word is not defined
		\G a forward reference exists
		\G so the definition is not skipped!
		bl word gfind
		bl-word gfind
		IF dup undefined?
		nip
		0=
		@@ -2354,7 +2383,7 @@ Defer vt, \ forward rference only
		0 Value lastghost

		: (THeader ( "name" -- ghost )
		\ >in @ bl word count type 2 spaces >in !
		\ >in @ bl-word count type 2 spaces >in !
		\ wordheaders will always be compiled to rom
		switchrom vt,
		\ build header in target
		@@ -2378,7 +2407,7 @@ Defer vt, \ forward rference only
		THEN
		T cfalign here H tlastcfa !
		\ Old Symbol table sed-script
		\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in !
		\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl-word count .sym ." /g" cr >in !
		HeaderGhost
		\ output symbol table to extra file
		dup >ghostname there symentry
		@@ -2425,7 +2454,7 @@ Variable last-prim-ghost
		: asmprimname, ( ghost -- : name )
		dup last-prim-ghost !
		>r
		here bl word count string, r@ >asm-name !
		here bl-word count string, r@ >asm-name !
		aprim-nr @ r> >asm-dummyaddr ! ;

		Defer setup-prim-semantics
		@@ -2444,7 +2473,7 @@ Defer setup-prim-semantics
		>in @ skip? IF 2drop EXIT THEN >in !
		dup 0< s" prims" T $has? H 0= and
		IF
		.sourcepos ." needs doer: " >in @ bl word count type >in ! cr
		.sourcepos ." needs doer: " >in @ bl-word count type >in ! cr
		THEN
		Ghost
		tuck swap resolve-noforwards <do:> swap >magic ! ;
		@@ -2472,7 +2501,7 @@ Variable prim#
		>in @ skip? IF drop EXIT THEN >in !
		s" prims" T $has? H 0=
		IF
		.sourcepos ." needs prim: " >in @ bl word count type >in ! cr
		.sourcepos ." needs prim: " >in @ bl-word count type >in ! cr
		THEN
		prim# @ #primitive
		-1 prim# +! ;
		@@ -2520,7 +2549,7 @@ Comment ( Comment \

		: ' ( -- xt )
		\G returns the target-cfa of a ghost
		bl word gfind 0= ABORT" CROSS: Ghost don't exists"
		bl-word gfind 0= ABORT" CROSS: Ghost don't exists"
		g>xt ;

		\ FIXME: this works for the current use cases, but is not
		@@ -2632,7 +2661,7 @@ Cond: \G T-\G ;Cond
		Cond: Literal ( n -- ) lit, ;Cond
		Cond: ALiteral ( n -- ) alit, ;Cond

		: Char ( "<char>" -- ) bl word char+ c@ ;
		: Char ( "<char>" -- ) bl-word char+ c@ ;
		Cond: [Char] ( "<char>" -- ) Char lit, ;Cond

		: (x#) ( adr len base -- )
		@@ -2718,7 +2747,7 @@ Variable no-loop
		compiling-state
		BEGIN
		compiling? WHILE
		BEGIN save-input bl word
		BEGIN save-input bl-word
		dup c@ 0= WHILE drop discard refill 0=
		ABORT" CROSS: End of file while target compiling"
		REPEAT
		@@ -3143,6 +3172,14 @@ variable cross-boot[][]
		: boot[][], ( -- )
		H cross-boot[][] $@ dup cell / T cell * , H bounds ?DO I @ T A, H cell +LOOP ;

		: wheres, ( -- ) cr ." Compiling wheres" cr
		H cross-wheres $@ dup cell / T cell * , H bounds ?DO I 2@
		dup undefined? IF ( ." undefined " dup >ghostname type cr ) drop -1
		ELSE g>xt THEN
		T A, , H 2 cells +LOOP ;

		: wheres-off cross-wheres $free ;

		>CROSS

		\ instantiate deferred extra, now
		@@ -3826,11 +3863,11 @@ Cond: defers T ' >body @ compile, H ;Cond

		Cond: [compile] ( -- ) \ name
		\g For immediate words, works even if forward reference
		bl word gfind 0= ABORT" CROSS: Can't compile"
		bl-word gfind 0= ABORT" CROSS: Can't compile"
		(gexecute) ;Cond

		Cond: postpone ( -- ) \ name
		bl word gfind 0= ABORT" CROSS: Can't compile"
		bl-word gfind 0= ABORT" CROSS: Can't compile"
		dup >magic @ <fwd> =
		ABORT" CROSS: Can't postpone on forward declaration"
		dup >magic @ <imm> =
		@@ -4121,7 +4158,7 @@ Variable outfile-fd

		: [ELSE]
		1 BEGIN
		BEGIN bl word count dup WHILE
		BEGIN bl-word count dup WHILE
		comment? 20 umin 2dup upcase
		2dup s" [IF]" str= >r
		2dup s" [IFUNDEF]" str= >r
		@@ -4162,7 +4199,7 @@ Cond: [ELSE] postpone [ELSE] ;Cond
		\ we want to use IFDEF on compiler directives (e.g. E?) in the source, too

		: directive?
		bl word count [ ' target >wordlist ] literal search-wordlist
		bl-word count [ ' target >wordlist ] literal search-wordlist
		dup IF nip THEN ;

		: [IFDEF] >in @ directive? swap >in !
		@@ -4180,7 +4217,7 @@ Cond: [IFUNDEF] postpone [IFUNDEF] ;Cond
		: C: >in @ tdefined? 0=
		IF >in ! X :
		ELSE drop
		BEGIN bl word dup c@
		BEGIN bl-word dup c@
		IF count comment? s" ;" str= ?EXIT
		ELSE refill 0= ABORT" CROSS: Out of Input while C:"
		THEN
		@@ -4210,11 +4247,11 @@ Cond: \+ \+ ;Cond
		Cond: \D \D ;Cond
		Cond: \? \? ;Cond

		: ?? bl word find IF execute ELSE drop 0 THEN ;
		: ?? bl-word find IF execute ELSE drop 0 THEN ;

		: needed:
		\G defines ghost for words that we want to be compiled
		BEGIN >in @ bl word c@ WHILE >in ! Ghost drop REPEAT drop ;
		BEGIN >in @ bl-word c@ WHILE >in ! Ghost drop REPEAT drop ;

		\ words that should be in minimal

		@@ -4300,7 +4337,7 @@ previous
		: \ postpone \ ; immediate
		: \G T-\G ; immediate
		: ( postpone ( ; immediate
		: include bl word count included ;
		: include bl-word count included ;
		: included swap >image swap included ;
		: require require ;
		: needs require ;

kernel/main.fs

+2 −1

Original line number	Diff line number	Diff line
		@@ -82,6 +82,7 @@ doc-on

		has? header [IF]
		1802 <> [IF] .s cr .( header start address expected!) cr uffz [THEN]
		wheres-off
		AConstant image-header
		: forthstart image-header @ ;
		[THEN]
		@@ -128,7 +129,7 @@ include kernel/pass.fs \ pass pointers from cross to target
		has? header [IF]
		\ set image size
		here image-header 2 cells + !
		." set image entry point" cr
		.( set image entry point) cr
		' boot >body image-header #08 cells + !
		' quit >body image-header #10 cells + !
		' do-execute >body image-header #11 cells + !

kernel/pass.fs

+3 −0

Original line number	Diff line number	Diff line
		@@ -45,4 +45,7 @@ included-files, included-files !
		align here default-recognizer !
		2 cells , ' rec-num A, ' rec-word A,

		align here wheres !
		wheres,

		>ram here normal-dp !

minos2/widgets.fs

+2 −2

Original line number	Diff line number	Diff line
		@@ -1291,12 +1291,12 @@ require animation.fs

		' widget-sync is screen-ops

		: widgets-loop ( -- ) depth { d }
		: widgets-loop ( -- ) depth fdepth { d fd }
		level# @ 0= IF enter-minos THEN
		1 level# +!@ >r top-widget .widget-draw
		BEGIN 0 looper-to# anims[] $@len ?sync or select
		#looper time( ." looper: " .!time cr )
		widget-sync gui( depth d u> IF ~~bt THEN )
		widget-sync gui( depth d u> fdepth fd u> or IF ~~bt THEN )
		level# @ r@ = UNTIL r> 0= IF leave-minos THEN ;

		previous previous previous