Annotation of gforth/arch/4stack/relocate-new.fs, revision 1.4

1.1       pazsan      1: \ relocate 4stack binary
                      2: 
1.3       anton       3: \ Copyright (C) 2000 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
1.4     ! anton      19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.3       anton      20: 
1.1       pazsan     21: Create magic 8 allot
                     22: Variable image
                     23: Variable relinfo
                     24: Variable imagesize
                     25: 
                     26: : be@  0 swap 4 bounds DO  8 lshift I c@ +  LOOP ;
                     27: 
                     28: : scan-header ( fd -- skip )  >r 0
                     29:     BEGIN
                     30:        8 +
                     31:        magic 8 r@ read-file throw 8 = WHILE
1.2       pazsan     32:        magic 8 s" Gforth2" compare 0= UNTIL
1.1       pazsan     33:     ELSE  true abort" Magic not found!"  THEN rdrop ;
                     34: 
                     35: Create bits $80 c, $40 c, $20 c, $10 c, $08 c, $04 c, $02 c, $01 c,
                     36: 
                     37: : bit@ ( n -- flag )
                     38:     dup 3 rshift relinfo @ + c@ swap 7 and bits + c@ and 0<> ;
                     39: 
                     40: 2Variable dovar
                     41: 2Variable docol
                     42: 2Variable dojmp
                     43: 2Variable docon
                     44: 
                     45: : relocate ( -- )  hex
                     46:     image @ $80C + be@ image @ $808 + be@ docon 2!
                     47:     image @ $814 + be@ image @ $810 + be@ dovar 2!
                     48:     image @ $81C + be@ image @ $818 + be@ dojmp 2!
                     49:     image @ $824 + be@ image @ $820 + be@ docol 2!
                     50:     imagesize @ 1 cells / 0 ?DO
                     51:        image @ I cells + be@
                     52: \      dup 8 u.r I bit@ IF '+ ELSE '- THEN emit I 7 and 7 = IF cr THEN 
                     53:        dup 0< I bit@ and IF
                     54:            CASE
                     55:                -1 OF
                     56:                    0 image @ I cells + !  1 ENDOF \ NIL
                     57:                -2 OF
                     58:                    docol 2@
                     59:                    image @ I cells + 2!  2 ENDOF \ docol
                     60:                -3 OF
                     61:                    docon 2@
                     62:                    image @ I cells + 2!  2 ENDOF \ docon
                     63:                -4 OF
                     64:                    dovar 2@
                     65:                    image @ I cells + 2!  2 ENDOF \ docon
                     66:                -8 OF
                     67:                    image @ I 1+ cells + be@ 5 -
                     68:                    docol 2@ nip
                     69:                    image @ I cells + 2!  2 ENDOF \ dodoes
                     70:                -9 OF
                     71:                    dojmp 2@
                     72:                    image @ I cells + 2!  2 ENDOF \ docol
                     73:                1 swap
                     74:            ENDCASE
                     75:        ELSE
                     76:            image @ I cells + ! 1
                     77:        THEN
                     78:     +LOOP
                     79:     image @ imagesize @ bounds ?DO
                     80:        I 2@ swap I 2!
                     81:        2 cells +LOOP ;
                     82: 
                     83: : read-gforth ( addr u -- )  r/o bin open-file throw
                     84:     >r r@ file-size throw drop
                     85:     r@ scan-header - dup allocate throw image !
                     86:     image @ swap r@ read-file throw drop
                     87:     image @ dup $804 ( 8 ) + be@ dup imagesize ! + relinfo !
                     88:     r> close-file throw
                     89:     relocate ;
                     90: 
                     91: Create 4magic  $10 allot
                     92: s" 4stack00" 4magic swap move
                     93: 
                     94: : write-gforth ( addr u -- )  w/o bin open-file throw >r
                     95:     imagesize @ 4magic $C + !
                     96:     4magic $10 r@ write-file throw
                     97:     image @ imagesize @ r@ write-file throw
                     98:     r> close-file throw ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>