version 1.176, 2011/10/06 20:04:35
|
version 1.183, 2012/08/27 13:33:48
|
Line 1
|
Line 1
|
\ CROSS.FS The Cross-Compiler 06oct92py |
\ CROSS.FS The Cross-Compiler 06oct92py |
\ Idea and implementation: Bernd Paysan (py) |
\ Idea and implementation: Bernd Paysan (py) |
|
|
\ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007,2009,2010 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007,2009,2010,2011 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 2057 $20 constant restrict-mask
|
Line 2057 $20 constant restrict-mask
|
<res> <> ABORT" CROSS: Cannot immediate a unresolved word" |
<res> <> ABORT" CROSS: Cannot immediate a unresolved word" |
<imm> ^imm @ ! ; |
<imm> ^imm @ ! ; |
: restrict restrict-mask flag! ; |
: restrict restrict-mask flag! ; |
|
: compile-only restrict-mask flag! ; |
|
|
: isdoer |
: isdoer |
\G define a forth word as doer, this makes obviously only sence on |
\G define a forth word as doer, this makes obviously only sence on |
Line 2128 Create tag-tab 1 c, 09 c,
|
Line 2129 Create tag-tab 1 c, 09 c,
|
s" ,0" tag-file-id write-line throw |
s" ,0" tag-file-id write-line throw |
THEN ; |
THEN ; |
|
|
: cross-gnu-tag-entry ( -- ) |
: put-cross-gnu-tag-entry ( addr u -- ) |
tlast @ 0<> \ not an anonymous (i.e. noname) header |
tlast @ 0<> \ not an anonymous (i.e. noname) header |
IF |
IF |
put-load-file-name |
put-load-file-name |
source >in @ min tag-file-id write-file throw |
source >in @ min tag-file-id write-file throw |
tag-beg count tag-file-id write-file throw |
tag-beg count tag-file-id write-file throw |
Last-Header-Ghost @ >ghostname tag-file-id write-file throw |
tag-file-id write-file throw |
tag-end count tag-file-id write-file throw |
tag-end count tag-file-id write-file throw |
base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw |
base @ decimal sourceline# 0 <# #s #> tag-file-id write-file throw |
\ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw |
\ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw |
s" ,0" tag-file-id write-line throw |
s" ,0" tag-file-id write-line throw |
base ! |
base ! |
THEN ; |
ELSE 2drop THEN ; |
|
|
: cross-vi-tag-entry ( -- ) |
: cross-gnu-tag-entry ( -- ) |
|
Last-Header-Ghost @ >ghostname put-cross-gnu-tag-entry ; |
|
|
|
: put-cross-vi-tag-entry ( addr u -- ) |
tlast @ 0<> \ not an anonymous (i.e. noname) header |
tlast @ 0<> \ not an anonymous (i.e. noname) header |
IF |
IF |
sourcefilename vi-tag-file-id write-file throw |
sourcefilename vi-tag-file-id write-file throw |
tag-tab count vi-tag-file-id write-file throw |
tag-tab count vi-tag-file-id write-file throw |
Last-Header-Ghost @ >ghostname vi-tag-file-id write-file throw |
vi-tag-file-id write-file throw |
tag-tab count vi-tag-file-id write-file throw |
tag-tab count vi-tag-file-id write-file throw |
s" /^" vi-tag-file-id write-file throw |
s" /^" vi-tag-file-id write-file throw |
source vi-tag-file-id write-file throw |
source vi-tag-file-id write-file throw |
s" $/" vi-tag-file-id write-line throw |
s" $/" vi-tag-file-id write-line throw |
THEN ; |
ELSE 2drop THEN ; |
|
|
|
: cross-vi-tag-entry ( -- ) |
|
Last-Header-Ghost @ >ghostname put-cross-vi-tag-entry ; |
|
|
: cross-tag-entry ( -- ) |
: cross-tag-entry ( -- ) |
cross-gnu-tag-entry |
cross-gnu-tag-entry |
cross-vi-tag-entry ; |
cross-vi-tag-entry ; |
|
|
|
: put-cross-tag-entry ( addr u -- ) |
|
2dup put-cross-gnu-tag-entry |
|
put-cross-vi-tag-entry ; |
|
|
|
: cross-record-name ( -- ) |
|
>in @ parse-name put-cross-tag-entry >in ! ; |
|
|
\ Check for words |
\ Check for words |
|
|
Defer skip? ' false IS skip? |
Defer skip? ' false IS skip? |
Line 2636 Defer instant-interpret-does>-hook ' no
|
Line 2650 Defer instant-interpret-does>-hook ' no
|
|
|
T has? primcentric H [IF] |
T has? primcentric H [IF] |
: does-resolved ( ghost -- ) |
: does-resolved ( ghost -- ) |
|
\ g>xt dup T >body H alit, compile call T cell+ @ a, H ; |
compile does-exec g>xt T a, H ; |
compile does-exec g>xt T a, H ; |
[ELSE] |
[ELSE] |
: does-resolved ( ghost -- ) |
: does-resolved ( ghost -- ) |
Line 2966 Builder input-var
|
Line 2981 Builder input-var
|
Build: ( m v size -- m v' ) over T , H + ;Build |
Build: ( m v size -- m v' ) over T , H + ;Build |
DO: abort" Not in cross mode" ;DO |
DO: abort" Not in cross mode" ;DO |
|
|
|
\ Mini-OOF |
|
|
|
Builder method |
|
Build: ( m v -- m' v ) over T , swap cell+ swap H ;Build |
|
DO: abort" Not in cross mode" ;DO |
|
|
|
Builder var |
|
Build: ( m v size -- m v+size ) over T , H + ;Build |
|
DO: ( o -- addr ) T @ H + ;DO |
|
|
|
Builder end-class |
|
Build: ( addr m v -- ) |
|
T here >r , dup , 2 cells H ?DO T ['] noop , 1 cells H +LOOP |
|
T cell+ dup cell+ r> rot @ 2 cells /string move H ;Build |
|
by Create |
|
|
|
: class ( class -- class methods vars ) dup T 2@ H ; |
|
: defines ( xt class -- ) T ' >body @ + ! H ; |
|
|
\ Peephole optimization 05sep01jaw |
\ Peephole optimization 05sep01jaw |
|
|
\ this section defines different compilation |
\ this section defines different compilation |
Line 3049 compile: does-resolved ;compile
|
Line 3083 compile: does-resolved ;compile
|
\ : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; |
\ : ?struc ( flag -- ) ABORT" CROSS: unstructured " ; |
\ : sys? ( sys -- sys ) dup 0= ?struc ; |
\ : sys? ( sys -- sys ) dup 0= ?struc ; |
|
|
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; |
: >mark ( -- sys ) T here 0 , H ; |
|
|
X has? abranch [IF] |
X has? abranch [IF] |
: branchoffset ( src dest -- ) drop ; |
: branchoffset ( src dest -- ) drop ; |
Line 3271 Cond: ABORT" if, ahead, there [char]
|
Line 3305 Cond: ABORT" if, ahead, there [char]
|
[THEN] |
[THEN] |
|
|
X has? rom [IF] |
X has? rom [IF] |
Cond: IS T ' >body @ H compile ALiteral compile ! ;Cond |
Cond: IS cross-record-name T ' >body @ H compile ALiteral compile ! ;Cond |
: IS T >address ' >body @ ! H ; |
: IS cross-record-name T >address ' >body @ ! H ; |
Cond: TO T ' >body @ H compile ALiteral compile ! ;Cond |
Cond: TO T ' >body @ H compile ALiteral compile ! ;Cond |
: TO T ' >body @ ! H ; |
: TO T ' >body @ ! H ; |
Cond: CTO T ' >body H compile ALiteral compile ! ;Cond |
Cond: CTO T ' >body H compile ALiteral compile ! ;Cond |
: CTO T ' >body ! H ; |
: CTO T ' >body ! H ; |
[ELSE] |
[ELSE] |
Cond: IS T ' >body H compile ALiteral compile ! ;Cond |
Cond: IS cross-record-name T ' >body H compile ALiteral compile ! ;Cond |
: IS T >address ' >body ! H ; |
: IS cross-record-name T >address ' >body ! H ; |
Cond: TO T ' >body H compile ALiteral compile ! ;Cond |
Cond: TO T ' >body H compile ALiteral compile ! ;Cond |
: TO T ' >body ! H ; |
: TO T ' >body ! H ; |
[THEN] |
[THEN] |