( Copyright PPC Paris 1986 )
( Vocabulaire dÅfinissant des mots pour la       )
( gestion d'une pile complexe en FORTH           )
( A. Goubault 08/86                              )

VOCABULARY COMPLEX_WORDS

: COMPLEX COMPLEX_WORDS DEFINITIONS ;

COMPLEX

( COMPLEX_BUFFER contient l'adresse de la pile   )
( imaginaire                                     )

VARIABLE COMPLEX_BUFFER 0 COMPLEX_BUFFER !
VARIABLE COMPLEX_STATUS 0 COMPLEX_STATUS !
HEX

( Construction de la double pile dans un "buffer")
( de 40 octets                                   )
: COMPLEX_STACK   ( -- adr )
  28 MAKEBF
  IF
    COMPLEX_BUFFER !
    DUP 28 0 FILL
  ELSE
    ABORT " No Room"
  THEN ;

( On construit la double pile si ce n'est pas    )
( dÅjÈ fait                                      )
: COMPLEX_STACK?  ( -- adr )
  COMPLEX_BUFFER @
  FINDBF DUP 0=
  IF COMPLEX_STACK
  THEN ;

( Permutation des deux piles                     )
: R<>I            ( -- )
  COMPLEX_STACK? L
  DUP PAD 28 CMOVE
  OVER SWAP 28 CMOVE
  PAD SWAP 28 CMOVE ;

( Activation du mode complexe                    )
: COMPLEX_MODE    ( -- adr )
  COMPLEX_STACK?
  DROP -1 COMPLEX_STATUS ! ;

( Retour au mode normal                          )
: REAL_MODE       ( -- adr )
  0 COMPLEX_STATUS ! ;

( Fonction agissant de maniÉre identique sur les )
( deux piles si le mode complexe est activÅ      )
: FUNCTION_COMPLEX ( CFA -- )
  DUP EXECUTE COMPLEX_STATUS @
  IF
    R<>I EXECUTE R<>I
   ELSE
    DROP
  THEN ;

( Fonctions ÅlÅmentaires agissant sur les deux   )
( si le mode complexe est activÅ                 )
: Z+  ['] F+ FUNCTION_COMPLEX ;
: Z-  ['] F- FUNCTION_COMPLEX ;
: COPYZ ['] FENTER FUNCTION_COMPLEX ;
: ZDN ['] RDN FUNCTION_COMPLEX ;
: ZUP ['] RUP FUNCTION_COMPLEX ;
: ECHZ ['] X<>Y FUNCTION_COMPLEX ;
: LASTZ ['] LASTX FUNCTION_COMPLEX ;
: ZDROP ['] FDROP FUNCTION_COMPLEX ;

( Fonction conjuguÅ                              )
: ZBAR
  COMPLEX_STATUS @
  IF
    L STO R<>I L STO CHS R<>I
   ELSE
    1/X
  THEN ;

( Fonctions de stockage sur la pile              )
: ZSTO            ( adr -- )
  DUP STO
  COMPLEX_STATUS @
  IF
    R<>I STO R<>I
   ELSE
    DROP
  THEN ;
: ZRCL            ( adr -- )
  DUP RCL
  COMPLEX_STATUS @
  IF
    R<>I RCL R<>I
   ELSE
    DROP
  THEN ;

DECIMAL