Return to comp-image.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/comp-image.fs, revision 1.3

1.1       anton       1: \ Compare nonrelocatable images and produce a relocatable image
                      2: 
                      3: \ Copyright (C) 1996 Free Software Foundation, Inc.
                      4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
                      9: \ as published by the Free Software Foundation; either version 2
                     10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
                     18: \ along with this program; if not, write to the Free Software
                     19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                     20: 
                     21: s" address-unit-bits" environment? drop constant bits/au
1.3     ! anton      22: 6 constant dodoes-tag
1.1       anton      23: 
                     24: : write-cell { w^ w  file-id -- ior }
                     25:     \ write a cell to the file
                     26:     w cell file-id write-file ;
                     27: 
                     28: : th ( addr1 n -- addr2 )
                     29:     cells + ;
                     30: 
                     31: : set-bit { u addr -- }
                     32:     \ set bit u in bit-vector addr
                     33:     u bits/au /mod
                     34:     >r 1 bits/au 1- rot - lshift
                     35:     r> addr +  cset ;
                     36: 
                     37: : compare-images { image1 image2 reloc-bits size file-id -- }
1.3     ! anton      38:     \G compares image1 and image2 (of size cells) and sets reloc-bits.
        !            39:     \G offset is the difference for relocated addresses
        !            40:     \ this definition is certainly to long and too complex, but is
        !            41:     \ hard to factor.
        !            42:     image1 @ image2 @ over - { dbase doffset }
        !            43:     doffset 0= abort" images have the same dictionary base address"
        !            44:     ." data offset=" doffset . cr
        !            45:     image1 cell+ @ image2 cell+ @ over - { cbase coffset }
        !            46:     coffset 0=
        !            47:     if
        !            48:        ." images have the same code base address; producing only a data-relocatable image" cr
        !            49:     else
        !            50:        coffset abs 11 cells <> abort" images produced by different engines"
        !            51:        ." code offset=" coffset . cr
        !            52:        0 image1 cell+ ! 0 image2 cell+ !
        !            53:     endif
1.1       anton      54:     size 0
                     55:     u+do
                     56:        image1 i th @ image2 i th @ { cell1 cell2 }
1.3     ! anton      57:        cell1 doffset + cell2 =
        !            58:        if
        !            59:            cell1 dbase - file-id write-cell throw
1.1       anton      60:            i reloc-bits set-bit
                     61:        else
1.3     ! anton      62:            cell1 coffset + cell2 =
        !            63:            if
        !            64:                cell1 cbase - cell / { tag }
        !            65:                tag dodoes-tag =
        !            66:                if
        !            67:                    \ make sure that the next cell will not be tagged
        !            68:                    dbase negate image1 i 1+ th +!
        !            69:                    dbase doffset + negate image2 i 1+ th +!
        !            70:                endif
        !            71:                -2 tag - file-id write-cell throw
        !            72:                i reloc-bits set-bit
        !            73:            else
        !            74:                cell1 file-id write-cell throw
        !            75:                cell1 cell2 <>
        !            76:                if
        !            77:                    0 i th 9 u.r cell1 17 u.r cell2 17 u.r cr
        !            78:                endif
1.1       anton      79:            endif
                     80:        endif
                     81:     loop ;
                     82: 
                     83: : slurp-file ( c-addr1 u1 -- c-addr2 u2 )
                     84:     \ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents
                     85:     r/o bin open-file throw >r
1.3     ! anton      86:     r@ file-size throw abort" file too large"
        !            87:     dup allocate throw swap
        !            88:     2dup r@ read-file throw over <> abort" could not read whole file"
        !            89:     r> close-file throw ;
1.1       anton      90: 
                     91: : comp-image ( "image-file1" "image-file2" "new-image" -- )
1.3     ! anton      92:     name slurp-file { image1 size1 }
1.1       anton      93:     image1 size1 s" Gforth1" search 0= abort" not a Gforth image"
                     94:     drop 8 + image1 - { header-offset }
                     95:     size1 aligned size1 <> abort" unaligned image size"
                     96:     size1 image1 header-offset + 2 cells + @ header-offset + <> abort" header gives wrong size"
1.3     ! anton      97:     name slurp-file { image2 size2 }
        !            98:     size1 size2 <> abort" image sizes differ"
        !            99:     name ( "new-image" ) w/o bin create-file throw { outfile }
1.1       anton     100:     size1 header-offset - 1- cell / bits/au / 1+ { reloc-size }
1.3     ! anton     101:     reloc-size allocate throw { reloc-bits }
1.1       anton     102:     reloc-bits reloc-size erase
                    103:     image1 header-offset outfile write-file throw
                    104:     base @ hex
                    105:     image1 header-offset +  image2 header-offset +  reloc-bits
                    106:     size1 header-offset - aligned cell /  outfile  compare-images
                    107:     base !
                    108:     reloc-bits reloc-size outfile write-file throw
                    109:     outfile close-file throw ;
                    110: 
                    111: