version 1.162, 2007/03/25 21:30:59
|
version 1.182, 2012/05/09 22:23:52
|
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 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. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 16
|
Line 16
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
0 |
0 |
[IF] |
[IF] |
Line 192 Create bases 10 , 2 , A , 100 ,
|
Line 191 Create bases 10 , 2 , A , 100 ,
|
1+ |
1+ |
THEN ; |
THEN ; |
|
|
: number? ( string -- string 0 / n -1 / d 0> ) |
: (number?) ( string -- string 0 / n -1 / d 0> ) |
dup >r count snumber? dup if |
dup >r count snumber? dup if |
rdrop |
rdrop |
else |
else |
Line 200 Create bases 10 , 2 , A , 100 ,
|
Line 199 Create bases 10 , 2 , A , 100 ,
|
then ; |
then ; |
|
|
: number ( string -- d ) |
: number ( string -- d ) |
number? ?dup 0= abort" ?" 0< |
(number?) ?dup 0= abort" ?" 0< |
IF |
IF |
s>d |
s>d |
THEN ; |
THEN ; |
|
|
[THEN] |
[THEN] |
|
|
|
[IFUNDEF] (number?) : (number?) number? ; [THEN] |
|
|
\ this provides assert( and struct stuff |
\ this provides assert( and struct stuff |
\GFORTH [IFUNDEF] assert1( |
\GFORTH [IFUNDEF] assert1( |
\GFORTH also forth definitions require assert.fs previous |
\GFORTH also forth definitions require assert.fs previous |
Line 764 Plugin ?do, ( -- ?do-token )
|
Line 765 Plugin ?do, ( -- ?do-token )
|
Plugin for, ( -- for-token ) |
Plugin for, ( -- for-token ) |
Plugin loop, ( do-token / ?do-token -- ) |
Plugin loop, ( do-token / ?do-token -- ) |
Plugin +loop, ( do-token / ?do-token -- ) |
Plugin +loop, ( do-token / ?do-token -- ) |
|
Plugin -loop, ( do-token / ?do-token -- ) |
Plugin next, ( for-token ) |
Plugin next, ( for-token ) |
Plugin leave, ( -- ) |
Plugin leave, ( -- ) |
Plugin ?leave, ( -- ) |
Plugin ?leave, ( -- ) |
Line 1244 bits/byte Constant tbits/byte
|
Line 1246 bits/byte Constant tbits/byte
|
H |
H |
tbits/char bits/byte / Constant tbyte |
tbits/char bits/byte / Constant tbyte |
|
|
|
: >signed ( u -- n ) |
|
1 tbits/char tcell * 1- lshift 2dup and |
|
IF negate or ELSE drop THEN ; |
|
|
\ Variables 06oct92py |
\ Variables 06oct92py |
|
|
Line 1722 T has? relocate H
|
Line 1727 T has? relocate H
|
|
|
Ghost (do) Ghost (?do) 2drop |
Ghost (do) Ghost (?do) 2drop |
Ghost (for) drop |
Ghost (for) drop |
Ghost (loop) Ghost (+loop) 2drop |
Ghost (loop) Ghost (+loop) Ghost (-loop) 2drop drop |
Ghost (next) drop |
Ghost (next) drop |
Ghost (does>) Ghost (does>1) Ghost (does>2) 2drop drop |
Ghost !does drop |
Ghost compile, drop |
Ghost compile, drop |
Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop |
Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop |
Ghost (C") Ghost c(abort") Ghost type 2drop drop |
Ghost (C") Ghost c(abort") Ghost type 2drop drop |
Line 2123 Create tag-tab 1 c, 09 c,
|
Line 2128 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 2316 Variable prim#
|
Line 2334 Variable prim#
|
prim# @ (THeader ( S xt ghost ) |
prim# @ (THeader ( S xt ghost ) |
['] prim-resolved over >comp ! |
['] prim-resolved over >comp ! |
dup >ghost-flags <primitive> set-flag |
dup >ghost-flags <primitive> set-flag |
over resolve-noforwards T A, H alias-mask flag! |
s" EC" T $has? H 0= |
|
IF |
|
over resolve-noforwards T A, H |
|
alias-mask flag! |
|
ELSE |
|
T here H resolve-noforwards T A, H |
|
THEN |
-1 prim# +! ; |
-1 prim# +! ; |
>CROSS |
>CROSS |
|
|
Line 2402 T 2 cells H Value xt>body
|
Line 2426 T 2 cells H Value xt>body
|
there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim, |
there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim, |
|
|
: (doeshandler,) ( -- ) |
: (doeshandler,) ( -- ) |
T cfalign H [G'] :doesjump addr, T 0 , H ; ' (doeshandler,) plugin-of doeshandler, |
T H ; ' (doeshandler,) plugin-of doeshandler, |
|
|
: (dodoes,) ( does-action-ghost -- ) |
: (dodoes,) ( does-action-ghost -- ) |
]comp [G'] :dodoes addr, comp[ |
]comp [G'] :dodoes addr, comp[ |
addr, |
addr, |
\ the relocator in the c engine, does not like the |
|
\ does-address to marked for relocation |
|
[ T e? ec H 0= [IF] ] T here H tcell - reloff [ [THEN] ] |
|
2 fillcfa ; ' (dodoes,) plugin-of dodoes, |
2 fillcfa ; ' (dodoes,) plugin-of dodoes, |
|
|
: (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit, |
: (dlit,) ( n -- ) compile lit td, ; ' (dlit,) plugin-of dlit, |
Line 2527 Cond: MAXI
|
Line 2548 Cond: MAXI
|
IF nip execute-exec-compile ELSE gexecute THEN |
IF nip execute-exec-compile ELSE gexecute THEN |
EXIT |
EXIT |
THEN |
THEN |
number? dup |
(number?) dup |
IF 0> IF swap lit, THEN lit, discard |
IF 0> IF swap lit, THEN lit, discard |
ELSE 2drop restore-input throw Ghost gexecute THEN ; |
ELSE 2drop restore-input throw Ghost gexecute THEN ; |
|
|
Line 2628 Defer instant-interpret-does>-hook ' no
|
Line 2649 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 2642 T has? primcentric H [IF]
|
Line 2664 T has? primcentric H [IF]
|
>TARGET |
>TARGET |
Cond: DOES> |
Cond: DOES> |
T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells |
T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells |
H + alit, compile (does>2) compile ;s |
H + alit, compile !does compile ;s |
doeshandler, resolve-does>-part |
doeshandler, resolve-does>-part |
;Cond |
;Cond |
|
|
Line 2939 by (Field)
|
Line 2961 by (Field)
|
T 1 cells H dup ; |
T 1 cells H dup ; |
>CROSS |
>CROSS |
|
|
|
\ ABI-CODE support |
|
Builder (ABI-CODE) |
|
Build: ;Build |
|
by: :doabicode noop ;DO |
|
|
|
BUILDER (;abi-code) |
|
Build: ;Build |
|
by: :do;abicode noop ;DO |
|
|
\ Input-Methods 01py |
\ Input-Methods 01py |
|
|
Builder input-method |
Builder input-method |
Line 2949 Builder input-var
|
Line 2980 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 2971 T has? primcentric H [IF]
|
Line 3021 T has? primcentric H [IF]
|
: (callcm) T here 0 a, 0 a, H ; ' (callcm) plugin-of colonmark, |
: (callcm) T here 0 a, 0 a, H ; ' (callcm) plugin-of colonmark, |
: (call-res) >tempdp resolved gexecute tempdp> drop ; |
: (call-res) >tempdp resolved gexecute tempdp> drop ; |
' (call-res) plugin-of colon-resolve |
' (call-res) plugin-of colon-resolve |
|
T has? ec H [IF] |
|
: (pprim) T @ H >signed dup 0< IF $4000 - ELSE |
|
cr ." wrong usage of (prim) " |
|
dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN |
|
T a, H ; ' (pprim) plugin-of prim, |
|
[ELSE] |
: (pprim) dup 0< IF $4000 - ELSE |
: (pprim) dup 0< IF $4000 - ELSE |
cr ." wrong usage of (prim) " |
cr ." wrong usage of (prim) " |
dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN |
dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN |
T a, H ; ' (pprim) plugin-of prim, |
T a, H ; ' (pprim) plugin-of prim, |
|
[THEN] |
|
|
\ if we want this, we have to spilt aconstant |
\ if we want this, we have to spilt aconstant |
\ and constant!! |
\ and constant!! |
Line 2998 Builder Defer
|
Line 3055 Builder Defer
|
compile: g>body compile lit-perform T A, H ;compile |
compile: g>body compile lit-perform T A, H ;compile |
|
|
Builder (Field) |
Builder (Field) |
compile: g>body T @ H compile lit+ T , H ;compile |
compile: g>body T @ H compile lit+ T here H reloff T , H ;compile |
|
|
Builder interpret/compile: |
Builder interpret/compile: |
compile: does-resolved ;compile |
compile: does-resolved ;compile |
Line 3025 compile: does-resolved ;compile
|
Line 3082 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 3210 Cond: ENDCASE endcase, ;Cond
|
Line 3267 Cond: ENDCASE endcase, ;Cond
|
1to compile (+loop) loop] |
1to compile (+loop) loop] |
compile unloop skiploop] ; ' (+loop,) plugin-of +loop, |
compile unloop skiploop] ; ' (+loop,) plugin-of +loop, |
|
|
|
: (-loop,) ( target-addr -- ) |
|
1to compile (-loop) loop] |
|
compile unloop skiploop] ; ' (-loop,) plugin-of -loop, |
|
|
: (next,) |
: (next,) |
compile (next) loop] compile unloop ; ' (next,) plugin-of next, |
compile (next) loop] compile unloop ; ' (next,) plugin-of next, |
|
|
Line 3219 Cond: FOR for, ;Cond
|
Line 3280 Cond: FOR for, ;Cond
|
|
|
Cond: LOOP 1 ncontrols? loop, ;Cond |
Cond: LOOP 1 ncontrols? loop, ;Cond |
Cond: +LOOP 1 ncontrols? +loop, ;Cond |
Cond: +LOOP 1 ncontrols? +loop, ;Cond |
|
Cond: -LOOP 1 ncontrols? -loop, ;Cond |
Cond: NEXT 1 ncontrols? next, ;Cond |
Cond: NEXT 1 ncontrols? next, ;Cond |
|
|
\ String words 23feb93py |
\ String words 23feb93py |
Line 3242 Cond: ABORT" if, ahead, there [char]
|
Line 3304 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] |
Line 3293 Cond: postpone ( -- ) \ name
|
Line 3355 Cond: postpone ( -- ) \ name
|
hex |
hex |
|
|
>CROSS |
>CROSS |
Create magic s" Gforth3x" here over allot swap move |
Create magic s" Gforth4x" here over allot swap move |
|
|
bigendian 1+ \ strangely, in magic big=0, little=1 |
bigendian 1+ \ strangely, in magic big=0, little=1 |
tcell 1 = 0 and or |
tcell 1 = 0 and or |