LEX 'FRACLEX' * (c) Copyright PPC-Paris et l'Auteur 1987 ID #E1 MSG 0 POLL 0 AD2-12 EQU #0C35F ADHEAD EQU #181B7 CLRFRC EQU #0C6F4 DSPFMT EQU #2F6DC DV2-12 EQU #0C4A8 EXPR EQU #0F23C FUNCD0 EQU #2F8BB MP2-12 EQU #0C432 POP1R EQU #0E8FD RCLW1 EQU #0E981 RCLW2 EQU #0E9BE RCSCR EQU #0E954 REV$ EQU #1B38E SPLITA EQU #0C6BF STR$SB EQU #18149 STSCR EQU #0E92C TST12A EQU #0D476 uRES12 EQU #0C994 XINV15 EQU #0C33E Normalement 1/X15 XXHEAD EQU #1A44E XYEX EQU #0C697 ENTRY FRC CHAR #F KEY 'FRAC$' TOKEN 88 ENDTXT NIBHEX 8812 mini : 1 param. maxi 2 * param. numÅriques FRC AD0EX sauvegarde D0 D0=(5) (FUNCD0) DAT0=A A C=C-1 S dÅcrÅmente le nombre C=C-1 S de paramÉtres C=0 W R2=C D-1 = 0 -> R2 P= 1 C=P 14 R1=C Do = 1 -> R1 R0=C N-1 = 1 -> R0 ST=0 0 repÉre paramÉtre prÅcision GOC POPN 1 seul paramÉtre alors POPN GOSBVL POP1R pope et teste n (prÅcision * ou nombre d'itÅrations) D1=D1+ 16 actualise D1 ?A=0 S paramÉtre prÅcision ? GOYES A0S oui alors on conserve le * repÉre prÅcision (S0=0) ST=1 0 repÉre itÅration A0S A=0 S ?A=0 X 1 seul digit ? GOYES aslc2 oui alors shift 2 fois ASLC non alors shift 3 fois aslc2 ASLC ASLC ici A(B) = n C=A B C(W) = 10^n C=-C X C(W) = 10^(-n) POPN GOSBVL POP1R pope et teste N ?C#0 B C(B) = n ? GOYES PARAM oui alors prÅcision donnÅe * ou nombre d'itÅrations * demandÅ LCHEX 499 C=C-A X C(X) = 499 - exposant de N LCHEX 990 C(W) = 10^(-10) GONC PARAM exposant de N > 0 alors * C(W) = prÅcision C=C+A X exposant < 0 alors prÅc. * flottante 10^(-10 + expos. * de N ) PARAM C=A S rÅcupÉre le signe de N DAT1=C W sauve le signe de N et le * paramÉtre prÅcision ou * itÅrations sur la math * stack A=0 S A(W) = ABS(N) GOSUB STO sauvegarde dans la scratch * math stack GOSUB stscr sauvegarde de ABS(Ho) = * ABS(N) GOSUB clrfrc A(W) = IP(ABS(N)) R3=A IP(ABS(N)) = ABS(No) -> R3 LOOP ?ST=0 0 option prÅcision ? GOYES PREC oui saut au test prÅcision A=DAT1 B A(B) = - paramÉtre * itÅrations A=A+1 B incrÅmentation GOC out derniÉre itÅration * alors rÅsultat DAT1=A B sauve le nombre * d'itÅrations restantes GONC ITER saute le test prÅcision PREC GOSUB A-1S A(W) = -IP(ABS(N)) * ou -ABS(Ni/Di) * X = ABS(N) * A(W) = ABS(N) * X = ABS(N) - ABS(Ni/Di) * = delta * A(W) = ABS(delta) C=DAT1 W C(W) = prÅcision et signe * de N C=0 S C(W) = prÅcision P= 3 pour TEST12A GOSBVL TST12A ABS(delta) <= prÅcision ? GOC out oui alors rÅsultat ITER GOSUB AR3 Ni -> scratch math stack GOSBVL RCLW2 X = ABS(Hi) GOSUB clrfrc A(W) = IP(ABS(Hi)) out GOC OUT FP(Hi) = 0 alors rÅsultat GOSUB A-1S A(W) = FP(ABS(Hi)) GOSBVL SPLITA A(W) -> X GOSBVL XINV15 X = 1/FP(ABS(Hi)) * = ABS(Hi+1) GOSUB ROUND ABS(Hi+1) arrondi È 12 * digits -> A(W) GOSBVL RCSCR fait la place pour Hi+1 GOSUB STOfrc ABS(Hi+1) -> scr. math st. * puis A(W) = IP(ABS(Hi+1)) * = ai+1 C=R3 C(W) = ABS(Ni) GOSUB mp2-12 A(W) = ai+1 * ABS(Ni) C=R0 C(W) = ABS(Ni-1) GOSUB AD A(W) = ABS(Ni+1) * = ai+1*ABS(Ni)+ABS(Ni-1) AR3EX R3 = ABS(Ni+1) * A(W) = ABS(Ni) R0=A RO = Ni remplace Ni-1 GOSBVL RCLW1 X = ABS(Hi+1) GOSUB clrfrc A(W) = ai+1 C=R1 C(W) = Di GOSUB mp2-12 A(W) = ai+1 * Di C=R2 C(W) = Di-1 GOSUB AD A(W) = Di+1 = ai+1*Di+Di-1 AR1EX R1= Di+1 A(W) = Di R2=A R2 = Di remplace Di-1 GOSUB AR3 X = ABS(Ni+1) -> scr.mstack A=B M A(W) = ABS(Ni+1) C=R1 C(W) = Di+1 GOSBVL DV2-12 X = ABS(Ni+1) / Di+1 GOSUB ROUND A(W) = ABS(Ni+1)/Di+1 * arrondi È 12 digits * scrmstk -> ABS(Ni+1) -> R3 GOTO LOOP OUT A=R3 A(W) = ABS(Ni+1) C=DAT1 W C(S) = signe de N A=C S A(W) = Ni+1 R3=A R3 = Ni+1 D0=(5) (FUNCD0) rÅcupÅration de D0 C=DAT0 A D0=C C=R1 C(W) = Di+1 P= 14 C=C-1 P C=C-1 W si Di+1 = 1 alors carry P= 0 nÅcessaire pour STR$00 ST=0 1 les blancs sont supprimÅs GONC DIF1 Di+1 # 1 alors rÅsultat * avec Di+1 GOSUB A2STR Ni+1 ou N en chaÑne GOTO expr et fin DIF1 A=R1 A(W) = Di+1 GOSUB REVST Di+1 sur la math stack -> * chaÑne alpha inversÅe * -> en-tÁte enlevÅe C=R1 C(A) = D1 (fin de chaÑne) RSTK=C sauve D1 sur pile retours LCASC '/' C(B) = / D1=D1- 2 prÅpare la pile È recevoir * / DAT1=C B / sur la pile A=R3 A(W) = Ni+1 D1=D1- 16 prÅpare la pile È recevoir * Ni+1 GOSUB REVST Ni+1 -> pile -> chaÑne * alpha -> chaÑne inversÅe * -> entÁte enlevÅe C=RSTK on rÅcupÉre D1 (fin de * chaÑne R1=C R1(A) = D1 (fin de chaÑne) * nÅcessaire pour ADHEAD GOSBVL ADHEAD ajoute l'entÁte GOSBVL REV$ renverse la chaÑne expr GOVLNG EXPR rÅsultat et retour au BASIC REVST GOSUB A2STR converti A(W) GOSBVL REV$ chaÑne inversÅe P= 0 nÅcessaire pour XXHEAD GOVLNG XXHEAD en-tÁte enlevÅe STOfrc GOSUB STO A(W) -> scr. math st. clrfrc GOSBVL CLRFRC X = IP(X) A=B A=B M X -> A(W) RTN mp2-12 GOSBVL MP2-12 X = A(W) * C(W) GOTO A=B X -> A(W) et retour AR3 A=R3 A(W) = ABS(Ni) STO GOSBVL SPLITA A(W) -> X stscr GOVLNG STSCR X -> scr. math st. ROUND GOSBVL uRES12 X 15 digits -> C(W) arrondi * È 12 digits A=C W GOSBVL RCSCR scr.mstack -> ABS(Ni) -> Y C=D M Y -> C(W) R3=C ABS(Ni) -> R3 RTN A-1S A=A-1 S positif -> nÅgatif GOSBVL RCLW2 X = 2e niveau scr.mstack A=B M X -> A(W) AD GOSBVL AD2-12 X = A(W) + C(W) A=0 S valeur absolue GOTO A=B X -> A(W) et retour A2STR DAT1=A W nombre sur la pile AD1EX sauve D1 D1=(5) (DSPFMT) C=DAT1 S C(S) = format courant R4=C sauve dans R4(S) C=0 A impose le .. DAT1=C 1 .. format STD AD1EX restaure D1 GOSBVL =STR$SB fait la conversion AD1EX sauve D1 D1=(5) DSPFMT C=R4 DAT1=C S restaure le format courant AD1EX restaure D1 RTN END