Cross compiler changes for mixed threading (99a0a501) · Commits · Bernd Paysan / gforth

cross.fs

+83 −38

Original line number	Diff line number	Diff line
		@@ -899,9 +899,14 @@ Variable cross-space-dp-orig
		THEN ;

		Defer is-forward
		Defer do-refered

		: prim-forward ( ghost -- )
		colonmark, 1 do-refered ; \ compile space for call
		' prim-forward IS is-forward

		: (ghostheader) ( -- )
		ghost-list linked <fwd> , 0 , ['] NoExec , ['] is-forward ,
		ghost-list linked <fwd> , 0 , ['] NoExec , what's is-forward ,
		0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , ;

		: ghostheader ( -- ) (ghostheader) 0 , ;
		@@ -1052,40 +1057,37 @@ End-Struct addr-struct
		dup @ ?dup IF nip EXIT THEN
		addr-struct %allocerase tuck swap ! ;

		>cross

		\ Predefined ghosts 12dec92py

		Ghost - drop \ need a ghost otherwise "-" would be treated as a number

		Ghost 0= drop
		Ghost branch Ghost ?branch 2drop
		Ghost (do) Ghost (?do) 2drop
		Ghost (for) drop
		Ghost (loop) Ghost (+loop) 2drop
		Ghost (next) drop
		Ghost unloop Ghost ;S 2drop
		Ghost lit Ghost (compile) Ghost ! 2drop drop
		Ghost (does>) Ghost noop 2drop
		Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop
		Ghost ' drop
		Ghost lit Ghost ! 2drop
		Ghost noop drop
		Ghost :docol Ghost :doesjump Ghost :dodoes 2drop drop
		Ghost :dovar drop
		Ghost over Ghost = Ghost drop 2drop drop
		Ghost 2drop drop
		Ghost 2dup drop
		Ghost state drop
		Ghost call drop
		Ghost @ drop
		Ghost useraddr drop
		Ghost execute drop
		Ghost + drop
		Ghost (C") drop
		Ghost decimal drop
		Ghost hex drop
		Ghost lit@ drop
		Ghost lit-perform drop
		Ghost lit+ drop
		Ghost does-exec drop

		\ \ Parameter for target systems 06oct92py


		>cross
		\ we define it ans like...
		wordlist Constant target-environment

		@@ -1637,6 +1639,28 @@ T has? relocate H
		: A! swap >address swap dup relon T ! H ;
		: A, ( w -- ) >address T here H relon T , H ;

		\ high-level ghosts

		>CROSS

		: call-forward ( ghost -- )
		there 0 colon, 0 do-refered ;
		' call-forward IS is-forward

		Ghost (do) Ghost (?do) 2drop
		Ghost (for) drop
		Ghost (loop) Ghost (+loop) 2drop
		Ghost (next) drop
		Ghost (does>) Ghost (compile) 2drop
		Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop
		Ghost (C") drop
		Ghost ' drop

		\ ' prim-forward IS is-forward

		\ user ghosts

		Ghost state drop

		\ \ -------------------- Host/Target copy etc. 29aug01jaw

		@@ -1698,7 +1722,7 @@ previous
		: (xt) T a, H ; ' (xt) plugin-of xt,
		: (prim) T a, H ; ' (prim) plugin-of prim,

		: (cr) >tempdp ]comp xt, comp[ tempdp> ; ' (cr) plugin-of colon-resolve
		: (cr) >tempdp colon, tempdp> ; ' (cr) plugin-of colon-resolve
		: (ar) T ! H ; ' (ar) plugin-of addr-resolve
		: (dr) ( ghost res-pnt target-addr addr )
		>tempdp drop over
		@@ -1738,6 +1762,8 @@ previous
		space>
		;

		' (refered) IS do-refered

		: refered ( ghost tag -- )
		\G creates a resolve structure
		T here aligned H swap (refered)
		@@ -1800,13 +1826,7 @@ Defer resolve-warning
		: prim-resolved ( ghost -- )
		>link @ prim, ;

		\ FIXME: not used currently
		: does-resolved ( ghost -- )
		dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;

		: (is-forward) ( ghost -- )
		colonmark, 0 (refered) ; \ compile space for call
		' (is-forward) IS is-forward
		0 Value resolved

		: resolve ( ghost tcfa -- )
		\G resolve referencies to ghost with tcfa
		@@ -1827,7 +1847,10 @@ Defer resolve-warning
		swap >r r@ >link @ swap \ ( list tcfa R: ghost )
		\ mark ghost as resolved
		dup r@ >link ! <res> r@ >magic !
		r@ >comp @ ['] is-forward = IF
		r@ to resolved
		r@ >comp @ ['] prim-forward = IF
		['] prim-resolved r@ >comp ! THEN
		r@ >comp @ what's is-forward = IF
		['] prim-resolved r@ >comp ! THEN
		\ loop through forward referencies
		r> -rot
		@@ -2176,9 +2199,11 @@ Variable prim#
		IF
		.sourcepos ." needs prim: " >in @ bl word count type >in ! cr
		THEN
		\ ['] prim-forward IS is-forward
		prim# @ (THeader ( S xt ghost )
		dup >ghost-flags <primitive> set-flag
		over resolve T A, H alias-mask flag!
		\ ['] call-forward IS is-forward
		-1 prim# +! ;
		>CROSS

		@@ -2458,8 +2483,8 @@ Cond: ; ( -- )
		fini,
		comp[
		;Resolve @
		IF ;Resolve @ ;Resolve cell+ @ resolve
		['] colon-resolved ;Resolve @ >comp !
		IF ['] colon-resolved ;Resolve @ >comp !
		;Resolve @ ;Resolve cell+ @ resolve
		THEN
		interpreting-state
		;Cond
		@@ -2478,6 +2503,10 @@ Cond: [ ( -- ) interpreting-state ;Cond

		Defer instant-interpret-does>-hook

		: does-resolved ( ghost -- )
		compile does-exec g>xt T a, H ;
		\ dup g>body alit, >do:ghost @ g>xt 0 t>body - colon, ;

		: resolve-does>-part ( -- )
		\ resolve words made by builders
		Last-Header-Ghost @ >do:ghost @ ?dup
		@@ -2489,8 +2518,9 @@ Cond: DOES>
		resolve-does>-part
		;Cond

		: DOES> switchrom doeshandler, T here H !does
		: DOES>
		['] does-resolved created >comp !
		switchrom doeshandler, T here H !does
		instant-interpret-does>-hook
		depth T ] H ;

		@@ -2538,12 +2568,20 @@ Cond: DOES>
		2dup >exec @ swap >exec2 !
		>comp @ swap >comp ! ;

		0 Value createhere

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

		: TCreate ( <name> -- )
		create-forward-warn
		IF ['] reswarn-forward IS resolve-warning THEN
		executed-ghost @ (Theader
		dup >created on dup to created
		2dup takeover-x-semantics hereresolve gdoes, ;
		2dup takeover-x-semantics
		there to createhere drop gdoes, ;

		: RTCreate ( <name> -- )
		\ creates a new word with code-field in ram
		@@ -2551,14 +2589,14 @@ Cond: DOES>
		IF ['] reswarn-forward IS resolve-warning THEN
		\ make Alias
		executed-ghost @ (THeader
		dup >created on
		dup >created on dup to created
		2dup takeover-x-semantics
		there 0 T a, H alias-mask flag!
		\ store poiter to code-field
		switchram T cfalign H
		there swap T ! H
		there tlastcfa !
		hereresolve gdoes, ;
		there to createhere drop gdoes, ;

		: Build: ( -- [xt] [colon-sys] )
		:noname postpone TCreate ;
		@@ -2572,6 +2610,10 @@ Cond: DOES>
		[ [THEN] ] ;

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

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

		: gdoes> ( ghost -- addr flag )
		@@ -2697,7 +2739,7 @@ BuildSmart: ( -- ) [T'] noop T A, H ;Build
		by: :dodefer ( ghost -- ) X @ texecute ;DO

		Builder interpret/compile:
		Build: ( inter comp -- ) swap T immediate A, A, H ;Build
		Build: ( inter comp -- ) swap T A, A, H ;Build-immediate
		DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO

		\ Sturctures 23feb95py
		@@ -2750,7 +2792,10 @@ DO: abort" Not in cross mode" ;DO
		T has? peephole H [IF]

		>CROSS

		: (callc) compile call T >body a, H ; ' (callc) plugin-of colon,
		: (call-res) >tempdp resolved gexecute tempdp> drop ;
		' (call-res) plugin-of colon-resolve
		: (prim) dup 0< IF ( $4000 - ) ELSE
		." wrong usage of (prim) "
		dup gdiscover IF .ghost ELSE . THEN cr -2 throw THEN
		@@ -2762,10 +2807,10 @@ T has? peephole H [IF]
		\ compile: g>body X @ lit, ;compile

		Builder (Constant)
		compile: g>body alit, compile @ ;compile
		compile: g>body compile lit@ T a, H ;compile

		Builder (Value)
		compile: g>body alit, compile @ ;compile
		compile: g>body compile lit@ T a, H ;compile

		\ this changes also Variable, AVariable and 2Variable
		Builder Create
		@@ -2775,10 +2820,10 @@ Builder User
		compile: g>body compile useraddr T @ , H ;compile

		Builder Defer
		compile: g>body alit, compile @ compile execute ;compile
		compile: g>body compile lit-perform T A, H ;compile

		Builder (Field)
		compile: g>body T @ H lit, compile + ;compile
		compile: g>body T @ H compile lit+ T , H ;compile

		Builder interpret/compile:
		compile: does-resolved ;compile

kernel/args.fs

+5 −0

Original line number	Diff line number	Diff line
		@@ -74,4 +74,9 @@ Variable argc ( -- addr ) \ gforth
		false to script?
		;

		: os-boot ( path n **argv argc -- )
		stdout TO outfile-id
		stdin TO infile-id
		argc ! argv ! pathstring 2! ;

		' (process-args) IS process-args

kernel/comp.fs

+20 −19

Original line number	Diff line number	Diff line
		@@ -230,18 +230,18 @@ has? peephole [IF]
		\G compile xt to use primitives (and their peephole optimization)
		\G instead of ","-ing the xt.
		\ !! all POSTPONEs here postpone primitives; this can be optimized
		dup >does-code ?dup if
		swap >body POSTPONE literal POSTPONE call , EXIT
		dup >does-code if
		POSTPONE does-exec , EXIT
		then
		dup >code-address CASE
		docon: OF >body POSTPONE literal POSTPONE @ EXIT ENDOF
		docon: OF >body POSTPONE lit@ , EXIT ENDOF
		\ docon is also used by VALUEs, so don't @ at compile time
		docol: OF >body POSTPONE call , EXIT ENDOF
		dovar: OF >body POSTPONE literal EXIT ENDOF
		douser: OF >body @ POSTPONE useraddr , EXIT ENDOF
		dodefer: OF >body POSTPONE literal POSTPONE @ POSTPONE EXECUTE EXIT
		dodefer: OF >body POSTPONE lit-perform , EXIT
		ENDOF
		dofield: OF >body @ POSTPONE literal POSTPONE + EXIT ENDOF
		dofield: OF >body @ POSTPONE lit+ , EXIT ENDOF
		ENDCASE
		peephole-compile, ;

		@@ -468,6 +468,21 @@ doer? :dofield [IF]
		[ELSE]
		: (Field) Create DOES> @ + ;
		[THEN]

		\ \ interpret/compile:

		struct
		>body
		cell% field interpret/compile-int
		cell% field interpret/compile-comp
		end-struct interpret/compile-struct

		: interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
		Create immediate swap A, A,
		DOES>
		abort" executed primary cfa of an interpret/compile: word" ;
		\ state @ IF cell+ THEN perform ;

		\ IS Defer What's Defers TO 24feb93py

		doer? :dodefer [IF]
		@@ -524,20 +539,6 @@ interpret/compile: TO ( w "name" -- ) \ core-ext
		interpret/compile: What's ( interpretation "name" -- xt; compilation "name" -- ; run-time -- xt ) \ gforth
		\G @i{Xt} is the XT that is currently assigned to @i{name}.

		\ \ interpret/compile:

		struct
		>body
		cell% field interpret/compile-int
		cell% field interpret/compile-comp
		end-struct interpret/compile-struct

		: interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
		Create immediate swap A, A,
		DOES>
		abort" executed primary cfa of an interpret/compile: word" ;
		\ state @ IF cell+ THEN perform ;

		: interpret/compile? ( xt -- flag )
		>does-code ['] DOES> >does-code = ;

kernel/int.fs

+2 −7

Original line number	Diff line number	Diff line
		@@ -860,8 +860,7 @@ AVariable init8 NIL init8 !
		rp@ backtrace-rp0 !
		[ [THEN] ]
		[ has? file [IF] ]
		pathstring 2@ fpath only-path
		init-included-files
		os-cold
		[ [THEN] ]
		'cold
		init8 chainperform
		@@ -890,11 +889,7 @@ has? new-input 0= [IF]
		: boot ( path n **argv argc -- )
		main-task up!
		[ has? os [IF] ]
		stdout TO outfile-id
		stdin TO infile-id
		\ !! [ [THEN] ]
		\ !! [ has? file [IF] ]
		argc ! argv ! pathstring 2!
		os-boot
		[ [THEN] ]
		sp@ sp0 !
		[ has? peephole [IF] ]

kernel/paths.fs

+9 −2

Original line number	Diff line number	Diff line
		@@ -64,8 +64,15 @@
		2dup c! char+ swap move ;
		[THEN]

		create sourcepath 1024 chars , 0 , 1024 chars allot \ !! make this dynamic
		sourcepath avalue fpath ( -- path-addr ) \ gforth
		\ create sourcepath 1024 chars , 0 , 1024 chars allot \ !! make this dynamic
		0 avalue fpath ( -- path-addr ) \ gforth

		: os-cold ( -- )
		1024 chars dup 2 cells + allocate throw to fpath
		0 swap fpath 2!
		pathstring 2@ fpath only-path
		init-included-files ;

		\ The path Gforth uses for @code{included} and friends.

		: also-path ( c-addr len path-addr -- ) \ gforth