native/complex.c

   1 #include "factor.h"
   2
   3 COMPLEX* complex(CELL real, CELL imaginary)
   4 {
   5         COMPLEX* complex = allot(sizeof(COMPLEX));
   6         complex->real = real;
   7         complex->imaginary = imaginary;
   8         return complex;
   9 }
  10
  11 CELL possibly_complex(CELL real, CELL imaginary)
  12 {
  13         if(zerop(imaginary))
  14                 return real;
  15         else
  16                 return tag_complex(complex(real,imaginary));
  17 }
  18
  19 void primitive_complexp(void)
  20 {
  21         check_non_empty(env.dt);
  22         env.dt = tag_boolean(typep(COMPLEX_TYPE,env.dt));
  23 }
  24
  25 void primitive_real(void)
  26 {
  27         switch(type_of(env.dt))
  28         {
  29         case FIXNUM_TYPE:
  30         case BIGNUM_TYPE:
  31         case FLOAT_TYPE:
  32         case RATIO_TYPE:
  33                 /* No op */
  34                 break;
  35         case COMPLEX_TYPE:
  36                 env.dt = untag_complex(env.dt)->real;
  37                 break;
  38         default:
  39                 type_error(COMPLEX_TYPE,env.dt);
  40                 break;
  41         }
  42 }
  43
  44 void primitive_imaginary(void)
  45 {
  46         switch(type_of(env.dt))
  47         {
  48         case FIXNUM_TYPE:
  49         case BIGNUM_TYPE:
  50         case FLOAT_TYPE:
  51         case RATIO_TYPE:
  52                 env.dt = tag_fixnum(0);
  53                 break;
  54         case COMPLEX_TYPE:
  55                 env.dt = untag_complex(env.dt)->imaginary;
  56                 break;
  57         default:
  58                 type_error(COMPLEX_TYPE,env.dt);
  59                 break;
  60         }
  61 }
  62
  63 void primitive_to_rect(void)
  64 {
  65         COMPLEX* c;
  66         switch(type_of(env.dt))
  67         {
  68         case FIXNUM_TYPE:
  69         case BIGNUM_TYPE:
  70         case FLOAT_TYPE:
  71         case RATIO_TYPE:
  72                 dpush(env.dt);
  73                 env.dt = tag_fixnum(0);
  74                 break;
  75         case COMPLEX_TYPE:
  76                 c = untag_complex(env.dt);
  77                 env.dt = c->imaginary;
  78                 dpush(c->real);
  79                 break;
  80         default:
  81                 type_error(COMPLEX_TYPE,env.dt);
  82                 break;
  83         }
  84 }
  85
  86 void primitive_from_rect(void)
  87 {
  88         CELL imaginary = env.dt;
  89         CELL real = dpop();
  90         check_non_empty(imaginary);
  91         check_non_empty(real);
  92
  93         if(!realp(imaginary))
  94                 type_error(REAL_TYPE,imaginary);
  95
  96         if(!realp(real))
  97                 type_error(REAL_TYPE,real);
  98
  99         env.dt = possibly_complex(real,imaginary);
 100 }
 101
 102 CELL number_eq_complex(CELL x, CELL y)
 103 {
 104         COMPLEX* cx = (COMPLEX*)UNTAG(x);
 105         COMPLEX* cy = (COMPLEX*)UNTAG(y);
 106         return tag_boolean(
 107                 untag_boolean(number_eq(cx->real,cy->real)) &&
 108                 untag_boolean(number_eq(cx->imaginary,cy->imaginary)));
 109 }
 110
 111 CELL add_complex(CELL x, CELL y)
 112 {
 113         COMPLEX* cx = (COMPLEX*)UNTAG(x);
 114         COMPLEX* cy = (COMPLEX*)UNTAG(y);
 115         return possibly_complex(
 116                 add(cx->real,cy->real),
 117                 add(cx->imaginary,cy->real));
 118 }
 119
 120 CELL subtract_complex(CELL x, CELL y)
 121 {
 122         COMPLEX* cx = (COMPLEX*)UNTAG(x);
 123         COMPLEX* cy = (COMPLEX*)UNTAG(y);
 124         return possibly_complex(
 125                 subtract(cx->real,cy->real),
 126                 subtract(cx->imaginary,cy->real));
 127 }
 128
 129 CELL multiply_complex(CELL x, CELL y)
 130 {
 131         COMPLEX* cx = (COMPLEX*)UNTAG(x);
 132         COMPLEX* cy = (COMPLEX*)UNTAG(y);
 133         return possibly_complex(
 134                 subtract(
 135                         multiply(cx->real,cy->real),
 136                         multiply(cx->imaginary,cy->imaginary)),
 137                 add(
 138                         multiply(cx->real,cy->imaginary),
 139                         multiply(cx->imaginary,cy->real)));
 140 }
 141
 142 #define COMPLEX_DIVIDE(x,y) \
 143         COMPLEX* cx = (COMPLEX*)UNTAG(x); \
 144         COMPLEX* cy = (COMPLEX*)UNTAG(y); \
 145 \
 146         CELL mag = add( \
 147                 multiply(cy->real,cy->real), \
 148                 multiply(cy->imaginary,cy->imaginary)); \
 149 \
 150         CELL r = add( \
 151                 multiply(cx->real,cy->real), \
 152                 multiply(cx->imaginary,cy->imaginary)); \
 153         CELL i = subtract( \
 154                 multiply(cx->imaginary,cy->real), \
 155                 multiply(cx->real,cy->imaginary));
 156
 157 CELL divide_complex(CELL x, CELL y)
 158 {
 159         COMPLEX_DIVIDE(x,y);
 160         return possibly_complex(divide(r,mag),divide(i,mag));
 161 }
 162
 163 CELL divfloat_complex(CELL x, CELL y)
 164 {
 165         COMPLEX_DIVIDE(x,y);
 166         return possibly_complex(divfloat(r,mag),divfloat(i,mag));
 167 }
 168
 169 CELL less_complex(CELL x, CELL y)
 170 {
 171         general_error(ERROR_INCOMPARABLE,tag_cons(cons(x,y)));
 172         return F;
 173 }
 174
 175 CELL lesseq_complex(CELL x, CELL y)
 176 {
 177         general_error(ERROR_INCOMPARABLE,tag_cons(cons(x,y)));
 178         return F;
 179 }
 180
 181 CELL greater_complex(CELL x, CELL y)
 182 {
 183         general_error(ERROR_INCOMPARABLE,tag_cons(cons(x,y)));
 184         return F;
 185 }
 186
 187 CELL greatereq_complex(CELL x, CELL y)
 188 {
 189         general_error(ERROR_INCOMPARABLE,tag_cons(cons(x,y)));
 190         return F;
 191 }