00001
00002
00003
00004
00005
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
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)
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
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)) {
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
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) {
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)) {
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
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)) {
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);
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;
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
00675
00676
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) {
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)) {
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
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:
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)
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
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
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
01284 a=makebig1(val);}
01285 else if (isbignum(argv[0])) { a=argv[0]; sign=big_sign(a);}
01286 else error(E_NOINT);
01287
01288
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 {
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)
01314 register context *ctx;
01315 register int n;
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 }