1: \ relocate 4stack binary
2:
3: Create magic 8 allot
4: Variable image
5: Variable relinfo
6: Variable imagesize
7:
8: : be@ 0 swap 4 bounds DO 8 lshift I c@ + LOOP ;
9:
10: : scan-header ( fd -- skip ) >r 0
11: BEGIN
12: 8 +
13: magic 8 r@ read-file throw 8 = WHILE
14: magic 8 s" Gforth2" compare 0= UNTIL
15: ELSE true abort" Magic not found!" THEN rdrop ;
16:
17: Create bits $80 c, $40 c, $20 c, $10 c, $08 c, $04 c, $02 c, $01 c,
18:
19: : bit@ ( n -- flag )
20: dup 3 rshift relinfo @ + c@ swap 7 and bits + c@ and 0<> ;
21:
22: 2Variable dovar
23: 2Variable docol
24:
25: : relocate ( -- ) hex
26: image @ $814 + be@ image @ $810 + be@ docol 2!
27: image @ $80C + be@ image @ $808 + be@ dovar 2!
28: imagesize @ 1 cells / 0 ?DO
29: image @ I cells + be@
30: \ dup 8 u.r I bit@ IF '+ ELSE '- THEN emit I 7 and 7 = IF cr THEN
31: dup 0< I bit@ and IF
32: CASE
33: -1 OF
34: 0 image @ I cells + ! 1 ENDOF \ NIL
35: -2 OF
36: docol 2@
37: image @ I cells + 2! 2 ENDOF \ docol
38: -3 OF
39: dovar 2@ $10. d+
40: image @ I cells + 2! 2 ENDOF \ docon
41: -4 OF
42: dovar 2@
43: image @ I cells + 2! 2 ENDOF \ docon
44: -8 OF
45: image @ I 1+ cells + be@ 5 -
46: dovar 2@ nip
47: image @ I cells + 2! 2 ENDOF \ dodoes
48: -9 OF
49: docol 2@
50: image @ I cells + 2! 2 ENDOF \ docol
51: 1 swap
52: ENDCASE
53: ELSE
54: image @ I cells + ! 1
55: THEN
56: +LOOP
57: image @ imagesize @ bounds ?DO
58: I 2@ swap I 2!
59: 2 cells +LOOP ;
60:
61: : read-gforth ( addr u -- ) r/o bin open-file throw
62: >r r@ file-size throw drop
63: r@ scan-header - dup allocate throw image !
64: image @ swap r@ read-file throw drop
65: image @ dup $804 ( 8 ) + be@ dup imagesize ! + relinfo !
66: r> close-file throw
67: relocate ;
68:
69: Create 4magic $10 allot
70: s" 4stack00" 4magic swap move
71:
72: : write-gforth ( addr u -- ) w/o bin open-file throw >r
73: imagesize @ 4magic $C + !
74: 4magic $10 r@ write-file throw
75: image @ imagesize @ r@ write-file throw
76: r> close-file throw ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>