HPHP48-P,*≡├ASSEMBLE
=aFIXHOOK EQU #16735
=xNEG EQU #1A995
=xi EQU #1AB45
=x+ EQU #1AB67
=x* EQU #1ADEE
=xSQRT EQU #1B374
=TestSysClr EQU #1C4EC
=XEQARRAY> EQU #1D0AB
=XEQC%V> EQU #1DD29
=aFLOOR EQU #2B767
=SPLITC EQU #2BCAC
=putop: EQU #5E51C
=putop2: EQU #5E530
=verysyminner EQU #5F2A3
=veryunsymin EQU #5F2EE
RPL
xROMID 905
xTITLE QPI v4.2'Fin
xCONFIG CfgPi
LABEL CfgPi
:: 905 TOSRRP ;
*********************************
ASSEMBLE
CON(1) 8
RPL
xNAME QPI
::
CK1&Dispatch
ONE Qpi%
TWO Qpi
EIGHT NOP
TEN
::
verysyminner
DUP ZERO_DO
DUP #1+ROLL Qpi
syminner top& #1-
LOOP
veryunsymin
;
FOUR
::
XEQARRAY> INNERCOMP
#1= IT :: %1 SWAP ;
COERCE2
{{ Y X }}
Y #1+_ONE_DO
X #1+_ONE_DO
Qpi X UNROLL
LOOP
X {}N
X Y INDEX@#- #*
INDEX@ #+UNROLL
LOOP
Y DUP ONE#> ITE {}N DROP
ABND
;
FIVE
::
RESOROMP xQPI
ZEROZERO 4ROLLSWAP
BEGIN
NEXTCOMPOB
WHILE
::
5PICK EvalNoCK 5UNROLL
ROT#1+UNROT
;
REPEAT
DROPSWAPDROP {}N
;
;
*********************************
NULLNAME Qpi
::
DTYPEREAL? case Qpi%
DUPTYPECMP? NOT?SEMI
THREE TestSysClr SWAP
XEQC%V>
Qpi% SWAP Qpi% SWAP
xi x* x+
SWAP NOT?SEMI
CLRSYMB
;
*--------------------------------
NULLNAME Qpi%
::
%0=case NOP
DUP Approx
DUP %100 %< case
:: ROTDROP Qout/ ;
ZERO
4PICK DUPDUP %* DUP % 500000 %>
:: case2DROP Approx
ROT %SGN ROT %* SWAP
ONE COLA Qpimin
;
4PICK %PI %/ DUP %ABS %100 %>
:: caseDROP
Approx TWO COLA Qpimin
;
4PICK %EXP DUP % 1000 %>
:: caseDROP Approx
2DUP %* %1 %= case2DROP
THREE COLA Qpimin1
;
4PICK DUP %0<
::
caseDROP %LN Approx
FOUR COLA Qpimin1
;
4ROLLDROP Qout
;
*--------------------------------
NULLNAME Qpimin1
::
OVER % 50 %< NOTcase 3DROP
COLA Qpimin
;
*--------------------------------
NULLNAME Qpimin
::
OVER % 1000 %< NOTcase 3DROP
5PICK 3PICK %<= case 3DROP
4ROLLDROP 4ROLLDROP 4ROLLDROP
OVER %9 %> ?SEMI
4ROLLDROP RDROP Qout
;
*--------------------------------
NULLNAME Qout
::
DUP#0=csedrp Qout/
ONE #=casedrop Qoutsqrt
TWO #=casedrop Qoutpi
THREE #=casedrop Qoutln
DROP Qoutexp
;
NULLNAME Qout/
::
%1=case DROP
' x/ THREE SYMBN
;
NULLNAME Qoutpi
::
Qout/ %1=case
:: DROP SYMBOL xPI ; ;
DUPEQ: %-1 casedrop
SYMBOL xPI xNEG ;
syminner
putop2: xPI x* SYMBN
;
NULLNAME Qoutexp
::
Qout/ syminner
putop: xEXP SYMBN
;
NULLNAME Qoutln
::
Qout/ syminner
putop: xLN SYMBN
;
NULLNAME Qoutsqrt
::
SWAPDUP %0< UNROT %ABS SWAP
GetRoot ROT GetRoot
ROT Qout/
syminner putop: xSQRT SYMBN
UNROTSWAP Qout/
DUPEQ: %1 ITE
:: DROP syminner ;
:: syminner get1 syminner
top& onlyputop*
;
get1 IT onlyputopCHS
SYMBN
;
*--------------------------------
NULLNAME GetRoot
::
%1=case DUP
DUP % 1048575 %>
case :: %1 SWAP ;
COERCE
CODE
GOSBVL =POP#
R1=A
GOSBVL =SAVPTR
C=0 A
C=C+1 A
R0=C
LC(1) 4
R2=C
C=C+1 A
R3=C A
-- A=R1
C=R2
GOSBVL =IntDiv
?C=0 A
GOYES sqrdone
?A=0 A
GOYES +
A=R2 A
C=R3 A
A=A+C A
R2=A A
C=C+1 A
C=C+1 A
R3=C A
GONC --
+ R1=C
A=R0
C=R3
CSRB.F A
GOSBVL =MUL#
A=B A
R0=A
GOTO --
sqrdone GOVLNG =Push2#Loop
ENDCODE
UNCOERCE2
;
*--------------------------------
NULLNAME Approx
CODE
ABASE #80100
nu ALLOC 16
inu ALLOC 16
de ALLOC 16
ide ALLOC 16
p0 ALLOC 16
q1 ALLOC 16
p1 ALLOC 16
q0 ALLOC 16
p2 ALLOC 16
q2 ALLOC 16
r ALLOC 16
c ALLOC 16
GOSBVL =POP1%
C=A S C[S]=sign
A=0 S
?A#0 W
GOYES +
GOSBVL =GETPTR
SETHEX
D1=D1- 5
D=D-1 A
LC(5) =%1
A=C A
PC=(A)
+ D1=(5) =aFIXHOOK
C=DAT1 A
D1=C
C=0 A
C=DAT1 1
?C#0 A
GOYES +
LCHEX 9
+ ?CBIT=0 3
GOYES +
?CBIT=0 1
GOYES +
SETHEX
C=C+CON B,6
+ SETDEC
R4=C W
D1=(5) (=IRAM@)-4
C=DAT1 A
D1=C
D1=(4) #100
C=0 W
C=C+1 S
CSR W
LCHEX 12
P= 3-1
- C=C-1 X
P=P+1
?A=0 P
GOYES -
ACEX X
C=C-A X
C=-C X
DAT1=A W nu
D1=D1+ 16 inu=nu
DAT1=A W
D1=D1+ 16 de
DAT1=C W
D1=D1+ 16 ide=de
DAT1=C W
A=0 W
D1=D1+ 16 p0=0
DAT1=A W
D1=D1+ 16 q1=0
DAT1=A W
A=A+1 S
ASR W
D1=D1+ 16 p1=1
DAT1=A W
D1=D1+ 16 q0=1
DAT1=A W
MAIN
* c = nu div de
D1=(2) nu
GOSUB GETA
D1=(2) de
GOSUB GETC
GOSBVL =DIVF
GOSBVL =aFLOOR
D1=(2) c
GOSUB PUTA
* r = nu mod de
D1=(2) nu
GOSUB GETA
D1=(2) de
GOSUB GETC
GOSBVL =aMODF R0,R1!
D1=(2) r
GOSUB PUTA
* p2 = c*p1+p0
D1=(2) c
GOSUB GETA
D1=(2) p1
GOSUB MULC
D1=(2) p0
GOSUB ADDC
D1=(2) p2
GOSUB PUTA
* q2 = c*q1+q0
D1=(2) c
GOSUB GETA
D1=(2) q1
GOSUB MULC
D1=(2) q0
GOSUB ADDC
D1=(2) q2
GOSUB PUTA
* If r=0 then return(p2/q2)
D1=(2) r
GOSUB GETA
?B=0 W
GOYES EXIT
* If 10^(digits-1)*abs(inu*q2-ide*p2)
* < ide*p2
* Then return (p2/q2)
D1=(2) ide
GOSUB GETA
D1=(2) p2
GOSUB MULC
GOSBVL =STAB0
D1=(2) inu
GOSUB GETA
D1=(2) q2
GOSUB MULC
GOSBVL =RCCD0
C=-C-1 S
GOSUB addf
A=0 S
C=R4.F A *10^(digits-1)
A=A+C A
GOSBVL =RCCD0
P= 1
GOSBVL =TST15
GONC CONT
* return(p2/q2)
EXIT D1=(2) q2
A=DAT1 W
AR4EX W A[S]=sign
D1=(2) p2
A=DAT1 15
R3=A W
* No PUSH2% in ROM
GOSUB +
A=R3 W
GOSBVL =PUSH%
GOSBVL =SAVPTR
A=R4 W
GOVLNG =PUSH%LOOP
+ A=PC
C=RSTK
D0=C
SETHEX
C=A-C A
CD1EX
RSTK=C
CD1EX
GOVLNG =MOVEDOWN
* p0=p1 p1=p2 q0=q1 q1=q2
CONT D1=(2) p2
A=DAT1 W
D1=(2) p1
C=DAT1 W
DAT1=A W
D1=(2) p0
DAT1=C W
D1=(2) q2
A=DAT1 W
D1=(2) q1
C=DAT1 W
DAT1=A W
D1=(2) q0
DAT1=C W
* nu=de de=r
D1=(2) r
A=DAT1 W
D1=(2) de
C=DAT1 W
DAT1=A W
D1=(2) nu
DAT1=C W
GOTO MAIN
MULC GOSUB GETC
GOVLNG =MULTF
ADDC GOSUB GETC
addf GOVLNG =ADDF
GETA A=DAT1 W
GOVLNG =SPLITA
GETC C=DAT1 W
GOVLNG =SPLITC
PUTA GOSBVL =PACK
DAT1=A W
RTN
ENDCODE
*--------------------------------
