version 1.2, 1997/02/01 14:59:28
|
version 1.3, 1997/03/04 17:49:46
|
Line 19
|
Line 19
|
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
|
|
s" address-unit-bits" environment? drop constant bits/au |
s" address-unit-bits" environment? drop constant bits/au |
|
6 constant dodoes-tag |
|
|
: write-cell { w^ w file-id -- ior } |
: write-cell { w^ w file-id -- ior } |
\ write a cell to the file |
\ write a cell to the file |
Line 34 s" address-unit-bits" environment? drop
|
Line 35 s" address-unit-bits" environment? drop
|
r> addr + cset ; |
r> addr + cset ; |
|
|
: compare-images { image1 image2 reloc-bits size file-id -- } |
: compare-images { image1 image2 reloc-bits size file-id -- } |
\ compares image1 and image2 (of size cells) and sets reloc-bits. |
\G compares image1 and image2 (of size cells) and sets reloc-bits. |
\ offset is the difference for relocated addresses |
\G offset is the difference for relocated addresses |
image1 @ image2 @ over - { base offset } |
\ this definition is certainly to long and too complex, but is |
offset 0= abort" images have the same base" |
\ hard to factor. |
." offset=" offset . cr |
image1 @ image2 @ over - { dbase doffset } |
|
doffset 0= abort" images have the same dictionary base address" |
|
." data offset=" doffset . cr |
|
image1 cell+ @ image2 cell+ @ over - { cbase coffset } |
|
coffset 0= |
|
if |
|
." images have the same code base address; producing only a data-relocatable image" cr |
|
else |
|
coffset abs 11 cells <> abort" images produced by different engines" |
|
." code offset=" coffset . cr |
|
0 image1 cell+ ! 0 image2 cell+ ! |
|
endif |
size 0 |
size 0 |
u+do |
u+do |
image1 i th @ image2 i th @ { cell1 cell2 } |
image1 i th @ image2 i th @ { cell1 cell2 } |
cell1 offset + cell2 = if |
cell1 doffset + cell2 = |
cell1 base - file-id write-cell throw |
if |
|
cell1 dbase - file-id write-cell throw |
i reloc-bits set-bit |
i reloc-bits set-bit |
else |
else |
cell1 file-id write-cell throw |
cell1 coffset + cell2 = |
cell1 cell2 <> if |
if |
0 i th 9 u.r cell1 17 u.r cell2 17 u.r cr |
cell1 cbase - cell / { tag } |
|
tag dodoes-tag = |
|
if |
|
\ make sure that the next cell will not be tagged |
|
dbase negate image1 i 1+ th +! |
|
dbase doffset + negate image2 i 1+ th +! |
|
endif |
|
-2 tag - file-id write-cell throw |
|
i reloc-bits set-bit |
|
else |
|
cell1 file-id write-cell throw |
|
cell1 cell2 <> |
|
if |
|
0 i th 9 u.r cell1 17 u.r cell2 17 u.r cr |
|
endif |
endif |
endif |
endif |
endif |
loop ; |
loop ; |
Line 56 s" address-unit-bits" environment? drop
|
Line 83 s" address-unit-bits" environment? drop
|
: slurp-file ( c-addr1 u1 -- c-addr2 u2 ) |
: slurp-file ( c-addr1 u1 -- c-addr2 u2 ) |
\ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents |
\ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents |
r/o bin open-file throw >r |
r/o bin open-file throw >r |
here $7fffffff r@ read-file throw |
r@ file-size throw abort" file too large" |
r> close-file throw |
dup allocate throw swap |
here swap |
2dup r@ read-file throw over <> abort" could not read whole file" |
dup allot ; |
r> close-file throw ; |
|
|
: comp-image ( "image-file1" "image-file2" "new-image" -- ) |
: comp-image ( "image-file1" "image-file2" "new-image" -- ) |
name { d: image-file1 } |
name slurp-file { image1 size1 } |
name { d: image-file2 } |
|
name { d: new-image } |
|
maxalign image-file1 slurp-file { image1 size1 } |
|
maxalign image-file2 slurp-file { image2 size2 } |
|
image1 size1 s" Gforth1" search 0= abort" not a Gforth image" |
image1 size1 s" Gforth1" search 0= abort" not a Gforth image" |
drop 8 + image1 - { header-offset } |
drop 8 + image1 - { header-offset } |
size1 size2 <> abort" image sizes differ" |
|
size1 aligned size1 <> abort" unaligned image size" |
size1 aligned size1 <> abort" unaligned image size" |
size1 image1 header-offset + 2 cells + @ header-offset + <> abort" header gives wrong size" |
size1 image1 header-offset + 2 cells + @ header-offset + <> abort" header gives wrong size" |
new-image w/o bin create-file throw { outfile } |
name slurp-file { image2 size2 } |
|
size1 size2 <> abort" image sizes differ" |
|
name ( "new-image" ) w/o bin create-file throw { outfile } |
size1 header-offset - 1- cell / bits/au / 1+ { reloc-size } |
size1 header-offset - 1- cell / bits/au / 1+ { reloc-size } |
maxalign here { reloc-bits } |
reloc-size allocate throw { reloc-bits } |
reloc-size allot |
|
reloc-bits reloc-size erase |
reloc-bits reloc-size erase |
image1 header-offset outfile write-file throw |
image1 header-offset outfile write-file throw |
base @ hex |
base @ hex |