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


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Sep 3 2015 10:36:19