Annotation of gforth/arch/4stack/relocate-new.fs, revision 1.2

1.1       pazsan      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
1.2     ! pazsan     14:        magic 8 s" Gforth2" compare 0= UNTIL
1.1       pazsan     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>