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

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
        !            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>