\ ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» \ º º \ º REORDER for F-PC Last Revision: 16-FEB-1991 KDM º \ º ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ º \ º º \ º Author: Idea and DOS-special words: º \ º Klaus M”dinger Ulrich Paul º \ º Aspernstr.33 Erlenweg 18 º \ º 8900 Augsburg 8901 Leitershofen º \ º Germany Germany º \ º º \ ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ \ *************************************************************************** \ Version for win32for mai 29, 2001 \ bug fixed, some modifications and improvements \ and test program for interpret and compile modes \ by Heinrich Moeller \ email: hmoeller@data-al.de \ *************************************************************************** IN-SYSTEM \ *************************************************************************** \ variables used for collecting some statistical data \ about the number of load and store operations needed for reorder \ *************************************************************************** variable regloads \ count # load operations for statistics variable regsaves \ count # of store operations variable savesreq \ how many store operations are required? \ *************************************************************************** \ Deferred words for stack manipulations \ *************************************************************************** defer $adjust defer $load defer $store ( offset -- ) defer $prefix defer $suffix \ *************************************************************************** \ Variables \ *************************************************************************** $30 constant actiontable-size create reo-actiontable actiontable-size allot create reo-w1 $20 allot \ Buffers holding words in the create reo-w2 $20 allot \ REORDER-command variable which-cell \ indicates which help cell is used 2variable help-cell \ 2 adjacent! help cells \ used instead of registers in interpret mode variable reo-d \ Difference stack-depth d>0 => stack-depth increases variable reo-e# \ Needed to build up the actiontable variable reo-q# \ Count of values left of '--' variable reo-mp \ Mainpointer, index in actiontable variable reo-ts \ Offsets in input-buffer variable reo-te variable reo-tsav \ to save the >in-pointer variable reo-maxi variable reo-tbw 1 constant reorder1 \ Constants for error-handling 2 constant reorder2 3 constant reorder3 4 constant reorder4 255 constant register \ 254 and 255 are number for registers in reo-actiontable \ *************************************************************************** \ Words for REORDER in direct mode \ *************************************************************************** : -pick0 ( offset -- ) \ pick register/helpcell 0 from stack 1- pick help-cell ! ; \ offset is # of stack item, from tos : -pick1 ( offset -- ) \ ditto for register/helpcell 1 1- pick help-cell CELL+ ! ; : -pick ( offset -- ) which-cell c@ IF -pick1 ELSE -pick0 THEN ; : stick0 ( offset -- ) \ store register/helpcell 0 to stack CELLS sp@ + help-cell @ swap ! ; : stick1 ( offset -- ) \ ditto for register/helpcell 1 CELLS sp@ + help-cell CELL+ @ swap ! ; : stick ( offset -- ) which-cell c@ IF stick1 ELSE stick0 THEN ; : adjust-SP ( n -- ) \ adjust stack pointer, add n items 1- CELLS \ correct n to include its space sp@ swap - sp! ; \ *************************************************************************** \ Error handling \ *************************************************************************** : reo-error ( err-# -- ) cr dup reorder1 = abort" Reorder-Error! Missing (" dup reorder2 = abort" Reorder-Error! Missing --" dup reorder3 = abort" Reorder-Error! Unknown element" reorder4 = abort" Reorder-Error! Not enough parameters" abort" Unknown Error in REORDER !" ; \ *************************************************************************** \ REORDER-Init \ *************************************************************************** : init-reorder reo-actiontable actiontable-size erase reo-q# off reo-mp off ; \ *************************************************************************** \ Build up the actiontable \ This code builds the original actiontable. In this format the entries \ reference an item as an index into this table, not from the TOS. (These \ are converted into the right format before the table is acted upon.) \ This routine is called whenever an element (word) is isolated on the \ right side of "--". The code rescans the left side to find the matching \ element (i.e. the same word). It then appends the location where it was found \ to the actiontable, where the location offsets refer to the start of the \ left side sequence of words, starting with 0 for the leftmost one. To speed \ things up a little bit (string comparisons are "expensive") we first check, \ if this element stays at the same location. We can skip it then for further \ processing. Obviously this means, that the element is in the original \ stack. \ *************************************************************************** : word>w2 ( -- ) \ read next word from input to w2 $20 word dup c@ 1+ reo-w2 swap cmove ; : ?action-overflow ( -- ) \ too many parameters for actiontable? reo-mp @ actiontable-size < not abort" too many parameters" ; : build-actiontable ( -- ? ) 1 reo-e# ! >in @ reo-tsav ! \ save >in-pointer reo-ts @ >in ! \ and put it in ts reo-mp @ reo-q# @ < IF \ are there elements already positioned right? reo-mp @ 1+ 0 DO word>w2 LOOP reo-w1 count reo-w2 count compare 0= IF ?action-overflow \ too many parameters for actiontable? reo-tsav @ >in ! \ restore >in 0 reo-actiontable reo-mp @ + c! \ put a 0 in actiontable ( nothing to do ) reo-mp incr \ incr mainpointer 0 \ leave 0 ( = no error ) exit THEN reo-ts @ >in ! THEN BEGIN word>w2 \ scan words left of -- save found words in reo-w2 reo-w1 count reo-w2 count compare \ compare currently regarded entry right of -- \ with entries left of -- WHILE \ while no matches >in @ reo-te @ = \ looked up all entries ? IF reorder3 \ right entry without left equivalent exit THEN reo-e# incr \ increment reo-e# REPEAT \ reo-e# has stack index of inparms ?action-overflow \ too many parameters for actiontable? reo-tsav @ >in ! \ restore >in reo-e# @ reo-actiontable reo-mp @ + c! \ make entry in actiontable reo-mp incr \ increment mainpointer 0 ; \ leave a 0 ( = no error ) \ *************************************************************************** \ debugging \ some words which help for debugging \ *************************************************************************** (( : .actiontable ( -- ) S" actiontable:" _TYPE reo-mp @ . reo-actiontable $10 DUMP _CR ; : .reo-w1 ( -- ) reo-w1 $20 dump cr ; )) \ *************************************************************************** \ Correct action-indices \ This routine changes the indices so that they refer to the new stack \ configuration. All indices are from the top of the stack, either the \ current one (if the stack does not grow) or the final one (if the stack \ grows). Note: Even if the stack shrinks the indices are from the original \ top of stack! Example: reorder ( a b c d -- c d ). The actiontable after \ the adjustment by this routine is ( 2 1 ), which is correct only for the \ original stack. We adjust the SP at the very end in a case where the \ stack shrinks and adjust it at the very beginning if it grows. This is \ necessary to always protect our stack in case of concurrent actions like \ interrupt routines. \ *************************************************************************** : swap-action-indices ( -- ) reo-mp @ 0 ?DO reo-actiontable I + dup c@ dup 0= IF 2drop ELSE reo-maxi @ 1+ swap - swap c! THEN LOOP ; \ *************************************************************************** \ Actualize index in actiontable after stack-manipulation \ The actiontable at any time contains the offsets into the stack \ all items of the new stack (after reorder) must be loaded from. \ In order to keep track of the process, we also use register numbers 255 and \ 244 as 'pseudo-offsets' to indicate that a stack item has been loaded into \ one of the registers. This also means that all stack items which have to be loaded \ from this stack item, now have to be loaded from the register. \ Therefore, after loading a stack item into a register, we call 'act-index' \ to replace all occurrencies of the stack item's offset in the actiontable \ with the register number. \ When we store this register into the destination stack position, we clear \ the corresponding byte in the actiontable to indicate that this stack item \ has been written. Then, we check if we can safely write the register to any \ different stack positions. For this purpose, we have to check if the stack \ item in not needed in the further stack manipulation process ('write-unneeded'). \ We do this by scanning the actiontable ('needed?'). \ If there are still any stack positions which could not be written, the \ corresponding byte in the actiontable is set to the offset of the stack \ position which the register was written to. This is again done by 'act-index'. \ After this, there are no more references to the register, so it is free \ and can be reused. \ It seems that this algorithm can be extended to more than 2 registers, but \ with win32for, there are only registers eax and ecx available. \ *************************************************************************** : act-index ( old new -- ) \ substitute old by new in actiontable reo-actiontable reo-mp @ bounds ?DO over I c@ = IF \ found? dup I c! THEN LOOP 2drop ; \ *************************************************************************** \ Toggle-whichcell \ *************************************************************************** : toggle-whichcell ( -- ) which-cell 1 toggle ; : which-register ( -- n ) \ calculate a register number for register which-cell C@ - ; \ use in reo-actiontable \ *************************************************************************** \ Element needed further ? \ This routine checks whether an item on the stack that is going to be \ overwritten is needed in the future. \ *************************************************************************** : needed? ( tbw -- needed ? ) \ where needed? reo-maxi @ swap - reo-actiontable reo-mp @ rot scan ; \ look where needed? \ *************************************************************************** \ write to unneeded stack positions \ in addition to writing a register/helpcell to the target location on the \ stack, the register is also written to all its target positions which can \ be safely overwritten because their current contents is not required \ for any further stack operations. This saves some load operations. \ The test if some stack item is still needed would not be required \ for stack items outside the old stack depth, but as it is very fast \ (needed? uses 'scan' which is a code definition in win32for), \ we use the same algorithm for all stack items, regardless of their \ position in the old/new stack frame. \ *************************************************************************** : write-unneeded ( index -- ) \ write register to unneeded positions reo-mp @ 0 ?DO reo-actiontable I + c@ which-register = IF \ must store here? I needed? nip 0= IF \ this position not needed further? reo-maxi @ I - swap >r $store r> \ store it regsaves incr 0 ELSE dup THEN reo-actiontable I + c! THEN LOOP drop ; : store-item ( index -- ) \ store item to stack >r 0 reo-actiontable reo-maxi @ + r@ - c! r@ $store regsaves incr \ for statistics r> write-unneeded ; \ write also to unneeded positions : load-item ( index -- ) \ load stack item dup which-register act-index \ reference to source will be ref to register $load regloads incr ; \ for statistics : store-tbw ( -- ) \ toggle register and store toggle-whichcell reo-maxi @ reo-tbw @ - \ reo-TBW := reo-MAX - reo-TBW store-item ; \ write previous cell to destination \ *************************************************************************** \ Write element(s) \ This routine is called to put an element into the new position on the \ stack. But as it operates on the part of the stack where the original \ items are located, it saves the current element at the destination before \ putting the new one there. It then checks whether the saved one can be \ put to it's new location (if it is not discarded). So, this routine will \ move from 1 to many items on the stack around before terminating. \ So, a "reorder ( a b c d -- d c b a )" is handled in two calls \ to this routine. It proceeds as follows: \ Upon entrance the current element is the "d". This item is loaded into a \ register/help cell. Before storing it at location "a" the "a" element \ is saved to another register/help cell. This "a" is then stuck \ at the original location of "d" \ and the routine terminates. It gets called a second time to do the rest. \ *************************************************************************** : write-element ( from to -- ) \ write source element 'from' to destination 'to' reo-tbw ! \ to be written: reo-tbw load-item \ load from source toggle-whichcell BEGIN reo-tbw @ needed? \ reo-y:=pos of needed. WHILE \ if so reo-actiontable - >r reo-maxi @ reo-tbw @ - \ reo-TBW := reo-MAX - reo-TBW load-item \ load stack item which is to be overwritten store-tbw \ toggle register and store r> reo-tbw ! \ set tbw to check needed again REPEAT drop store-tbw ; \ toggle register and store \ *************************************************************************** \ set all elements of the new stack \ *************************************************************************** : do-stack ( -- ) BEGIN reo-mp @ while reo-mp decr reo-actiontable reo-mp @ + c@ \ which element should be loaded? ?dup IF reo-mp @ write-element THEN \ element already in right position ? REPEAT ; \ *************************************************************************** \ Interpret actiontable \ This routine works on the actiontable. It does the real work. After dealing \ with stack growth or shrinkage it calls the proper routines to do the \ real action. \ *************************************************************************** : interpret-actiontable ( -- ) reo-mp @ reo-q# @ 2dup max reo-maxi ! \ maximum stack value - reo-d ! \ reo-d=difference stack-depth swap-action-indices reo-d @ 0> IF \ stack increases? reo-d @ $adjust \ adjust stack THEN do-stack \ reorder complete stack reo-d @ 0< IF reo-d @ $adjust THEN ; \ *************************************************************************** \ Main routine \ reo-ts points to start of left sided elements, reo-te after last of them \ after the first loop. reo-q# is count of them, without "--" ! \ *************************************************************************** : reo-w1! ( ^string -- ) \ save counted string to reo-w1 reo-w1 over c@ 1+ cmove ; \ save it in reo-w1 : reorder ( -- ) init-reorder $20 word count S" (" COMPARE IF \ not found a "(" ? reorder1 reo-error exit THEN \ if not, syntax error >in @ reo-ts ! \ set ts BEGIN $20 word \ get next word dup c@ 0= IF \ no more words after "(" ? reorder4 reo-error exit THEN \ if so, error-exit reo-w1! \ save it in reo-w1 reo-w1 count S" --" compare \ word <> "--" ? WHILE reo-w1 count S" )" compare 0= IF \ word = ")"? reorder2 reo-error exit THEN \ if so, syntax error reo-q# incr \ and incr q# >in @ reo-te ! REPEAT BEGIN $20 word \ get word dup c@ 0= IF \ no more words after "(" ? reorder4 reo-error exit THEN \ if so, error-exit reo-w1! \ and save it in buffer reo-w1 reo-w1 count S" )" compare \ word is not ")"? WHILE build-actiontable \ searching left, building actiontable dup IF \ error in build-actiontable? reo-error exit ELSE drop THEN REPEAT $prefix interpret-actiontable \ start the action $suffix ; immediate : ro postpone reorder ; \ no need to type too much immediate \ *************************************************************************** \ Automatic test \ The test is based on some assumptions: \ 1.) The "stack comment" read by reorder is analysed correctly, and \ reo-actiontable is contructed properly. \ 2.) It is not important which numbers are on the stack, as long als \ the input parameters are all different. This test program always uses the \ values 1, ... n for input parameters (n=number of input parameters). \ \ There are 2 versions, for interpret mode and for compile mode \ the compile mode creates code for the reorder to be checked which is executed \ only once and then overwritten with the code for the next reorder. \ \ How it works: \ The test program creates for given numbers of input,output-Parameters n,m \ all possible stack manipulationens and checks reorder with the input \ parameters 1,..,n. \ For this purpose, it sets the input stack and the variables reo-mp and reo-q# \ and calls the funktion 'interpret-actiontable'. The result is verified \ and the stack is cleaned up. If there is an error encountered, the program \ displays the stack operation which caused the error. \ \ For n input and m output parameters, there are n power m possible stack \ manipulations, which correspond to all numbers of m digits to the base n \ To create all of them, we use a structure 'stacktable' similar to \ 'reo-actiontable' after 'build-actiontable', but before 'swap-action-indices'. \ The only difference is that we start counting stack positions with 0 instead of 1. \ We start with 0 and use the function 'incr-stacktable' to count up. \ (Thus we have a very simple implementation of arithmetics for big numbers \ of an arbitrary base up to 255, with the only operation of counting up. \ We don't use forth's arithmetic for this purpose because of the limitation \ to 16 or 32 bits, respectively.) \ Each number representation in 'stacktable' is used to build 'reo-actiontable' \ and to test the corresponding stack manipulation. \ *************************************************************************** 5 value #in-items \ stack input items 8 value #out-items \ stack output items variable reorder-errors \ count errors create stacktable \ a structure similar to the actiontable actiontable-size allot \ after construction by 'build-actiontable' : incr-stacktable ( -- ? ) \ increment stacktable -- return 1 if overflow 1 #out-items 0 ?DO \ add 1 to the least significant digit I stacktable + c@ + #in-items /mod swap I stacktable + c! dup 0= IF LEAVE THEN \ overflow 0 -- it's finished LOOP ; : init-stat ( -- ) \ initialize statistics about load/store ops 0 regloads ! \ how many load operations 0 regsaves ! \ how many save operations 0 savesreq ! ; \ minimum # save operations required : .statistic ( -- ) \ display statistics about load/store ops regloads @ . ." loads, " regsaves @ dup . ." saves" cr savesreq @ = not IF \ the real number of store ops should savesreq @ . ." required saves" cr \ not be bigger than what is required THEN ; \ *************************************************************************** \ 'copy-actiontable' creates a 'real' actiontable from the stacktable \ used to generate all possible stack manipulations \ *************************************************************************** : copy-actiontable ( n -- ) \ create a 'real' actiontable from stacktable reo-actiontable actiontable-size erase \ clear it first 0 ?DO i stacktable + c@ dup i <> IF \ this stack item will change? 1+ i reo-actiontable + c! \ actiontable stack count starts with 1 savesreq incr \ this will require one store operation ELSE drop THEN \ nothing to do LOOP ; : setup-instack ( n -- 1 2 .. n ) \ setup input stack with n parameters 1+ 1 DO i LOOP ; \ *************************************************************************** \ 'do-reorder' leaves a variable number of stack items (depending on the 'stacktable') \ which are consumed by 'check-stack'. Therefore, these words \ must always be used together. \ note: unlike the fpc version, here reo-q# is the number of stack input items \ without the '--'! \ *************************************************************************** : do-reorder ( -- ... ) \ perform 1 test #out-items copy-actiontable \ create reo-actiontable from stacktable #in-items reo-q# ! \ set # input paramters #out-items reo-mp ! \ set # output parameters #in-items setup-instack \ setup input stack interpret-actiontable ; \ run reorder : .stackitems ( n1 n2..nm m -- ) \ display and drop n top stack items dup 0 ?do dup i - roll . loop drop ; : .stackparm ( n -- ) \ display a stack parameter as a,b,c... 'a' + emit bl emit ; : .reo-error ( -- ) \ display information about erroneous #in-items 0 DO i 1+ . LOOP \ stack manipulation by reorder ." reorder ( " #in-items 0 DO i .stackparm LOOP ." -- " stacktable #out-items 0 ?DO dup c@ .stackparm 1+ LOOP drop ." ) returns " depth >r do-reorder r> depth swap - 1- 0 max .stackitems cr ; : .reorder-errors ( -- ) \ display # of errors if any reorder-errors @ ?dup IF . ." reorder-errors" cr THEN ; : check-stack ( ... -- ) \ check if the output stack after reorder stacktable #out-items + \ complies with the stacktable #out-items 0 ?DO 1- dup c@ 1+ rot <> IF reorder-errors incr .reo-error THEN LOOP drop ; : init-reotest ( -- ) \ some initialization for test init-stat \ initialize statistics reorder-errors off \ clear error count stacktable actiontable-size erase ; \ start with 0 : reo-test ( -- ) \ perform test for #in-items and #out-items init-reotest \ initialization for test BEGIN depth >r do-reorder \ perform 1 reorder in interpret mode check-stack \ check the reorder result depth r> <> abort" stack error" incr-stacktable UNTIL .reorder-errors ; \ display # of errors if any : .#inparms ( -- ) \ display current # of input parameters #in-items . ." input parameters" cr ; : .#outparms ( -- ) \ display current # of output parameters #out-items . ." output parameters" cr ; : testit ( -- ) \ test for different output stack depths .#inparms \ display current # of input parameters 8 3 DO \ test for these output items init-stat \ initialize statistics i to #out-items \ set stack output items .#outparms \ display current # of output parameters reo-test \ perform test, interpret mode .statistic \ display statistic results LOOP ; \ *************************************************************************** \ Assembler code generation \ The following test works similar to the above test, but \ compiles code for each stack reorder to be checked. \ The compiled code is executed only once and then overwritten with \ the instructions for the next test. \ *************************************************************************** : next, ( -- ) \ compile next $8b c, $06 c, \ mov eax, [esi] $83 c, $c6 c, $04 c, \ add esi, # 4 $8b c, $0c c, $38 c, \ mov ecx, [eax] [edi] $03 c, $cf c, \ add ecx, edi $ff c, $e1 c, ; \ jmp ecx 0 value save-here \ remember current dictionary size 0 value patchit \ address to be patched with code for reorder : reo-execute ( -- ) \ execute compiled reorder operation [ here to patchit ] noop ; \ this will be patched to execute reorder : compiled-reorder ( -- ...) \ compile reorder code and perform 1 test here to save-here \ remember current dictionary size here cell+ , \ indirect threaded state @ >r \ save current state state on \ switch to compile mode do-reorder \ compile code for reorder r> state ! \ restore state next, \ compile next save-here patchit ! \ patch reo-execute to execute reorder reo-execute \ execute compiled reorder operation save-here here - allot ; \ remove compiled assembler code : reo-ctest ( -- ) \ like reo-test, but with code compilation init-reotest \ initialization for test BEGIN depth >r compiled-reorder \ compile reorder code and perform 1 test check-stack \ check the reorder result depth r> <> abort" stack error" incr-stacktable UNTIL .reorder-errors ; \ display # of errors if any : ctestit ( -- ) \ test for different output stack depths .#inparms \ display current # of input parameters 8 3 DO \ test for these output items init-stat \ initialize statistics i to #out-items \ set stack output items .#outparms \ display current # of output parameters reo-ctest \ perform test, compile mode .statistic \ display statistic results LOOP ; \ *************************************************************************** \ runtime primitives for REORDER in compile mode \ these primitives implement stack operations (load, store and adjust stack) \ thus inline assembly is not required \ but inline assembly is usually faster and more compact \ this code is only included for completeness \ *************************************************************************** (( IN-APPLICATION CODE [adjust-SP] ( n -- ) \ n bytes! push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS sub esp, ebx pop ebx \ necessary for shinking stack! exec ;c CODE [-pick00] ( -- ) \ stack index is 0 nextip mov help-cell [edi], ebx exec ;c CODE [-pick01] ( -- ) \ stack index is 0 nextip mov help-cell CELL+ [edi], ebx exec ;c CODE [-pick0] ( -- ) push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS mov ecx, [ebx*4] [esp] mov help-cell [edi], ecx pop ebx exec ;c CODE [-pick1] ( -- ) push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS mov ecx, [ebx*4] [esp] mov help-cell CELL+ [edi], ecx pop ebx exec ;c CODE [stick00] ( -- ) nextip mov ebx, help-cell [edi] exec ;c CODE [stick01] ( -- ) nextip mov ebx, help-cell CELL+ [edi] exec ;c CODE [stick0] ( -- ) push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS mov ecx, help-cell [edi] mov [ebx*4] [esp], ecx pop ebx exec ;c CODE [stick1] ( -- ) push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS mov ecx, help-cell CELL+ [edi] mov [ebx*4] [esp], ecx pop ebx exec ;c \ *************************************************************************** \ Words for REORDER in compiling mode \ *************************************************************************** IN-SYSTEM : win32$load ( offset -- ) state @ IF \ compiling or interpreting 1- ?DUP IF which-cell c@ IF COMPILE [-pick1] ELSE COMPILE [-pick0] THEN , ELSE which-cell c@ IF COMPILE [-pick01] ELSE COMPILE [-pick00] THEN THEN ELSE -pick THEN ; : win32$store ( offset -- ) state @ IF 1- ?DUP IF which-cell c@ IF COMPILE [stick1] ELSE COMPILE [stick0] THEN , ELSE which-cell c@ IF COMPILE [stick01] ELSE COMPILE [stick00] THEN THEN ELSE stick THEN ; : win32$adjust-sp ( n -- ) \ increment stack by n cells state @ IF COMPILE [adjust-sp] CELLS , ELSE adjust-sp THEN ; ' win32$load is $load ' win32$store is $store ' win32$adjust-sp is $adjust ' noop is $suffix ' noop is $prefix )) \ *************************************************************************** \ words for compiling inline assembler, indirect threaded forth model \ the few instructions used here are compiled directly, without \ a 'real' assembler \ it handles the special case tos (top of stack) in register ebx \ *************************************************************************** \ : verbose ; \ display assembler instructions \ uncomment this line if you want to see what is compiled : load-eax ( offset -- ) \ load register eax from stack $8B C, \ mov reg, mem ?DUP IF \+ verbose ." mov eax, " dup . ." [esp]" cr $44 C, $24 C, C, \ mov eax, nn [esp] ELSE \ a little shorter, without offset \+ verbose ." mov eax, [esp]" cr $04 C, $24 C, \ mov eax, [esp] THEN ; : load-ecx ( offset -- ) \ load register ecx from stack $8B C, \ mov reg, mem ?DUP IF \+ verbose ." mov ecx, " dup . ." [esp]" cr $4C C, $24 C, C, \ mov ecx, nn [esp] ELSE \ a little shorter, without offset \+ verbose ." mov ecx, [esp]" cr $0C C, $24 C, \ move ecx, [esp] THEN ; : load-tos ( -- ) \ load TOS to register $8B C, \ mov reg, reg which-cell c@ IF \+ verbose ." mov ecx, ebx" cr $CB C, \ mov ecx, ebx ELSE \+ verbose ." mov eax, ebx" cr $C3 C, \ mov eax, ebx THEN ; : asm$load, ( offset -- ) \ assemble load code 1- ?DUP IF 1- CELLS which-cell c@ IF load-ecx ELSE load-eax THEN ELSE load-tos \ TOS, directly load ebx THEN ; : asm$load ( offset -- ) state @ IF asm$load, \ compiling or interpreting ELSE -pick THEN ; : store-ecx ( offset -- ) $89 C, \ mov mem, reg ?DUP IF \+ verbose ." mov " dup . ." [esp], ecx" cr $4C C, $24 C, C, \ mov nn [esp], ecx ELSE \+ verbose ." mov [esp], ecx" cr $0C C, $24 C, \ mov [esp], ecx THEN ; : store-eax ( offset -- ) $89 C, \ mov mem, reg ?DUP IF \+ verbose ." mov " dup . ." [esp], eax" cr $44 C, $24 C, C, \ mov nn [esp], eax ELSE \+ verbose ." mov [esp], eax" cr $04 C, $24 C, \ mov [esp], eax THEN ; : store-tos ( -- ) $8B C, \ mov reg, reg which-cell c@ IF \+ verbose ." mov ebx, ecx" cr $D9 C, \ mov ebx, ecx ELSE \+ verbose ." mov ebx, eax" cr $D8 C, \ mov ebx, eax THEN ; : asm$store, ( offset -- ) 1- ?DUP IF 1- CELLS which-cell c@ IF store-ecx ELSE store-eax THEN ELSE store-tos \ TOS THEN ; : asm$store ( offset -- ) state @ IF asm$store, ELSE stick THEN ; : asm$adjust-sp, ( n -- ) \ increment stack by n cells \ S" $adjust-sp: " _TYPE DUP . _CR ?DUP IF CELLS DUP 0< IF \ add it to sp ABS CELL- ?DUP IF \ something to do? \+ verbose ." add esp, # " dup . cr $83 C, $C4 C, C, \ add esp, # nn THEN \+ verbose ." pop ebx" cr $5B C, \ pop ebx ELSE \ >0 \+ verbose ." push ebx" cr $53 C, \ push ebx CELL- ?DUP IF \+ verbose ." sub esp, # " dup . cr $83 C, $EC C, C, \ sub esp, # nn THEN THEN THEN ; : asm$adjust-sp ( n -- ) \ increment stack by n cells state @ IF asm$adjust-sp, ELSE adjust-sp THEN ; variable inline-addr \ remember starting address of inline code \ to calculate the offset to add to esi : inline ( -- ) \ compile inline code, indirect threaded here cell+ , \ requires 8 bytes here inline-addr ! \ save 'cfa' of inline code here cell+ , ; \ here the code starts : -inline ( -- ) \ end of inline code $81 c, $c6 c, \ add esi, #dword here >r \ here patch the value to be added to esi cell allot \ #dword to be added $8b c, $46 c, $fc c, \ mov eax, -4 [esi] esi already points to next cfa $8b c, $0c c, $38 c, \ mov ecx, [eax] [edi] $03 c, $cf c, \ add ecx, edi $ff c, $e1 c, \ jmp ecx align here inline-addr @ - cell+ r> ! \ patch #dword to be added to esi \+ verbose inline-addr @ (see) \ see what has been compiled ; : asm$prefix ( -- ) state @ IF inline THEN ; : asm$suffix ( -- ) state @ IF -inline THEN ; ' asm$load is $load ' asm$store is $store ' asm$adjust-sp is $adjust ' asm$suffix is $suffix ' asm$prefix is $prefix IN-APPLICATION