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 ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>