home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / cmac.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-01-06  |  6.0 KB  |  323 lines
  1. #ifndef FIRSTWORD
  2. #include "include.h"
  3. #endif
  4. #include "mp.h"
  5. #include "arith.h"  
  6. #include "num_include.h"
  7.  
  8.  
  9. /* I believe the instructions used here are ok for 68010.. */
  10.  
  11. #ifdef MC68K
  12. #define MC68020
  13. #endif
  14.   
  15. static
  16. object *modulus;
  17. #define FIXNUMP(x) (type_of(x)==t_fixnum)
  18.  
  19. /* Note: the modulus is guaranteed > 0 */
  20.  
  21. #define FIX_MOD(X,MOD) {register int MOD_2; \
  22.                  if (X > (MOD_2=(MOD >>1))) X=X-MOD; else \
  23.                    if (X < -MOD_2)  X=X+MOD;}
  24.  
  25.  
  26.  
  27. #define MYmake_fixnum(doto,x) \
  28.   {register int CMPt1; \
  29.    doto \
  30.    ((((CMPt1=(x))+1024)&-2048)==0?small_fixnum(CMPt1):make_fixnum(CMPt1));}
  31.  
  32. void siLcmod();
  33. void siLcplus();
  34. void siLctimes();
  35. void siLcdifference();
  36.  
  37.  
  38. object ctimes(),cplus(),cdifference(),cmod();
  39.  
  40.  
  41.      
  42. init_cmac()
  43. {
  44. /* add_symbol("ctimes",&ctimes,"cplus",&cplus,"cdifference",&cdifference,"cmod",
  45.  &cmod, 0); */
  46. modulus = (&((make_si_special("MODULUS",Cnil))->s.s_dbind));
  47. make_si_function("CMOD",siLcmod);
  48. make_si_function("CPLUS",siLcplus);
  49. make_si_function("CTIMES",siLctimes);
  50. make_si_function("CDIFFERENCE",siLcdifference);
  51.  
  52. }
  53.  
  54. /* if hi < 0 this is taken to be the two's complement expression of
  55.    a bignum  */
  56. object
  57. signed_bignum2(hi,lo)
  58.      int hi,lo;
  59. { 
  60.   GEN w;
  61.   object result;
  62.   long u[4];
  63.   u[0] = 0x01010004;
  64.   u[1] = 0x01010004;
  65.   u[2] = 0;
  66.   u[3] = 0;
  67.   
  68.   if (hi < 0)
  69.       { setsigne(u,-1);
  70.     if (lo > 0) /* no borrow */
  71.      { lo = -lo;
  72.        hi = -hi;}
  73.        else {hi -= 1;
  74.          hi = -hi;}
  75.      }
  76.   else
  77.     if (hi > 0)
  78.       {setsigne(u,1);
  79.      }
  80.   else /*hi==0 */
  81.     { setsigne(u,1);
  82.       setlgef(u,3);
  83.       MP_LOW(u,3) = lo;
  84.       result = make_integer(u);
  85.       setlgef(u,4);
  86.       return result;}
  87.   /* its length 4 */
  88.   MP_START_LOW(w,u,4);
  89.   MP_NEXT_UP(w) = lo;
  90.   MP_NEXT_UP(w) = hi;
  91.   return(make_integer(u));
  92. }
  93.   
  94.   
  95.   
  96.        
  97.       
  98.  
  99. #ifdef MC68020
  100. /*    
  101. int
  102. dblrem(m,n,mod)
  103. int m,n,mod;
  104. { asm("movl a6@(8),d1");
  105.   asm("mulsl a6@(12),d0:d1");
  106.   asm("divsl a6@(16),d0:d1");
  107. }
  108. */
  109. #endif
  110.  
  111. object make_integer();  
  112.  
  113. static unsigned long small_pos_int[3]={0x1000003,0x01000003,0};
  114. static unsigned long small_neg_int[3]={0x1000003,0xff000003,0};
  115. static unsigned long s4_neg_int[4]={0x1000004,0xff000004,1,0};
  116.  
  117. object
  118. fplus(a,b)
  119.      int a,b;
  120. { int z ;
  121.   int x;
  122.   if (a >= 0)
  123.    { if (b >= 0)
  124.        { x = a + b;
  125.      if (x == 0) return small_fixnum(0);
  126.      small_pos_int[2]=x;
  127.      return make_integer(small_pos_int);
  128.        }
  129.      else
  130.        { /* b neg */
  131.      x = a + b;
  132.      MYmake_fixnum(return,x);
  133.        }}
  134.   else
  135.     { /* a neg */
  136.       if (b >= 0)
  137.     { x = a + b;
  138.       MYmake_fixnum(return,x);
  139.     }
  140.       else
  141.     { /* both neg */
  142.         { unsigned long Xtx,Xty,overflow,Xtres;
  143.           Xtres = addll(-a,-b);
  144.           if (overflow)
  145.         { 
  146.           s4_neg_int[3]=Xtres;
  147.           return make_integer(s4_neg_int);}
  148.           else
  149.         { small_neg_int[2]=Xtres;
  150.           return make_integer(small_neg_int);}
  151.         }}}
  152. }
  153.  
  154.  
  155. object
  156. fminus(a,b)
  157.      int a,b;
  158. { int z ;
  159.   int x;
  160.   if (a >= 0)
  161.    { if (b >= 0)
  162.        { x = a - b;
  163.      MYmake_fixnum(return,x);
  164.      }
  165.      else
  166.        { /* b neg */
  167.      x = a - b;
  168.      if (x==0) return small_fixnum(0);
  169.      small_pos_int[2]=x;
  170.      return make_integer(small_pos_int);
  171.        }}
  172.   else
  173.     { /* a neg */
  174.       if (b <= 0)
  175.     { x = a - b;
  176.       MYmake_fixnum(return,x);
  177.     }
  178.       else
  179.     {  /* b positive */
  180.         { unsigned long Xtx,Xty,overflow,Xtres;
  181.           unsigned long t[4];
  182.           Xtres = addll(-a,b);
  183.           if (overflow)
  184.         { s4_neg_int[3]=Xtres;
  185.           return make_integer(s4_neg_int);}
  186.           else
  187.         { small_neg_int[2]=Xtres;
  188.           return make_integer(small_neg_int);}
  189.         }}}
  190. }
  191.        
  192. #define our_minus(a,b) ((FIXNUMP(a)&&FIXNUMP(b))?fminus(fix(a),fix(b)): \
  193.             number_minus(a,b))
  194. #define our_plus(a,b) ((FIXNUMP(a)&&FIXNUMP(b))?fplus(fix(a),fix(b)): \
  195.             number_plus(a,b))
  196. #define our_times(a,b) number_times(a,b)
  197.  
  198. int
  199. dblrem(a,b,mod)
  200. int a,b,mod;
  201. {int h,l,sign;
  202.  if (a<0) 
  203.    {a= -a; sign= (b<0)? (b= -b,1) :-1;}
  204.  else { sign= (b<0) ? (b= -b,-1) : 1;}
  205.  
  206.  l = mulul(a,b,h);
  207.  b = divul(l,mod,h);
  208.  return ((sign<0) ? -h :h);}
  209.  
  210.  
  211. object      
  212. cmod(x)
  213. object x;
  214. {register object mod = *modulus;
  215.  if (mod==Cnil) return(x);
  216. else
  217.  if((type_of(mod)==t_fixnum && type_of(x)==t_fixnum))
  218.     {register int xx,mm;
  219.      mm=fix(mod);
  220.      if (mm==2) {xx= (fix(x) & 1); return(small_fixnum(xx));}
  221.      xx=(fix(x)%mm);
  222.      FIX_MOD(xx,mm);
  223.      MYmake_fixnum(return,xx);
  224.    }
  225.  else
  226.    {object qp,rp,mod2;
  227.     int compare;
  228.     integer_quotient_remainder_1(x,mod,&qp,&rp);
  229.     mod2=shift_integer(mod,-1);
  230.     compare = number_compare(rp,small_fixnum(0));
  231.     if (compare >= 0)
  232.       {compare=number_compare(rp,mod2);
  233.        if (compare > 0) rp=number_minus(rp,mod);}
  234.     else
  235.       if (number_compare(number_negate(mod2), rp) > 0)
  236.     {rp = number_plus(rp,mod);}
  237.     return rp;}}
  238.  
  239. object
  240. ctimes(a,b)
  241. object a,b;
  242. {object mod = *modulus;
  243.  if (FIXNUMP(mod))
  244.      {register int res, m ;
  245.       res=dblrem(fix(a),fix(b),m=fix(mod));
  246.       FIX_MOD(res,m);
  247.       MYmake_fixnum(return,res);}
  248. else if (mod==Cnil)
  249.   { return(our_times(a,b));}
  250. return cmod(number_times(a,b));}
  251.  
  252.  
  253. object
  254. cdifference(a,b)
  255. object a,b;
  256. {object mod = *modulus;
  257.  if (FIXNUMP(mod))
  258.    {register int res,m;
  259.     res=((fix(a)-fix(b))%(m=fix(mod)));
  260.     FIX_MOD(res,m);
  261.     MYmake_fixnum(return,res);}
  262.  else if (mod==Cnil)
  263.      return (our_minus(a,b));
  264.  else return(cmod(number_minus(a,b)));}
  265.  
  266. object
  267. cplus(a,b)
  268. object a,b;
  269. {object mod = *modulus;
  270.  if (FIXNUMP(mod))
  271.    {register int res,m;
  272.     res=((fix(a)+fix(b))%(m=fix(mod)));
  273.     FIX_MOD(res,m);
  274.     MYmake_fixnum(return,res);}
  275.  else
  276.    if (mod==Cnil)
  277.      return (our_plus(a,b));
  278.  else
  279.    return(cmod(number_plus(a,b)));}
  280.  
  281. void
  282. siLcmod()
  283. {check_arg(1);
  284.  vs_base[0]=cmod(vs_base[0]);
  285. }
  286.  
  287. void
  288. siLcplus()
  289. {register object *base;
  290.  base=vs_base;
  291.  check_arg(2);
  292.  base[0]=cplus(base[0],base[1]);
  293.  vs_top=base+1;
  294. }
  295.  
  296. void
  297. siLctimes()
  298. {register object *base;
  299.  base=vs_base;
  300.  check_arg(2);
  301.  base[0]=ctimes(base[0],base[1]);
  302.  vs_top=base+1;
  303. }
  304.  
  305. void
  306. siLcdifference()
  307. {register object *base;
  308.  base=vs_base;
  309.  check_arg(2);
  310.  base[0]=cdifference(base[0],base[1]);
  311.  vs_top=base+1;
  312. }
  313.  
  314. object 
  315. memq(a,b)
  316. register object a,b;
  317. {while (1)
  318.     {if ((a==b->c.c_car)||b==Cnil) return b;
  319.     b=b->c.c_cdr;}}
  320.  
  321.  
  322.  
  323.