File:  [gforth] / gforth / arch / 4stack / relocate-new.fs
Revision 1.1: download - view: text, annotated - select for diffs
Thu May 29 19:42:45 1997 UTC (26 years, 10 months ago) by pazsan
Branches: MAIN
CVS tags: v0-4-0, HEAD
Added port of gforth to 4stack to CVS archive

    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>