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 #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
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);}
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)
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
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))) {
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
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) {
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)) {
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
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))) {
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);
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;
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
00702
00703
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) {
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)) {
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
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:
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)
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
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
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
01321 a=makebig1(val);}
01322 else if (isbignum(argv[0])) { a=argv[0]; sign=big_sign(a);}
01323 else error(E_NOINT);
01324
01325
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 {
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)
01351 register context *ctx;
01352 register int n;
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 }