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