Return to relocate-new.fs CVS log

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

changed FSF address in copyright messages

    1: \ relocate 4stack binary
    2: 
    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
   19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   20: 
   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
   32: 	magic 8 s" Gforth2" compare 0= UNTIL
   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 ;