**********************************************************************
* Name: ORD
* Stack: ( {names} --> )
* Description: Replacement for slow HP ORDER
* To do:
* - last-ramword handling in machine language?
*
* Timing samples for <-LIB-> after L->DIR (~80 variables, SX)
*
* HP ORD
* Reversing order: 124s 6.8s
* Redundant: 117s 1.4s
*
* The redundant case changes the order of the last 2 variables only
**********************************************************************
ASSEMBLE
sGX EQU 8 GX ?
fUSEIRAM EQU 1 Use IRAM in BLKSWAP?
fCKPORT EQU 2 Check that context isn't in a port?
SETFLAG fUSEIRAM Yes
RPL
ASSEMBLE
CON(1) 8
RPL
xNAME ORD
::
CK1
:: CK&DISPATCH0
FIVE NOP
SIX ONE{}N ( Allow idnt as arg too )
;
* First handle the new lastram-word
DUP CARCOMP
DUPTYPEIDNT? ?SKIP SETTYPEERR ( Error if not idnt )
DoHere: DUP@ ?SKIP SETNONEXTERR ( Error if not variable )
* ( {ids} id1 ob1 )
DUPTYPERRP? ( --> {} id ob rrp? )
SWAP REFERENCED? ( --> {} id rrp? ob ref? )
ROTAND ITE
MOVERRP
:: OVER PURGE SWAP CREATE ;
* ( {ids} )
* The code cannot order itself
* Make a copy of code to tempob if necessary
* (Could do it always to save a couple nibbles..)
CODE
GOSBVL =SAVPTR
GOSUB GETRRP&LAST B[A]=->context C[A]=->lastram-name
D0=C
GOSBVL =TRAVERSE+ D0 = ->lastram-word
GOSBVL =SKIPOB
CD0EX C[A] = ->contexttail
A=PC
?A<B A pc < context ?
GOYES in100
?A>C A pc > contexttail ?
GOYES in100
in100 GOVLNG =GPPushT/FLp Push F if in context
ENDCODE
?SKIP :: 'R TOTEMPOB EVAL ; ( Evaluate code from tempob )
( Normal evaluate )
* Each slot in userob is:
*
* [Name][Object][Link]
*
* Moving the variable to upper userob:
*
* Start: [Name1][Ob1][Link1][Name2]..[NameN][ObN][LinkN]
* End: [Name2][Ob2]..[NameN][ObN][LinkN][Name1][Ob1][Link1]
*
* = Swap blocks: ->Name1 ->Name2 ->LinkN+5
*
* If someone would like to implement it all in ml:
*
* Moving the variable to lastram-word:
*
* Start: [Off]...[Name1][Ob1][Link1][Name2]..[LinkL][NameN][ObN][Extra5]
* End: [Off']..[Name2][Ob2]..[NameN][ObN][Extra5][Name1][Ob1][Link1]
*
* = Fix: Replace Link1 with Extra5 before swap
* Replace Extra5 with LinkN before swap
* Off = Off + LinkN - Link1 before swap
* = Swap blocks: ->Name1 ->Name2 ->ObNtail+5
* Note that the extra 5 nibbles may be referenced. Thus the PTRADJUST2 call
* must use the correct endaddress of the context.
*
CODE
* R0 & R1 used by BLKSWAP
* R2 free
* R3[A] = ->idnt (sequence)
* R4[A] = ->next tail address
* Setup idnt list
GOSBVL =PopASavptr
A=A+CON A,10
R3=A R3[A] = ->idnt1_body
* Setup next free location
GOSUB GETRRP&LAST B[A]= ->context C[A]= ->last-ramname
R4=C R4[A] = ->lastram-name
GOSUB SETSXGX Setup sGX
* Disable ON-C
LC(1) #F
GOSUB SETINITEN
* Note! 1st idnt has already been handled so skipob starts the loop
ORDERLOOP GOSBVL =chk_attn
GOC ORDEREXIT
A=R3
D0=A D0 = ->idnt_body
D0=D0- 5
GOSBVL =SKIPOB
A=DAT0 A
LC(5) =SEMI
?A=C A
GOYES ORDEREXIT Found SEMI - done
LC(4) =DOIDNT
?A#C A
GOYES ORDERERR Not id! Error
D0=D0+ 5
AD0EX
R3=A R3[A] = ->idnt_body
R0=A * For FIND
GOSUB GETCONTEXT A[A] = ->context
GOSUB FIND D0 = ->Ob1 D[A] = ->Name1
GOC ORDERERR Not variable! Error
GOSBVL =SKIPOB
D0=D0+ 5
C=D A
CD0EX D0 = ->Name1 C[A] = ->Name2
D1=C D1 = ->Name2
A=R4 A[A] = ->next
?C>=A A Special case?
GOYES ORDERSPC
C=A-C A C[A] = nibbles2 = next-Name2
* Also update ->next to be ->Name1 + nibbles2
AD0EX A[A] = ->Name1
D0=A
A=A+C A
R4=A.F A R4[A] = ->next'
GOSUB BLKSWAP+
GOTO ORDERLOOP
ORDEREXIT C=0 P
GOSUB SETINITEN Enable ON-C
GOVLNG =GETPTRLOOP
ORDERERR GOSBVL =GETPTR
GOVLNG (=SYNTAXERR)+5
* Special cases:
* 1) Variable is already at it's final location
* Then ->Name2 = ->next
* Solution: set ->next = ->Name1 & continue
* 2) Duplicate ids in the list
* Then ->Name1 > ->next
* Assuming above check is already made then ->Name2 > ->next
* Solution: keep ->next the same & continue
ORDERSPC ?C#A A ->Name2 <> ->next?
GOYES sp100 Yes - duplicate idnt, keep ->next
AD0EX Already at right place..
R4=A Set ->next = ->Name1
sp100 GOTO ORDERLOOP
****************************************
FIND ?ST=1 sGX
GOYES ff100
GOVLNG =S_FIND D0 = ->Ob D[A]=->Name
ff100 GOVLNG =G_FIND CS if not found
****************************************
GETRRP&LAST GOSUB GETCONTEXT
B=A A B[A] = ->context
GOSBVL =FNDLOPTR
A=DAT0 A A[A] = offset
CD0EX
C=C+A A C[A] = ->last-ramname
RTN
****************************************
GETCONTEXT D0=(5) =aCONTEXT
A=DAT0 A
D0=A
A=DAT0 A
RTN
****************************************
SETINITEN D0=(5) =INITEN
?ST=0 sGX
GOYES si100
D0=(5) =G_INITEN
si100 DAT0=C 1
RTN
**********************************************************************
SETSXGX ST=0 sGX Assume SX
D0=(5) =IRAM@
A=DAT0 S 7 for S, 8 for G
A=A+A S
RTNNC
ST=1 sGX Set GX
RTN
**********************************************************************
* Swap contiguous memory blocks in place.
* Entry: D0= ->block1 (lower)
* D1= ->block2 (higher)
* C[A]= size of block2
* Alters: A[W] C[W] B[A] D[A]
* Stack: 1 (BLKswap)
* Algorithm:
*
* If block2 is smaller than (or equal to) block1 then
* swap block2 and start of block1
* recalculate nibbles1, return block2 pointer back and restart
* x y
* Start: 1234567890123456789ABCDEF
* End: ABCDEF7890123456789123456
* x y
* Else
* swap block1 and start of block2
* recalculate nibbles2 and restart
* x y
* Start: ABCDEF1234567890123456789
* End: 123456ABCDEF7890123456789
* x y
* Final result:
* x y
* Start: 1234567890123456789ABCDEF
* Final: ABCDEF1234567890123456789
* x
*
* Performance can be poor if one of the blocks is small.
* Setting compiler flag fUSEIRAM enables special code when either
* block is smaller than #100 nibbles. IRAMBUFF is then used as a buffer
* for the smaller block to do a buffered block swap.
*
**********************************************************************
* PTRADJUST2:
* Entry: A[A]= ->block1 B[A]= ->block1tail C[A]= offs1
* R0[A]= ->block2 R1[A]= ->block2tail D0= offs2
* Exit:
* All same as entry except C[A] moved to D[A]
* Uses:
* D1 C[15-14]
* Applied:
* Entry: A[A]= ->block1 B[A]= ->block2 C[A]= nibbles2
* R0[A]= ->block2 R1[A]= ->block2tail D0= -nibbles1
BLKSWAP+ ?C=0 A
RTNYES
AD1EX
B=A A B[A] = ->block2
R0=A R0[A] = ->block2
RSTK=C
C=C+A A
R1=C R1[A] = ->block2tail
AD0EX A[A] = ->block1
C=R0
C=C-A A
C=-C A
D0=C D0 = -nibbles1
C=RSTK C[A] = nibbles2
GOSBVL =PTRADJUST2
* Restore entry conditions for BLKSWAP
D0=A D0 = ->block1
A=B A
D1=A D1 = ->block2
C=D A C[A] = nibbles2
BLKSWAP B=C A B[A] = nibbles2 during loop
BLKswaplp ?B=0 A * Done if nibbles2 = 0
RTNYES
AD0EX
D0=A
CD1EX
D1=C
C=C-A A C[A] = nibbles1
?C=0 A * Done if nibbles1 = 0
RTNYES
?C>=B A * nibbles1 >= nibbles2 ?
GOYES BLKup&back * Swap block & D1 comes back
IF fUSEIRAM
A=C A
A=0 B
?A=0 A
GOYES BLKiram1 * Use IRAM if nibbles1 < #100
ENDIF
B=B-C A * Block 2 becomes smaller
GOSUB BLKswap * swap blocks of size nibbles1
GONC BLKswaplp
BLKup&back
IF fUSEIRAM
A=B A
A=0 B
?A=0 A
GOYES BLKiram2 * Use IRAM if nibbles2 < #100
ENDIF
C=B A * nibbles2
GOSUB BLKswap
CD1EX * D1 back to where it was
C=C-B A
CD1EX
GONC BLKswaplp
IF fUSEIRAM
* nibbles1 < #100. block1 to IRAM, block2 down, block1 to end
BLKiram1 R0=C R0[A] = nibbles1
CD0EX
R1=C R1[A] = ->block1
D0=C
GOSUB GETIRAM
D1=C
C=R0
GOSBVL =MOVEDOWN Buffered block1, D0 = ->block2
A=R1
D1=A D1 = ->block1
C=B A C[A] = nibbles2
GOSBVL =MOVEDOWN D1 = ->block2tail'
GOSUB GETIRAM
D0=C
C=R0 C[A] = nibbles1
GOVLNG =MOVEDOWN
* nibbles2 < #100. block2 to IRAM, block1 up, block2 to bottom
BLKiram2 R0=C R0[A] = nibbles1
CD1EX
R1=C R1[A] = ->block2
D0=C D0 = ->block2
GOSUB GETIRAM
D1=C
C=B A C[A] = nibbles2
GOSBVL =MOVEDOWN D0 = ->block2tail
C=R1
CD0EX D0 = ->block2
D1=C D1 = ->block2tail = ->block1tail'
C=R0
GOSBVL =MOVEUP D0 = ->block1
GOSUB GETIRAM
CD0EX D0 = ->buffer
D1=C D1 = ->block1
C=B A C[A] = nibbles2
GOVLNG =MOVEDOWN
GETIRAM LC(5) =IRAMBUFF
?ST=0 sGX
RTNYES
LC(5) =G_IRAMBUFF
RTN
ENDIF
**********************************************************************
* Swap equal size blocks
* Entry: D0= ->blk1 D1= ->blk2 C[A]= nibbles
* Exit: D0= ->blk1 tail D1= ->blk2 tail CC
* Alters: A[W] C[W] D[A] P CRY
**********************************************************************
BLKswap C=C-1 A
GOC BLKupdone * Nothing to swap
P=C 0 * P=nibs
CSR A * C[A]=words
D=C A
D=D-1 A
GOC BLKupwrd * Swap the last <= 16 nibbles
BLKuplp A=DAT0 W * Modified MOVEDOWN code
C=DAT1 W
DAT0=C W
DAT1=A W
D0=D0+ 16
D1=D1+ 16
D=D-1 B
GONC BLKuplp
D=D-1 XS
GONC BLKuplp
D=D+1 X
D=D-1 A
GONC BLKuplp
BLKupwrd A=DAT0 WP
C=DAT1 WP
DAT0=C WP
DAT1=A WP
CD0EX
C+P+1
D0=C
CD1EX
C+P+1
D1=C
BLKupdone P= 0
RTNCC
**********************************************************************
ENDCODE
;
