gforth/cross.fs - diff

Return to cross.fs CVS log

Up to [gforth] / gforth

Diff for /gforth/cross.fs between versions 1.92 and 1.99

version 1.92, 2001/02/04 22:37:12	version 1.99, 2001/06/16 22:53:36
Line 656 hex	Line 656 hex
4713 Constant <imm> 4714 Constant <do:>	4713 Constant <imm> 4714 Constant <do:>
4715 Constant <skip>	4715 Constant <skip>

\ iForth makes only immediate directly after create	\ Compiler States
\ make atonce trick! ?

Variable atonce atonce off	Variable comp-state
	0 Constant interpreting
	1 Constant compiling
	2 Constant resolving
	3 Constant assembling

: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;	Defer lit, ( n -- )
	Defer alit, ( n -- )

	Defer branch, ( target-addr -- ) \ compiles a branch
	Defer ?branch, ( target-addr -- ) \ compiles a ?branch
	Defer branchmark, ( -- branch-addr ) \ reserves room for a branch
	Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch
	Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch
	Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment)
	Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
	Defer branchfrom, ( -- ) \ ?!
	Defer branchtomark, ( -- target-addr ) \ marks a branch destination

	Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position
	Defer prim, ( tcfa -- ) \ compiles a primitive invocation
	\ at current position
	Defer colonmark, ( -- addr ) \ marks a colon call
	Defer colon-resolve ( tcfa addr -- )

	Defer addr-resolve ( target-addr addr -- )
	Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )

	Defer do, ( -- do-token )
	Defer ?do, ( -- ?do-token )
	Defer for, ( -- for-token )
	Defer loop, ( do-token / ?do-token -- )
	Defer +loop, ( do-token / ?do-token -- )
	Defer next, ( for-token )

	[IFUNDEF] ca>native
	defer ca>native
	[THEN]

: GhostHeader <fwd> , 0 , ['] NoExec , ;	\ ghost structure

: >magic ; \ type of ghost	: >magic ; \ type of ghost
: >link cell+ ; \ pointer where ghost is in target, or if unresolved	: >link cell+ ; \ pointer where ghost is in target, or if unresolved
\ points to the where we have to resolve (linked-list)	\ points to the where we have to resolve (linked-list)
: >exec cell+ cell+ ; \ execution symantics (while target compiling) of ghost	: >exec cell+ cell+ ; \ execution symantics (while target compiling) of ghost
: >end 3 cells + ; \ room for additional tags	: >comp 3 cells + ; \ compilation semantics
	: >end 4 cells + ; \ room for additional tags
\ for builder (create, variable...) words the	\ for builder (create, variable...) words the
\ execution symantics of words built are placed here	\ execution symantics of words built are placed here

	\ resolve structure

	: >next ; \ link to next field
	: >tag cell+ ; \ indecates type of reference: 0: call, 1: address, 2: doer
	: >taddr cell+ cell+ ;
	: >ghost 3 cells + ;
	: >file 4 cells + ;
	: >line 5 cells + ;

	\ refer variables

Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>	Variable executed-ghost \ last executed ghost, needed in tcreate and gdoes>
Variable last-ghost \ last ghost that is created	Variable last-ghost \ last ghost that is created
Variable last-header-ghost \ last ghost definitions with header	Variable last-header-ghost \ last ghost definitions with header

	: (refered) ( ghost addr tag -- )
	\G creates a reference to ghost at address taddr
	rot >r here r@ >link @ , r> >link !
	( taddr tag ) ,
	( taddr ) ,
	last-header-ghost @ ,
	loadfile ,
	sourceline# ,
	;

	\ iForth makes only immediate directly after create
	\ make atonce trick! ?

	Variable atonce atonce off

	: NoExec true ABORT" CROSS: Don't execute ghost, or immediate target word" ;

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

	: GhostHeader <fwd> , 0 , ['] NoExec , ['] is-forward , ;

: Make-Ghost ( "name" -- ghost )	: Make-Ghost ( "name" -- ghost )
>in @ GhostName swap >in !	>in @ GhostName swap >in !
<T Create atonce @ IF immediate atonce off THEN	<T Create atonce @ IF immediate atonce off THEN
Line 743 ghost (does>) ghost noop	Line 811 ghost (does>) ghost noop
ghost (.") ghost (S") ghost (ABORT") 2drop drop	ghost (.") ghost (S") ghost (ABORT") 2drop drop
ghost ' drop	ghost ' drop
ghost :docol ghost :doesjump ghost :dodoes 2drop drop	ghost :docol ghost :doesjump ghost :dodoes 2drop drop
ghost :dovar drop	ghost :dovar ghost :dodefer ghost :dofield 2drop drop
ghost over ghost = ghost drop 2drop drop	ghost over ghost = ghost drop 2drop drop
ghost - drop	ghost call ghost useraddr ghost execute 2drop drop
	ghost + ghost - ghost @ 2drop drop
ghost 2drop drop	ghost 2drop drop
ghost 2dup drop	ghost 2dup drop

Line 1268 previous	Line 1337 previous

\ \ -------------------- Compiler Plug Ins 01aug97jaw	\ \ -------------------- Compiler Plug Ins 01aug97jaw

\ Compiler States

Variable comp-state
0 Constant interpreting
1 Constant compiling
2 Constant resolving
3 Constant assembling

Defer lit, ( n -- )
Defer alit, ( n -- )

Defer branch, ( target-addr -- ) \ compiles a branch
Defer ?branch, ( target-addr -- ) \ compiles a ?branch
Defer branchmark, ( -- branch-addr ) \ reserves room for a branch
Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch
Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch
Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment)
Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
Defer branchfrom, ( -- ) \ ?!
Defer branchtomark, ( -- target-addr ) \ marks a branch destination

Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position
Defer colonmark, ( -- addr ) \ marks a colon call
Defer colon-resolve ( tcfa addr -- )

Defer addr-resolve ( target-addr addr -- )
Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )

Defer do, ( -- do-token )
Defer ?do, ( -- ?do-token )
Defer for, ( -- for-token )
Defer loop, ( do-token / ?do-token -- )
Defer +loop, ( do-token / ?do-token -- )
Defer next, ( for-token )

[IFUNDEF] ca>native
defer ca>native
[THEN]

>TARGET	>TARGET
DEFER >body \ we need the system >body	DEFER >body \ we need the system >body
\ and the target >body	\ and the target >body
Line 1322 DEFER dodoes,	Line 1352 DEFER dodoes,
DEFER ]comp \ starts compilation	DEFER ]comp \ starts compilation
DEFER comp[ \ ends compilation	DEFER comp[ \ ends compilation

: (cc) T a, H ; ' (cc) IS colon,	: (prim) T a, H ; ' (prim) IS prim,

: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve	: (cr) >tempdp ]comp prim, comp[ tempdp> ; ' (cr) IS colon-resolve
: (ar) T ! H ; ' (ar) IS addr-resolve	: (ar) T ! H ; ' (ar) IS addr-resolve
: (dr) ( ghost res-pnt target-addr addr )	: (dr) ( ghost res-pnt target-addr addr )
>tempdp drop over	>tempdp drop over
Line 1336 DEFER comp[ \ ends compilation	Line 1366 DEFER comp[ \ ends compilation

: (cm) ( -- addr )	: (cm) ( -- addr )
T here align H	T here align H
-1 colon, ; ' (cm) IS colonmark,	-1 prim, ; ' (cm) IS colonmark,

>TARGET	>TARGET
: compile, colon, ;	: compile, prim, ;
>CROSS	>CROSS

\ resolve structure

: >next ; \ link to next field
: >tag cell+ ; \ indecates type of reference: 0: call, 1: address, 2: doer
: >taddr cell+ cell+ ;
: >ghost 3 cells + ;
: >file 4 cells + ;
: >line 5 cells + ;

: (refered) ( ghost addr tag -- )
\G creates a reference to ghost at address taddr
rot >r here r@ >link @ , r> >link !
( taddr tag ) ,
( taddr ) ,
last-header-ghost @ ,
loadfile ,
sourceline# ,
;

: refered ( ghost tag -- )	: refered ( ghost tag -- )
\G creates a resolve structure	\G creates a resolve structure
T here aligned H swap (refered)	T here aligned H swap (refered)
Line 1430 Exists-Warnings on	Line 1441 Exists-Warnings on
ELSE true abort" CROSS: Ghostnames inconsistent "	ELSE true abort" CROSS: Ghostnames inconsistent "
THEN ;	THEN ;

	: colon-resolved ( ghost -- )
	>link @ colon, ; \ compile-call
	: prim-resolved ( ghost -- )
	>link @ prim, ;

: resolve ( ghost tcfa -- )	: resolve ( ghost tcfa -- )
\G resolve referencies to ghost with tcfa	\G resolve referencies to ghost with tcfa
\ is ghost resolved?, second resolve means another definition with the	\ is ghost resolved?, second resolve means another definition with the
Line 1439 Exists-Warnings on	Line 1455 Exists-Warnings on
swap >r r@ >link @ swap \ ( list tcfa R: ghost )	swap >r r@ >link @ swap \ ( list tcfa R: ghost )
\ mark ghost as resolved	\ mark ghost as resolved
dup r@ >link ! <res> r@ >magic !	dup r@ >link ! <res> r@ >magic !
	r@ >comp @ ['] is-forward = IF
	['] prim-resolved r@ >comp ! THEN
\ loop through forward referencies	\ loop through forward referencies
r> -rot	r> -rot
comp-state @ >r Resolving comp-state !	comp-state @ >r Resolving comp-state !
Line 1450 Exists-Warnings on	Line 1468 Exists-Warnings on

\ gexecute ghost, 01nov92py	\ gexecute ghost, 01nov92py

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

: is-resolved ( ghost -- )
>link @ colon, ; \ compile-call

: gexecute ( ghost -- )	: gexecute ( ghost -- )
dup @ <fwd> = IF is-forward ELSE is-resolved THEN ;	dup >comp @ execute ;

: addr, ( ghost -- )	: addr, ( ghost -- )
dup @ <fwd> = IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ;	dup forward? IF 1 refered 0 T a, H ELSE >link @ T a, H THEN ;

\ !! : ghost, ghost gexecute ;	\ !! : ghost, ghost gexecute ;

Line 1567 Variable to-doc to-doc on	Line 1579 Variable to-doc to-doc on
IF	IF
s" " doc-file-id write-line throw	s" " doc-file-id write-line throw
s" make-doc " doc-file-id write-file throw	s" make-doc " doc-file-id write-file throw
	Last-Header-Ghost @ >ghostname doc-file-id write-file throw
tlast @ >image count 1F and doc-file-id write-file throw
>in @	>in @
[char] ( parse 2drop	[char] ( parse 2drop
[char] ) parse doc-file-id write-file throw	[char] ) parse doc-file-id write-file throw
Line 1765 Comment ( Comment \	Line 1776 Comment ( Comment \
ELSE postpone literal postpone gexecute THEN ;	ELSE postpone literal postpone gexecute THEN ;
immediate	immediate

	T has? peephole H [IF]
	: (cc) compile call T >body a, H ; ' (cc) IS colon,
	[ELSE]
	' (prim) IS colon,
	[THEN]

: [G']	: [G']
\G ticks a ghost and returns its address	\G ticks a ghost and returns its address
bl word gfind 0= ABORT" CROSS: Ghost don't exists"	bl word gfind 0= ABORT" CROSS: Ghost don't exists"
Line 1798 Cond: ['] T ' H alit, ;Cond	Line 1815 Cond: ['] T ' H alit, ;Cond

: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H	: (>body) ( cfa -- pfa ) xt>body + ; ' (>body) T IS >body H

: (doer,) ( ghost -- ) ]comp gexecute comp[ 1 fillcfa ; ' (doer,) IS doer,	: (doer,) ( ghost -- ) ]comp addr, comp[ 1 fillcfa ; ' (doer,) IS doer,

: (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol,	: (docol,) ( -- ) [G'] :docol doer, ; ' (docol,) IS docol,

Line 1868 Cond: [Char] ( "<char>" -- ) restrict	Line 1885 Cond: [Char] ( "<char>" -- ) restrict
\ some special literals 27jan97jaw	\ some special literals 27jan97jaw

\ !! Known Bug: Special Literals and plug-ins work only correct	\ !! Known Bug: Special Literals and plug-ins work only correct
\ on 16 and 32 Bit Targets and 32 Bit Hosts!	\ on targets with char = 8 bit

Cond: MAXU	Cond: MAXU
restrict?	restrict?
tcell 1 cells u>	compile lit tcell 0 ?DO FF T c, H LOOP
IF compile lit tcell 0 ?DO FF T c, H LOOP
ELSE ffffffff lit, THEN
;Cond	;Cond

Cond: MINI	Cond: MINI
restrict?	restrict?
tcell 1 cells u>	compile lit bigendian
IF compile lit bigendian	IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP
IF 80 T c, H tcell 1 ?DO 0 T c, H LOOP	ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H
ELSE tcell 1 ?DO 0 T c, H LOOP 80 T c, H	THEN
THEN
ELSE tcell 2 = IF 8000 ELSE 80000000 THEN lit, THEN
;Cond	;Cond

Cond: MAXI	Cond: MAXI
restrict?	restrict?
tcell 1 cells u>	compile lit bigendian
IF compile lit bigendian	IF 7F T c, H tcell 1 ?DO FF T c, H LOOP
IF 7F T c, H tcell 1 ?DO FF T c, H LOOP	ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H
ELSE tcell 1 ?DO FF T c, H LOOP 7F T c, H	THEN
THEN
ELSE tcell 2 = IF 7fff ELSE 7fffffff THEN lit, THEN
;Cond	;Cond

>CROSS	>CROSS
Line 1967 Cond: ; ( -- ) restrict?	Line 1978 Cond: ; ( -- ) restrict?
comp[	comp[
state off	state off
;Resolve @	;Resolve @
IF ;Resolve @ ;Resolve cell+ @ resolve THEN	IF ;Resolve @ ;Resolve cell+ @ resolve
	['] colon-resolved ;Resolve @ >comp ! THEN
Interpreting comp-state !	Interpreting comp-state !
;Cond	;Cond
Cond: [ restrict? state off Interpreting comp-state ! ;Cond	Cond: [ restrict? state off Interpreting comp-state ! ;Cond
Line 1985 Create GhostDummy ghostheader	Line 1997 Create GhostDummy ghostheader
GhostDummy >link ! GhostDummy	GhostDummy >link ! GhostDummy
tlastcfa @ >tempdp dodoes, tempdp> ;	tlastcfa @ >tempdp dodoes, tempdp> ;

	: g>body ( ghost -- body )
	>link @ T >body H ;
	: does-resolved ( ghost -- )
	dup g>body alit, >end @ g>body colon, ;

>TARGET	>TARGET
Cond: DOES> restrict?	Cond: DOES> restrict?
compile (does>) doeshandler,	compile (does>) doeshandler,
\ resolve words made by builders	\ resolve words made by builders
tdoes @ ?dup IF @ T here H resolve THEN	tdoes @ ?dup IF @ dup T here H resolve
	['] prim-resolved swap >comp ! THEN
;Cond	;Cond
: DOES> switchrom doeshandler, T here H !does depth T ] H ;	: DOES> switchrom doeshandler, T here H !does depth T ] H ;

Line 1998 Cond: DOES> restrict?	Line 2016 Cond: DOES> restrict?

\ Builder 11may93jaw	\ Builder 11may93jaw

: Builder ( Create-xt do:-xt "name" -- )	: Builder ( Create-xt do-ghost "name" -- )
\ builds up a builder in current vocabulary	\ builds up a builder in current vocabulary
\ create-xt is executed when word is interpreted	\ create-xt is executed when word is interpreted
\ do:-xt is executet when the created word from builder is executed	\ do:-xt is executet when the created word from builder is executed
\ for do:-xt an additional entry after the normal ghost-enrys is used	\ for do:-xt an additional entry after the normal ghost-enrys is used

Make-Ghost ( Create-xt do:-xt ghost )	Make-Ghost ( Create-xt do-ghost ghost )
rot swap ( do:-xt Create-xt ghost )	rot swap ( do-ghost Create-xt ghost )
>exec ! , ;	>exec ! , ;
\ rot swap >exec dup @ ['] NoExec <>
\ IF 2drop ELSE ! THEN , ;

: gdoes, ( ghost -- )	: gdoes, ( ghost -- )
\ makes the codefield for a word that is built	\ makes the codefield for a word that is built
Line 2030 Cond: DOES> restrict?	Line 2046 Cond: DOES> restrict?
executed-ghost @	executed-ghost @
create-forward-warn	create-forward-warn
IF ['] reswarn-forward IS resolve-warning THEN	IF ['] reswarn-forward IS resolve-warning THEN
Theader >r dup gdoes,	Theader >r dup , dup gdoes,
\ stores execution semantic in the built word	\ stores execution semantic in the built word
\ if the word already has a semantic (concerns S", IS, .", DOES>)	\ if the word already has a semantic (concerns S", IS, .", DOES>)
\ then keep it	\ then keep it
>end @ >exec @ r> >exec dup @ ['] NoExec =	>end @
IF ! ELSE 2drop THEN ;	dup >exec @ r@ >exec dup @ ['] NoExec = IF ! ELSE 2drop THEN
	>comp @ r> >comp ! ;

: RTCreate ( <name> -- )	: RTCreate ( <name> -- )
\ creates a new word with code-field in ram	\ creates a new word with code-field in ram
Line 2070 Cond: DOES> restrict?	Line 2087 Cond: DOES> restrict?
: gdoes> ( ghost -- addr flag )	: gdoes> ( ghost -- addr flag )
executed-ghost @	executed-ghost @
state @ IF gexecute true EXIT THEN	state @ IF gexecute true EXIT THEN
>link @ T >body H false ;	g>body false ;

\ DO: ;DO 11may93jaw	\ DO: ;DO 11may93jaw
\ changed to ?EXIT 10may93jaw	\ changed to ?EXIT 10may93jaw

: DO: ( -- addr [xt] [colon-sys] )	: DO: ( -- ghost [xt] [colon-sys] )
here ghostheader	here ghostheader
:noname postpone gdoes> postpone ?EXIT ;	:noname postpone gdoes> postpone ?EXIT ;

: by: ( -- addr [xt] [colon-sys] ) \ name	: by: ( -- ghost [xt] [colon-sys] ) \ name
ghost	ghost
:noname postpone gdoes> postpone ?EXIT ;	:noname postpone gdoes> postpone ?EXIT ;

: ;DO ( addr [xt] [colon-sys] -- addr )	: ;DO ( ghost [xt] [colon-sys] -- ghost )
postpone ; ( S addr xt )	postpone ; ( S addr xt )
over >exec ! ; immediate	over >exec ! ; immediate

: by ( -- addr ) \ Name	T has? peephole H [IF]
	: compile: ( ghost -- ghost [xt] [colon-sys] )
	:noname postpone g>body ;
	: ;compile ( ghost [xt] [colon-sys] -- ghost )
	postpone ; over >comp ! ; immediate
	[ELSE]
	: compile: ( ghost -- ghost xt colon-sys ) :noname ;
	: ;compile ( ghost xt colon-sys -- ghost )
	postpone ; drop ['] prim-resolved over >comp ! ; immediate
	[THEN]

	: by ( -- ghost ) \ Name
ghost >end @ ;	ghost >end @ ;

>TARGET	>TARGET
Line 2095 Cond: DOES> restrict?	Line 2123 Cond: DOES> restrict?

Build: ( n -- ) ;	Build: ( n -- ) ;
by: :docon ( ghost -- n ) T @ H ;DO	by: :docon ( ghost -- n ) T @ H ;DO
	compile: alit, compile @ ;compile
Builder (Constant)	Builder (Constant)

Build: ( n -- ) T , H ;	Build: ( n -- ) T , H ;
Line 2111 Builder 2Constant	Line 2140 Builder 2Constant

BuildSmart: ;	BuildSmart: ;
by: :dovar ( ghost -- addr ) ;DO	by: :dovar ( ghost -- addr ) ;DO
	\ compile: alit, ;compile
Builder Create	Builder Create

T has? rom H [IF]	T has? rom H [IF]
Line 2120 Builder Variable	Line 2150 Builder Variable
[ELSE]	[ELSE]
Build: T 0 , H ;	Build: T 0 , H ;
by Create	by Create
	\ compile: alit, ;compile
Builder Variable	Builder Variable
[THEN]	[THEN]

Line 2130 Builder 2Variable	Line 2161 Builder 2Variable
[ELSE]	[ELSE]
Build: T 0 , 0 , H ;	Build: T 0 , 0 , H ;
by Create	by Create
	\ compile: alit, ;compile
Builder 2Variable	Builder 2Variable
[THEN]	[THEN]

Line 2140 Builder AVariable	Line 2172 Builder AVariable
[ELSE]	[ELSE]
Build: T 0 A, H ;	Build: T 0 A, H ;
by Create	by Create
	\ compile: alit, ;compile
Builder AVariable	Builder AVariable
[THEN]	[THEN]

Line 2162 Variable tudp 0 tudp !	Line 2195 Variable tudp 0 tudp !

Build: 0 u, X , ;	Build: 0 u, X , ;
by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO	by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO
	compile: compile useraddr T @ , H ;compile
Builder User	Builder User

Build: 0 u, X , 0 u, drop ;	Build: 0 u, X , 0 u, drop ;
Line 2182 Builder AValue	Line 2216 Builder AValue

BuildSmart: ( -- ) [T'] noop T A, H ;	BuildSmart: ( -- ) [T'] noop T A, H ;
by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO	by: :dodefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
	compile: alit, compile @ compile execute ;compile
Builder Defer	Builder Defer

Build: ( inter comp -- ) swap T immediate A, A, H ;	Build: ( inter comp -- ) swap T immediate A, A, H ;
Line 2198 Builder interpret/compile:	Line 2233 Builder interpret/compile:

Build: ;	Build: ;
by: :dofield T @ H + ;DO	by: :dofield T @ H + ;DO
	compile: T @ H lit, compile + ;compile
Builder (Field)	Builder (Field)

Build: ( align1 offset1 align size "name" -- align2 offset2 )	Build: ( align1 offset1 align size "name" -- align2 offset2 )
Line 2662 previous	Line 2698 previous
: .s .s ;	: .s .s ;
: bye bye ;	: bye bye ;

	\ dummy

	: group source >in ! drop ;

\ turnkey direction	\ turnkey direction
: H forth ; immediate	: H forth ; immediate
: T minimal ; immediate	: T minimal ; immediate

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.92
changed lines
	Added in v.1.99