arith.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* arith.c  EULISP arithmetic functions                 
00003 /* Copyright(c)1988 Toshihiro MATSUI, Electrotechnical Laboratory
00004 /*      1986-May
00005 .*      1988-Feb        boxing and unboxing recoded by macros
00006 /****************************************************************/
00007 
00008 static char *rcsid="@(#)$Id$";
00009 
00010 #include "eus.h"
00011 #include <math.h>
00012 #if alpha
00013 #include <limits.h>
00014 #endif
00015 #if Cygwin
00016 #include <stdlib.h>
00017 #endif
00018 
00019 extern pointer RANDSTATE;
00020 extern int gcd();
00021 extern pointer makeratio();
00022 
00023 extern pointer copy_big(), big_plus(), big_minus();
00024 extern void    sub_int_big(), add_int_big();
00025 extern pointer add_big_big(), big_times();
00026 extern pointer makebig(), makebig1(), makebig2(), extend_big(pointer,int);
00027 extern pointer normalize_bignum();
00028 extern eusfloat_t big_to_float(pointer);
00029 extern pointer eusfloat_to_big(float);
00030 extern eusinteger_t big_sign(pointer);
00031 
00032 /****************************************************************/
00033 /* number predicates
00034 /****************************************************************/
00035 pointer NUMEQUAL(ctx,n,argv)
00036 register context *ctx;
00037 register int n;
00038 register pointer argv[];
00039 { register eusfloat_t fx,fy;
00040   register pointer a,x;
00041   numunion nu;
00042 
00043   if (n<=1) error(E_MISMATCHARG);
00044   x=argv[--n];
00045   if (isint(x)) {
00046     while (--n>=0) {
00047       a=argv[n];
00048       if (isflt(a)) { fx=intval(x); fy=fltval(a); goto flteqnum;}
00049       else if (isint(a)) { if (x!=a) return(NIL);}
00050       else if (pisratio(a)) { x=makeratio(intval(x),1); goto reqnum;}
00051       else if (pisbignum(a)) { return(NIL);} /* kanehiro's patch 2000.12.13 */
00052       else  error(E_NONUMBER);}
00053     return(T);}
00054   else if (isratio(x)) {
00055     while (--n>=0) {
00056       a=argv[n];
00057       if (isflt(a)) { fx=ratio2flt(x); fy=fltval(a); goto flteqnum;}
00058       else if (isint(a)) a=makeratio(intval(a),1);
00059       else if (!pisratio(a))  error(E_NONUMBER);
00060 reqnum:
00061       if ((a->c.ratio.numerator != x->c.ratio.numerator) ||
00062           (a->c.ratio.denominator != x->c.ratio.denominator))
00063         return(NIL);}
00064     return(T);}
00065   else  if (isflt(x)) {
00066     fx=fltval(x);
00067     while (--n>=0) {
00068       fy=ckfltval(argv[n]);
00069 flteqnum:
00070       if (fx!=fy) return(NIL);}
00071     return(T); }
00072   else if (pisbignum(x)) 
00073     { eusinteger_t *xv, *av;
00074       int size,i;
00075       xv=bigvec(x); size=bigsize(x);
00076       while (--n >=0) {
00077         a=argv[n];
00078         if (!isbignum(a)) return(NIL);
00079         if (size != bigsize(a)) return(NIL);
00080         av=bigvec(a);
00081         for (i=0; i<size; i++) if (xv[i]!=av[i]) return(NIL);}
00082       return(T); }
00083   else error(E_NONUMBER);}
00084 
00085 pointer NUMNEQUAL(ctx,n,argv)
00086 register context *ctx;
00087 register int n;
00088 register pointer argv[];
00089 { register i;
00090   pointer cmparr[2];
00091   numunion nu;
00092 
00093   if (n<=1) error(E_MISMATCHARG);
00094   while(--n>=0) {
00095     cmparr[0] = argv[n];
00096     for(i=0;i<n;++i){
00097       cmparr[1]=argv[i];
00098       if((NIL) != NUMEQUAL(ctx,2,cmparr))
00099         return(NIL);}}
00100   return(T);
00101 }
00102 
00103 pointer GREATERP(ctx,n,argv)
00104 register context *ctx;
00105 register int n;
00106 register pointer argv[];
00107 { register pointer left,right;
00108   register eusfloat_t fleft,fright;
00109   eusinteger_t ival;
00110   eusinteger_t sign;
00111   int comparison;
00112   numunion nu;
00113 
00114   if (n<=1) error(E_MISMATCHARG);
00115   right=argv[--n];
00116 
00117   if (isint(right)) goto INTGT;
00118   else if (isflt(right))  goto FLTGT;
00119   else if (pisratio(right)) goto RATGT;
00120   else if (pisbignum(right)) goto BIGGT;
00121   else error(E_NONUMBER);
00122 
00123 INTGT:
00124   while (--n>=0) {
00125     left=argv[n];
00126     if (isint(left)) {
00127       if ((eusinteger_t)left <= (eusinteger_t)right) return(NIL); }
00128     else if (isflt(left)) { fright=intval(right); goto fltgt2;}
00129     else if (isbignum(left)) {
00130       if (big_sign(left)<0) return(NIL); 
00131       right=left; goto BIGGT; }
00132     if (!isint(left)) error(E_NONUMBER);
00133     right=left;}
00134   return(T);
00135 
00136 BIGGT:
00137   sign=big_sign(right);
00138   while (--n>=0) {
00139     left=argv[n];
00140     if (isint(left)) {
00141       ival= intval(left);
00142       if (sign>=0) return(NIL);
00143       right=left;
00144       goto INTGT; }
00145     else if (isflt(left)) {
00146       fright=big_to_float(right);
00147       if (fltval(left)<=fright) return(NIL);
00148       goto FLTGT1;}
00149     else if (pisbignum(left)) {
00150       comparison=big_compare(left, right);
00151       if (comparison<=0) return(NIL);
00152       right=left;
00153       sign=big_sign(right);}
00154     else if (isratio(left)) goto RATGT; }
00155 FLTGT:
00156   fright=fltval(right);
00157 FLTGT1:
00158   while (--n>=0) {
00159     fltgt2:  fleft=ckfltval(argv[n]);
00160     if (fleft<=fright) return(NIL);
00161     fright=fleft; }
00162   return(T); 
00163 RATGT:
00164   error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
00165   }
00166 
00167 pointer LESSP(ctx,n,argv)
00168 register context *ctx;
00169 register int n;
00170 register pointer argv[];
00171 { register pointer left,right;
00172   register eusfloat_t fleft,fright;
00173   eusinteger_t ival;
00174   eusinteger_t sign;
00175   int comparison;
00176   numunion nu;
00177 
00178   if (n<=1) error(E_MISMATCHARG);
00179   right=argv[--n];
00180 
00181   if (isint(right)) goto INTLT;
00182   else if (isflt(right))  goto FLTLT;
00183   else if (pisratio(right)) goto RATLT;
00184   else if (pisbignum(right)) goto BIGLT;
00185   else error(E_NONUMBER);
00186 
00187 INTLT:
00188   while (--n>=0) {
00189     left=argv[n];
00190     if (isint(left)) {
00191       if ((eusinteger_t)left >= (eusinteger_t)right) return(NIL); }
00192     else if (isflt(left)) { fright=intval(right); goto FLTLT2;}
00193     else if (isbignum(left)) {
00194       if (big_sign(left)>0) return(NIL); 
00195       right=left; goto BIGLT; }
00196     if (!isint(left)) error(E_NONUMBER);
00197     right=left;}
00198   return(T);
00199 
00200 BIGLT:
00201   sign=big_sign(right);
00202   while (--n>=0) {
00203     left=argv[n];
00204     if (isint(left)) {
00205       ival= intval(left);
00206       if (sign<0) return(NIL);
00207       right=left;
00208       goto INTLT; }
00209     else if (isflt(left)) {
00210       fright=big_to_float(right);
00211       if (fltval(left)>=fright) return(NIL);
00212       goto FLTLT1;}
00213     else if (pisbignum(left)) {
00214       comparison=big_compare(left, right);
00215       if (comparison>=0) return(NIL);
00216       right=left;
00217       sign=big_sign(right);}
00218     else if (isratio(left)) goto RATLT; }
00219 FLTLT:
00220   fright=fltval(right);
00221 FLTLT1:
00222   while (--n>=0) {
00223     FLTLT2:  fleft=ckfltval(argv[n]);
00224     if (fleft>=fright) return(NIL);
00225     fright=fleft; }
00226   return(T); 
00227 RATLT:
00228   error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
00229   }
00230 
00231 pointer GREQP(ctx,n,argv)       
00232 register context *ctx;
00233 register int n;
00234 register pointer argv[];
00235 { register pointer left,right;
00236   register eusfloat_t fleft,fright;
00237   eusinteger_t ival;
00238   eusinteger_t sign;
00239   int comparison;
00240   numunion nu;
00241 
00242   if (n<=1) error(E_MISMATCHARG);
00243   right=argv[--n];
00244 
00245   if (isint(right)) goto INTGE;
00246   else if (isflt(right))  goto FLTGE;
00247   else if (pisratio(right)) goto RATGE;
00248   else if (pisbignum(right)) goto BIGGE;
00249   else error(E_NONUMBER);
00250 
00251 INTGE:
00252   while (--n>=0) {
00253     left=argv[n];
00254     if (isint(left)) {
00255       if ((eusinteger_t)left < (eusinteger_t)right) return(NIL); }
00256     else if (isflt(left)) { fright=intval(right); goto FLTGE2;}
00257     else if (isbignum(left)) {
00258       if ((sign=big_sign(left))<0) return(NIL);
00259       right=left; goto BIGGE; }
00260     if (!isint(left)) error(E_NONUMBER);
00261     right=left;}
00262   return(T);
00263 
00264 BIGGE:
00265   sign=big_sign(right);
00266   while (--n>=0) {
00267     left=argv[n];
00268     if (isint(left)) {
00269       ival= intval(left);
00270       if (sign>0) return(NIL);
00271       right=left;
00272       goto INTGE; }
00273     else if (isflt(left)) {
00274       fright=big_to_float(right);
00275       if (fltval(left)<fright) return(NIL);
00276       goto FLTGE1;}
00277     else if (pisbignum(left)) {
00278       comparison=big_compare(left, right);
00279       if (comparison<0) return(NIL);
00280       right=left;
00281       sign=big_sign(right);}
00282     else if (isratio(left)) goto RATGE; }
00283 FLTGE:
00284   fright=fltval(right);
00285 FLTGE1:
00286   while (--n>=0) {
00287     FLTGE2:  fleft=ckfltval(argv[n]);
00288     if (fleft<fright) return(NIL);
00289     fright=fleft; }
00290   return(T); 
00291 RATGE:
00292   error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
00293   }
00294 
00295 pointer LSEQP(ctx,n,argv)       /*less-or-equalp*/
00296 register context *ctx;
00297 int n;
00298 pointer argv[];
00299 { register pointer left,right;
00300   register eusfloat_t fleft,fright;
00301   eusinteger_t ival;
00302   eusinteger_t sign;
00303   int comparison;
00304   numunion nu;
00305 
00306   if (n<=1) error(E_MISMATCHARG);
00307   right=argv[--n];
00308 
00309   if (isint(right)) goto INTLE;
00310   else if (isflt(right))  goto FLTLE;
00311   else if (pisratio(right)) goto RATLE;
00312   else if (pisbignum(right)) goto BIGLE;
00313   else error(E_NONUMBER);
00314 
00315 INTLE:
00316   while (--n>=0) {
00317     left=argv[n];
00318     if (isint(left)) {
00319       if ((eusinteger_t)left > (eusinteger_t)right) return(NIL); }
00320     else if (isflt(left)) { fright=intval(right); goto FLTLE2;}
00321     else if (isbignum(left)) {
00322       if ((sign=big_sign(left))>0) return(NIL);
00323       right=left; goto BIGLE; }
00324     if (!isint(left)) error(E_NONUMBER);
00325     right=left;}
00326   return(T);
00327 
00328 BIGLE:
00329   sign=big_sign(right);
00330   while (--n>=0) {
00331     left=argv[n];
00332     if (isint(left)) {
00333       ival= intval(left);
00334       if (sign<0) return(NIL);
00335       right=left;
00336       goto INTLE; }
00337     else if (isflt(left)) {
00338       fright=big_to_float(right);
00339       if (fltval(left) > fright) return(NIL);
00340       goto FLTLE1;}
00341     else if (pisbignum(left)) {
00342       comparison=big_compare(left, right);
00343       if (comparison > 0) return(NIL);
00344       right=left;
00345       sign=big_sign(right);}
00346     else if (isratio(left)) goto RATLE; }
00347 FLTLE:
00348   fright=fltval(right);
00349 FLTLE1:
00350   while (--n>=0) {
00351     FLTLE2:  fleft=ckfltval(argv[n]);
00352     if (fleft > fright) return(NIL);
00353     fright=fleft; }
00354   return(T); 
00355 RATLE:
00356   error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
00357   }
00358 
00359 pointer MOD(ctx,n,argv)
00360 register context *ctx;
00361 int n;
00362 pointer argv[];
00363 { ckarg(2);
00364   if (isflt(argv[0]) || isflt(argv[1])) {
00365     numunion nu;
00366     register eusfloat_t x,y;
00367     x=ckfltval(argv[0]); y=ckfltval(argv[1]);
00368     return(makeflt(fmod(x,y)));
00369   } else {
00370     register eusinteger_t x,y;
00371     x=bigintval(argv[0]); y=bigintval(argv[1]);
00372     return(mkbigint(x % y));}}
00373 
00374 pointer SUB1(ctx,n,argv)
00375 register context *ctx;
00376 int n;
00377 pointer argv[];
00378 { register pointer a=argv[0];
00379   eusfloat_t x;
00380   numunion nu;
00381 
00382   ckarg(1);
00383   if (a==makeint(MINNEGFIXNUM)) { return(makebig1(MINNEGFIXNUM-1));}
00384   if (isint(a)) return((pointer)((eusinteger_t)a-4));
00385   else if (isflt(a)) {
00386     x=fltval(a);
00387     return(makeflt(x-1.0)); }
00388   else if (isbignum(a)) {
00389     a=copy_big(a); sub_int_big(1,a); return(normalize_bignum(a));}
00390   else error(E_NOINT);
00391   }
00392 
00393 
00394 pointer ADD1(ctx,n,argv)
00395 register context *ctx;
00396 int n;
00397 pointer argv[];
00398 { register pointer a=argv[0];
00399   eusfloat_t x;
00400   numunion nu;
00401 
00402   ckarg(1);
00403   if (a==makeint(MAXPOSFIXNUM)) { return(makebig1(MAXPOSFIXNUM+1));}
00404   if (isint(a)) return((pointer)((eusinteger_t)a+4));
00405   else if (isflt(a)) {
00406     x=fltval(a);
00407     return(makeflt(x+1.0)); }
00408   else if (isbignum(a)) {
00409     a=copy_big(a); add_int_big(1,a); return(a);}
00410   else error(E_NOINT);
00411   }
00412 
00413 /* extended numbers */
00414 
00415 pointer ratio_plus(x,y)
00416 pointer x,y;
00417 {
00418   register eusinteger_t x_num, x_den, y_num, y_den, z_num, z_den, d1,d2,t;
00419 
00420   x_num = intval(x->c.ratio.numerator);
00421   x_den = intval(x->c.ratio.denominator);
00422   y_num = intval(y->c.ratio.numerator);
00423   y_den = intval(y->c.ratio.denominator);
00424   
00425   d1=gcd(x_den,y_den);
00426   if(d1 == 1){
00427   z_num = x_num * y_den + x_den * y_num;
00428   z_den = x_den * y_den;
00429   return(makeratio(z_num,z_den));}
00430   else{
00431     t = x_num * (y_den / d1) + y_num * (x_den / d1);
00432     d2=gcd(t,d1);
00433     
00434     z_num = t / d2;
00435     z_den = (x_den / d1) * (y_den / d2);
00436     return(makeratio(z_num,z_den));}
00437 }
00438 
00439 pointer ratio_minus(x,y)
00440 pointer x,y;
00441 {
00442   register eusinteger_t x_num,x_den,y_num,y_den,z_num,z_den,d1,d2,t;
00443 
00444   x_num = intval(x->c.ratio.numerator);
00445   x_den = intval(x->c.ratio.denominator);
00446   y_num = intval(y->c.ratio.numerator);
00447   y_den = intval(y->c.ratio.denominator);
00448   d1 = gcd(x_den,y_den);
00449   if(d1 == 1){
00450     z_num = x_num * y_den - x_den * y_num;
00451     z_den = x_den * y_den;
00452   return(makeratio(z_num,z_den));}
00453   else{
00454     t = x_num * (y_den / d1) - y_num * (x_den / d1);
00455     d2=gcd(t,d1);
00456     z_num = t / d2;
00457     z_den = (x_den / d1) * (y_den / d2);
00458     return(makeratio(z_num,z_den));}
00459 }
00460 
00461 pointer ratio_times(x,y)
00462 pointer x,y;
00463 {
00464   register eusinteger_t x_num,x_den,y_num,y_den,z_num,z_den,d1,d2;
00465 
00466   x_num = intval(x->c.ratio.numerator);
00467   x_den = intval(x->c.ratio.denominator);
00468   y_num = intval(y->c.ratio.numerator);
00469   y_den = intval(y->c.ratio.denominator);
00470   d1=gcd(x_num,y_den);
00471   d2=gcd(x_den,y_num);
00472 
00473   z_num = (x_num / d1) * (y_num / d2);
00474   z_den = (x_den / d2) * (y_den / d1);
00475 
00476   return(makeratio(z_num,z_den));
00477 }
00478 
00479 pointer ratio_divide(x,y)
00480 pointer x,y;
00481 {
00482   register eusinteger_t x_num,x_den,y_num,y_den,z_num,z_den,d1,d2;
00483   register int sign;
00484 
00485   x_num = intval(x->c.ratio.numerator);
00486   x_den = intval(x->c.ratio.denominator);
00487   y_num = intval(y->c.ratio.numerator);
00488   y_den = intval(y->c.ratio.denominator);
00489    
00490   d1=gcd(x_num,y_num);
00491   d2=gcd(x_den,y_den);
00492 
00493   if(y_num >= 0) sign=1; else sign=-1;
00494 
00495   z_num = (x_num / d1) * (y_den  / d2) * sign;
00496   z_den = abs((x_den / d2) * (y_num / d1));
00497 
00498   return(makeratio(z_num,z_den));
00499 }
00500 
00501 pointer int2ratio(i)
00502 eusinteger_t i;
00503 { return(makeratio(i,1));}
00504 
00505 eusfloat_t ratio2flt(r)
00506 pointer r;
00507 { pointer p,q;
00508   eusfloat_t num, den;
00509   p=r->c.ratio.numerator;
00510   q=r->c.ratio.denominator;
00511   if (isint(p)) num=intval(p);
00512   else if (isbignum(p)) num=big_to_float(p);
00513   else error(E_USER,(pointer)"illegal ratio numerator");
00514 
00515   if (isint(q)) den=intval(q);
00516   else if (isbignum(q)) den=big_to_float(q);
00517   else error(E_USER,(pointer)"illegal ratio denominator");
00518 
00519   return(num/den);}
00520 
00521 pointer return_ratio(r)
00522 pointer r;
00523 { if (intval(r->c.ratio.numerator)==0) return(makeint(0));
00524   else if (intval(r->c.ratio.denominator)==1) return(r->c.ratio.numerator);
00525   else return(r);}
00526 
00527 
00528 pointer PLUS(ctx,n,argv)
00529 register context *ctx;
00530 register int  n;
00531 register pointer argv[];
00532 { eusfloat_t fs;
00533   register eusinteger_t is=0,j;
00534   register int i=0;
00535   register pointer a, r, rs;
00536   pointer b;
00537   numunion nu;
00538 
00539   while (i<n) {
00540     a=argv[i];
00541     if (isint(a)) {
00542       j=intval(a);
00543       is+=j;
00544       if (((is >> 1) ^ is)&((eusinteger_t)1<<(WORD_SIZE-3))) { /* fixnum overflow */
00545         b=makebig1(0); goto bigplus;} }
00546     else if (isflt(a)) { fs=is; goto fplus;}
00547     else if (pisratio(a)) { rs=makeratio(is,1);  goto rplus;}
00548     else if (pisbignum(a)) { b=copy_big(a); goto bigplus;}
00549     else error(E_NONUMBER);
00550     i++;}
00551   return(makeint(is));
00552 rplus:
00553   while (i<n) {
00554     a=argv[i];
00555     if (isint(a)) a=makeratio(intval(a),1);
00556     else if (isflt(a)) {  fs=ratio2flt(rs);   goto fplus;}
00557     else if (!isratio(a)) error(E_NONUMBER);
00558     rs= ratio_plus(rs, a);
00559     i++;}
00560   return(return_ratio(rs));
00561 fplus:
00562   while (i<n) {
00563     fs+=ckfltval(argv[i]);
00564     i++;}
00565   return(makeflt(fs));
00566 bigplus:
00567   /*  fprintf(stderr, "big plus\n"); */
00568   i++;
00569   if (is >= 0)  add_int_big(is, b);
00570   else sub_int_big(-is, b);
00571   vpush(b);
00572   while (i<n) {
00573     a=argv[i];
00574     if (isint(a)) {
00575       j=intval(a);
00576       if (j>0) add_int_big(j,b);
00577       else if (j<0) sub_int_big(-j,b); 
00578       b=normalize_bignum(b);}
00579     else if (isbignum(a)) {
00580       b=big_plus(a,b);
00581       vpop();
00582       vpush(b);
00583       b=normalize_bignum(b);
00584       }
00585     i++; }
00586   vpop();
00587   return(b);
00588   }
00589 
00590 pointer MINUS(ctx,n,argv)
00591 register context *ctx;
00592 register int  n;
00593 register pointer argv[];
00594 { eusfloat_t fs;
00595   register eusinteger_t is,ia;
00596   register int i;
00597   register pointer a=argv[0], rs, b, z;
00598   numunion nu;
00599 
00600   if (n<1) error(E_MISMATCHARG);
00601   else if (n==1) {      /*negate*/
00602     if (a==makeint(MINNEGFIXNUM)) return(makebig1(-MINNEGFIXNUM));
00603     if (isint(a)) return(makeint(-intval(a)));
00604     else if (isflt(a)) {
00605       fs= -fltval(a);
00606       return(makeflt(fs));}
00607     else if (isratio(a)) {      /* buggy when numerator == MINNEGFIXNUM */
00608       return(makeratio(-intval(a->c.ratio.numerator),
00609                         intval(a->c.ratio.denominator)));}
00610 
00611     else if (isbignum(a)) {  return(normalize_bignum(big_minus(a)));}
00612     else error(E_NONUMBER); }
00613 
00614   /* n>1 */
00615 
00616   i=1; 
00617 
00618   if (isint(a)) { is=intval(a); goto IMINUS;}
00619   else if (isflt(a)) { fs=fltval(a); goto FMINUS;}
00620   else if (pisratio(a)) { rs=a; goto RMINUS;}
00621   else if (isbignum(a)) { b=copy_big(a); goto BIGMINUS;}
00622   else error(E_NONUMBER);
00623 
00624 IMINUS:
00625   while (i<n) {
00626     a=argv[i++];
00627     if (isint(a)) {
00628       is -= intval(a);
00629       if (((is >> 1) ^ is)&((eusinteger_t)1<<(WORD_SIZE-3))) { /* fixnum overflow */
00630         b=makebig1(is); goto BIGMINUS;} }
00631     else if (isflt(a)) { fs=is; goto FMINUS1;}
00632     else if (pisratio(a)) { rs=makeratio(is,1); goto RMINUS1;}
00633     else if (isbignum(a)) {
00634       z=big_minus(a);  /* bignum -a is copied to z */
00635       vpush(z);
00636       if (is>0)  add_int_big(is, z);
00637       else if (is<0) sub_int_big(-is, z);
00638       z=normalize_bignum(z);
00639       if (isint(z)) { vpop(); is= intval(z);}
00640       else { b=z; goto BIGMINUS1;} }
00641     else error(E_NONUMBER);    } 
00642   return(makeint(is));
00643 
00644 RMINUS:
00645   while (i<n) {
00646     a=argv[i++];
00647 RMINUS1:
00648     if (isint(a)) a=makeratio(intval(a),1);
00649     else if (isflt(a)) {  fs=ratio2flt(rs);   goto FMINUS;}
00650     else if (!isratio(a)) error(E_NONUMBER);
00651     rs= ratio_minus(rs, a);
00652     }
00653   return(return_ratio(rs));
00654 
00655 FMINUS:
00656   while (i<n) {
00657     a=argv[i++];
00658 FMINUS1:
00659     fs -= ckfltval(a);    }
00660   return(makeflt(fs));
00661 
00662 BIGMINUS:
00663    vpush(b);
00664 BIGMINUS1:
00665    while (i<n) {
00666      a=argv[i++];
00667      if (isint(a)) {
00668         ia=intval(a);
00669         if (ia>0) sub_int_big(intval(a), b);
00670         else if (ia<0) add_int_big(-ia, b);
00671         b=normalize_bignum(b);
00672         if (isint(b)) { vpop(); is=intval(b); goto IMINUS;}
00673         }
00674      else if (isflt(a)) {
00675         is= big_to_float(b); vpop(); goto FMINUS;}
00676      else if (isbignum(a)) {
00677         z= big_minus(a);
00678         vpush(z);
00679         b=big_plus(b,z);
00680         ctx->vsp[-2]=b; /*replace b on the stack*/
00681         vpop();
00682         b=normalize_bignum(b);
00683         if (isint(b)) { vpop(); is=intval(b); goto IMINUS;}
00684         }
00685      else if (isratio(a)) error(E_USER,(pointer)"BIG-RATIO not supported");
00686      else error(E_NONUMBER);}
00687     return(b);}
00688 
00689 pointer TIMES(ctx,n,argv)
00690 register context *ctx;
00691 register int n;
00692 register pointer argv[];
00693 { register eusfloat_t fs;
00694   register eusinteger_t is,s;
00695   register int i;
00696   register eusinteger_t sign=1;
00697   register pointer a, rs, b;
00698   eusinteger_t hi, lo;
00699   numunion nu;
00700 
00701 /*  fprintf(stderr, "TIMES ");
00702   for (i=0; i<n; i++) fprintf(stderr, "%x ", argv[i]);
00703   fprintf(stderr, "\n"); */
00704   
00705   i=1;  
00706   a=argv[0];
00707   if (isint(a)) { is=intval(a); goto ITIMES;}
00708   else if (isflt(a)) { fs=fltval(a); goto FTIMES;}
00709   else if (isratio(a)) { rs=a; vpush(rs); goto RTIMES;}
00710   else if (isbignum(a)) { b=copy_big(a); vpush(b); goto BIGTIMES;}
00711   else error(E_NONUMBER);
00712 
00713 ITIMES:
00714   while (i<n) {
00715     a=argv[i++];
00716 ITIMES1:
00717 
00718     if (isint(a)) {
00719       s=intval(a);
00720       if (s==0 || is==0) { is=0; break;}
00721       if (is<0) { sign= -1; is = -is;}
00722       if (s<0) { sign= -sign; s = -s;}
00723       extended_mul(is, s, 0, &hi, &lo);
00724       if( hi !=0 || (lo & ((eusinteger_t)7 << (WORD_SIZE-3)))!=0) { /*overflow -->bignum */
00725         b=makebig2(hi, lo & MASK);
00726         b=normalize_bignum(b);
00727         vpush(b);
00728         if (sign<0) complement_big(b);
00729         goto BIGTIMES;}
00730       else is= lo*sign;}
00731     else if (isflt(a)) { fs=is; goto FTIMES1;}
00732     else if (pisbignum(a)) { /* fixnum times bignum */
00733       b=copy_big(a);
00734       vpush(b);
00735       goto BIGTIMES1;}
00736     else if (pisratio(a)) {
00737       rs=makeratio(is,1);
00738       vpush(rs);
00739       goto RTIMES1;}
00740     else error(E_NONUMBER);}
00741   return(makeint(is));
00742 
00743 RTIMES:
00744   while (i<n) {
00745     a=argv[i++];
00746 RTIMES1:
00747     if (isint(a)) a=makeratio(intval(a),1);
00748     else if (isflt(a)) {  fs=ratio2flt(rs);   goto FTIMES1;}
00749     else if (!isratio(a)) error(E_NONUMBER);
00750     rs= ratio_times(rs, a); 
00751     ctx->vsp[-1]=rs;
00752     }
00753   ctx->lastalloc=rs;
00754   vpop();
00755   return(return_ratio(rs));
00756 
00757 BIGTIMES:
00758   while (i<n) {
00759     a=argv[i++];
00760     if (isint(a)) {
00761       is=intval(a);
00762 BIGTIMES1:
00763       /* Here, b is saved, (b * is) is going to be performed */
00764       sign=big_sign(b);
00765       if (sign<0) { complement_big(b);}
00766       if (is<0) { sign = -sign; is= -is;}
00767       mul_int_big(is, b);
00768       if (sign<0) complement_big(b);
00769       b=normalize_bignum(b);
00770       if (isint(b)) { is=intval(b); vpop(); goto ITIMES;}
00771       }
00772     else if (isflt(a)) {
00773       fs = big_to_float(b); vpop(); goto FTIMES1;}
00774     else if (pisbignum(a)) {
00775       sign=big_sign(b);
00776       if (sign<0) complement_big(b);
00777       if (big_sign(a)<0) { sign= -sign; a=big_minus(a);}
00778       vpush(a);
00779       b=big_times(a,b);
00780       ctx->vsp[-2]=b;
00781       vpop();
00782       b=normalize_bignum(b);
00783       if (isint(b)) { is=intval(b); vpop(); goto ITIMES;}
00784       }
00785     else if (pisratio(a)) {
00786       error(E_USER,(pointer)"sorry, big * ratio is not yet implemented.");}
00787     else error(E_NONUMBER);
00788     }
00789   ctx->lastalloc= vpop();
00790   return(b);
00791 
00792 FTIMES:
00793   while (i<n) {
00794     a=argv[i++];
00795 FTIMES1:
00796     fs*=ckfltval(a);}
00797   return(makeflt(fs));}
00798 
00799 pointer QUOTIENT(ctx, n,argv)
00800 register context *ctx;
00801 register int  n;
00802 pointer argv[];
00803 { register eusfloat_t fs;
00804   register eusinteger_t is;
00805   register int i=1;
00806   register pointer a, rs;
00807   numunion nu;
00808   int sign;
00809 
00810   if (n<1) error(E_MISMATCHARG);
00811   a=argv[0];
00812   if (isint(a)) is=intval(a);
00813   else if (isflt(a)) { fs=fltval(a); goto fquo;}
00814   else if (pisratio(a)) {rs=a; goto rquo;}
00815   else if (pisbignum(a)) { rs=copy_big(a); goto bquo;}
00816   else error(E_NONUMBER);
00817 
00818   if (n==1) {
00819     fs=fltval(a);
00820     return(makeflt(1.0/fs));}
00821 
00822   while (i<n) {
00823     a=argv[i];
00824     if (isflt(a)) { fs=is; goto fquo2;}
00825     else if (isint(a)) is/=intval(a);
00826     else if (pisratio(a)) { rs=makeratio(is,1); goto rquo;}
00827     else if (pisbignum(a)) is = 0;
00828     else error(E_NONUMBER);
00829     i++;}
00830   return(makeint(is));
00831 
00832 rquo:   /*quotient of ratios*/
00833   while (i<n) {
00834     a=argv[i];
00835     if (isint(a)) a=makeratio(intval(a),1);
00836     else if (isflt(a)) {  fs=ratio2flt(rs);   goto fquo;}
00837     else if (!isratio(a)) error(E_NONUMBER);
00838     rs= ratio_divide(rs, a);
00839     i++;}
00840   return(return_ratio(rs));
00841 fquo:
00842   if (n==1) return(makeflt(1.0/fs));
00843 fquo2:
00844   while (i<n) {
00845     a=argv[i];
00846     fs/=ckfltval(a);
00847     i++;}
00848   return(makeflt(fs));
00849 
00850 bquo:
00851   if (big_sign(rs)<0) { sign= -1; complement_big(rs);}
00852   else sign=1;
00853   while (i<n) {
00854     a=argv[i];
00855     if (isflt(a)) {
00856       fs=sign*big_to_float(rs); goto fquo2;}
00857     if (!isint(a)) {
00858       int rv = sign*div_big_big(a, rs);
00859       return(mkbigint(rv));
00860     } else {
00861       is=intval(a);
00862       if (is<0) { sign = - sign; is= -is;}
00863       div_int_big(is, rs);
00864     }
00865     i++;
00866     }
00867   if (sign<0) complement_big(rs);
00868   return(normalize_bignum(rs));
00869   }
00870 
00871 
00872 
00873 
00874 pointer SIN(ctx,n,argv)
00875 register context *ctx;
00876 int n;
00877 pointer argv[];
00878 { numunion nu;
00879   ckarg(1);
00880   return(makeflt(sin(ckfltval(argv[0]))));}
00881 
00882 pointer COS(ctx,n,argv)
00883 register context *ctx;
00884 int n;
00885 pointer argv[];
00886 { numunion nu;
00887   ckarg(1);
00888   return(makeflt(cos(ckfltval(argv[0]))));}
00889 
00890 pointer TAN(ctx,n,argv)
00891 register context *ctx;
00892 int n;
00893 pointer argv[];
00894 { numunion nu;
00895   ckarg(1);
00896   return(makeflt(tan(ckfltval(argv[0]))));}
00897 
00898 pointer ATAN(ctx,n,argv)
00899 register context *ctx;
00900 int n;
00901 pointer argv[];
00902 { numunion nu;
00903   if (n==1) return(makeflt(atan(ckfltval(argv[0]))));
00904   else if (n==2) return(makeflt(atan2(ckfltval(argv[0]),ckfltval(argv[1]))));
00905   else error(E_MISMATCHARG);}
00906 
00907 pointer TANH(ctx,n,argv)
00908 register context *ctx;
00909 int n;
00910 pointer argv[];
00911 { numunion nu;
00912   ckarg(1);
00913   return(makeflt(tanh(ckfltval(argv[0]))));}
00914 
00915 pointer ATANH(ctx,n,argv)
00916 register context *ctx;
00917 int n;
00918 pointer argv[];
00919 { numunion nu;
00920   ckarg(1);
00921   return(makeflt(atanh(ckfltval(argv[0]))));}
00922 
00923 pointer SINH(ctx,n,argv)
00924 register context *ctx;
00925 int n;
00926 pointer argv[];
00927 { numunion nu;
00928   ckarg(1);
00929   return(makeflt(sinh(ckfltval(argv[0]))));}
00930 
00931 pointer ASINH(ctx,n,argv)
00932 register context *ctx;
00933 int n;
00934 pointer argv[];
00935 { numunion nu;
00936   ckarg(1);
00937   return(makeflt(asinh(ckfltval(argv[0]))));}
00938 
00939 pointer COSH(ctx,n,argv)
00940 register context *ctx;
00941 int n;
00942 pointer argv[];
00943 { numunion nu;
00944   ckarg(1);
00945   return(makeflt(cosh(ckfltval(argv[0]))));}
00946 
00947 pointer ACOSH(ctx,n,argv)
00948 register context *ctx;
00949 int n;
00950 pointer argv[];
00951 { numunion nu;
00952   ckarg(1);
00953   return(makeflt(acosh(ckfltval(argv[0]))));}
00954 
00955 pointer SQRT(ctx,n,argv)
00956 register context *ctx;
00957 int n;
00958 pointer argv[];
00959 { numunion nu;
00960   ckarg(1);
00961   return(makeflt(sqrt(ckfltval(argv[0]))));}
00962 
00963 pointer LOG(ctx,n,argv)
00964 register context *ctx;
00965 int n;
00966 pointer argv[];
00967 { double a;
00968   numunion nu;
00969   a=log(ckfltval(argv[0]));
00970   if (n==1) return(makeflt(a));
00971   else if (n==2) return(makeflt(a/log(ckfltval(argv[1]))));
00972   else error(E_MISMATCHARG);}
00973 
00974 pointer EXP(ctx,n,argv)
00975 register context *ctx;
00976 int n;
00977 pointer argv[];
00978 { numunion nu;
00979   ckarg(1);
00980   return(makeflt(exp(ckfltval(argv[0]))));}
00981 
00982 pointer ABS(ctx,n,argv)
00983 register context *ctx;
00984 int n;
00985 register pointer argv[];
00986 { register pointer a, b;
00987   eusfloat_t fa;
00988   numunion nu;
00989   ckarg(1);
00990   a=argv[0];
00991   if (a==makeint(MINNEGFIXNUM)) return(makebig1(-MINNEGFIXNUM));
00992   if (isint(a)) return(makeint(abs(intval(a))));
00993   else if (isflt(a)) return(makeflt(fabs(fltval(a))));
00994   else if (pisbignum(a)) {
00995     if (big_sign(a)<0) {
00996        b=copy_big(a);
00997        complement_big(b);
00998        return(b);}
00999     else return(a);}
01000   else error(E_NONUMBER);}
01001 
01002 pointer ROUND(ctx,n,argv)
01003 register context *ctx;
01004 int n;
01005 register pointer argv[];
01006 { register pointer a=argv[0];
01007   eusfloat_t f;
01008   register eusinteger_t x;
01009   numunion nu;
01010   ckarg(1);
01011   if (isint(a)) return(a);
01012   else if (isbignum(a)) return(a);
01013   else {
01014     f=ckfltval(a);
01015     f=(double)rint(f);
01016     return(eusfloat_to_big(f));}
01017   }
01018 
01019 pointer FLOOR(ctx,n,argv)
01020 register context *ctx;
01021 int n;
01022 pointer argv[];
01023 { register pointer a=argv[0];
01024   eusfloat_t f;
01025   register eusinteger_t x;
01026   numunion nu;
01027   ckarg(1);
01028   if (isint(a)) return(a);
01029   else if (isbignum(a)) return(a);
01030   else {
01031     f=floor(ckfltval(a)); return(eusfloat_to_big(f));} }
01032 
01033 pointer CEILING(ctx,n,argv)
01034 register context *ctx;
01035 int n;
01036 pointer argv[];
01037 { register pointer a=argv[0];
01038   eusfloat_t f;
01039   numunion nu;
01040   ckarg(1);
01041   if (isint(a)) return(a);
01042   else if (isbignum(a)) return(a);
01043   else { f=ckfltval(a); f=ceil(f); return(eusfloat_to_big(f));}
01044   }
01045 
01046 pointer TRUNCATE(ctx,n,argv)
01047 register context *ctx;
01048 int n;
01049 pointer argv[];
01050 { register pointer a=argv[0];
01051   eusfloat_t f;
01052   register eusinteger_t x;
01053   numunion nu;
01054   ckarg(1);
01055   if (isint(a)) return(a);
01056   else if (isbignum(a)) return(a);
01057   else { f=ckfltval(a); return(eusfloat_to_big(f));}
01058   }
01059 
01060 pointer FREXP(ctx,n,argv)
01061 context *ctx;
01062 int n;
01063 pointer argv[];
01064 { eusfloat_t  f,z;
01065   int exp;
01066   pointer p;
01067   numunion nu;
01068   extern double frexp(double, int *);
01069   ckarg(1);
01070   f=ckfltval(argv[0]);
01071   z=frexp(f, &exp);
01072   p=cons(ctx, makeint(exp), NIL);
01073   return(cons(ctx,makeflt(z),p));
01074   }
01075 
01076 pointer EUSFLOAT(ctx,n,argv)
01077 register context *ctx;
01078 int n;
01079 pointer argv[];
01080 { pointer a;
01081   eusfloat_t f;
01082   numunion nu;
01083   ckarg(1);
01084   a=argv[0];
01085   if (isflt(a)) return(a);
01086   else if (isint(a)) { f=intval(a); return(makeflt(f));}
01087   else { f=ckfltval(a); return(makeflt(f));}
01088   }
01089 
01090 pointer DECFLOAT(ctx,n,argv)    /*(decode-float FLOAT) -> int*/
01091 register context *ctx;
01092 int n;
01093 pointer argv[];
01094 { pointer x;
01095   eusinteger_t i;
01096   ckarg(1);
01097   x=argv[0];
01098   if (!isflt(x)) error(E_NONUMBER);
01099   i=intval(x);
01100   return(makeint(i));}
01101 
01102 pointer MAX(ctx,n,argv)
01103 register context *ctx;
01104 register int  n;
01105 pointer argv[];
01106 { eusfloat_t fs,fm;
01107   register i=1;
01108   register eusinteger_t is;
01109   register pointer a=argv[0];
01110   numunion nu;
01111   if (n<1) error(E_MISMATCHARG);
01112   if (n==1) return(a);
01113   if (isint(a)) is=(eusinteger_t)a;
01114   else { fs=ckfltval(a); goto fmax; }
01115   while (i<n) {
01116     a=argv[i];
01117     if (isint(a)) { if (is<(eusinteger_t)a) is=(eusinteger_t)a;}
01118     else { fs=intval((pointer)is); goto fmax; }
01119     i++;}
01120   return((pointer)is);
01121 fmax:
01122   while (i<n) {
01123     fm=ckfltval(argv[i]);
01124     if (fs<fm) fs=fm;
01125     i++;}
01126   return(makeflt(fs));}
01127 
01128 pointer MIN(ctx,n,argv)
01129 register context *ctx;
01130 register int  n;
01131 register pointer argv[];
01132 { eusfloat_t fs,fm;
01133   register int i=1;
01134   register eusinteger_t is;
01135   register pointer a=argv[0];
01136   numunion nu;
01137   if (n<1) error(E_MISMATCHARG);
01138   if (n==1) return(a);
01139   if (isint(a)) is=(eusinteger_t)a;
01140   else { fs=ckfltval(a); goto fmin;}
01141   while (i<n) {
01142     a=argv[i];
01143     if (isint(a)) { if (is>(eusinteger_t)a) is=(eusinteger_t)a;}
01144     else { fs=intval((pointer)is); goto fmin;}
01145     i++;}
01146   return((pointer)is);
01147 fmin:
01148   while (i<n) {
01149     fm=ckfltval(argv[i]);
01150     if (fs>fm) fs=fm;
01151     i++;}
01152   return(makeflt(fs));}
01153 
01154 /****************************************************************/
01155 /* bit wise logical operations
01156 /****************************************************************/
01157 pointer LOGAND(context *ctx, int n, pointer argv[])
01158 { int i=1,j,k,rsize,psize;
01159   eusinteger_t *rbv, *bbv, *pbv;
01160   pointer b,p,r=argv[0];
01161 
01162   if (isbignum(r)) {
01163     r=copy_big(r); rsize=bigsize(r); rbv=bigvec(r);
01164     p=argv[i++];
01165     goto bigand;}
01166 
01167   k=intval(r);
01168   while (i<n) {
01169     p=argv[i++];
01170     if (isint(p)) k &=intval(p);
01171     else if (isbignum(p)) {
01172       b=copy_big(p);
01173       p=makeint((eusinteger_t)r);
01174       r=b; rsize=bigsize(r); rbv=bigvec(r);
01175       goto bigand;}
01176     else error(E_NOINT);}
01177   return(makeint(k));
01178 
01179   while (i<n) {
01180     p=argv[i++];
01181 bigand:
01182     /* r is bignum */
01183     if (isint(p)) {
01184       rbv[0] &= intval(p);
01185       if (intval(p)>=0) for (j=1; j<rsize; j++) rbv[j]=0; }
01186     else if (isbignum(p)) {
01187       psize=bigsize(p);
01188       if (rsize>=psize) {
01189         for (j=0; j<psize; j++)  rbv[j] &= p->c.bgnm.bv->c.ivec.iv[j];
01190         if (rsize>psize) {
01191           if (big_sign(p)>0)  for (j=psize; j<rsize; j++) rbv[j]=0;}
01192         }
01193       else if (big_sign(r)<0) {
01194         r=extend_big(r,psize);
01195         rsize=psize; rbv=bigvec(r);
01196         for (j=0; j<psize; j++)  rbv[j] &= p->c.bgnm.bv->c.ivec.iv[j];
01197         }
01198       else 
01199         for (j=0; j<rsize; j++)  rbv[j] &= p->c.bgnm.bv->c.ivec.iv[j]; 
01200       }
01201     else  error(E_NOINT);}
01202   return(normalize_bignum(r));}
01203 
01204 pointer LOGIOR(ctx,n,argv)
01205 register context *ctx;
01206 register int n;
01207 register pointer argv[];
01208 { register eusinteger_t result=0;
01209   register int i=0;
01210   pointer p;
01211   while (i<n) {
01212     p=argv[i];
01213     if (!isint(p)) {
01214       if (isbignum(p)) result |= bigintval(p);
01215       else error(E_NOINT);}
01216     else  result |= intval(p);
01217     i++; }
01218   return(mkbigint(result));}
01219 
01220 pointer LOGXOR(ctx,n,argv)
01221 register context *ctx;
01222 register int n;
01223 register pointer argv[];
01224 { register eusinteger_t result=0;
01225   register int i=0;
01226   while (i<n) 
01227     if (!isint(argv[i])) error(E_NOINT);
01228     else result ^= intval(argv[i++]);
01229   return(makeint(result));}
01230 
01231 pointer LOGEQV(ctx,n,argv)
01232 register context *ctx;
01233 register int n;
01234 register pointer argv[];
01235 { register eusinteger_t result=0;
01236   register int i=0;
01237   while (n>0) {
01238     if (!isint(argv[--n])) error(E_NOINT);
01239     result ^= intval(argv[n]); }
01240   return(makeint(~result));}
01241 
01242 pointer LOGNAND(ctx,n,argv)
01243 register context *ctx;
01244 register int n;
01245 register pointer argv[];
01246 { register eusinteger_t result= ~0;
01247   register int i=0;
01248   while (i<n) 
01249     if (!isint(argv[i])) error(E_NOINT);
01250     else result &= intval(argv[i++]);
01251   return(makeint(~result));}
01252 
01253 pointer LOGNOR(ctx,n,argv)
01254 register context *ctx;
01255 register int n;
01256 register pointer argv[];
01257 { register eusinteger_t result=0;
01258   register int i=0;
01259   while (i<n) 
01260     if (!isint(argv[i])) error(E_NOINT);
01261     else result |= intval(argv[i++]);
01262   return(makeint(~result));}
01263 
01264 pointer LOGNOT(ctx,n,argv)
01265 register context *ctx;
01266 int n;
01267 pointer argv[];
01268 { eusinteger_t i;
01269   ckarg(1);
01270   if (!isint(argv[0])) error(E_NOINT);
01271   else {
01272     i=intval(argv[0]);
01273     return(makeint(~i));}}
01274 
01275 pointer LOGTEST(ctx,n,argv)
01276 register context *ctx;
01277 int n;
01278 register pointer argv[];
01279 { ckarg(2);
01280   if (!isint(argv[0])) error(E_NOINT);
01281   if (!isint(argv[1])) error(E_NOINT);
01282   if ((eusinteger_t)argv[0] & (eusinteger_t)argv[1] & (eusinteger_t)~3) return(T);
01283   else return(NIL);}
01284 
01285 pointer LOGBITP(ctx,n,argv)
01286 register context *ctx;
01287 register int n;
01288 register pointer argv[];
01289 { register eusinteger_t index,val;
01290   ckarg(2);
01291   index=ckintval(argv[0]);
01292   val=ckintval(argv[1]);
01293   if (index<0) error(E_NOINT);
01294   if ((val>>index) & 1) return(T); else return(NIL);}
01295 
01296 pointer ASH(ctx,n,argv)
01297 register context *ctx;
01298 register int n;
01299 register pointer argv[];
01300 { register eusinteger_t count,val;
01301   register int firstone;
01302   register eusinteger_t sign;
01303   pointer a,b;
01304   ckarg(2);
01305   count=ckintval(argv[1]);
01306   if (isint(argv[0])) {
01307     val=intval(argv[0]);
01308     if (count<=0) return(makeint(val>>(-count)));
01309     if (val<=0) { return(makeint(val<<count));}
01310 #if (WORD_SIZE == 64)
01311     firstone=ffsl(val);
01312 #else
01313     firstone=ffs(val);
01314 #endif
01315     if ((firstone + count)<WORD_SIZE-2) {
01316       sign=(val>=0)?1:(-1);
01317       val=val<<count;
01318       if (sign>0) return(makeint(val));
01319       else return(makeint(~val)); }
01320     /*extend to big*/
01321     a=makebig1(val);}
01322   else if (isbignum(argv[0])) { a=argv[0]; sign=big_sign(a);}
01323   else error(E_NOINT);
01324 
01325   /*shift b by count bits*/
01326   { int size=bigsize(a);
01327     int i, j, k;
01328     eusinteger_t x, *av, *bv;
01329     pointer b=makebig(size+(count+(WORD_SIZE-1))/(WORD_SIZE-1));
01330     vpush(b);
01331     av=bigvec(a); bv=bigvec(b);    
01332     if (count>=0) {
01333       j= count/(WORD_SIZE-1); k=count % (WORD_SIZE-1);
01334       for (i=0; i<size; i++) {
01335         x=av[i];
01336         bv[i+j] |= (x << k);
01337         bv[i+j+1] = (x>>((WORD_SIZE-1)-k)); } }
01338     else {  /* count <0 ; shift right */
01339       count = -count;
01340       j=count/(WORD_SIZE-1); k=count % (WORD_SIZE-1);
01341       for (i=0; i<size-j-1; i++) {
01342         bv[i]=(av[j+i]>>k) | ((av[j+i+1]<<((WORD_SIZE-1)-k)) & MASK); }
01343       bv[size-j-1]=av[size-1]>>k;
01344       }
01345     b=normalize_bignum(b);
01346     vpop();
01347     return(b); }
01348   }
01349 
01350 pointer LDB(ctx,n,argv) /*(LDB 'val 'pos 'width)*/
01351 register context *ctx;
01352 register int n;                 /*no byte specifier in euslisp*/
01353 register pointer argv[];
01354 { register eusinteger_t pos,width=8;
01355 #if (WORD_SIZE == 64)
01356   register unsigned long val;
01357 #else
01358   register unsigned int val;
01359 #endif
01360   ckarg2(2,3);
01361   val=ckintval(argv[0]);  pos=ckintval(argv[1]);
01362   if (n==3) width=ckintval(argv[2]);
01363   val=(val<<(WORD_SIZE-pos-width))>>(WORD_SIZE-width);
01364   return(makeint(val));}
01365 
01366 pointer DPB(ctx,n,argv)
01367 register context *ctx;
01368 int n;
01369 pointer argv[];
01370 { register eusinteger_t pos,width=8;
01371 #if (WORD_SIZE == 64)
01372   register unsigned long val,target,mask=~0L;
01373 #else
01374   register unsigned int val,target,mask=~0;
01375 #endif
01376   ckarg(4);
01377   val=ckintval(argv[0]);
01378   target=ckintval(argv[1]);
01379   pos=ckintval(argv[2]);
01380   width=ckintval(argv[3]);
01381   mask=mask<<(WORD_SIZE-(pos+width));
01382   mask=mask>>(WORD_SIZE-width); 
01383   val &= mask;
01384   mask <<= pos;
01385   target=(target & ~mask) | (val<<pos);
01386   return(makeint(target));}
01387 
01388 pointer MAKERANDOMSTATE(ctx,n,argv)
01389 register context *ctx;
01390 int n;
01391 register pointer argv[];
01392 { pointer state;
01393   pointer randvec;
01394   time_t tm;
01395 
01396   ckarg2(0,1);
01397   state=NIL;
01398   randvec=makevector(C_INTVECTOR, 2);
01399   if (n==1) {
01400     state=argv[0];
01401     if (state==NIL) { goto MAKERANDSTATENIL; }
01402     else if (state==T) {
01403       if (time(&tm)==-1){
01404         error(E_USER,(pointer)"failed to fetch time"); }
01405       srand((unsigned int)tm);
01406       randvec->c.ivec.iv[0] = rand();
01407       randvec->c.ivec.iv[1] = rand();
01408       return (randvec); }
01409     if (!isintvector(state) && !isstring(state)) error(E_NOVECTOR);
01410     if (vecsize(state)<2) error(E_VECSIZE); }
01411 MAKERANDSTATENIL:
01412   if (state==NIL) {
01413     state=Spevalof(RANDSTATE);
01414     if (state==UNBOUND) state=speval(RANDSTATE); }
01415   randvec->c.ivec.iv[0] = state->c.ivec.iv[0];
01416   randvec->c.ivec.iv[1] = state->c.ivec.iv[1];
01417   return (randvec);
01418   }
01419 
01420 pointer RANDOM(ctx,n,argv)
01421 register context *ctx;
01422 int n;
01423 register pointer argv[];
01424 { pointer a=argv[0],state;
01425   eusinteger_t imax,irandval;
01426   eusfloat_t fmax,frandval;
01427   double randval;
01428   double erand48();
01429 #if news || sanyo
01430   long random();
01431 #endif
01432   numunion nu;
01433 
01434   ckarg2(1,2);
01435   if (n==2) {
01436     state=argv[1];
01437     if (!isintvector(state) && !isstring(state)) error(E_NOVECTOR);
01438     if (vecsize(state)<2) error(E_VECSIZE);}
01439   else {
01440     state=Spevalof(RANDSTATE);
01441     if (state==UNBOUND) state=speval(RANDSTATE);}
01442 #if news || sanyo
01443   randval=random();
01444 #else
01445 #if alpha
01446   randval=erand48((unsigned short *)state->c.ivec.iv);
01447 #elif Win32 || Cygwin
01448   randval=((double)rand())/RAND_MAX;
01449 #else
01450   randval=erand48((unsigned short *)(state->c.ivec.iv));
01451 #endif
01452 #endif
01453   if (isint(a)) {
01454     imax=intval(a);
01455     irandval=randval*imax;
01456     return(makeint(irandval));}
01457   else if (isflt(a)) {
01458     fmax=fltval(a);
01459     frandval=randval*fmax;
01460     return(makeflt(frandval));}
01461   else error(E_NONUMBER);
01462   }
01463 
01464 
01465 void arith(ctx,mod)
01466 register context *ctx;
01467 pointer mod;
01468 {
01469   defun(ctx,"=",mod,NUMEQUAL);
01470   defun(ctx,"/=",mod,NUMNEQUAL);
01471   defun(ctx,">",mod,GREATERP);
01472   defun(ctx,"<",mod,LESSP);
01473   defun(ctx,">=",mod,GREQP);
01474   defun(ctx,"<=",mod,LSEQP);
01475   defun(ctx,"MOD",mod,MOD);
01476   defun(ctx,"1-",mod,SUB1);
01477   defun(ctx,"1+",mod,ADD1);
01478   defun(ctx,"+",mod,PLUS);
01479   defun(ctx,"-",mod,MINUS);
01480   defun(ctx,"*",mod,TIMES);
01481   defun(ctx,"/",mod,QUOTIENT);
01482   defun(ctx,"SIN",mod,SIN);
01483   defun(ctx,"COS",mod,COS);
01484   defun(ctx,"TAN",mod,TAN);
01485   defun(ctx,"ATAN",mod,ATAN);
01486   defun(ctx,"TANH",mod,TANH);
01487   defun(ctx,"ATANH",mod,ATANH);
01488   defun(ctx,"SINH",mod,SINH);
01489   defun(ctx,"ASINH",mod,ASINH);
01490   defun(ctx,"COSH",mod,COSH);
01491   defun(ctx,"ACOSH",mod,ACOSH);
01492   defun(ctx,"SQRT",mod,SQRT);
01493   defun(ctx,"LOG",mod,LOG);
01494   defun(ctx,"EXP",mod,EXP);
01495   defun(ctx,"ABS",mod,ABS);
01496   defun(ctx,"ROUND",mod,ROUND);
01497   defun(ctx,"FLOOR",mod,FLOOR);
01498   defun(ctx,"CEILING",mod,CEILING);
01499   defun(ctx,"TRUNCATE",mod,TRUNCATE);
01500   defun(ctx,"FLOAT",mod,EUSFLOAT);
01501   defun(ctx,"DECODE-FLOAT",mod,DECFLOAT);
01502   defun(ctx,"MAX",mod,MAX);
01503   defun(ctx,"MIN",mod,MIN);
01504   defun(ctx,"LOGAND",mod,LOGAND);
01505   defun(ctx,"LOGIOR",mod,LOGIOR);
01506   defun(ctx,"LOGXOR",mod,LOGXOR);
01507   defun(ctx,"LOGEQV",mod,LOGEQV);
01508   defun(ctx,"LOGNAND",mod,LOGNAND);
01509   defun(ctx,"LOGNOR",mod,LOGNOR);
01510   defun(ctx,"LOGNOT",mod,LOGNOT);
01511   defun(ctx,"LOGTEST",mod,LOGTEST);
01512   defun(ctx,"LOGBITP",mod,LOGBITP);
01513   defun(ctx,"ASH",mod,ASH);
01514   defun(ctx,"LDB",mod,LDB);
01515   defun(ctx,"DPB",mod,DPB);
01516   defun(ctx,"MAKE-RANDOM-STATE",mod,MAKERANDOMSTATE);
01517   defun(ctx,"RANDOM",mod,RANDOM);
01518   defun(ctx,"FREXP",mod,FREXP);
01519 }


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Mar 9 2017 04:57:49