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" Gforth14" 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: 2Variable dojmp
25: 2Variable docon
26:
27: : relocate ( -- ) hex
28: image @ $80C + be@ image @ $808 + be@ docon 2!
29: image @ $814 + be@ image @ $810 + be@ dovar 2!
30: image @ $81C + be@ image @ $818 + be@ dojmp 2!
31: image @ $824 + be@ image @ $820 + be@ docol 2!
32: imagesize @ 1 cells / 0 ?DO
33: image @ I cells + be@
34: \ dup 8 u.r I bit@ IF '+ ELSE '- THEN emit I 7 and 7 = IF cr THEN
35: dup 0< I bit@ and IF
36: CASE
37: -1 OF
38: 0 image @ I cells + ! 1 ENDOF \ NIL
39: -2 OF
40: docol 2@
41: image @ I cells + 2! 2 ENDOF \ docol
42: -3 OF
43: docon 2@
44: image @ I cells + 2! 2 ENDOF \ docon
45: -4 OF
46: dovar 2@
47: image @ I cells + 2! 2 ENDOF \ docon
48: -8 OF
49: image @ I 1+ cells + be@ 5 -
50: docol 2@ nip
51: image @ I cells + 2! 2 ENDOF \ dodoes
52: -9 OF
53: dojmp 2@
54: image @ I cells + 2! 2 ENDOF \ docol
55: 1 swap
56: ENDCASE
57: ELSE
58: image @ I cells + ! 1
59: THEN
60: +LOOP
61: image @ imagesize @ bounds ?DO
62: I 2@ swap I 2!
63: 2 cells +LOOP ;
64:
65: : read-gforth ( addr u -- ) r/o bin open-file throw
66: >r r@ file-size throw drop
67: r@ scan-header - dup allocate throw image !
68: image @ swap r@ read-file throw drop
69: image @ dup $804 ( 8 ) + be@ dup imagesize ! + relinfo !
70: r> close-file throw
71: relocate ;
72:
73: Create 4magic $10 allot
74: s" 4stack00" 4magic swap move
75:
76: : write-gforth ( addr u -- ) w/o bin open-file throw >r
77: imagesize @ 4magic $C + !
78: 4magic $10 r@ write-file throw
79: image @ imagesize @ r@ write-file throw
80: r> close-file throw ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>