archive/src/rat3f-hc.c

   1 /* #include <xcmpinclude.h>   */
   2
   3 #ifdef SUN3
   4 #define MC68000
   5 #endif
   6
   7 #define MASK    0x7fffffff
   8
   9 object number_times();
  10 object fixnum_times();
  11 object mcmod();
  12 object shift_integer();
  13 object bignum2();
  14 #define FIXNUMP(x) (type_of(x)==t_fixnum)
  15
  16 /* Note: the modulus is guaranteed > 0 */
  17
  18 #define FIX_MOD(X,MOD) {register int MOD_2; \
  19                              if (X > (MOD_2=(MOD >>1))) X=X-MOD; else \
  20                                if (X < -MOD_2)  X=X+MOD;}
  21
  22
  23
  24 #define MYmake_fixnum(doto,x) \
  25   {register int CMPt1; \
  26    doto \
  27    ((((CMPt1=(x))+1024)&-2048)==0?small_fixnum(CMPt1):make_fixnum(CMPt1));}
  28
  29
  30
  31
  32 int
  33 dblrem(m,n,mod)
  34 int m,n,mod;
  35 { asm("movl a6@(8),d1");
  36   asm("mulsl a6@(12),d0:d1");
  37   asm("divsl a6@(16),d0:d1");
  38 }
  39
  40 /* adds m and n returning the remainder modulo mod */
  41
  42 plusrem(m,n,mod)
  43 int m,n,mod;
  44 { asm("movl a6@(0x8),d1");
  45   asm("addl a6@(0xc),d1");
  46   asm("bvs plus_overflow_case");
  47   asm("divsll a6@(16),d0:d1");
  48   asm("bra plus_endend");
  49   asm ("plus_overflow_case:");
  50   asm("bcs plus_neg_args");
  51   asm("clrl d0");
  52   asm("jra plus_end");
  53   asm("plus_neg_args:");
  54   asm("movl #-1,d0");
  55   asm("plus_end:");
  56   asm("divsl a6@(16),d0:d1");
  57   asm("plus_endend:");
  58 }
  59
  60
  61 /* subtracts n from m returning the remainder modulo mod */
  62
  63 subrem(m,n,mod)
  64 int m,n,mod;
  65 { asm("movl a6@(0x8),d1");
  66   asm("subl a6@(0xc),d1");
  67   asm("bvs sub_overflow_case");
  68   asm("divsll a6@(16),d0:d1");
  69   asm("bra sub_endend");
  70   asm ("sub_overflow_case:");
  71   asm("bcc sub_neg_args");
  72   asm("clrl d0");
  73   asm("jra sub_end");
  74   asm("sub_neg_args:");
  75   asm("movl #-1,d0");
  76   asm("sub_end:");
  77   asm("divsl a6@(16),d0:d1");
  78   asm("sub_endend:");
  79   }
  80
  81
  82
  83 /* like fixnum_times multiply to ints to get a t_fixnum or t_bignum ,
  84 but utilize the ordinary mulsl for the common small case */
  85
  86 object
  87 ftimes(m,n)
  88 int m,n;
  89 {register object res;
  90   asm("movl a6@(8),d0");
  91   asm("mulsl a6@(12),d0");
  92   asm("bvs ftimes_overflow");
  93   asm("movl d0,a6@(8)");
  94   MYmake_fixnum(res=,*&m);
  95   asm("bra ftimes_end");
  96   asm("ftimes_overflow:");
  97   res=fixnum_times(m,n);
  98   asm("ftimes_end:");
  99   return res;}
 100
 101
 102 /*
 103 int TOPhalf;
 104
 105 int
 106 ftimes1(m,n)
 107 int m,n;
 108 { asm("movl a6@(8),d0");
 109   asm("mulsl a6@(12),d1:d0");
 110   asm("movl d1, _TOPhalf");
 111 }
 112
 113 */
 114
 115
 116 /* multiply fixnum objects m and n faster than number_times */
 117 /*
 118
 119 object
 120 ftimes(m,n)
 121 object m,n;
 122 {register int ans;
 123  ans=ftimes1(fix(m),fix(n));
 124  if (ans < 0)
 125    { if (TOPhalf==-1) return (CMPmake_fixnum(ans));
 126       else return (number_times(m,n));}
 127  else
 128    { if (TOPhalf==0) return (CMPmake_fixnum(ans));
 129       else return (number_times(m,n));}}
 130
 131 */
 132
 133 object
 134 ctimes(a,b,mod)
 135 object a,b,mod;
 136 {if (FIXNUMP(a) && FIXNUMP(b))
 137   {if (mod==Cnil) return ftimes(fix(a),fix(b));
 138    else if (FIXNUMP(mod))
 139      {register int res, m ;
 140       res=dblrem(fix(a),fix(b),m=fix(mod));
 141       FIX_MOD(res,m);
 142       MYmake_fixnum(return,res);}}
 143  return mcmod(number_times(a,b),mod);}
 144
 145 object
 146 mcmod(x,mod)
 147 object x,mod;
 148 {if (mod==Cnil) return(x);
 149 else
 150  if((type_of(mod)==t_fixnum && type_of(x)==t_fixnum))
 151     {register int xx,mm;
 152      mm=fix(mod);xx=(fix(x)%mm);
 153      FIX_MOD(xx,mm);
 154      MYmake_fixnum(return,xx);
 155    }
 156  else
 157    {object qp,rp,mod2;
 158     int compare;
 159     integer_quotient_remainder_1(x,mod,&qp,&rp);
 160     mod2=shift_integer(mod,-1);
 161     compare=number_compare(rp,mod2);
 162       if (compare > 0) rp=number_minus(rp,mod);
 163    return rp;}}
 164
 165
 166 /* add two fixnums:  First add m and n, then if there is an overflow condition
 167  branch to construct bignum.  Otherwise set res = the result,
 168  and then act on it.  The use of *&m is to inhibit compilers from making
 169  the arg m a register, so that we would not know where it was. */
 170
 171
 172 object
 173 fplus(m,n)
 174 int m,n;
 175 {object res;
 176   asm("movl a6@(0x8),d0");
 177   asm("addl a6@(0xc),d0");
 178   asm("bvs fplus_overflow_case");
 179   asm("movl d0,a6@(0x8)");
 180   asm("jra fplus_rest");
 181   asm ("fplus_overflow_case:");
 182   asm("movl d0,a6@(0x8)");
 183   res=((*&n>0)?bignum2(1, *&m & MASK):bignum2(-2, *&m & MASK));
 184   asm ("jra fplus_end");
 185   asm("fplus_rest:");
 186   MYmake_fixnum(res=,*&m);
 187   asm("fplus_end:");
 188     return res;
 189     }
 190
 191
 192 /* subtract two fixnums:
 193  First  m - n, then if there is an overflow condition
 194  branch to construct bignum.  Otherwise set res = the result,
 195  and then act on it.  The use of *&m is to inhibit compilers from making
 196  the arg m a register, so that we would not know where it was. */
 197
 198 object
 199 fminus(m,n)
 200 int m,n;
 201 {object res;
 202   asm("movl a6@(0x8),d0");
 203   asm("subl a6@(0xc),d0");
 204   asm("bvs fminus_overflow_case");
 205   asm("movl d0,a6@(0x8)");
 206   asm("jra fminus_rest");
 207   asm ("fminus_overflow_case:");
 208   asm("movl d0,a6@(0x8)");
 209   res=((*&n<0)?bignum2(1, *&m & MASK):bignum2(-2, *&m & MASK));
 210   asm ("jra fminus_end");
 211   asm("fminus_rest:");
 212   MYmake_fixnum(res=,*&m);
 213   asm("fminus_end:");
 214     return res;
 215     }
 216
 217
 218
 219
 220 /* in fixnum case of m and mod put it into the right range. */
 221
 222 int
 223 fmod(m,mod)
 224  int m,mod;
 225 {int register res,m2;
 226  res=m%mod;
 227  m2= (mod >> 1);
 228  if (res > m2) return( m - mod);
 229  else if (res < -m2) return (res + mod);
 230  else return res;}
 231
 232 object
 233 cdifference(a,b,mod)
 234 object a,b,mod;
 235 {if (FIXNUMP(mod))
 236    {register int res,m;
 237     res=((fix(a)-fix(b))%(m=fix(mod)));
 238     FIX_MOD(res,m);
 239     MYmake_fixnum(return,res);}
 240  else if (mod==Cnil)
 241      {if (FIXNUMP(a) && FIXNUMP(b))
 242         return fminus(fix(a),fix(b));
 243       else return(number_minus(a,b));
 244     }
 245  else return(mcmod(number_minus(a,b),mod));}
 246
 247
 248
 249 object
 250 cplus(a,b,mod)
 251 object a,b,mod;
 252 {if (FIXNUMP(mod))
 253    {register int res,m;
 254     res=((fix(a)+fix(b))%(m=fix(mod)));
 255     FIX_MOD(res,m);
 256     MYmake_fixnum(return,res);}
 257  else
 258    if (mod==Cnil)
 259      {if (FIXNUMP(a) && FIXNUMP(b))
 260         return fplus(fix(a),fix(b));
 261       else return(number_plus(a,b));
 262     }
 263  else
 264    return(mcmod(number_plus(a,b),mod));}
 265
 266
 267 /*
 268 cdifference(a,b,mod)
 269 object a,b,mod;
 270 {if (FIXNUMP(a) && FIXNUMP(b))
 271   {if (mod==Cnil) return fplus(fix(a),(- fix(b)));
 272    else if (FIXNUMP(mod))
 273      {register int res, m ;
 274       res=subrem(fix(a),fix(b),m=fix(mod));
 275       FIX_MOD(res,m);
 276       return (CMPmake_fixnum(res));}}
 277  return mcmod(number_minus(a,b),mod);}
 278
 279
 280 object
 281 cplus(a,b,mod)
 282 object a,b,mod;
 283 {if (FIXNUMP(a) && FIXNUMP(b))
 284   {if (mod==Cnil) return fplus(fix(a),fix(b));
 285    else if (FIXNUMP(mod))
 286      {register int res, m ,m2;
 287       res=plusrem(fix(a),fix(b),m=fix(mod));
 288       m2=(m >> 1);
 289       if (res > m2) res=res-m;
 290       else if (res < -m2) res=res+m;
 291       return (CMPmake_fixnum(res));}}
 292  return mcmod(number_plus(a,b),mod);}
 293
 294 */
 295
 296
 297