version 1.23, 1995/02/08 13:38:50
|
version 1.35, 1996/05/09 18:12:58
|
Line 1
|
Line 1
|
\ CROSS.FS The Cross-Compiler 06oct92py |
\ CROSS.FS The Cross-Compiler 06oct92py |
\ $Id$ |
|
\ Idea and implementation: Bernd Paysan (py) |
\ Idea and implementation: Bernd Paysan (py) |
\ Copyright 1992-94 by the GNU Forth Development Group |
|
|
\ Copyright (C) 1995 Free Software Foundation, Inc. |
|
|
|
\ This file is part of Gforth. |
|
|
|
\ Gforth is free software; you can redistribute it and/or |
|
\ modify it under the terms of the GNU General Public License |
|
\ as published by the Free Software Foundation; either version 2 |
|
\ of the License, or (at your option) any later version. |
|
|
|
\ This program is distributed in the hope that it will be useful, |
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
\ GNU General Public License for more details. |
|
|
|
\ You should have received a copy of the GNU General Public License |
|
\ along with this program; if not, write to the Free Software |
|
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
|
|
\ Log: |
\ Log: |
\ changed in ; [ to state off 12may93jaw |
\ changed in ; [ to state off 12may93jaw |
Line 120 H
|
Line 136 H
|
-4 Constant :dovar |
-4 Constant :dovar |
-5 Constant :douser |
-5 Constant :douser |
-6 Constant :dodefer |
-6 Constant :dodefer |
-7 Constant :dodoes |
-7 Constant :dofield |
-8 Constant :doesjump |
-8 Constant :dodoes |
|
-9 Constant :doesjump |
|
|
>CROSS |
>CROSS |
|
|
Line 287 VARIABLE Already
|
Line 304 VARIABLE Already
|
UNTIL |
UNTIL |
2 cells + count cr ." CROSS: Exists: " type 4 spaces drop |
2 cells + count cr ." CROSS: Exists: " type 4 spaces drop |
swap cell+ ! |
swap cell+ ! |
ELSE true ABORT" CROSS: Ghostnames inconsistent" |
ELSE true abort" CROSS: Ghostnames inconsistent " |
THEN ; |
THEN ; |
|
|
: resolve ( ghost tcfa -- ) |
: resolve ( ghost tcfa -- ) |
Line 356 VARIABLE ^imm
|
Line 373 VARIABLE ^imm
|
\ Target Header Creation 01nov92py |
\ Target Header Creation 01nov92py |
|
|
: string, ( addr count -- ) |
: string, ( addr count -- ) |
dup T c, H bounds DO I c@ T c, H LOOP ; |
dup T c, H bounds ?DO I c@ T c, H LOOP ; |
: name, ( "name" -- ) bl word count string, T cfalign H ; |
: name, ( "name" -- ) bl word count string, T cfalign H ; |
: view, ( -- ) ( dummy ) ; |
: view, ( -- ) ( dummy ) ; |
|
|
|
\ Target Document Creation (goes to crossdoc.fd) 05jul95py |
|
|
|
s" crossdoc.fd" r/w create-file throw value doc-file-id |
|
\ contains the file-id of the documentation file |
|
|
|
: \G ( -- ) |
|
source >in @ /string doc-file-id write-line throw |
|
source >in ! drop ; immediate |
|
|
|
Variable to-doc |
|
|
|
: cross-doc-entry ( -- ) |
|
to-doc @ tlast @ 0<> and \ not an anonymous (i.e. noname) header |
|
IF |
|
s" " doc-file-id write-line throw |
|
s" make-doc " doc-file-id write-file throw |
|
tlast @ >image count $1F and doc-file-id write-file throw |
|
>in @ |
|
[char] ( parse 2drop |
|
[char] ) parse doc-file-id write-file throw |
|
s" )" doc-file-id write-file throw |
|
[char] \ parse 2drop |
|
POSTPONE \g |
|
>in ! |
|
THEN to-doc on ; |
|
|
|
\ Target TAGS creation |
|
|
|
s" kernal.TAGS" r/w create-file throw value tag-file-id |
|
\ contains the file-id of the tags file |
|
|
|
Create tag-beg 2 c, 7F c, bl c, |
|
Create tag-end 2 c, bl c, 01 c, |
|
Create tag-bof 1 c, 0C c, |
|
|
|
2variable last-loadfilename 0 0 last-loadfilename 2! |
|
|
|
: put-load-file-name ( -- ) |
|
loadfilename 2@ last-loadfilename 2@ d<> |
|
IF |
|
tag-bof count tag-file-id write-line throw |
|
sourcefilename 2dup |
|
tag-file-id write-file throw |
|
last-loadfilename 2! |
|
s" ,0" tag-file-id write-line throw |
|
THEN ; |
|
|
|
: cross-tag-entry ( -- ) |
|
tlast @ 0<> \ not an anonymous (i.e. noname) header |
|
IF |
|
put-load-file-name |
|
source >in @ min tag-file-id write-file throw |
|
tag-beg count tag-file-id write-file throw |
|
tlast @ >image count $1F and 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 |
|
\ >in @ 0 <# #s [char] , hold #> tag-file-id write-line throw |
|
s" ,0" tag-file-id write-line throw |
|
base ! |
|
THEN ; |
|
|
|
\ Target header creation |
|
|
VARIABLE CreateFlag CreateFlag off |
VARIABLE CreateFlag CreateFlag off |
|
|
: (Theader ( "name" -- ghost ) T align H view, |
: (Theader ( "name" -- ghost ) T align H view, |
Line 374 VARIABLE CreateFlag CreateFlag off
|
Line 454 VARIABLE CreateFlag CreateFlag off
|
dup >magic ^imm ! \ a pointer for immediate |
dup >magic ^imm ! \ a pointer for immediate |
Already @ IF dup >end tdoes ! |
Already @ IF dup >end tdoes ! |
ELSE 0 tdoes ! THEN |
ELSE 0 tdoes ! THEN |
80 flag! ; |
80 flag! |
|
cross-doc-entry cross-tag-entry ; |
|
|
VARIABLE ;Resolve 1 cells allot |
VARIABLE ;Resolve 1 cells allot |
|
|
Line 383 VARIABLE ;Resolve 1 cells allot
|
Line 464 VARIABLE ;Resolve 1 cells allot
|
|
|
>TARGET |
>TARGET |
: Alias ( cfa -- ) \ name |
: Alias ( cfa -- ) \ name |
|
dup 0< IF to-doc off THEN |
(THeader over resolve T A, H 80 flag! ; |
(THeader over resolve T A, H 80 flag! ; |
>CROSS |
>CROSS |
|
|
Line 417 ghost (loop) ghost (+loop)
|
Line 499 ghost (loop) ghost (+loop)
|
ghost (next) drop |
ghost (next) drop |
ghost unloop ghost ;S 2drop |
ghost unloop ghost ;S 2drop |
ghost lit ghost (compile) ghost ! 2drop drop |
ghost lit ghost (compile) ghost ! 2drop drop |
ghost (;code) ghost noop 2drop |
ghost (does>) ghost noop 2drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost (.") ghost (S") ghost (ABORT") 2drop drop |
ghost ' |
ghost ' |
|
|
Line 505 Cond: [ restrict? state off ;Cond
|
Line 587 Cond: [ restrict? state off ;Cond
|
|
|
>TARGET |
>TARGET |
Cond: DOES> restrict? |
Cond: DOES> restrict? |
compile (;code) dodoes, tdoes @ ?dup IF @ T here H resolve THEN |
compile (does>) dodoes, tdoes @ ?dup IF @ T here H resolve THEN |
;Cond |
;Cond |
: DOES> dodoes, T here H !does depth T ] H ; |
: DOES> dodoes, T here H !does depth T ] H ; |
|
|
Line 604 Build: ( n -- ) T A, H ;
|
Line 686 Build: ( n -- ) T A, H ;
|
by Constant |
by Constant |
Builder AConstant |
Builder AConstant |
|
|
|
Build: ( d -- ) T , , H ; |
|
DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO |
|
Builder 2Constant |
|
|
Build: T 0 , H ; |
Build: T 0 , H ; |
by Constant |
by Constant |
Builder Value |
Builder Value |
|
|
|
Build: T 0 A, H ; |
|
by Constant |
|
Builder AValue |
|
|
Build: ( -- ) compile noop ; |
Build: ( -- ) compile noop ; |
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
DO: ( ghost -- ) ABORT" CROSS: Don't execute" ;DO |
Builder Defer |
Builder Defer |
by Defer :dodefer resolve |
by Defer :dodefer resolve |
|
|
|
\ Sturctures 23feb95py |
|
|
|
>CROSS |
|
: nalign ( addr1 n -- addr2 ) |
|
\ addr2 is the aligned version of addr1 wrt the alignment size n |
|
1- tuck + swap invert and ; |
|
>TARGET |
|
|
|
Build: >r rot r@ nalign dup T , H ( align1 size offset ) |
|
+ swap r> nalign ; |
|
DO: T @ H + ;DO |
|
Builder Field |
|
by Field :dofield resolve |
|
|
|
: struct T 0 1 chars H ; |
|
: end-struct T 2Constant H ; |
|
|
|
: cells: ( n -- size align ) |
|
T cells 1 cells H ; |
|
|
|
\ ' 2Constant Alias2 end-struct |
|
\ 0 1 T Chars H 2Constant struct |
|
|
\ structural conditionals 17dec92py |
\ structural conditionals 17dec92py |
|
|
>CROSS |
>CROSS |
Line 764 Cond: [ELSE] [ELSE] ;Cond
|
Line 877 Cond: [ELSE] [ELSE] ;Cond
|
|
|
bigendian Constant bigendian |
bigendian Constant bigendian |
|
|
: save-cross ( "name" -- ) |
Create magic s" Gforth10" here over allot swap move |
bl parse ." Saving to " 2dup type |
|
|
char 1 bigendian + cell + magic 7 + c! |
|
|
|
: save-cross ( "image-name" "binary-name" -- ) |
|
bl parse ." Saving to " 2dup type cr |
w/o bin create-file throw >r |
w/o bin create-file throw >r |
s" gforth00" r@ write-file throw \ write magic |
s" #! " r@ write-file throw |
|
bl parse r@ write-file throw |
|
s" -i" r@ write-file throw |
|
#lf r@ emit-file throw |
|
r@ dup file-position throw drop 8 mod 8 swap ( file-id limit index ) |
|
?do |
|
bl over emit-file throw |
|
loop |
|
drop |
|
magic 8 r@ write-file throw \ write magic |
image @ there r@ write-file throw \ write image |
image @ there r@ write-file throw \ write image |
bit$ @ there 1- cell>bit rshift 1+ |
bit$ @ there 1- cell>bit rshift 1+ |
r@ write-file throw \ write tags |
r@ write-file throw \ write tags |
Line 788 cell constant cell
|
Line 914 cell constant cell
|
\ include bug5.fs |
\ include bug5.fs |
\ only forth also minimal definitions |
\ only forth also minimal definitions |
|
|
: \ postpone \ ; |
: \ postpone \ ; |
: ( postpone ( ; |
: \G postpone \G ; |
|
: ( postpone ( ; |
: include bl word count included ; |
: include bl word count included ; |
: .( [char] ) parse type ; |
: .( [char] ) parse type ; |
: cr cr ; |
: cr cr ; |