X-Git-Url: http://git.subgeniuskitty.com/pforth/.git/blobdiff_plain/a1f4e52df60d8f26327ed57f5a9e7b70d0a04273..8e9db35f299d8f606ba003d3cd8fa9e2c868c880:/fth/utils/clone.fth diff --git a/fth/utils/clone.fth b/fth/utils/clone.fth index 99c0297..98254b5 100644 --- a/fth/utils/clone.fth +++ b/fth/utils/clone.fth @@ -1,489 +1,489 @@ -\ @(#) clone.fth 97/12/10 1.1 -\ Clone for PForth -\ -\ Create the smallest dictionary required to run an application. -\ -\ Clone decompiles the Forth dictionary starting with the top -\ word in the program. It then moves all referenced secondaries -\ into a new dictionary. -\ -\ This work was inspired by the CLONE feature that Mike Haas wrote -\ for JForth. Mike's CLONE disassembled 68000 machine code then -\ reassembled it which is much more difficult. -\ -\ Copyright Phil Burk & 3DO 1994 -\ -\ O- trap custom 'C' calls -\ O- investigate ALITERAL, XLITERAL, use XLITERAL in ['] - -anew task-clone.fth -decimal - -\ move to 'C' -: PRIMITIVE? ( xt -- flag , true if primitive ) - ['] FIRST_COLON < -; - -: 'SELF ( -- xt , return xt of word being compiled ) - ?comp - latest name> - [compile] literal -; immediate - - -:struct CL.REFERENCE - long clr_OriginalXT \ original XT of word - long clr_NewXT \ corresponding XT in cloned dictionary - long clr_TotalSize \ size including data in body -;struct - -variable CL-INITIAL-REFS \ initial number of refs to allocate -100 cl-initial-refs ! -variable CL-REF-LEVEL \ level of threading while scanning -variable CL-NUM-REFS \ number of secondaries referenced -variable CL-MAX-REFS \ max number of secondaries allocated -variable CL-LEVEL-MAX \ max level reached while scanning -variable CL-LEVEL-ABORT \ max level before aborting -10 cl-level-abort ! -variable CL-REFERENCES \ pointer to cl.reference array -variable CL-TRACE \ print debug stuff if true - -\ Cloned dictionary builds in allocated memory but XTs are relative -\ to normal code-base, if CL-TEST-MODE true. -variable CL-TEST-MODE - -variable CL-INITIAL-DICT \ initial size of dict to allocate -20 1024 * cl-initial-dict ! -variable CL-DICT-SIZE \ size of allocated cloned dictionary -variable CL-DICT-BASE \ pointer to virtual base of cloned dictionary -variable CL-DICT-ALLOC \ pointer to allocated dictionary memory -variable CL-DICT-PTR \ rel pointer index into cloned dictionary -0 cl-dict-base ! - - -: CL.INDENT ( -- ) - cl-ref-level @ 2* 2* spaces -; -: CL.DUMP.NAME ( xt -- ) - cl.indent - >name id. cr -; - -: CL.DICT[] ( relptr -- addr ) - cl-dict-base @ + -; - -: CL, ( cell -- , comma into clone dictionary ) - cl-dict-ptr @ cl.dict[] ! - cell cl-dict-ptr +! -; - - -: CL.FREE.DICT ( -- , free dictionary we built into ) - cl-dict-alloc @ ?dup - IF - free dup ?error - 0 cl-dict-alloc ! - THEN -; - -: CL.FREE.REFS ( -- , free dictionary we built into ) - cl-references @ ?dup - IF - free dup ?error - 0 cl-references ! - THEN -; - -: CL.ALLOC.REFS ( -- , allocate references to track ) - cl-initial-refs @ \ initial number of references - dup cl-max-refs ! \ maximum allowed - sizeof() cl.reference * - allocate dup ?error - cl-references ! -; - -: CL.RESIZE.REFS ( -- , allocate references to track ) - cl-max-refs @ \ current number of references allocated - 5 * 4 / dup cl-max-refs ! \ new maximum allowed -\ cl.indent ." Resize # references to " dup . cr - sizeof() cl.reference * - cl-references @ swap resize dup ?error - cl-references ! -; - - -: CL.ALLOC.DICT ( -- , allocate dictionary to build into ) - cl-initial-dict @ \ initial dictionary size - dup cl-dict-size ! - allocate dup ?error - cl-dict-alloc ! -\ -\ kludge dictionary if testing - cl-test-mode @ - IF - cl-dict-alloc @ code-base @ - cl-dict-ptr +! - code-base @ cl-dict-base ! - ELSE - cl-dict-alloc @ cl-dict-base ! - THEN - ." CL.ALLOC.DICT" cr - ." cl-dict-alloc = $" cl-dict-alloc @ .hex cr - ." cl-dict-base = $" cl-dict-base @ .hex cr - ." cl-dict-ptr = $" cl-dict-ptr @ .hex cr -; - -: CODEADDR>DATASIZE { code-addr -- datasize } -\ Determine size of any literal data following execution token. -\ Examples are text following (."), or branch offsets. - code-addr @ - CASE - ['] (literal) OF cell ENDOF \ a number - ['] 0branch OF cell ENDOF \ branch offset - ['] branch OF cell ENDOF - ['] (do) OF 0 ENDOF - ['] (?do) OF cell ENDOF - ['] (loop) OF cell ENDOF - ['] (+loop) OF cell ENDOF - ['] (.") OF code-addr cell+ c@ 1+ ENDOF \ text - ['] (s") OF code-addr cell+ c@ 1+ ENDOF - ['] (c") OF code-addr cell+ c@ 1+ ENDOF - 0 swap - ENDCASE -; - -: XT>SIZE ( xt -- wordsize , including code and data ) - dup >code - swap >name - dup latest = - IF - drop here - ELSE - dup c@ 1+ + aligned 8 + \ get next name - name> >code \ where is next word - THEN - swap - -; - -\ ------------------------------------------------------------------ -: CL.TRAVERSE.SECONDARY { code-addr ca-process | xt dsize -- } -\ scan secondary and pass each code-address to ca-process -\ CA-PROCESS ( code-addr -- , required stack action for vector ) - 1 cl-ref-level +! - cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL" - BEGIN - code-addr @ -> xt -\ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr - code-addr codeaddr>datasize -> dsize \ any data after this? - code-addr ca-process execute \ process it - code-addr cell+ dsize + aligned -> code-addr \ skip past data -\ !!! Bummer! EXIT called in middle of secondary will cause early stop. - xt ['] EXIT = \ stop when we get to EXIT - UNTIL - -1 cl-ref-level +! -; - -\ ------------------------------------------------------------------ - -: CL.DUMP.XT ( xt -- ) - cl-trace @ - IF - dup primitive? - IF ." PRI: " - ELSE ." SEC: " - THEN - cl.dump.name - ELSE - drop - THEN -; - -\ ------------------------------------------------------------------ -: CL.REF[] ( index -- clref ) - sizeof() cl.reference * - cl-references @ + -; - -: CL.DUMP.REFS ( -- , print references ) - cl-num-refs @ 0 - DO - i 3 .r ." : " - i cl.ref[] - dup s@ clr_OriginalXT >name id. ." => " - dup s@ clr_NewXT . - ." , size = " - dup s@ clr_TotalSize . cr - drop \ clref - loop -; - -: CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found } - BEGIN -\ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr - indx cl-num-refs @ >= - IF - true - ELSE - indx cl.ref[] s@ clr_OriginalXT -\ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr - xt = - IF - true - dup -> flag - ELSE - false - indx 1+ -> indx - THEN - THEN - UNTIL - indx flag -\ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space indx . flag . cr -; - -: CL.ADD.REF { xt | clref -- , add referenced secondary to list } - cl-references @ 0= abort" CL.ADD.REF - References not allocated!" -\ -\ do we need to allocate more room? - cl-num-refs @ cl-max-refs @ >= - IF - cl.resize.refs - THEN -\ - cl-num-refs @ cl.ref[] -> clref \ index into array - xt clref s! clr_OriginalXT - 0 clref s! clr_NewXT - xt xt>size clref s! clr_TotalSize -\ - 1 cl-num-refs +! -; - -\ ------------------------------------------------------------------ - -\ called by cl.traverse.secondary to compile each piece of secondary -: CL.RECOMPILE.SECONDARY { code-addr | xt clref dsize -- , } -\ recompile to new location -\ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr - code-addr @ -> xt -\ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr - xt cl.dump.xt - xt primitive? - IF - xt cl, - ELSE - xt CL.XT>REF_INDEX - IF - cl.ref[] -> clref - clref s@ clr_NewXT - dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT" - cl, - ELSE - cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr - abort - THEN - THEN -\ -\ transfer any literal data - code-addr codeaddr>datasize -> dsize - dsize 0> - IF -\ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr - code-addr cell+ cl-dict-ptr @ cl.dict[] dsize move - cl-dict-ptr @ dsize + aligned cl-dict-ptr ! - THEN -\ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr -; - -: CL.RECOMPILE.REF { indx | clref codesize datasize -- } -\ all references have been resolved so recompile new secondary - depth >r - indx cl.ref[] -> clref - cl-trace @ - IF - cl.indent - clref s@ clr_OriginalXT >name id. ." recompiled at $" - cl-dict-ptr @ .hex cr \ new address - THEN - cl-dict-ptr @ clref s! clr_NewXT -\ -\ traverse this secondary and compile into new dictionary - clref s@ clr_OriginalXT - >code ['] cl.recompile.secondary cl.traverse.secondary -\ -\ determine whether there is any data following definition - cl-dict-ptr @ - clref s@ clr_NewXT - -> codesize \ size of cloned code - clref s@ clr_TotalSize \ total bytes - codesize - -> datasize - cl-trace @ - IF - cl.indent - ." Move data: data size = " datasize . ." codesize = " codesize . cr - THEN -\ -\ copy any data that followed definition - datasize 0> - IF - clref s@ clr_OriginalXT >code codesize + - clref s@ clr_NewXT cl-dict-base @ + codesize + - datasize move - datasize cl-dict-ptr +! \ allot space in clone dictionary - THEN - - depth r> - abort" Stack depth change in CL.RECOMPILE.REF" -; - -\ ------------------------------------------------------------------ -: CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list ) - depth 1- >r -\ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr - cl-ref-level @ cl-level-max @ MAX cl-level-max ! - @ ( get xt ) -\ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr - dup cl.dump.xt - dup primitive? - IF - drop -\ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr - ELSE - dup CL.XT>REF_INDEX - IF - drop \ indx \ already referenced once so ignore - drop \ xt - ELSE - >r \ indx - dup cl.add.ref - >code 'self cl.traverse.secondary \ use 'self for recursion! - r> cl.recompile.ref \ now that all refs resolved, recompile - THEN - THEN -\ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr - depth r> - abort" Stack depth change in CL.SCAN.SECONDARY" -; - -: CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list ) - dup primitive? abort" Cannot CLONE a PRIMITIVE word!" - 0 cl-ref-level ! - 0 cl-level-max ! - 0 cl-num-refs ! - dup cl.add.ref \ word being cloned is top of ref list - >code ['] cl.scan.secondary cl.traverse.secondary - 0 cl.recompile.ref -; - -\ ------------------------------------------------------------------ -: CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict ) - cl.xt>ref_index 0= abort" not in cloned dictionary!" - cl.ref[] s@ clr_NewXT -; -: CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict ) - cl.xt>New_XT - cl-dict-base @ + -; - -: CL.REPORT ( -- ) - ." Clone scan went " cl-level-max @ . ." levels deep." cr - ." Clone scanned " cl-num-refs @ . ." secondaries." cr - ." New dictionary size = " cl-dict-ptr @ cl-dict-base @ - . cr -; - - -\ ------------------------------------------------------------------ -: CL.TERM ( -- , cleanup ) - cl.free.refs - cl.free.dict -; - -: CL.INIT ( -- ) - cl.term - 0 cl-dict-size ! - ['] first_colon cl-dict-ptr ! - cl.alloc.dict - cl.alloc.refs -; - -: 'CLONE ( xt -- , clone dictionary from this word ) - cl.init - cl.clone.xt - cl.report - cl.dump.refs - cl-test-mode @ - IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr - THEN -; - -: SAVE-CLONE ( -- ) - bl word - ." Save cloned image in " dup count type - drop ." SAVE-CLONE unimplemented!" \ %Q -; - -: CLONE ( -- ) - ' 'clone -; - -if.forgotten cl.term - -\ ---------------------------------- TESTS -------------------- - - -: TEST.CLONE ( -- ) - cl-test-mode @ not abort" CL-TEST-MODE not on!" - 0 cl.ref[] s@ clr_NewXT execute -; - - -: TEST.CLONE.REAL ( -- ) - cl-test-mode @ abort" CL-TEST-MODE on!" - code-base @ - 0 cl.ref[] s@ clr_NewXT \ get cloned execution token - cl-dict-base @ code-base ! -\ WARNING - code-base munged, only execute primitives or cloned code - execute - code-base ! \ restore code base for normal -; - - -: TCL1 - 34 dup + -; - -: TCL2 - ." Hello " tcl1 . cr -; - -: TCL3 - 4 0 - DO - tcl2 - i . cr - i 100 + . cr - LOOP -; - -create VAR1 567 , -: TCL4 - 345 var1 ! - ." VAR1 = " var1 @ . cr - var1 @ 345 - - IF - ." TCL4 failed!" cr - ELSE - ." TCL4 succeded! Yay!" cr - THEN -; - -\ do deferred words get cloned! -defer tcl.vector - -: TCL.DOIT ." Hello Fred!" cr ; -' tcl.doit is tcl.vector - -: TCL.DEFER - 12 . cr - tcl.vector - 999 dup + . cr -; - -trace-stack on -cl-test-mode on - +\ @(#) clone.fth 97/12/10 1.1 +\ Clone for PForth +\ +\ Create the smallest dictionary required to run an application. +\ +\ Clone decompiles the Forth dictionary starting with the top +\ word in the program. It then moves all referenced secondaries +\ into a new dictionary. +\ +\ This work was inspired by the CLONE feature that Mike Haas wrote +\ for JForth. Mike's CLONE disassembled 68000 machine code then +\ reassembled it which is much more difficult. +\ +\ Copyright Phil Burk & 3DO 1994 +\ +\ O- trap custom 'C' calls +\ O- investigate ALITERAL, XLITERAL, use XLITERAL in ['] + +anew task-clone.fth +decimal + +\ move to 'C' +: PRIMITIVE? ( xt -- flag , true if primitive ) + ['] FIRST_COLON < +; + +: 'SELF ( -- xt , return xt of word being compiled ) + ?comp + latest name> + [compile] literal +; immediate + + +:struct CL.REFERENCE + long clr_OriginalXT \ original XT of word + long clr_NewXT \ corresponding XT in cloned dictionary + long clr_TotalSize \ size including data in body +;struct + +variable CL-INITIAL-REFS \ initial number of refs to allocate +100 cl-initial-refs ! +variable CL-REF-LEVEL \ level of threading while scanning +variable CL-NUM-REFS \ number of secondaries referenced +variable CL-MAX-REFS \ max number of secondaries allocated +variable CL-LEVEL-MAX \ max level reached while scanning +variable CL-LEVEL-ABORT \ max level before aborting +10 cl-level-abort ! +variable CL-REFERENCES \ pointer to cl.reference array +variable CL-TRACE \ print debug stuff if true + +\ Cloned dictionary builds in allocated memory but XTs are relative +\ to normal code-base, if CL-TEST-MODE true. +variable CL-TEST-MODE + +variable CL-INITIAL-DICT \ initial size of dict to allocate +20 1024 * cl-initial-dict ! +variable CL-DICT-SIZE \ size of allocated cloned dictionary +variable CL-DICT-BASE \ pointer to virtual base of cloned dictionary +variable CL-DICT-ALLOC \ pointer to allocated dictionary memory +variable CL-DICT-PTR \ rel pointer index into cloned dictionary +0 cl-dict-base ! + + +: CL.INDENT ( -- ) + cl-ref-level @ 2* 2* spaces +; +: CL.DUMP.NAME ( xt -- ) + cl.indent + >name id. cr +; + +: CL.DICT[] ( relptr -- addr ) + cl-dict-base @ + +; + +: CL, ( cell -- , comma into clone dictionary ) + cl-dict-ptr @ cl.dict[] ! + cell cl-dict-ptr +! +; + + +: CL.FREE.DICT ( -- , free dictionary we built into ) + cl-dict-alloc @ ?dup + IF + free dup ?error + 0 cl-dict-alloc ! + THEN +; + +: CL.FREE.REFS ( -- , free dictionary we built into ) + cl-references @ ?dup + IF + free dup ?error + 0 cl-references ! + THEN +; + +: CL.ALLOC.REFS ( -- , allocate references to track ) + cl-initial-refs @ \ initial number of references + dup cl-max-refs ! \ maximum allowed + sizeof() cl.reference * + allocate dup ?error + cl-references ! +; + +: CL.RESIZE.REFS ( -- , allocate references to track ) + cl-max-refs @ \ current number of references allocated + 5 * 4 / dup cl-max-refs ! \ new maximum allowed +\ cl.indent ." Resize # references to " dup . cr + sizeof() cl.reference * + cl-references @ swap resize dup ?error + cl-references ! +; + + +: CL.ALLOC.DICT ( -- , allocate dictionary to build into ) + cl-initial-dict @ \ initial dictionary size + dup cl-dict-size ! + allocate dup ?error + cl-dict-alloc ! +\ +\ kludge dictionary if testing + cl-test-mode @ + IF + cl-dict-alloc @ code-base @ - cl-dict-ptr +! + code-base @ cl-dict-base ! + ELSE + cl-dict-alloc @ cl-dict-base ! + THEN + ." CL.ALLOC.DICT" cr + ." cl-dict-alloc = $" cl-dict-alloc @ .hex cr + ." cl-dict-base = $" cl-dict-base @ .hex cr + ." cl-dict-ptr = $" cl-dict-ptr @ .hex cr +; + +: CODEADDR>DATASIZE { code-addr -- datasize } +\ Determine size of any literal data following execution token. +\ Examples are text following (."), or branch offsets. + code-addr @ + CASE + ['] (literal) OF cell ENDOF \ a number + ['] 0branch OF cell ENDOF \ branch offset + ['] branch OF cell ENDOF + ['] (do) OF 0 ENDOF + ['] (?do) OF cell ENDOF + ['] (loop) OF cell ENDOF + ['] (+loop) OF cell ENDOF + ['] (.") OF code-addr cell+ c@ 1+ ENDOF \ text + ['] (s") OF code-addr cell+ c@ 1+ ENDOF + ['] (c") OF code-addr cell+ c@ 1+ ENDOF + 0 swap + ENDCASE +; + +: XT>SIZE ( xt -- wordsize , including code and data ) + dup >code + swap >name + dup latest = + IF + drop here + ELSE + dup c@ 1+ + aligned 8 + \ get next name + name> >code \ where is next word + THEN + swap - +; + +\ ------------------------------------------------------------------ +: CL.TRAVERSE.SECONDARY { code-addr ca-process | xt dsize -- } +\ scan secondary and pass each code-address to ca-process +\ CA-PROCESS ( code-addr -- , required stack action for vector ) + 1 cl-ref-level +! + cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL" + BEGIN + code-addr @ -> xt +\ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr + code-addr codeaddr>datasize -> dsize \ any data after this? + code-addr ca-process execute \ process it + code-addr cell+ dsize + aligned -> code-addr \ skip past data +\ !!! Bummer! EXIT called in middle of secondary will cause early stop. + xt ['] EXIT = \ stop when we get to EXIT + UNTIL + -1 cl-ref-level +! +; + +\ ------------------------------------------------------------------ + +: CL.DUMP.XT ( xt -- ) + cl-trace @ + IF + dup primitive? + IF ." PRI: " + ELSE ." SEC: " + THEN + cl.dump.name + ELSE + drop + THEN +; + +\ ------------------------------------------------------------------ +: CL.REF[] ( index -- clref ) + sizeof() cl.reference * + cl-references @ + +; + +: CL.DUMP.REFS ( -- , print references ) + cl-num-refs @ 0 + DO + i 3 .r ." : " + i cl.ref[] + dup s@ clr_OriginalXT >name id. ." => " + dup s@ clr_NewXT . + ." , size = " + dup s@ clr_TotalSize . cr + drop \ clref + loop +; + +: CL.XT>REF_INDEX { xt | indx flag -- index flag , true if found } + BEGIN +\ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr + indx cl-num-refs @ >= + IF + true + ELSE + indx cl.ref[] s@ clr_OriginalXT +\ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr + xt = + IF + true + dup -> flag + ELSE + false + indx 1+ -> indx + THEN + THEN + UNTIL + indx flag +\ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space indx . flag . cr +; + +: CL.ADD.REF { xt | clref -- , add referenced secondary to list } + cl-references @ 0= abort" CL.ADD.REF - References not allocated!" +\ +\ do we need to allocate more room? + cl-num-refs @ cl-max-refs @ >= + IF + cl.resize.refs + THEN +\ + cl-num-refs @ cl.ref[] -> clref \ index into array + xt clref s! clr_OriginalXT + 0 clref s! clr_NewXT + xt xt>size clref s! clr_TotalSize +\ + 1 cl-num-refs +! +; + +\ ------------------------------------------------------------------ + +\ called by cl.traverse.secondary to compile each piece of secondary +: CL.RECOMPILE.SECONDARY { code-addr | xt clref dsize -- , } +\ recompile to new location +\ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr + code-addr @ -> xt +\ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr + xt cl.dump.xt + xt primitive? + IF + xt cl, + ELSE + xt CL.XT>REF_INDEX + IF + cl.ref[] -> clref + clref s@ clr_NewXT + dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT" + cl, + ELSE + cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr + abort + THEN + THEN +\ +\ transfer any literal data + code-addr codeaddr>datasize -> dsize + dsize 0> + IF +\ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr + code-addr cell+ cl-dict-ptr @ cl.dict[] dsize move + cl-dict-ptr @ dsize + aligned cl-dict-ptr ! + THEN +\ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr +; + +: CL.RECOMPILE.REF { indx | clref codesize datasize -- } +\ all references have been resolved so recompile new secondary + depth >r + indx cl.ref[] -> clref + cl-trace @ + IF + cl.indent + clref s@ clr_OriginalXT >name id. ." recompiled at $" + cl-dict-ptr @ .hex cr \ new address + THEN + cl-dict-ptr @ clref s! clr_NewXT +\ +\ traverse this secondary and compile into new dictionary + clref s@ clr_OriginalXT + >code ['] cl.recompile.secondary cl.traverse.secondary +\ +\ determine whether there is any data following definition + cl-dict-ptr @ + clref s@ clr_NewXT - -> codesize \ size of cloned code + clref s@ clr_TotalSize \ total bytes + codesize - -> datasize + cl-trace @ + IF + cl.indent + ." Move data: data size = " datasize . ." codesize = " codesize . cr + THEN +\ +\ copy any data that followed definition + datasize 0> + IF + clref s@ clr_OriginalXT >code codesize + + clref s@ clr_NewXT cl-dict-base @ + codesize + + datasize move + datasize cl-dict-ptr +! \ allot space in clone dictionary + THEN + + depth r> - abort" Stack depth change in CL.RECOMPILE.REF" +; + +\ ------------------------------------------------------------------ +: CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list ) + depth 1- >r +\ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr + cl-ref-level @ cl-level-max @ MAX cl-level-max ! + @ ( get xt ) +\ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr + dup cl.dump.xt + dup primitive? + IF + drop +\ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr + ELSE + dup CL.XT>REF_INDEX + IF + drop \ indx \ already referenced once so ignore + drop \ xt + ELSE + >r \ indx + dup cl.add.ref + >code 'self cl.traverse.secondary \ use 'self for recursion! + r> cl.recompile.ref \ now that all refs resolved, recompile + THEN + THEN +\ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr + depth r> - abort" Stack depth change in CL.SCAN.SECONDARY" +; + +: CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list ) + dup primitive? abort" Cannot CLONE a PRIMITIVE word!" + 0 cl-ref-level ! + 0 cl-level-max ! + 0 cl-num-refs ! + dup cl.add.ref \ word being cloned is top of ref list + >code ['] cl.scan.secondary cl.traverse.secondary + 0 cl.recompile.ref +; + +\ ------------------------------------------------------------------ +: CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict ) + cl.xt>ref_index 0= abort" not in cloned dictionary!" + cl.ref[] s@ clr_NewXT +; +: CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict ) + cl.xt>New_XT + cl-dict-base @ + +; + +: CL.REPORT ( -- ) + ." Clone scan went " cl-level-max @ . ." levels deep." cr + ." Clone scanned " cl-num-refs @ . ." secondaries." cr + ." New dictionary size = " cl-dict-ptr @ cl-dict-base @ - . cr +; + + +\ ------------------------------------------------------------------ +: CL.TERM ( -- , cleanup ) + cl.free.refs + cl.free.dict +; + +: CL.INIT ( -- ) + cl.term + 0 cl-dict-size ! + ['] first_colon cl-dict-ptr ! + cl.alloc.dict + cl.alloc.refs +; + +: 'CLONE ( xt -- , clone dictionary from this word ) + cl.init + cl.clone.xt + cl.report + cl.dump.refs + cl-test-mode @ + IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr + THEN +; + +: SAVE-CLONE ( -- ) + bl word + ." Save cloned image in " dup count type + drop ." SAVE-CLONE unimplemented!" \ %Q +; + +: CLONE ( -- ) + ' 'clone +; + +if.forgotten cl.term + +\ ---------------------------------- TESTS -------------------- + + +: TEST.CLONE ( -- ) + cl-test-mode @ not abort" CL-TEST-MODE not on!" + 0 cl.ref[] s@ clr_NewXT execute +; + + +: TEST.CLONE.REAL ( -- ) + cl-test-mode @ abort" CL-TEST-MODE on!" + code-base @ + 0 cl.ref[] s@ clr_NewXT \ get cloned execution token + cl-dict-base @ code-base ! +\ WARNING - code-base munged, only execute primitives or cloned code + execute + code-base ! \ restore code base for normal +; + + +: TCL1 + 34 dup + +; + +: TCL2 + ." Hello " tcl1 . cr +; + +: TCL3 + 4 0 + DO + tcl2 + i . cr + i 100 + . cr + LOOP +; + +create VAR1 567 , +: TCL4 + 345 var1 ! + ." VAR1 = " var1 @ . cr + var1 @ 345 - + IF + ." TCL4 failed!" cr + ELSE + ." TCL4 succeded! Yay!" cr + THEN +; + +\ do deferred words get cloned! +defer tcl.vector + +: TCL.DOIT ." Hello Fred!" cr ; +' tcl.doit is tcl.vector + +: TCL.DEFER + 12 . cr + tcl.vector + 999 dup + . cr +; + +trace-stack on +cl-test-mode on +