\ ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» \ º º \ º REORDER for F-PC Last Revision: 16-FEB-1991 KDM º \ º 20-May-2001 UP º \ º ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ º \ º º \ º Author: Idea and DOS-special words: º \ º Klaus M”dinger Ulrich Paul º \ º Karwendelstr. 103 Erlenweg 18 º \ º 86163 Augsburg 86391 Stadtbergen º \ º Germany Germany º \ º º \ º Bug detected by Heinrich M”ller on 17-May-2001 ( Ten years in the º \ º field! ) º \ º Fixed by Ulrich Paul on 20-May-2001 º \ º A lot of comments added, too. º \ º º \ º Test program added by Heinrich Moeller on May 25, 2001 º \ ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ \ *************************************************************************** \ Deferred words for stack manipulations \ *************************************************************************** defer $adjust defer $load defer $store defer $prefix defer $suffix \ *************************************************************************** \ Variables \ *************************************************************************** 2variable regloads 2variable regsaves create reo-actiontable $30 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 \ same as "help-cell 4 allot", but \ this would imply a 16bit arch. 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-x variable reo-y variable reo-src variable reo-tbw variable reo-h# variable reo-last 1 constant reorder1 \ Constants for error-handling 2 constant reorder2 3 constant reorder3 4 constant reorder4 \ *************************************************************************** \ Words for REORDER in direct mode \ *************************************************************************** : adjust-SP ( n -- ) 1- 2* \ correct n to include its space sp@ swap - sp! ; : -pick ( offs -- ) 2* sp@ + @ which-cell @ 1 and 2* help-cell + ! ; : stick ( offs -- ) 2* sp@ + which-cell @ 1 and 2* help-cell + @ swap ! ; \ *************************************************************************** \ Words for REORDER in compiling mode \ *************************************************************************** : dose$store ( offs -- ) 1- 2* $89 c, \ MOV which-cell @ IF $56 ELSE $4E THEN c, c, ; : dose$load ( offs -- ) 1- 2* $8B c, \ MOV which-cell @ IF $56 ELSE $4E THEN c, c, ; : dos$load state @ \ compiling or interpreting IF dose$load ELSE -pick THEN 1. regloads d+! ; : dos$store state @ IF dose$store ELSE stick THEN 1. regsaves d+! ; : dose$adjust-sp 2* negate $81 c, $c5 c, , ; : dos$adjust-sp state @ IF dose$adjust-sp ELSE adjust-sp THEN ; : dose$prefix state @ IF here x, \ enter code adr into X-list $87 c, $ec c, \ xchg rp,sp THEN ; : dose$suffix state @ IF $87 c, $EC c, \ xchg rp,sp $26 c, $AD c, $FF c, $E0 c, \ NEXT THEN ; : strcompare ( csa1 csa2 -- n ) dup c@ \ csa1 csa2 len 1+ comp \ include count byte into comparison! ; \ *************************************************************************** \ 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 $30 0 fill 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. \ *************************************************************************** : build-actiontable 1 reo-e# ! >in @ reo-tsav ! \ save >in-pointer reo-ts @ >in ! \ reset >in to just after "(" reo-mp @ reo-q# @ 1- < \ are we still in the old stack range? IF \ if we are, we check if element stays reo-mp @ 1+ 0 \ so we skip all words before it DO $20 word dup c@ 1+ reo-w2 swap cmove LOOP \ on exit reo-w2 contains element reo-w1 reo-w2 strcompare 0= \ compare it to the newly found at right IF \ if both are the same, the elem. does not change places 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 exit \ leave 0 ( = no error ) THEN reo-ts @ >in ! \ element does not stay, rescan THEN BEGIN \ $20 word dup c@ 1+ reo-w2 \ scan words left of -- swap cmove \ save found word in reo-w2 reo-w1 reo-w2 strcompare 0<> \ compare currently regarded entry \ right of -- with entries left of -- WHILE \ while no matches >in @ reo-te @ = \ looked up all entries ? IF reorder3 exit THEN \ right entry without left equivalent reo-e# incr \ increment reo-e# REPEAT \ loop until right elem. is found left 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 ) \ *************************************************************************** \ 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 \ the actiontable is still in LR state reo-mp @ 0 \ We process the full actiontable DO reo-actiontable I + dup c@ dup 0= \ get actioncode from table IF \ do nothing if NOP (=0) drop drop \ simply drop adr and actioncode ELSE reo-maxi @ 1+ \ else substitute by maxi - actioncode swap - swap c! \ this references elements from TOS THEN LOOP ; \ *************************************************************************** \ Actualize index in actiontable after stack-manipulation \ When we move an item to a new place we must update the actiontable so that \ the item is found at it's new index. There arises one problem: \ Assume the following situation: reorder ( a b c -- c a b ) \ The actiontable contains these values: 1 3 2 at the beginning. We now \ start processing it from right to left. The 2 indicates where the rightmost \ item comes from ( 2 from TOS ). It is to written to 1 from TOS, but there \ is currently our "c". We save that, overwrite it by "b" and update the \ actiontable to reflect where b can be found from now on ( 1 from TOS ). \ That is correct, but now we have an actiontable of 1 3 1, which is not \ correct! The two 1s denominate different locations! This is the reason \ why we set the most significant bit for all indices that are the result \ of the index updating procedure. This prevents all already updated \ indices to being updated another time erratically. An index cannot need \ more than one update under all circumstances. \ *************************************************************************** : act-index reo-q# @ 0 \ loop over all elements on left side ?DO reo-actiontable I + \ point to next element c@ reo-last @ = \ is it the same as the previous one? IF \ if so, then reo-tbw @ $80 or \ get element-# to be written, set MSB reo-actiontable I + c! \ and store it there THEN LOOP ; \ *************************************************************************** \ Toggle-whichcell \ *************************************************************************** : toggle-whichcell which-cell @ -1 xor which-cell ! ; \ *************************************************************************** \ Set to be written \ This code does the physical write of an element at it's target destination. \ It is used in 2 contexts, one where TBW already is in logical format \ ( = from TOS ) and the other where it is in absolut format ( = index into \ the actiontable ). The H# is used to tell these apart. \ *************************************************************************** : set-tbw reo-h# @ 0= \ get setting of help switch IF \ if TBW in absolut format reo-maxi @ reo-tbw @ - reo-tbw ! \ then convert it into logical format ELSE \ if set 0 reo-h# ! \ simpy reset it (safety measure) THEN reo-tbw @ $store \ pysically put item into place act-index \ update the indices in actiontable 0 reo-actiontable reo-maxi @ reo-tbw @ - + c! \ set cur opcode to NOP ; \ *************************************************************************** \ Element needed further ? \ This routine checks whether an item on the stack that is going to be \ overwritten is needed in the future. If so \ reo-y points to the next location in actiontable where reo-tbw is needed \ for storage. The AND with $7F clears the MSB, that was set in "act-index" \ as a measure to prevent multiple updates of one index. \ *************************************************************************** : f-needed? reo-mp @ reo-y ! \ we scan from the mainpointer down BEGIN reo-y decr \ decr our work ptr reo-actiontable reo-y @ + c@ $7f and \ get next element from table reo-maxi @ reo-tbw @ - = \ is it the same as the to be written? not \ continue if not WHILE reo-y @ -1 = IF exit THEN \ exit also, if full table scanned REPEAT \ repeat till another position found ; \ *************************************************************************** \ 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 \ help cell. Before storing it at location "a" the "a" element is saved to \ another 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 reo-mp @ reo-tbw ! \ reo-tbw := current item pos. reo-src @ $load \ get item from stack into a help cell toggle-whichcell \ switch to the other cell reo-src @ reo-last ! \ save src for index update BEGIN \ now try to put the item into place f-needed? \ reo-y:=pos of needed now reo-y @ -1 <> \ element at reo-tbw furthermore needed? WHILE \ if so 1 reo-h# ! \ reo-maxi @ reo-tbw @ - reo-tbw ! \ change from absolut to logical index reo-tbw @ $load \ load current item into a help cell toggle-whichcell \ switch to the other help cell set-tbw \ put the item into the stack reo-tbw @ reo-last ! \ save current pos reo-y @ reo-tbw ! \ make the next needed index the current REPEAT toggle-whichcell \ switch to the other help cell set-tbw \ and store last item ; \ *************************************************************************** \ Do head ( all elements in limits of old stack-depth ) \ This routine manages all elements that stay within the original boundaries \ of the stack. It must take care not to overwrite an element that is needed \ later. The AND with $7F clears the MSB that was set by "act-index" to \ prevent multiple updates of one index. \ *************************************************************************** : do-head reo-q# @ 1- reo-mp ! \ set main pointer to num of elements 0 reo-h# ! 0 which-cell ! \ reset important vars BEGIN \ process all elements on orig. stack reo-mp decr \ decr. main pointer reo-actiontable reo-mp @ + \ get current action code c@ $7f and reo-src ! \ ckear MSB and save it reo-src @ 0= \ element already in right position ? not \ is indicated by 0 as index IF write-element THEN \ if not, put it there, but save old element reo-mp @ 0= \ all elements processed? UNTIL \ loop until all processed ; \ *************************************************************************** \ Do tail ( all elements right of old stack-depth, if stack has increased \ This routine is called if there are more elements on the stack afterwards \ The algorithm here is a bit tricky: \ for each element on the left side of "--", going from the current TOS down, \ we search all occurrances of it on the right side, but only in the part that \ lies in the additional stack space. The rest is done by do-tail. \ Whenever we find an occurrance we copy the stack item to the new location. \ Note: the original stack is NOT modified - all items lie in the same order \ there afterwards. \ so "reorder ( a b c -- c c a a )" makes the stack ( a b c a ) at the end of \ this routine. \ *************************************************************************** : do-tail BEGIN \ scan left sided elements from TOS down reo-mp decr \ decr. main pointer reo-mp @ reo-q# @ 2- = \ only 1 element left? ( it is "--" ) IF exit THEN \ yes, done reo-actiontable reo-mp @ + c@ reo-src ! \ save elem. pos. reo-src @ 0= not \ position=0 indicates NOP UNTIL \ rightmost nonzero element found on leave reo-src @ $load \ get the stack item into a help cell reo-maxi @ reo-mp @ - $store \ and put it into the new location reo-mp @ reo-x ! \ copy the current main pointer BEGIN \ search for more occurrances of item reo-x decr \ decrement work counter reo-x @ reo-q# @ 2 - = \ only 1 element left? ( it is "--" ) IF recurse exit THEN \ if all copies of curr. elem. written, call ourselves reo-actiontable reo-x @ + c@ reo-src @ = \ is copy of elem. at reo-x needed? IF \ yes, found one more occurrence 0 reo-actiontable reo-x @ + c! \ overwrite actioncode with NOP reo-maxi @ reo-x @ - reo-y ! \ save location of copy reo-y @ $store \ stick the new item into the stack THEN 0 UNTIL \ loop unconditionally ; \ *************************************************************************** \ 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# @ - 1+ reo-d ! \ reo-d=difference in stack-depth reo-d @ 0> \ stack increases? IF \ yes, stack grows reo-d @ $adjust \ point the SP to the new pos reo-mp @ reo-maxi ! \ save the total count of elements swap-action-indices \ adjust indices to be relative of new TOS do-tail \ process the excess elements first ELSE \ stack doesn't grow reo-mp @ 0= \ stack empty after reorder? IF reo-d @ $adjust exit THEN \ yes, so simply adjust the SP, done reo-mp @ reo-d @ - reo-maxi ! \ max=mp-d = num of elem. at end on stack swap-action-indices \ adjust indices to be relative to new TOS THEN \ actiontable adjusted now do-head \ process elements, that stay in old stack depth reo-d @ 0< IF reo-d @ $adjust THEN \ if stack shrunk, adjust SP now ; \ *************************************************************************** \ 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, incl "--" ! \ *************************************************************************** : reorder ( -- ) init-reorder $20 word " (" ">$ strcompare 0<> \ found a "(" ? IF reorder1 reo-error exit THEN \ if not, syntax error >in @ reo-ts ! \ set ts BEGIN \ scan current stack configuration $20 word \ get next word dup c@ 0= \ something found at all? IF reorder4 reo-error exit THEN \ no more words after "(" ? --> error dup c@ 1+ reo-w1 swap cmove \ save new word in reo-w1 reo-q# incr \ and incr words found so far reo-w1 " --" ">$ strcompare 0<> \ word <> "--" ? WHILE \ loop until "--" found reo-w1 " )" ">$ strcompare 0= \ word = ")"? i.e. no "--" found IF reorder2 reo-error exit THEN \ if so, syntax error >in @ reo-te ! \ save current inpointer REPEAT \ "--" found when leaving this loop BEGIN \ scan the new stack configuration $20 word \ get word dup c@ 0= IF reorder4 reo-error exit THEN \ no more words after "--" ? --> error dup c@ 1+ reo-w1 swap cmove \ and save new word in buffer reo-w1 reo-w1 " )" ">$ strcompare 0<> \ word is not ")"? WHILE \ loop until ")" found build-actiontable \ searching left, building actiontable dup 0<> \ error in build-actiontable? IF reo-error exit ELSE drop THEN \ exit on error, else drop error code REPEAT \ all elements scanned on leave of loop $prefix \ do machine specific setup interpret-actiontable \ start the action $suffix \ do machine specific cleanup ; immediate \ *************************************************************************** \ Init. deferred words for MS-DOS-machine \ *************************************************************************** ' dos$load is $load ' dos$store is $store ' dos$adjust-sp is $adjust ' dose$suffix is $suffix ' dose$prefix is $prefix \ As this test is only important for people porting the code to other platforms \ it is commented out by default. comment: \ *************************************************************************** \ 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). \ 3.) The code generation in compile mode is not tested; \ only the interpret mode is checked. \ 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. \ *************************************************************************** 4 value #in-items \ stack input items 8 value #out-items \ stack output items $30 constant actiontable-size 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 ; 2variable savesreq \ how many save operations are required? : init-stat ( -- ) \ initialise statistics about load/store ops 0. regloads 2! \ how many load operations 0. regsaves 2! \ how many save operations 0. savesreq 2! ; \ minimum # save operations required : .statistic ( -- ) \ display statistics about load/store ops regloads 2@ d. ." loads, " regsaves 2@ 2dup d. ." saves" cr savesreq 2@ d= not IF savesreq 2@ d. ." required saves" cr THEN ; : 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 remains unchanged? 1+ i reo-actiontable + c! 1. savesreq d+! 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 ( -- ) \ perform 1 test #out-items copy-actiontable \ create reo-actiontable from stacktable #in-items 1+ 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 ; : reo-test ( -- ) \ perform test for #in-items and #out-items init-stat \ initialise statistics reorder-errors off \ clear error count stacktable actiontable-size erase \ start with 0 BEGIN do-reorder \ perform 1 test check-stack \ check the reorder result incr-stacktable UNTIL .reorder-errors ; \ display # of errors if any : testit ( -- ) 7 3 DO \ test for these output items i . ." output parameters" cr init-stat i !> #out-items \ set stack output items reo-test .statistic LOOP ; comment;