[pforth] / fth / utils / clone.fth

\ @(#) 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
Commit	Line	Data
8e9db35f PB	1	\ @(#) clone.fth 97/12/10 1.1
	2	\ Clone for PForth
	3	\
	4	\ Create the smallest dictionary required to run an application.
	5	\
	6	\ Clone decompiles the Forth dictionary starting with the top
	7	\ word in the program. It then moves all referenced secondaries
	8	\ into a new dictionary.
	9	\
	10	\ This work was inspired by the CLONE feature that Mike Haas wrote
	11	\ for JForth. Mike's CLONE disassembled 68000 machine code then
	12	\ reassembled it which is much more difficult.
	13	\
	14	\ Copyright Phil Burk & 3DO 1994
	15	\
	16	\ O- trap custom 'C' calls
	17	\ O- investigate ALITERAL, XLITERAL, use XLITERAL in [']
	18
	19	anew task-clone.fth
	20	decimal
	21
	22	\ move to 'C'
	23	: PRIMITIVE? ( xt -- flag , true if primitive )
	24	['] FIRST_COLON <
	25	;
	26
	27	: 'SELF ( -- xt , return xt of word being compiled )
	28	?comp
	29	latest name>
	30	[compile] literal
	31	; immediate
	32
	33
	34	:struct CL.REFERENCE
	35	long clr_OriginalXT \ original XT of word
	36	long clr_NewXT \ corresponding XT in cloned dictionary
	37	long clr_TotalSize \ size including data in body
	38	;struct
	39
	40	variable CL-INITIAL-REFS \ initial number of refs to allocate
	41	100 cl-initial-refs !
	42	variable CL-REF-LEVEL \ level of threading while scanning
	43	variable CL-NUM-REFS \ number of secondaries referenced
	44	variable CL-MAX-REFS \ max number of secondaries allocated
	45	variable CL-LEVEL-MAX \ max level reached while scanning
	46	variable CL-LEVEL-ABORT \ max level before aborting
	47	10 cl-level-abort !
	48	variable CL-REFERENCES \ pointer to cl.reference array
	49	variable CL-TRACE \ print debug stuff if true
	50
	51	\ Cloned dictionary builds in allocated memory but XTs are relative
	52	\ to normal code-base, if CL-TEST-MODE true.
	53	variable CL-TEST-MODE
	54
	55	variable CL-INITIAL-DICT \ initial size of dict to allocate
	56	20 1024 * cl-initial-dict !
	57	variable CL-DICT-SIZE \ size of allocated cloned dictionary
	58	variable CL-DICT-BASE \ pointer to virtual base of cloned dictionary
	59	variable CL-DICT-ALLOC \ pointer to allocated dictionary memory
	60	variable CL-DICT-PTR \ rel pointer index into cloned dictionary
	61	0 cl-dict-base !
	62
	63
	64	: CL.INDENT ( -- )
65	cl-ref-level @ 2* 2* spaces
66	;
67	: CL.DUMP.NAME ( xt -- )
68	cl.indent
69	>name id. cr
70	;
71
72	: CL.DICT[] ( relptr -- addr )
73	cl-dict-base @ +
74	;
75
76	: CL, ( cell -- , comma into clone dictionary )
77	cl-dict-ptr @ cl.dict[] !
78	cell cl-dict-ptr +!
79	;
80
81
82	: CL.FREE.DICT ( -- , free dictionary we built into )
83	cl-dict-alloc @ ?dup
84	IF
85	free dup ?error
86	0 cl-dict-alloc !
87	THEN
88	;
89
90	: CL.FREE.REFS ( -- , free dictionary we built into )
91	cl-references @ ?dup
92	IF
93	free dup ?error
94	0 cl-references !
95	THEN
96	;
97
98	: CL.ALLOC.REFS ( -- , allocate references to track )
99	cl-initial-refs @ \ initial number of references
100	dup cl-max-refs ! \ maximum allowed
101	sizeof() cl.reference *
102	allocate dup ?error
103	cl-references !
104	;
105
106	: CL.RESIZE.REFS ( -- , allocate references to track )
107	cl-max-refs @ \ current number of references allocated
108	5 * 4 / dup cl-max-refs ! \ new maximum allowed
109	\ cl.indent ." Resize # references to " dup . cr
110	sizeof() cl.reference *
111	cl-references @ swap resize dup ?error
112	cl-references !
113	;
114
115
116	: CL.ALLOC.DICT ( -- , allocate dictionary to build into )
117	cl-initial-dict @ \ initial dictionary size
118	dup cl-dict-size !
119	allocate dup ?error
120	cl-dict-alloc !
121	\
122	\ kludge dictionary if testing
123	cl-test-mode @
124	IF
125	cl-dict-alloc @ code-base @ - cl-dict-ptr +!
126	code-base @ cl-dict-base !
127	ELSE
128	cl-dict-alloc @ cl-dict-base !
129	THEN
130	." CL.ALLOC.DICT" cr
131	." cl-dict-alloc = $" cl-dict-alloc @ .hex cr
132	." cl-dict-base = $" cl-dict-base @ .hex cr
133	." cl-dict-ptr = $" cl-dict-ptr @ .hex cr
134	;
135
136	: CODEADDR>DATASIZE { code-addr -- datasize }
137	\ Determine size of any literal data following execution token.
138	\ Examples are text following (."), or branch offsets.
139	code-addr @
140	CASE
141	['] (literal) OF cell ENDOF \ a number
142	['] 0branch OF cell ENDOF \ branch offset
143	['] branch OF cell ENDOF
144	['] (do) OF 0 ENDOF
145	['] (?do) OF cell ENDOF
146	['] (loop) OF cell ENDOF
147	['] (+loop) OF cell ENDOF
148	['] (.") OF code-addr cell+ c@ 1+ ENDOF \ text
149	['] (s") OF code-addr cell+ c@ 1+ ENDOF
150	['] (c") OF code-addr cell+ c@ 1+ ENDOF
151	0 swap
152	ENDCASE
153	;
154
155	: XT>SIZE ( xt -- wordsize , including code and data )
156	dup >code
157	swap >name
158	dup latest =
159	IF
160	drop here
161	ELSE
162	dup c@ 1+ + aligned 8 + \ get next name
163	name> >code \ where is next word
164	THEN
165	swap -
166	;
167
168	\ ------------------------------------------------------------------
169	: CL.TRAVERSE.SECONDARY { code-addr ca-process \| xt dsize -- }
170	\ scan secondary and pass each code-address to ca-process
171	\ CA-PROCESS ( code-addr -- , required stack action for vector )
172	1 cl-ref-level +!
173	cl-ref-level @ cl-level-abort @ > abort" Clone exceeded CL-ABORT-LEVEL"
174	BEGIN
175	code-addr @ -> xt
176	\ cl.indent ." CL.TRAVERSE.SECONDARY - code-addr = $" code-addr .hex ." , xt = $" xt .hex cr
177	code-addr codeaddr>datasize -> dsize \ any data after this?
178	code-addr ca-process execute \ process it
179	code-addr cell+ dsize + aligned -> code-addr \ skip past data
180	\ !!! Bummer! EXIT called in middle of secondary will cause early stop.
181	xt ['] EXIT = \ stop when we get to EXIT
182	UNTIL
183	-1 cl-ref-level +!
184	;
185
186	\ ------------------------------------------------------------------
187
188	: CL.DUMP.XT ( xt -- )
189	cl-trace @
190	IF
191	dup primitive?
192	IF ." PRI: "
193	ELSE ." SEC: "
194	THEN
195	cl.dump.name
196	ELSE
197	drop
198	THEN
199	;
200
201	\ ------------------------------------------------------------------
202	: CL.REF[] ( index -- clref )
203	sizeof() cl.reference *
204	cl-references @ +
205	;
206
207	: CL.DUMP.REFS ( -- , print references )
208	cl-num-refs @ 0
209	DO
210	i 3 .r ." : "
211	i cl.ref[]
212	dup s@ clr_OriginalXT >name id. ." => "
213	dup s@ clr_NewXT .
214	." , size = "
215	dup s@ clr_TotalSize . cr
216	drop \ clref
217	loop
218	;
219
220	: CL.XT>REF_INDEX { xt \| indx flag -- index flag , true if found }
221	BEGIN
222	\ cl.indent ." CL.XT>REF_INDEX - indx = " indx . cr
223	indx cl-num-refs @ >=
224	IF
225	true
226	ELSE
227	indx cl.ref[] s@ clr_OriginalXT
228	\ cl.indent ." CL.XT>REF_INDEX - clr_OriginalXT = " dup . cr
229	xt =
230	IF
231	true
232	dup -> flag
233	ELSE
234	false
235	indx 1+ -> indx
236	THEN
237	THEN
238	UNTIL
239	indx flag
240	\ cl.indent ." CL.XT>REF_INDEX - " xt >name id. space indx . flag . cr
241	;
242
243	: CL.ADD.REF { xt \| clref -- , add referenced secondary to list }
244	cl-references @ 0= abort" CL.ADD.REF - References not allocated!"
245	\
246	\ do we need to allocate more room?
247	cl-num-refs @ cl-max-refs @ >=
248	IF
249	cl.resize.refs
250	THEN
251	\
252	cl-num-refs @ cl.ref[] -> clref \ index into array
253	xt clref s! clr_OriginalXT
254	0 clref s! clr_NewXT
255	xt xt>size clref s! clr_TotalSize
256	\
257	1 cl-num-refs +!
258	;
259
260	\ ------------------------------------------------------------------
261
262	\ called by cl.traverse.secondary to compile each piece of secondary
263	: CL.RECOMPILE.SECONDARY { code-addr \| xt clref dsize -- , }
264	\ recompile to new location
265	\ cl.indent ." CL.RECOMPILE.SECONDARY - enter - " .s cr
266	code-addr @ -> xt
267	\ cl.indent ." CL.RECOMPILE.SECONDARY - xt = $" dup .hex dup >name id. cr
268	xt cl.dump.xt
269	xt primitive?
270	IF
271	xt cl,
272	ELSE
273	xt CL.XT>REF_INDEX
274	IF
275	cl.ref[] -> clref
276	clref s@ clr_NewXT
277	dup 0= abort" CL.RECOMPILE.SECONDARY - unresolved NewXT"
278	cl,
279	ELSE
280	cl.indent ." CL.RECOMPILE.SECONDARY - xt not in ref table!" cr
281	abort
282	THEN
283	THEN
284	\
285	\ transfer any literal data
286	code-addr codeaddr>datasize -> dsize
287	dsize 0>
288	IF
289	\ cl.indent ." CL.RECOMPILE.SECONDARY - copy inline data of size" dsize . cr
290	code-addr cell+ cl-dict-ptr @ cl.dict[] dsize move
291	cl-dict-ptr @ dsize + aligned cl-dict-ptr !
292	THEN
293	\ cl.indent ." CL.RECOMPILE.SECONDARY - leave - " .s cr
294	;
295
296	: CL.RECOMPILE.REF { indx \| clref codesize datasize -- }
297	\ all references have been resolved so recompile new secondary
298	depth >r
299	indx cl.ref[] -> clref
300	cl-trace @
301	IF
302	cl.indent
303	clref s@ clr_OriginalXT >name id. ." recompiled at $"
304	cl-dict-ptr @ .hex cr \ new address
305	THEN
306	cl-dict-ptr @ clref s! clr_NewXT
307	\
308	\ traverse this secondary and compile into new dictionary
309	clref s@ clr_OriginalXT
310	>code ['] cl.recompile.secondary cl.traverse.secondary
311	\
312	\ determine whether there is any data following definition
313	cl-dict-ptr @
314	clref s@ clr_NewXT - -> codesize \ size of cloned code
315	clref s@ clr_TotalSize \ total bytes
316	codesize - -> datasize
317	cl-trace @
318	IF
319	cl.indent
320	." Move data: data size = " datasize . ." codesize = " codesize . cr
321	THEN
322	\
323	\ copy any data that followed definition
324	datasize 0>
325	IF
326	clref s@ clr_OriginalXT >code codesize +
327	clref s@ clr_NewXT cl-dict-base @ + codesize +
328	datasize move
329	datasize cl-dict-ptr +! \ allot space in clone dictionary
330	THEN
331
332	depth r> - abort" Stack depth change in CL.RECOMPILE.REF"
333	;
334
335	\ ------------------------------------------------------------------
336	: CL.SCAN.SECONDARY ( code-addr -- , scan word and add referenced secondaries to list )
337	depth 1- >r
338	\ cl.indent ." CL.SCAN.SECONDARY - enter - " .s cr
339	cl-ref-level @ cl-level-max @ MAX cl-level-max !
340	@ ( get xt )
341	\ cl.indent ." CL.SCAN.SECONDARY - xt = " dup . dup >name id. cr
342	dup cl.dump.xt
343	dup primitive?
344	IF
345	drop
346	\ cl.indent ." CL.SCAN.SECONDARY - found primitive." cr
347	ELSE
348	dup CL.XT>REF_INDEX
349	IF
350	drop \ indx \ already referenced once so ignore
351	drop \ xt
352	ELSE
353	>r \ indx
354	dup cl.add.ref
355	>code 'self cl.traverse.secondary \ use 'self for recursion!
356	r> cl.recompile.ref \ now that all refs resolved, recompile
357	THEN
358	THEN
359	\ cl.indent ." CL.SCAN.SECONDARY - leave - " .s cr
360	depth r> - abort" Stack depth change in CL.SCAN.SECONDARY"
361	;
362
363	: CL.CLONE.XT ( xt -- , scan top word and add referenced secondaries to list )
364	dup primitive? abort" Cannot CLONE a PRIMITIVE word!"
365	0 cl-ref-level !
366	0 cl-level-max !
367	0 cl-num-refs !
368	dup cl.add.ref \ word being cloned is top of ref list
369	>code ['] cl.scan.secondary cl.traverse.secondary
370	0 cl.recompile.ref
371	;
372
373	\ ------------------------------------------------------------------
374	: CL.XT>NEW_XT ( xt -- xt' , convert normal xt to xt in cloned dict )
375	cl.xt>ref_index 0= abort" not in cloned dictionary!"
376	cl.ref[] s@ clr_NewXT
377	;
378	: CL.XT>NEW_ADDR ( xt -- addr , addr in cloned dict )
379	cl.xt>New_XT
380	cl-dict-base @ +
381	;
382
383	: CL.REPORT ( -- )
384	." Clone scan went " cl-level-max @ . ." levels deep." cr
385	." Clone scanned " cl-num-refs @ . ." secondaries." cr
386	." New dictionary size = " cl-dict-ptr @ cl-dict-base @ - . cr
387	;
388
389
390	\ ------------------------------------------------------------------
391	: CL.TERM ( -- , cleanup )
392	cl.free.refs
393	cl.free.dict
394	;
395
396	: CL.INIT ( -- )
397	cl.term
398	0 cl-dict-size !
399	['] first_colon cl-dict-ptr !
400	cl.alloc.dict
401	cl.alloc.refs
402	;
403
404	: 'CLONE ( xt -- , clone dictionary from this word )
405	cl.init
406	cl.clone.xt
407	cl.report
408	cl.dump.refs
409	cl-test-mode @
410	IF ." WARNING - CL-TEST-MODE on so we can't save cloned image." cr
411	THEN
412	;
413
414	: SAVE-CLONE ( <filename> -- )
415	bl word
416	." Save cloned image in " dup count type
417	drop ." SAVE-CLONE unimplemented!" \ %Q
418	;
419
420	: CLONE ( <name> -- )
421	' 'clone
422	;
423
424	if.forgotten cl.term
425
426	\ ---------------------------------- TESTS --------------------
427
428
429	: TEST.CLONE ( -- )
430	cl-test-mode @ not abort" CL-TEST-MODE not on!"
431	0 cl.ref[] s@ clr_NewXT execute
432	;
433
434
435	: TEST.CLONE.REAL ( -- )
436	cl-test-mode @ abort" CL-TEST-MODE on!"
437	code-base @
438	0 cl.ref[] s@ clr_NewXT \ get cloned execution token
439	cl-dict-base @ code-base !
440	\ WARNING - code-base munged, only execute primitives or cloned code
441	execute
442	code-base ! \ restore code base for normal
443	;
444
445
446	: TCL1
447	34 dup +
448	;
449
450	: TCL2
451	." Hello " tcl1 . cr
452	;
453
454	: TCL3
455	4 0
456	DO
457	tcl2
458	i . cr
459	i 100 + . cr
460	LOOP
461	;
462
463	create VAR1 567 ,
464	: TCL4
465	345 var1 !
466	." VAR1 = " var1 @ . cr
467	var1 @ 345 -
468	IF
469	." TCL4 failed!" cr
470	ELSE
471	." TCL4 succeded! Yay!" cr
472	THEN
473	;
474
475	\ do deferred words get cloned!
476	defer tcl.vector
477
478	: TCL.DOIT ." Hello Fred!" cr ;
479	' tcl.doit is tcl.vector
480
481	: TCL.DEFER
482	12 . cr
483	tcl.vector
484	999 dup + . cr
485	;
486
487	trace-stack on
488	cl-test-mode on
489