File:  [gforth] / gforth / arch / 4stack / relocate.fs
Revision 1.14: download - view: text, annotated - select for diffs
Sat Nov 1 22:19:30 2008 UTC (14 years ago) by anton
Branches: MAIN
CVS tags: v0-7-0, HEAD
updated copyright years

    1: \ relocate 4stack binary
    2: 
    3: \ Copyright (C) 2000,2003,2007,2008 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 3
   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, see http://www.gnu.org/licenses/.
   19: 
   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: : x@   dup 4 + l@ swap l@ ;
   27: : x!   tuck l! 4 + l! ;
   28: 
   29: : scan-header ( fd -- skip )  >r 0
   30:     BEGIN
   31: 	8 +
   32: 	magic 8 r@ read-file throw 8 = WHILE
   33: 	magic 8 s" Gforth3" compare 0= UNTIL
   34:     ELSE  true abort" Magic not found!"  THEN rdrop ;
   35: 
   36: Create bits $80 c, $40 c, $20 c, $10 c, $08 c, $04 c, $02 c, $01 c,
   37: 
   38: : bit@ ( n -- flag )
   39:     dup 3 rshift relinfo @ + c@ swap 7 and bits + c@ and 0<> ;
   40: 
   41: 2Variable dovar
   42: 2Variable docol
   43: 
   44: : relocate ( -- )  hex
   45:     image @ $814 + be@ image @ $810 + be@ docol x!
   46:     image @ $80C + be@ image @ $808 + be@ dovar x!
   47:     imagesize @ 1 2* 2* / 0 ?DO
   48: 	image @ I 2* 2* + be@
   49: \	dup 8 u.r I bit@ IF '+ ELSE '- THEN emit I 7 and 7 = IF cr THEN 
   50: 	dup $80000000 and 0<> I bit@ and IF
   51: 	    CASE
   52: 		$FFFFFFFF OF
   53: 		    0 image @ I 2* 2* + l!  1 ENDOF \ NIL
   54: 		$FFFFFFFE OF
   55: 		    docol x@
   56: 		    image @ I 2* 2* + x!  2 ENDOF \ docol
   57: 		$FFFFFFFD OF
   58: 		    dovar x@ $10. d+
   59: 		    image @ I 2* 2* + x!  2 ENDOF \ docon
   60: 		$FFFFFFFC OF
   61: 		    dovar x@
   62: 		    image @ I 2* 2* + x!  2 ENDOF \ docon
   63: 		$FFFFFFF7 OF
   64: 		    image @ I 1+ 2* 2* + be@ 5 -
   65: 		    dovar x@ nip
   66: 		    image @ I 2* 2* + x!  2 ENDOF \ dodoes
   67: 		$FFFFFFF6 OF
   68: 		    docol x@
   69: 		    image @ I 2* 2* + x!  2 ENDOF \ docol
   70: 		1 swap
   71: 	    ENDCASE
   72: 	ELSE
   73: 	    image @ I 2* 2* + l! 1
   74: 	THEN
   75:     +LOOP
   76:     image @ imagesize @ bounds ?DO
   77: 	I x@ swap I x!
   78: 	8 +LOOP ;
   79: 
   80: : read-gforth ( addr u -- )  r/o bin open-file throw
   81:     >r r@ file-size throw drop
   82:     ( r@ scan-header - ) dup allocate throw image !
   83:     image @ swap r@ read-file throw drop
   84:     image @ dup $804 ( 8 ) + be@ dup imagesize ! + relinfo !
   85:     r> close-file throw
   86:     relocate ;
   87: 
   88: Create 4magic  here $10 dup allot erase
   89: s" 4stack00" 4magic swap move
   90: 
   91: : write-gforth ( addr u -- )  w/o bin create-file throw >r
   92:     imagesize @ 4magic $C + !
   93:     4magic $10 r@ write-file throw
   94:     image @ imagesize @ r@ write-file throw
   95:     r> close-file throw ;

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