\ TracePFA ( pfa -- ) analyze word, mark as referenced. If word \ calls others, recursively analyze ALL SUB-words until all are known. decimal only forth definitions ANEW TASK-TREE.F .need CFATable> defer CFATable> ' noop is CFATable> .then variable Tracking \ user turns this on for mem & file allocation tracking \ in his target image variable NoConsole \ if true, clone dummy code for \ KEY, EMIT, ?TERMINAL also TGT definitions \ Record-keeping Stacks ... entries made for each referenced pfa... 0 DynamicStack References \ Sorted stack of called addresses... 0 DynamicStack RefPackets \ 'References' index also index for here... \ index holds address of 'Packet', described below. EXISTS? status? .IF : NumRefs ReferencesBase freecell ; ' numrefs is #Cloned .THEN also forth definitions : InitClone ReferencesVAR FreeStack RefPacketsVAR @&FreeBlocks InitClone ; previous definitions variable CFABase \ holds CFA of word we ate tracing or cloning... \ and a sample-definition... \ Global-Defer Sample-Defer ' (pushadr) is Sample-Defer : Sample-Defer (pushadr) @execute ; $ 4e75 w, ' (pushadr) , \ RefPacket definition and handlers ... :struct RefPacket ubyte Ref_IsPFA \ it non-zero, called address IS a legal pfa. ubyte Ref_Resolved \ true if defined in the targetimage. ulong Ref_#Times \ #times this PFA is called ulong Ref_TgtAdr \ Target relative resolved address ;struct : ValidPFA? ( pfa -- flag ) false swap ( -- 0 pfa ) dup cell- @ $ 00f0,f800 and 0= ( -- 0 pfa flag ) IF \ a rational size code exists... dup >name dup Valid-Name? ( -- 0 pfa nfa? flag ) IF \ the name-field seems to make sense... name> over = ( -- 0 pfa flag ) IF \ going back to the pfa gives the original adr, it's good! 2drop true dup THEN ELSE drop THEN THEN drop ; : IsValuePFA? ( pfa? -- flag ) dup validpfa? dup ( -- adr flag flag ) IF drop dup cell- @ $ f,0000 and VALUE_ID = THEN swap drop ; defer JustForParent ' justforParent >parent forget JustForParent constant DeferParent : GETNAME ( cfa -- , move fullname to HERE ) >name dup c@ $ 1f and dup >r 1+ ( -- nfa count+1 ) here swap move r> here c! ; : SUBSTITUTE? ( cfa -- cfa' ) dup >r dup ValidPFA? IF dup GETNAME only redefs definitions here find IF dup CFABase @ - IF ( -- cfa cfa2 ) swap THEN THEN only forth definitions drop dup r@ = ( not found in redefs ) Tracking @ 0= and ( notracking wanted ) IF only AllocRedefs definitions here find IF dup CFABase @ - IF ( -- cfa cfa2 ) swap THEN THEN only forth definitions drop THEN dup r@ = ( still not found ) NoConsole @ and IF only IORedefs definitions here find IF dup CFABase @ - IF ( -- cfa cfa2 ) swap THEN THEN only forth definitions drop THEN THEN rdrop ; : ( pfa index -- address ) >r MEMF_CLEAR sizeof() RefPacket allocblock? ( -- pfa pktadr ) dup r> RefPackets StackInsert ( -- pfa pktadr ) swap ValidPFA? over ..! Ref_IsPFA ( -- pktadr ) ; : ( pfa index -- packetaddr ) 2dup References StackInsert ( -- pfa index ) ; variable IfCreateRefs Global-Defer TrapPacket : PacketFor ( pfa -- Packet-Base ) dup References StackFind ( -- pfa index flag ) IF \ it exists... cells RefPacketsBase + @ ( -- pfa pktaddr ) ELSE IfCreateRefs @ IF \ 1st time referenced ... dup ( -- pktadr pktadr ) ELSE \ error...shouldn't be extending ref tables... ( -- pfa pktaddr ) TrapPacket quit THEN THEN swap drop ; 0 .IF : CreateDoes? ( adr -- ??_ID , return ID code if not a colon def ) \ \ Check if the SFA has a special_ID marked in the SFA... \ dup PacketFor ..@ ref_IsPFA dup IF drop dup cell- @ $ f,0000 and THEN swap drop ; .THEN \ the word that cycles thru a PFA... .need myself : MYSELF ( -- , compile self ) latest name> calladr, ; IMMEDIATE .then : CallingLibOpen? ( opadr -- flag ) 0 >r dup @ $ 2d07,2e3c = IF dup 16 + Calls? IF ' LibOpen? = IF rdrop true >r THEN THEN THEN drop r> ; defer DoTracePFA : TraceIVs ( class-cfa -- ) dup >LastIvar @ ( -- classCFA lastivar ) BEGIN ?dup WHILE ( classCFA lastivar ) do-does-size - dup ( classCFA insobjcfa insobjcfa ) >IvarClass @ do-does-size - recurse >PrevIvar @ REPEAT ( class-cfa -- ) DoTracePFA ; : CheckIf:Class ( cfa -- ) dup cell- @ :CLASS_BIT and IF \ it's an ODE :CLASS! \ dup >CFATable ( -- cfa &cfa's ) dup >#Methods 0 DO dup @ DoTracePFA cell+ LOOP drop ( -- cfa ) \ \ [ 0 .if ] dup do-does-size + @ ( -- xxx &cfa's ) CFATable> TraceIVs [ .else ] dup >LastIvar @ BEGIN ?dup WHILE do-does-size - dup DoTracePFA dup >IvarClass @ do-does-size - DoTracePFA >PrevIvar @ REPEAT [ .then ] \ \ THEN drop ; : CheckIfClass ( cfa -- ) dup PacketFor ..@ ref_IsPFA \ ValidPFA? IF dup cell- @ CLASS_BIT and IF \ it's an ODE CLASS! \ \ \ [ 0 .if ] dup do-does-size + @ ( -- xxx &cfa's ) dup >#Methods 0 DO dup @ DoTracePFA cell+ LOOP drop [ .else ] dup do-does-size + @ ( -- xxx &cfa's ) CFATable> TraceIVs [ .then ] \ \ ELSE dup CheckIf:Class THEN THEN drop ; variable do?pause variable TrapOn : TracePFA ( pfa -- ) \ ?pause TrapOn @ IF dup TrapOn @ = IF cr ." TRAPPED: " TrapOn @ .hex ." , CfaBase = " CFABASE @ .hex quit THEN THEN Status? IfCreateRefs on Substitute? CFABase @ swap dup CFABase ! dup IsValuePFA? 0= over references stackfind swap drop 0= and >r \ \ Get or create the 'packet' for this pfa... \ dup PacketFor ( -- pfa packet ) \ \ if vectored, pull up executable contents \ dup ..@ ref_IsPFA IF over cell- @ $ f,0000 and dup USERDEF_ID = swap GLOBDEF_ID = or IF over >is @ myself THEN THEN \ \ register the fact that its being called... \ dup ..@ ref_#times 1+ over ..! ref_#times r> IF \ \ start the loop checking for more references \ >r 0 >r ( -- opadr ) ( -r- packetadr hibra ) dup CheckIfClass BEGIN do?pause @ IF ?pause THEN dup w@ $ 4e75 - r@ or WHILE dup Calls? IF ( -- opadr calledadr ) myself ELSE dup ALit? IF \ ( -- opadr ref'd-addr ) check if a create/does dup 2- w@ $ 4e75 = >r dup do-does-size - dup cell- @ $ f,0000 and $ 1,0000 $ 6,0000 within? >r ValidPFA? r> and r> and IF do-does-size - myself \ some kind of data word ELSE dup ValidPFA? IF myself ELSE drop \ is pointing to some kind of data area (ARRAY?) THEN THEN THEN THEN dup CallingLibOpen? IF 18 + ELSE dup w@ >r dup +NextOp ( -- opadr opsize ) ( -r- hibra opc ) over + swap ( -- nextopa opadr ) r> dup BranchOp? ( -- nextadr opadr opcode flag ) IF BRAto? dup r@ > ( -- nextadr dest replaceflag ) IF dup r> drop >r THEN drop ( -- nextadr ) ELSE 2drop THEN r@ -dup IF ( -- nextadr hibra ) over <= IF r> drop 0 >r THEN THEN THEN REPEAT r> 2drop r> drop ELSE 2drop THEN CFABase ! ; ' tracepfa is dotracepfa : .Refs ( -- , show contents of stacks ) cr base @ >r ReferencesBase freecell dup . ." PFAs referenced ..." cr ?dup IF 0 DO i cells ReferencesBase + @ ( -- pfa ) hex dup 9 .r space dup packetfor dup ..@ ref_ISPFA IF over >name id. ELSE ." -- No NFA --" THEN space ascii . 30 emit-to-column space swap drop ( -- packet ) ..@ ref_#times decimal 3 .r ." times" flushemit ?pause cr LOOP THEN r> base ! ; : ShowCalls ( -- , ) ReferencesVAR FreeStack RefPacketsVAR @&FreeBlocks [compile] ' TracePFA .refs ; only forth definitions also TGT