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

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

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