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