Return to relocate.fs CVS log

Up to [gforth] / gforth / arch / 4stack

Annotation of gforth/arch/4stack/relocate.fs, revision 1.7

1.1       pazsan      1: \ relocate 4stack binary
                      2: 
1.7     ! anton       3: \ Copyright (C) 2000,2003 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
                      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.6       pazsan     32:        magic 8 s" Gforth3" 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: 
                     43: : relocate ( -- )  hex
                     44:     image @ $814 + be@ image @ $810 + be@ docol 2!
                     45:     image @ $80C + be@ image @ $808 + be@ dovar 2!
                     46:     imagesize @ 1 cells / 0 ?DO
                     47:        image @ I cells + be@
                     48: \      dup 8 u.r I bit@ IF '+ ELSE '- THEN emit I 7 and 7 = IF cr THEN 
                     49:        dup 0< I bit@ and IF
                     50:            CASE
                     51:                -1 OF
                     52:                    0 image @ I cells + !  1 ENDOF \ NIL
                     53:                -2 OF
                     54:                    docol 2@
                     55:                    image @ I cells + 2!  2 ENDOF \ docol
                     56:                -3 OF
                     57:                    dovar 2@ $10. d+
                     58:                    image @ I cells + 2!  2 ENDOF \ docon
                     59:                -4 OF
                     60:                    dovar 2@
                     61:                    image @ I cells + 2!  2 ENDOF \ docon
                     62:                -8 OF
                     63:                    image @ I 1+ cells + be@ 5 -
                     64:                    dovar 2@ nip
                     65:                    image @ I cells + 2!  2 ENDOF \ dodoes
                     66:                -9 OF
                     67:                    docol 2@
                     68:                    image @ I cells + 2!  2 ENDOF \ docol
                     69:                1 swap
                     70:            ENDCASE
                     71:        ELSE
                     72:            image @ I cells + ! 1
                     73:        THEN
                     74:     +LOOP
                     75:     image @ imagesize @ bounds ?DO
                     76:        I 2@ swap I 2!
                     77:        2 cells +LOOP ;
                     78: 
                     79: : read-gforth ( addr u -- )  r/o bin open-file throw
                     80:     >r r@ file-size throw drop
1.6       pazsan     81:     ( r@ scan-header - ) dup allocate throw image !
1.1       pazsan     82:     image @ swap r@ read-file throw drop
                     83:     image @ dup $804 ( 8 ) + be@ dup imagesize ! + relinfo !
                     84:     r> close-file throw
                     85:     relocate ;
                     86: 
1.5       pazsan     87: Create 4magic  here $10 dup allot erase
1.1       pazsan     88: s" 4stack00" 4magic swap move
                     89: 
                     90: : write-gforth ( addr u -- )  w/o bin open-file throw >r
                     91:     imagesize @ 4magic $C + !
                     92:     4magic $10 r@ write-file throw
                     93:     image @ imagesize @ r@ write-file throw
                     94:     r> close-file throw ;