LEX    'COMPLEX'
* (c) 1988, PPC Paris et l'Auteur

AD2-12 EQU    #0C35F  ajouter deux 12-chiffres
AD2-15 EQU    #0C363  ajouter deux 15-chiffres
AVMEME EQU    #2F599
D1=AVE EQU    #18651  mettre D1 È AVMEME
D=AVMS EQU    #1A460  mettre D(A) È AVMEME
DECDC  EQU    #05287  dÅcompiler dÅclaration variable
DECP   EQU    #0328F  parse dÅclaration variable
DMNSN  EQU    #0AE39  crÅe et alloue un tableau
DPVCTR EQU    #0AC50  crÅe une variable
DV2-15 EQU    #0C4AC  diviser deux 15-chiffres
EXAB1  EQU    #0D3E7  Åchanger AB avec Scratch1
EXPR   EQU    #0F23C  adresse de retour des fonctions
FINDA  EQU    #023E3  selon A(B), faire...
FNRTN4 EQU    #0F238  adresse de retour des fonctions
FUNCD1 EQU    #2F8C0
MEMERR EQU    #0944D  ERR:Insufficient Memory
MP2-12 EQU    #0C432  multiplier deux 12-chiffres
NXTSTM EQU    #08A48  revient dans la Basic Loop
POP1N  EQU    #0BD1C  dÅpile un nombre de la M.S.
POP2N  EQU    #0BC8C  dÅpile deux nombres de la M.S.
PREP   EQU    #0ADAF  prÅpare la crÅation de variable
R<RSTK EQU    #014DD  sauve des niveaux de RSTK
RCCD1  EQU    #0D3F5  rappelle CD depuis Scratch1
RCCD2  EQU    #0D41C  rappelle CD depuis Scratch2
RCSCR  EQU    #0E954  dÅpile 15-chiffre dans Scratch
RDATTY EQU    #17CC6  ERR: Data Type
RSTK<R EQU    #014A8  restaure des niveaux de RSTK
SPACE  EQU    #0AD9D  calcule la place pour 1 tableau
SQR-15 EQU    #0C534  racine carrÅe de 15-chiffres
STAB1  EQU    #0D3D9  stocke AB dans Scratch1
STKCHR EQU    #18504  empile un caractÉre sur la M.S.
STSCR  EQU    #0E92C  empile 15-chiffres dans Scratch
XYEX   EQU    #0C697  Åchange AB avec CD
uRES12 EQU    #0C994  convertit de 15 en 12-chiffres

       ID     #5E
       MSG    0
       POLL   P       il y a un poll handler
       ENTRY  DECL
       CHAR   #D
       ENTRY  CONJE
       CHAR   #F
       ENTRY  IMPTE
       CHAR   #F
       ENTRY  MAGE
       CHAR   #F
       ENTRY  REPTE
       CHAR   #F
       KEY    'COMPLEX'
       TOKEN  27
       KEY    'CONJ'
       TOKEN  28
       KEY    'IMPT'
       TOKEN  29
       KEY    'MAG'
       TOKEN  30
       KEY    'REPT'
       TOKEN  31
       ENDTXT

*****************************************************

P      LCHEX  38      si poll = pCMPLX
       ?B=C   B
       GOYES  O       alors le prendre
       RTNSXM         sinon retour

O      GOSBVL D1=AVE  D1 := pointeur sur M.S.
       P=     5       sauve des niveaux de pile...
       GOSBVL R<RSTK  ... pour plus tard

       D0=(5) FUNCD1  rappeler le numÅro de token...
       A=DAT0 B       ... dans A(B)
       GOSBVL FINDA   selon le token :
       CON(2) #7A       nombre complexe :
       REL(3) NUM         aller en NUM
       CON(2) #67       rappel :
       REL(3) RCL         aller en RCL
       CON(2) #84       division :
       REL(3) DIV         aller en DIV
       CON(2) #83       multiplication :
       REL(3) MUL         aller en MUL
       CON(2) #87       addition :
       REL(3) ADD         aller en ADD
       CON(2) #82       soustraction
       REL(3) SUB         aller en SUB
       CON(2) #69       stocker rÅel dans complexe :
       REL(3) RSTO         aller en RSTO
       CON(2) #68       stocker complexe dans compl :
       REL(3) CSTO         aller en CSTO
       CON(2) #7F       RES ou () en mode CALC :
       REL(3) RES         aller en RES
       CON(2) 00      sinon : on ne reconnait pas
       P=     5       le token, donc on restaure
       GOSBVL RSTK<R  les niveaux de pile et
       RTNSXM         on sort.

*****************************************************

RES    C=R1           C(W) := partie rÅelle
       GOSUB  PUSH    empiler sur la pile
       C=R0           C(W) := partie imaginaire
       GONC   EXIT2   B.E.T.

*****************************************************

ADD    SETDEC         pour SPLITA dans AD2-12
       A=R1           prendre...
       C=R3           ... les parties rÅelles
       GOSBVL AD2-12  et les additionner
       GOSUB  ures12  les convertir en 12-chiffres
       DAT1=C W       et les empiler sur la M.S.
       A=R0           prendre...
       C=R2           ... les parties imaginaires
       GOSBVL AD2-12  et les additionner
EXIT3  GOSUB  ures12  les convertir en 12-chiffres
EXIT2  GOSUB  PUSH    et les empiler
       P=     0       ajouter un "stack-header"
       LCHEX  0E      aux nombres sur la M.S.
       GOSBVL STKCHR
EXIT1  SETHEX         pour RSTK<R
       P=     5       restaurer les niveaux sauvÅs
       GOSBVL RSTK<R
       XM=0           le poll a ÅtÅ traitÅ
       B=0    S       les lignes suivantes sont
       B=B-1  S       recquises par RCL
       B=B-1  S       B(S) = type variable = E
       A=R1           B(A) = R1(A) = adresse variable
       B=A    A
       RTN            retour È l'appelant

*****************************************************

SUB    SETDEC
       C=R1           C(W) := partie rÅelle
       C=-C-1 S       changement de signe
       DAT1=C W       empiler C(W) sur la M.S.
       C=R0           idem avec partie imaginaire
       C=-C-1 S
       GONC   EXIT2   B.E.T.

*****************************************************

DOIT   SETDEC         utilisÅ par MUL et DIV
       A=R0           A(W) := Im1
       C=R3           C(W) := Re2
       GOSUB  mp2-12  AB := Im1 * Re2
       GOSUB  stscr   empiler AB sur la MathScrStk
       A=R1           A(W) := Re1
       C=R2           C(W) := Im2
       GOSUB  mp2-12  AB := Re1 * Im2
       GOSUB  stscr   empiler AB sur la MathScrStk
       A=R1           A(W) := Re1
       C=R3           C(W) := Re2
       GOSUB  mp2-12  AB := Re1 * Re2
       GOSUB  stscr   empiler AB sur la MathScrStk
       A=R0           A(W) := Im1
       C=R2           C(W) := Im2
       GOSUB  mp2-12  AB := Im1 * Im2
rcscr  GOVLNG RCSCR   et sortie par RCSCR

*****************************************************

MUL    GOSUB  DOIT    calculs communs avec DIV
       A=-A-1 S       AB = - Im1 * Im2
       GOSUB  ad2-15  Re1 * Re2 - Im1 * Im2
       GOSUB  ures12  conversion en 12-chiffres
       DAT1=C W       et rÅsultat sur la M.S.
       GOSUB  rcscr   AB := Re1 * Im2
       GOSBVL XYEX    CD := Re1 * Im2
       GOSUB  rcscr   AB := Im1 * Re2
       GOSUB  ad2-15  AB := Re1 * Im2 - Im1 * Re2
       GOTO   EXIT3   ... et sortie

*****************************************************

DIV    GOSUB  DOIT    calculs communs avec MUL
       GOSUB  ad2-15  AB := Re1 * Re2 + Im1 * Im2
       GOSBVL STAB1   sauvegarde dans Scratch1
       A=R3           A(W) := Re2
       C=A    W       C(W) := Re2
       GOSUB  mp2-12  AB := Re2 * Re2
       C=B    W       stocker AB dans Scratch2
       AR2EX          et rappeler
       R3=C           Im2
       C=A    W       C(W) := Im2
       GOSUB  mp2-12  AB := Im2 * Im2
       GOSBVL RCCD2   CD := Re2 * Re2
       GOSUB  ad2-15  AB := Re2 * Re2 + Im2 * Im2
       GOSBVL EXAB1   Åchanger Re1 * Im2 + Re2 * Im1
       GOSUB  rccd1   CD := Re2 * Re2 + Im2 * Im2
       GOSBVL DV2-15  AB := (Re1 * Im2 + Re2 * Im1) /
       GOSUB  ures12  ...   (Re2 * Re2 + Im2 * Im2)
       DAT1=C W       et empiler sur la M.S.
       GOSUB  rcscr   CD := Re1 * Im2
       C=-C-1 S       CD := - Re1 * Im2
       GOSBVL XYEX    AB := - Re1 * Im2
       GOSUB  rcscr   CD := Im1 * Re2
       GOSUB  ad2-15  AB := Im1 * Re2 - Re1 * Im2
       GOSUB  rccd1   CD := (Re2 * Re2 + Im2 * Im2)
       GOSBVL DV2-15  AB := (Im1 * Re2 + Re1 * Im2) /
       GOTO   EXIT3   ...   (Re2 * Re2 + Im2 * Im2)

*****************************************************

PUSH   A=C    W       A(W) := nombre È empiler
       GOSBVL D=AVMS  D(A) := available memory start
       D1=D1- 16      faire de la place pour le nb
       CD1EX          C(A) := D1
       D1=C           et restaurer D1
       ?D>=C  A       assez de place ?
       GOYES  memerr  non : erreur
       DAT1=A W       oui : empiler le nombre
       RTNCC                et revenir È l'appelant
memerr GOVLNG MEMERR  ERR: Insufficient Memory

*****************************************************

       REL(5) Decdc   Routine de dÅcompilation
       REL(5) Decp    Routine de parse
DECL   LCHEX  E       Ecrire le type de la variable
       D1=(5) #2F890  dans S-R1-3
       DAT1=C P       car recquis par PREP
RIP    GOSBVL PREP    prÅparation de la crÅation
       GOSBVL DPVCTR  get dope vector
       R1=C           R1 := dope vector
       ?A#0   A       si variable = tableau
       GOYES  ARR     alors on continue
       A=A+1  A       sinon on fait comme si c'etait
       ST=1   0       un tableau dans la suite.
ARR    GOSBVL SPACE   Calculer place nÅcessaire
       GOSBVL DMNSN   et allouer la mÅmoire
       GOC    RIP     on rÅpÉte si il y en a d'autres
       GOVLNG NXTSTM  sinon, on revient È Basic

Decdc  GOVLNG DECDC
Decp   GOVLNG DECP

*****************************************************

RCL    A=R1           A(A) := adresse de la variable
       D0=A           D0 := ^ partie rÅelle
       C=DAT0 W       C(W) := partie rÅelle
       D0=D0+ 16      D0 := ^ partie imaginaire
       GOSUB  PUSH    empiler partie rÅelle sur M.S.
       C=DAT0 W       C(W) := partie imaginaire
       GOTO   EXIT2   et sortie

*****************************************************

CSTO   GOSUB  CKVAR   VÅrifier si variable valide
       D1=D1+ 2       sauter le "header" 0E
       C=DAT1 W       C(W) := partie imaginaire
       D1=D1+ 16      D1 := ^ partie im. sur la M.S.
WRITR  DAT0=C W       Åcrire partie imaginaire
       D0=D0- 16      D0 := ^ partie rÅelle de la var
       C=DAT1 W       C(W) := partie rÅelle
       DAT0=C W       Åcrire partie rÅelle
       C=D    A       restaurer D1
       D1=C           È son ancienne valeur
       GOTO   EXIT1   et sortie

*****************************************************

RSTO   GOSUB  CKVAR   vÅrifier si variable valide
       C=0    W       Partie imaginaire := 0
       GOC    WRITR   B.E.T.

*****************************************************

CKVAR  CD1EX          sauver D1 dans D(A)
       D=C    A
       D1=C
       D0=(5) #2F880  lire type de la variable
       C=DAT0 S       dans la zone scratch
       D0=D0- 15      D0 := ^ adr. var dans scratch
       C=DAT0 A       C(A) := adresse de la variable
       D0=C           D0 := ^ variable
       D0=D0+ 16      D0 := ^ partie imaginaire
       C=C+1  S       vÅrifier le type
       C=C+1  S       si c'est E : complexe
       RTNC           alors retour avec Carry = 1
rdatty GOVLNG RDATTY  sinon : ERR: Data Type

*****************************************************

       NIBHEX 811     1 paramÉtre numÅrique (R ou C)
REPTE  GOSUB  pop1n   dÅpiler partie imaginaire
expr   GOVLNG EXPR    et retour...

*****************************************************

       NIBHEX 811     1 paramÉtre numÅrique (R ou C)
CONJE  GOSUB  pop1n   dÅpiler l'argument
       GONC   expr    si rÅel, c'est terminÅ
       C=R0           C(W) := partie imaginaire
       C=-C-1 S       C(W) := - partie imaginaire
       GOSUB  PUSH    empiler C(W) sur la M.S.
       LCHEX  0E      et mettre le "header" 0E
       GOSBVL STKCHR  sur la M.S.
       GONC   expr    B.E.T.

*****************************************************

NUM    GOSBVL POP2N   dÅpiler deux nombres de la M.S.
       GOC    rdatty  erreur si il y en a un complexe
       GOTO   EXIT2   sinon sortie

*****************************************************

       NIBHEX 811     1 paramÉtre numÅrique (R ou C)
IMPTE  GOSUB  pop1n   dÅpiler un argument de la M.S.
       C=0    W       si c'est un rÅel,
       GONC   fnrtn4  alors renvoyer 0
       C=R0           sinon partie imaginaire
       GOC    fnrtn4

*****************************************************

       NIBHEX 811     1 paramÉtre numÅrique (R ou C)
MAGE   GOSUB  pop1n   dÅpiler un argument de la M.S.
       C=A    W       si c'est un rÅel,
       GONC   fnrtn4  alors on peut le renvoyer
       SETDEC
       GOSUB  mp2-12  AB := Re * Re
       GOSBVL EXAB1   sauver dans Scratch1
       C=A    W       C(W) := Partie imaginaire
       GOSUB  mp2-12  AB := Im * Im
       GOSUB  rccd1   CD := Re * Re
       GOSUB  ad2-15  AB := Re * Re + Im * Im
       GOSBVL SQR-15  AB := SRQ (Re * Re + Im * Im)
       GOSUB  ures12  conversion en 12-chiffres

*****************************************************

fnrtn4 GOVLNG FNRTN4  pour sauver quelques quartets
pop1n  GOVLNG POP1N
ures12 GOVLNG uRES12
ad2-15 GOVLNG AD2-15
mp2-12 GOVLNG MP2-12
stscr  GOVLNG STSCR
rccd1  GOVLNG RCCD1

       END