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 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:
27: : scan-header ( fd -- skip ) >r 0
28: BEGIN
29: 8 +
30: magic 8 r@ read-file throw 8 = WHILE
31: magic 8 s" Gforth2" compare 0= UNTIL
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>