arith.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* arith.c EULISP arithmetic functions
3 /* Copyright(c)1988 Toshihiro MATSUI, Electrotechnical Laboratory
4 /* 1986-May
5 .* 1988-Feb boxing and unboxing recoded by macros
6 /****************************************************************/
7 
8 static char *rcsid="@(#)$Id$";
9 
10 #include "eus.h"
11 #include <math.h>
12 #if alpha
13 #include <limits.h>
14 #endif
15 #if Cygwin
16 #include <stdlib.h>
17 #endif
18 extern int ffsl(long int i); // #include <string.h> // ffsl
19 
20 extern pointer RANDSTATE;
21 extern int gcd();
22 extern pointer makeratio();
23 
24 extern pointer copy_big(), big_plus(), big_minus();
25 extern void sub_int_big(), add_int_big();
26 extern pointer add_big_big(), big_times();
27 extern pointer makebig(), makebig1(), makebig2(), extend_big(pointer,int);
28 extern pointer normalize_bignum();
30 extern pointer eusfloat_to_big(float);
32 
33 /****************************************************************/
34 /* number predicates
35 /****************************************************************/
36 pointer NUMEQUAL(ctx,n,argv)
37 register context *ctx;
38 register int n;
39 register pointer argv[];
40 { register eusfloat_t fx,fy;
41  register pointer a,x;
42  numunion nu;
43 
44  if (n<=1) error(E_MISMATCHARG);
45  x=argv[--n];
46  if (isint(x)) {
47  while (--n>=0) {
48  a=argv[n];
49  if (isflt(a)) { fx=intval(x); fy=fltval(a); goto flteqnum;}
50  else if (isint(a)) { if (x!=a) return(NIL);}
51  else if (pisratio(a)) { x=makeratio(intval(x),1); goto reqnum;}
52  else if (pisbignum(a)) { return(NIL);} /* kanehiro's patch 2000.12.13 */
53  else error(E_NONUMBER);}
54  return(T);}
55  else if (isratio(x)) {
56  while (--n>=0) {
57  a=argv[n];
58  if (isflt(a)) { fx=ratio2flt(x); fy=fltval(a); goto flteqnum;}
59  else if (isint(a)) a=makeratio(intval(a),1);
60  else if (!pisratio(a)) error(E_NONUMBER);
61 reqnum:
62  if ((a->c.ratio.numerator != x->c.ratio.numerator) ||
63  (a->c.ratio.denominator != x->c.ratio.denominator))
64  return(NIL);}
65  return(T);}
66  else if (isflt(x)) {
67  fx=fltval(x);
68  while (--n>=0) {
69  fy=ckfltval(argv[n]);
70 flteqnum:
71  if (fx!=fy) return(NIL);}
72  return(T); }
73  else if (pisbignum(x))
74  { eusinteger_t *xv, *av;
75  int size,i;
76  xv=bigvec(x); size=bigsize(x);
77  while (--n >=0) {
78  a=argv[n];
79  if (!isbignum(a)) return(NIL);
80  if (size != bigsize(a)) return(NIL);
81  av=bigvec(a);
82  for (i=0; i<size; i++) if (xv[i]!=av[i]) return(NIL);}
83  return(T); }
84  else error(E_NONUMBER);}
85 
86 pointer NUMNEQUAL(ctx,n,argv)
87 register context *ctx;
88 register int n;
89 register pointer argv[];
90 { register int i;
91  pointer cmparr[2];
92  numunion nu;
93 
94  if (n<=1) error(E_MISMATCHARG);
95  while(--n>=0) {
96  cmparr[0] = argv[n];
97  for(i=0;i<n;++i){
98  cmparr[1]=argv[i];
99  if((NIL) != NUMEQUAL(ctx,2,cmparr))
100  return(NIL);}}
101  return(T);
102 }
103 
104 pointer GREATERP(ctx,n,argv)
105 register context *ctx;
106 register int n;
107 register pointer argv[];
108 { register pointer left,right;
109  register eusfloat_t fleft,fright;
110  eusinteger_t ival;
111  eusinteger_t sign;
112  int comparison;
113  numunion nu;
114 
115  if (n<=1) error(E_MISMATCHARG);
116  right=argv[--n];
117 
118  if (isint(right)) goto INTGT;
119  else if (isflt(right)) goto FLTGT;
120  else if (pisratio(right)) goto RATGT;
121  else if (pisbignum(right)) goto BIGGT;
122  else error(E_NONUMBER);
123 
124 INTGT:
125  while (--n>=0) {
126  left=argv[n];
127  if (isint(left)) {
128  if ((eusinteger_t)left <= (eusinteger_t)right) return(NIL); }
129  else if (isflt(left)) { fright=intval(right); goto fltgt2;}
130  else if (isbignum(left)) {
131  if (big_sign(left)<0) return(NIL);
132  right=left; goto BIGGT; }
133  if (!isint(left)) error(E_NONUMBER);
134  right=left;}
135  return(T);
136 
137 BIGGT:
138  sign=big_sign(right);
139  while (--n>=0) {
140  left=argv[n];
141  if (isint(left)) {
142  ival= intval(left);
143  if (sign>=0) return(NIL);
144  right=left;
145  goto INTGT; }
146  else if (isflt(left)) {
147  fright=big_to_float(right);
148  if (fltval(left)<=fright) return(NIL);
149  goto FLTGT1;}
150  else if (pisbignum(left)) {
151  comparison=big_compare(left, right);
152  if (comparison<=0) return(NIL);
153  right=left;
154  sign=big_sign(right);}
155  else if (isratio(left)) goto RATGT; }
156 FLTGT:
157  fright=fltval(right);
158 FLTGT1:
159  while (--n>=0) {
160  fltgt2: fleft=ckfltval(argv[n]);
161  if (fleft<=fright) return(NIL);
162  fright=fleft; }
163  return(T);
164 RATGT:
165  error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
166  }
167 
168 pointer LESSP(ctx,n,argv)
169 register context *ctx;
170 register int n;
171 register pointer argv[];
172 { register pointer left,right;
173  register eusfloat_t fleft,fright;
174  eusinteger_t ival;
175  eusinteger_t sign;
176  int comparison;
177  numunion nu;
178 
179  if (n<=1) error(E_MISMATCHARG);
180  right=argv[--n];
181 
182  if (isint(right)) goto INTLT;
183  else if (isflt(right)) goto FLTLT;
184  else if (pisratio(right)) goto RATLT;
185  else if (pisbignum(right)) goto BIGLT;
186  else error(E_NONUMBER);
187 
188 INTLT:
189  while (--n>=0) {
190  left=argv[n];
191  if (isint(left)) {
192  if ((eusinteger_t)left >= (eusinteger_t)right) return(NIL); }
193  else if (isflt(left)) { fright=intval(right); goto FLTLT2;}
194  else if (isbignum(left)) {
195  if (big_sign(left)>0) return(NIL);
196  right=left; goto BIGLT; }
197  if (!isint(left)) error(E_NONUMBER);
198  right=left;}
199  return(T);
200 
201 BIGLT:
202  sign=big_sign(right);
203  while (--n>=0) {
204  left=argv[n];
205  if (isint(left)) {
206  ival= intval(left);
207  if (sign<0) return(NIL);
208  right=left;
209  goto INTLT; }
210  else if (isflt(left)) {
211  fright=big_to_float(right);
212  if (fltval(left)>=fright) return(NIL);
213  goto FLTLT1;}
214  else if (pisbignum(left)) {
215  comparison=big_compare(left, right);
216  if (comparison>=0) return(NIL);
217  right=left;
218  sign=big_sign(right);}
219  else if (isratio(left)) goto RATLT; }
220 FLTLT:
221  fright=fltval(right);
222 FLTLT1:
223  while (--n>=0) {
224  FLTLT2: fleft=ckfltval(argv[n]);
225  if (fleft>=fright) return(NIL);
226  fright=fleft; }
227  return(T);
228 RATLT:
229  error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
230  }
231 
232 pointer GREQP(ctx,n,argv)
233 register context *ctx;
234 register int n;
235 register pointer argv[];
236 { register pointer left,right;
237  register eusfloat_t fleft,fright;
238  eusinteger_t ival;
239  eusinteger_t sign;
240  int comparison;
241  numunion nu;
242 
243  if (n<=1) error(E_MISMATCHARG);
244  right=argv[--n];
245 
246  if (isint(right)) goto INTGE;
247  else if (isflt(right)) goto FLTGE;
248  else if (pisratio(right)) goto RATGE;
249  else if (pisbignum(right)) goto BIGGE;
250  else error(E_NONUMBER);
251 
252 INTGE:
253  while (--n>=0) {
254  left=argv[n];
255  if (isint(left)) {
256  if ((eusinteger_t)left < (eusinteger_t)right) return(NIL); }
257  else if (isflt(left)) { fright=intval(right); goto FLTGE2;}
258  else if (isbignum(left)) {
259  if ((sign=big_sign(left))<0) return(NIL);
260  right=left; goto BIGGE; }
261  if (!isint(left)) error(E_NONUMBER);
262  right=left;}
263  return(T);
264 
265 BIGGE:
266  sign=big_sign(right);
267  while (--n>=0) {
268  left=argv[n];
269  if (isint(left)) {
270  ival= intval(left);
271  if (sign>0) return(NIL);
272  right=left;
273  goto INTGE; }
274  else if (isflt(left)) {
275  fright=big_to_float(right);
276  if (fltval(left)<fright) return(NIL);
277  goto FLTGE1;}
278  else if (pisbignum(left)) {
279  comparison=big_compare(left, right);
280  if (comparison<0) return(NIL);
281  right=left;
282  sign=big_sign(right);}
283  else if (isratio(left)) goto RATGE; }
284 FLTGE:
285  fright=fltval(right);
286 FLTGE1:
287  while (--n>=0) {
288  FLTGE2: fleft=ckfltval(argv[n]);
289  if (fleft<fright) return(NIL);
290  fright=fleft; }
291  return(T);
292 RATGE:
293  error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
294  }
295 
296 pointer LSEQP(ctx,n,argv) /*less-or-equalp*/
297 register context *ctx;
298 int n;
299 pointer argv[];
300 { register pointer left,right;
301  register eusfloat_t fleft,fright;
302  eusinteger_t ival;
303  eusinteger_t sign;
304  int comparison;
305  numunion nu;
306 
307  if (n<=1) error(E_MISMATCHARG);
308  right=argv[--n];
309 
310  if (isint(right)) goto INTLE;
311  else if (isflt(right)) goto FLTLE;
312  else if (pisratio(right)) goto RATLE;
313  else if (pisbignum(right)) goto BIGLE;
314  else error(E_NONUMBER);
315 
316 INTLE:
317  while (--n>=0) {
318  left=argv[n];
319  if (isint(left)) {
320  if ((eusinteger_t)left > (eusinteger_t)right) return(NIL); }
321  else if (isflt(left)) { fright=intval(right); goto FLTLE2;}
322  else if (isbignum(left)) {
323  if ((sign=big_sign(left))>0) return(NIL);
324  right=left; goto BIGLE; }
325  if (!isint(left)) error(E_NONUMBER);
326  right=left;}
327  return(T);
328 
329 BIGLE:
330  sign=big_sign(right);
331  while (--n>=0) {
332  left=argv[n];
333  if (isint(left)) {
334  ival= intval(left);
335  if (sign<0) return(NIL);
336  right=left;
337  goto INTLE; }
338  else if (isflt(left)) {
339  fright=big_to_float(right);
340  if (fltval(left) > fright) return(NIL);
341  goto FLTLE1;}
342  else if (pisbignum(left)) {
343  comparison=big_compare(left, right);
344  if (comparison > 0) return(NIL);
345  right=left;
346  sign=big_sign(right);}
347  else if (isratio(left)) goto RATLE; }
348 FLTLE:
349  fright=fltval(right);
350 FLTLE1:
351  while (--n>=0) {
352  FLTLE2: fleft=ckfltval(argv[n]);
353  if (fleft > fright) return(NIL);
354  fright=fleft; }
355  return(T);
356 RATLE:
357  error(E_USER,(pointer)"sorry, comparison of ratios are not yet implemented");
358  }
359 
360 pointer MOD(ctx,n,argv)
361 register context *ctx;
362 int n;
363 pointer argv[];
364 { ckarg(2);
365  if (isflt(argv[0]) || isflt(argv[1])) {
366  numunion nu;
367  register eusfloat_t x,y;
368  x=ckfltval(argv[0]); y=ckfltval(argv[1]);
369  return(makeflt(fmod(x,y)));
370  } else {
371  register eusinteger_t x,y;
372  x=bigintval(argv[0]); y=bigintval(argv[1]);
373  return(mkbigint(x % y));}}
374 
375 pointer SUB1(ctx,n,argv)
376 register context *ctx;
377 int n;
378 pointer argv[];
379 { register pointer a=argv[0];
380  eusfloat_t x;
381  numunion nu;
382 
383  ckarg(1);
384  if (a==makeint(MINNEGFIXNUM)) { return(makebig1(MINNEGFIXNUM-1));}
385  if (isint(a)) return((pointer)((eusinteger_t)a-4));
386  else if (isflt(a)) {
387  x=fltval(a);
388  return(makeflt(x-1.0)); }
389  else if (isbignum(a)) {
390  a=copy_big(a); sub_int_big(1,a); return(normalize_bignum(a));}
391  else error(E_NOINT);
392  }
393 
394 
395 pointer ADD1(ctx,n,argv)
396 register context *ctx;
397 int n;
398 pointer argv[];
399 { register pointer a=argv[0];
400  eusfloat_t x;
401  numunion nu;
402 
403  ckarg(1);
404  if (a==makeint(MAXPOSFIXNUM)) { return(makebig1(MAXPOSFIXNUM+1));}
405  if (isint(a)) return((pointer)((eusinteger_t)a+4));
406  else if (isflt(a)) {
407  x=fltval(a);
408  return(makeflt(x+1.0)); }
409  else if (isbignum(a)) {
410  a=copy_big(a); add_int_big(1,a); return(a);}
411  else error(E_NOINT);
412  }
413 
414 /* extended numbers */
415 
417 pointer x,y;
418 {
419  register eusinteger_t x_num, x_den, y_num, y_den, z_num, z_den, d1,d2,t;
420 
421  x_num = intval(x->c.ratio.numerator);
422  x_den = intval(x->c.ratio.denominator);
423  y_num = intval(y->c.ratio.numerator);
424  y_den = intval(y->c.ratio.denominator);
425 
426  d1=gcd(x_den,y_den);
427  if(d1 == 1){
428  z_num = x_num * y_den + x_den * y_num;
429  z_den = x_den * y_den;
430  return(makeratio(z_num,z_den));}
431  else{
432  t = x_num * (y_den / d1) + y_num * (x_den / d1);
433  d2=gcd(t,d1);
434 
435  z_num = t / d2;
436  z_den = (x_den / d1) * (y_den / d2);
437  return(makeratio(z_num,z_den));}
438 }
439 
441 pointer x,y;
442 {
443  register eusinteger_t x_num,x_den,y_num,y_den,z_num,z_den,d1,d2,t;
444 
445  x_num = intval(x->c.ratio.numerator);
446  x_den = intval(x->c.ratio.denominator);
447  y_num = intval(y->c.ratio.numerator);
448  y_den = intval(y->c.ratio.denominator);
449  d1 = gcd(x_den,y_den);
450  if(d1 == 1){
451  z_num = x_num * y_den - x_den * y_num;
452  z_den = x_den * y_den;
453  return(makeratio(z_num,z_den));}
454  else{
455  t = x_num * (y_den / d1) - y_num * (x_den / d1);
456  d2=gcd(t,d1);
457  z_num = t / d2;
458  z_den = (x_den / d1) * (y_den / d2);
459  return(makeratio(z_num,z_den));}
460 }
461 
463 pointer x,y;
464 {
465  register eusinteger_t x_num,x_den,y_num,y_den,z_num,z_den,d1,d2;
466 
467  x_num = intval(x->c.ratio.numerator);
468  x_den = intval(x->c.ratio.denominator);
469  y_num = intval(y->c.ratio.numerator);
470  y_den = intval(y->c.ratio.denominator);
471  d1=gcd(x_num,y_den);
472  d2=gcd(x_den,y_num);
473 
474  z_num = (x_num / d1) * (y_num / d2);
475  z_den = (x_den / d2) * (y_den / d1);
476 
477  return(makeratio(z_num,z_den));
478 }
479 
481 pointer x,y;
482 {
483  register eusinteger_t x_num,x_den,y_num,y_den,z_num,z_den,d1,d2;
484  register int sign;
485 
486  x_num = intval(x->c.ratio.numerator);
487  x_den = intval(x->c.ratio.denominator);
488  y_num = intval(y->c.ratio.numerator);
489  y_den = intval(y->c.ratio.denominator);
490 
491  d1=gcd(x_num,y_num);
492  d2=gcd(x_den,y_den);
493 
494  if(y_num >= 0) sign=1; else sign=-1;
495 
496  z_num = (x_num / d1) * (y_den / d2) * sign;
497  z_den = abs((x_den / d2) * (y_num / d1));
498 
499  return(makeratio(z_num,z_den));
500 }
501 
503 eusinteger_t i;
504 { return(makeratio(i,1));}
505 
507 pointer r;
508 { pointer p,q;
509  eusfloat_t num, den;
510  p=r->c.ratio.numerator;
511  q=r->c.ratio.denominator;
512  if (isint(p)) num=intval(p);
513  else if (isbignum(p)) num=big_to_float(p);
514  else error(E_USER,(pointer)"illegal ratio numerator");
515 
516  if (isint(q)) den=intval(q);
517  else if (isbignum(q)) den=big_to_float(q);
518  else error(E_USER,(pointer)"illegal ratio denominator");
519 
520  return(num/den);}
521 
523 pointer r;
524 { if (intval(r->c.ratio.numerator)==0) return(makeint(0));
525  else if (intval(r->c.ratio.denominator)==1) return(r->c.ratio.numerator);
526  else return(r);}
527 
528 
529 pointer PLUS(ctx,n,argv)
530 register context *ctx;
531 register int n;
532 register pointer argv[];
533 { eusfloat_t fs;
534  register eusinteger_t is=0,j;
535  register int i=0;
536  register pointer a, r, rs;
537  pointer b;
538  numunion nu;
539 
540  while (i<n) {
541  a=argv[i];
542  if (isint(a)) {
543  j=intval(a);
544  is+=j;
545  if (((is >> 1) ^ is)&((eusinteger_t)1<<(WORD_SIZE-3))) { /* fixnum overflow */
546  b=makebig1(0); goto bigplus;} }
547  else if (isflt(a)) { fs=is; goto fplus;}
548  else if (pisratio(a)) { rs=makeratio(is,1); goto rplus;}
549  else if (pisbignum(a)) { b=copy_big(a); goto bigplus;}
550  else error(E_NONUMBER);
551  i++;}
552  return(makeint(is));
553 rplus:
554  while (i<n) {
555  a=argv[i];
556  if (isint(a)) a=makeratio(intval(a),1);
557  else if (isflt(a)) { fs=ratio2flt(rs); goto fplus;}
558  else if (!isratio(a)) error(E_NONUMBER);
559  rs= ratio_plus(rs, a);
560  i++;}
561  return(return_ratio(rs));
562 fplus:
563  while (i<n) {
564  fs+=ckfltval(argv[i]);
565  i++;}
566  return(makeflt(fs));
567 bigplus:
568  /* fprintf(stderr, "big plus\n"); */
569  i++;
570  if (is >= 0) add_int_big(is, b);
571  else sub_int_big(-is, b);
572  vpush(b);
573  while (i<n) {
574  a=argv[i];
575  if (isint(a)) {
576  j=intval(a);
577  if (j>0) add_int_big(j,b);
578  else if (j<0) sub_int_big(-j,b);
579  b=normalize_bignum(b);}
580  else if (isbignum(a)) {
581  b=big_plus(a,b);
582  vpop();
583  vpush(b);
584  b=normalize_bignum(b);
585  }
586  i++; }
587  vpop();
588  return(b);
589  }
590 
591 pointer MINUS(ctx,n,argv)
592 register context *ctx;
593 register int n;
594 register pointer argv[];
595 { eusfloat_t fs;
596  register eusinteger_t is,ia;
597  register int i;
598  register pointer a=argv[0], rs, b, z;
599  numunion nu;
600 
601  if (n<1) error(E_MISMATCHARG);
602  else if (n==1) { /*negate*/
603  if (a==makeint(MINNEGFIXNUM)) return(makebig1(-MINNEGFIXNUM));
604  if (isint(a)) return(makeint(-intval(a)));
605  else if (isflt(a)) {
606  fs= -fltval(a);
607  return(makeflt(fs));}
608  else if (isratio(a)) { /* buggy when numerator == MINNEGFIXNUM */
609  return(makeratio(-intval(a->c.ratio.numerator),
610  intval(a->c.ratio.denominator)));}
611 
612  else if (isbignum(a)) { return(normalize_bignum(big_minus(a)));}
613  else error(E_NONUMBER); }
614 
615  /* n>1 */
616 
617  i=1;
618 
619  if (isint(a)) { is=intval(a); goto IMINUS;}
620  else if (isflt(a)) { fs=fltval(a); goto FMINUS;}
621  else if (pisratio(a)) { rs=a; goto RMINUS;}
622  else if (isbignum(a)) { b=copy_big(a); goto BIGMINUS;}
623  else error(E_NONUMBER);
624 
625 IMINUS:
626  while (i<n) {
627  a=argv[i++];
628  if (isint(a)) {
629  is -= intval(a);
630  if (((is >> 1) ^ is)&((eusinteger_t)1<<(WORD_SIZE-3))) { /* fixnum overflow */
631  b=makebig1(is); goto BIGMINUS;} }
632  else if (isflt(a)) { fs=is; goto FMINUS1;}
633  else if (pisratio(a)) { rs=makeratio(is,1); goto RMINUS1;}
634  else if (isbignum(a)) {
635  z=big_minus(a); /* bignum -a is copied to z */
636  vpush(z);
637  if (is>0) add_int_big(is, z);
638  else if (is<0) sub_int_big(-is, z);
639  z=normalize_bignum(z);
640  if (isint(z)) { vpop(); is= intval(z);}
641  else { b=z; goto BIGMINUS1;} }
642  else error(E_NONUMBER); }
643  return(makeint(is));
644 
645 RMINUS:
646  while (i<n) {
647  a=argv[i++];
648 RMINUS1:
649  if (isint(a)) a=makeratio(intval(a),1);
650  else if (isflt(a)) { fs=ratio2flt(rs); goto FMINUS;}
651  else if (!isratio(a)) error(E_NONUMBER);
652  rs= ratio_minus(rs, a);
653  }
654  return(return_ratio(rs));
655 
656 FMINUS:
657  while (i<n) {
658  a=argv[i++];
659 FMINUS1:
660  fs -= ckfltval(a); }
661  return(makeflt(fs));
662 
663 BIGMINUS:
664  vpush(b);
665 BIGMINUS1:
666  while (i<n) {
667  a=argv[i++];
668  if (isint(a)) {
669  ia=intval(a);
670  if (ia>0) sub_int_big(intval(a), b);
671  else if (ia<0) add_int_big(-ia, b);
672  b=normalize_bignum(b);
673  if (isint(b)) { vpop(); is=intval(b); goto IMINUS;}
674  }
675  else if (isflt(a)) {
676  is= big_to_float(b); vpop(); goto FMINUS;}
677  else if (isbignum(a)) {
678  z= big_minus(a);
679  vpush(z);
680  b=big_plus(b,z);
681  ctx->vsp[-2]=b; /*replace b on the stack*/
682  vpop();
683  b=normalize_bignum(b);
684  if (isint(b)) { vpop(); is=intval(b); goto IMINUS;}
685  }
686  else if (isratio(a)) error(E_USER,(pointer)"BIG-RATIO not supported");
687  else error(E_NONUMBER);}
688  return(b);}
689 
690 pointer TIMES(ctx,n,argv)
691 register context *ctx;
692 register int n;
693 register pointer argv[];
694 { register eusfloat_t fs;
695  register eusinteger_t is,s;
696  register int i;
697  register eusinteger_t sign=1;
698  register pointer a, rs, b;
699  eusinteger_t hi, lo;
700  numunion nu;
701 
702 /* fprintf(stderr, "TIMES ");
703  for (i=0; i<n; i++) fprintf(stderr, "%x ", argv[i]);
704  fprintf(stderr, "\n"); */
705 
706  i=1;
707  a=argv[0];
708  if (isint(a)) { is=intval(a); goto ITIMES;}
709  else if (isflt(a)) { fs=fltval(a); goto FTIMES;}
710  else if (isratio(a)) { rs=a; vpush(rs); goto RTIMES;}
711  else if (isbignum(a)) { b=copy_big(a); vpush(b); goto BIGTIMES;}
712  else error(E_NONUMBER);
713 
714 ITIMES:
715  while (i<n) {
716  a=argv[i++];
717 ITIMES1:
718 
719  if (isint(a)) {
720  s=intval(a);
721  if (s==0 || is==0) { is=0; break;}
722  if (is<0) { sign= -1; is = -is;}
723  if (s<0) { sign= -sign; s = -s;}
724  extended_mul(is, s, 0, &hi, &lo);
725  if( hi !=0 || (lo & ((eusinteger_t)7 << (WORD_SIZE-3)))!=0) { /*overflow -->bignum */
726  b=makebig2(hi, lo & MASK);
727  b=normalize_bignum(b);
728  vpush(b);
729  if (sign<0) complement_big(b);
730  goto BIGTIMES;}
731  else is= lo*sign;}
732  else if (isflt(a)) { fs=is; goto FTIMES1;}
733  else if (pisbignum(a)) { /* fixnum times bignum */
734  b=copy_big(a);
735  vpush(b);
736  goto BIGTIMES1;}
737  else if (pisratio(a)) {
738  rs=makeratio(is,1);
739  vpush(rs);
740  goto RTIMES1;}
741  else error(E_NONUMBER);}
742  return(makeint(is));
743 
744 RTIMES:
745  while (i<n) {
746  a=argv[i++];
747 RTIMES1:
748  if (isint(a)) a=makeratio(intval(a),1);
749  else if (isflt(a)) { fs=ratio2flt(rs); goto FTIMES1;}
750  else if (!isratio(a)) error(E_NONUMBER);
751  rs= ratio_times(rs, a);
752  ctx->vsp[-1]=rs;
753  }
754  ctx->lastalloc=rs;
755  vpop();
756  return(return_ratio(rs));
757 
758 BIGTIMES:
759  while (i<n) {
760  a=argv[i++];
761  if (isint(a)) {
762  is=intval(a);
763 BIGTIMES1:
764  /* Here, b is saved, (b * is) is going to be performed */
765  sign=big_sign(b);
766  if (sign<0) { complement_big(b);}
767  if (is<0) { sign = -sign; is= -is;}
768  mul_int_big(is, b);
769  if (sign<0) complement_big(b);
770  b=normalize_bignum(b);
771  if (isint(b)) { is=intval(b); vpop(); goto ITIMES;}
772  }
773  else if (isflt(a)) {
774  fs = big_to_float(b); vpop(); goto FTIMES1;}
775  else if (pisbignum(a)) {
776  sign=big_sign(b);
777  if (sign<0) complement_big(b);
778  if (big_sign(a)<0) { sign= -sign; a=big_minus(a);}
779  vpush(a);
780  b=big_times(a,b);
781  ctx->vsp[-2]=b;
782  vpop();
783  b=normalize_bignum(b);
784  if (isint(b)) { is=intval(b); vpop(); goto ITIMES;}
785  }
786  else if (pisratio(a)) {
787  error(E_USER,(pointer)"sorry, big * ratio is not yet implemented.");}
788  else error(E_NONUMBER);
789  }
790  ctx->lastalloc= vpop();
791  return(b);
792 
793 FTIMES:
794  while (i<n) {
795  a=argv[i++];
796 FTIMES1:
797  fs*=ckfltval(a);}
798  return(makeflt(fs));}
799 
800 pointer QUOTIENT(ctx, n,argv)
801 register context *ctx;
802 register int n;
803 pointer argv[];
804 { register eusfloat_t fs;
805  register eusinteger_t is;
806  register int i=1;
807  register pointer a, rs;
808  numunion nu;
809  int sign;
810 
811  if (n<1) error(E_MISMATCHARG);
812  a=argv[0];
813  if (isint(a)) is=intval(a);
814  else if (isflt(a)) { fs=fltval(a); goto fquo;}
815  else if (pisratio(a)) {rs=a; goto rquo;}
816  else if (pisbignum(a)) { rs=copy_big(a); goto bquo;}
817  else error(E_NONUMBER);
818 
819  if (n==1) {
820  fs=fltval(a);
821  return(makeflt(1.0/fs));}
822 
823  while (i<n) {
824  a=argv[i];
825  if (isflt(a)) { fs=is; goto fquo2;}
826  else if (isint(a)) is/=intval(a);
827  else if (pisratio(a)) { rs=makeratio(is,1); goto rquo;}
828  else if (pisbignum(a)) is = 0;
829  else error(E_NONUMBER);
830  i++;}
831  return(makeint(is));
832 
833 rquo: /*quotient of ratios*/
834  while (i<n) {
835  a=argv[i];
836  if (isint(a)) a=makeratio(intval(a),1);
837  else if (isflt(a)) { fs=ratio2flt(rs); goto fquo;}
838  else if (!isratio(a)) error(E_NONUMBER);
839  rs= ratio_divide(rs, a);
840  i++;}
841  return(return_ratio(rs));
842 fquo:
843  if (n==1) return(makeflt(1.0/fs));
844 fquo2:
845  while (i<n) {
846  a=argv[i];
847  fs/=ckfltval(a);
848  i++;}
849  return(makeflt(fs));
850 
851 bquo:
852  if (big_sign(rs)<0) { sign= -1; complement_big(rs);}
853  else sign=1;
854  while (i<n) {
855  a=argv[i];
856  if (isflt(a)) {
857  fs=sign*big_to_float(rs); goto fquo2;}
858  if (!isint(a)) {
859  int rv = sign*div_big_big(a, rs);
860  return(mkbigint(rv));
861  } else {
862  is=intval(a);
863  if (is<0) { sign = - sign; is= -is;}
864  div_int_big(is, rs);
865  }
866  i++;
867  }
868  if (sign<0) complement_big(rs);
869  return(normalize_bignum(rs));
870  }
871 
872 
873 
874 
875 pointer SIN(ctx,n,argv)
876 register context *ctx;
877 int n;
878 pointer argv[];
879 { numunion nu;
880  ckarg(1);
881  return(makeflt(sin(ckfltval(argv[0]))));}
882 
883 pointer COS(ctx,n,argv)
884 register context *ctx;
885 int n;
886 pointer argv[];
887 { numunion nu;
888  ckarg(1);
889  return(makeflt(cos(ckfltval(argv[0]))));}
890 
891 pointer TAN(ctx,n,argv)
892 register context *ctx;
893 int n;
894 pointer argv[];
895 { numunion nu;
896  ckarg(1);
897  return(makeflt(tan(ckfltval(argv[0]))));}
898 
899 pointer ATAN(ctx,n,argv)
900 register context *ctx;
901 int n;
902 pointer argv[];
903 { numunion nu;
904  if (n==1) return(makeflt(atan(ckfltval(argv[0]))));
905  else if (n==2) return(makeflt(atan2(ckfltval(argv[0]),ckfltval(argv[1]))));
906  else error(E_MISMATCHARG);}
907 
908 pointer TANH(ctx,n,argv)
909 register context *ctx;
910 int n;
911 pointer argv[];
912 { numunion nu;
913  ckarg(1);
914  return(makeflt(tanh(ckfltval(argv[0]))));}
915 
916 pointer ATANH(ctx,n,argv)
917 register context *ctx;
918 int n;
919 pointer argv[];
920 { numunion nu;
921  ckarg(1);
922  return(makeflt(atanh(ckfltval(argv[0]))));}
923 
924 pointer SINH(ctx,n,argv)
925 register context *ctx;
926 int n;
927 pointer argv[];
928 { numunion nu;
929  ckarg(1);
930  return(makeflt(sinh(ckfltval(argv[0]))));}
931 
932 pointer ASINH(ctx,n,argv)
933 register context *ctx;
934 int n;
935 pointer argv[];
936 { numunion nu;
937  ckarg(1);
938  return(makeflt(asinh(ckfltval(argv[0]))));}
939 
940 pointer COSH(ctx,n,argv)
941 register context *ctx;
942 int n;
943 pointer argv[];
944 { numunion nu;
945  ckarg(1);
946  return(makeflt(cosh(ckfltval(argv[0]))));}
947 
948 pointer ACOSH(ctx,n,argv)
949 register context *ctx;
950 int n;
951 pointer argv[];
952 { numunion nu;
953  ckarg(1);
954  return(makeflt(acosh(ckfltval(argv[0]))));}
955 
956 pointer SQRT(ctx,n,argv)
957 register context *ctx;
958 int n;
959 pointer argv[];
960 { numunion nu;
961  ckarg(1);
962  return(makeflt(sqrt(ckfltval(argv[0]))));}
963 
964 pointer LOG(ctx,n,argv)
965 register context *ctx;
966 int n;
967 pointer argv[];
968 { double a;
969  numunion nu;
970  a=log(ckfltval(argv[0]));
971  if (n==1) return(makeflt(a));
972  else if (n==2) return(makeflt(a/log(ckfltval(argv[1]))));
973  else error(E_MISMATCHARG);}
974 
975 pointer EXP(ctx,n,argv)
976 register context *ctx;
977 int n;
978 pointer argv[];
979 { numunion nu;
980  ckarg(1);
981  return(makeflt(exp(ckfltval(argv[0]))));}
982 
983 pointer ABS(ctx,n,argv)
984 register context *ctx;
985 int n;
986 register pointer argv[];
987 { register pointer a, b;
988  eusfloat_t fa;
989  numunion nu;
990  ckarg(1);
991  a=argv[0];
992  if (a==makeint(MINNEGFIXNUM)) return(makebig1(-MINNEGFIXNUM));
993  if (isint(a)) return(makeint(labs(intval(a))));
994  else if (isflt(a)) return(makeflt(fabs(fltval(a))));
995  else if (pisbignum(a)) {
996  if (big_sign(a)<0) {
997  b=copy_big(a);
998  complement_big(b);
999  return(b);}
1000  else return(a);}
1001  else error(E_NONUMBER);}
1002 
1003 pointer ROUND(ctx,n,argv)
1004 register context *ctx;
1005 int n;
1006 register pointer argv[];
1007 { register pointer a=argv[0];
1008  eusfloat_t f;
1009  register eusinteger_t x;
1010  numunion nu;
1011  ckarg(1);
1012  if (isint(a)) return(a);
1013  else if (isbignum(a)) return(a);
1014  else {
1015  f=ckfltval(a);
1016  f=(double)rint(f);
1017  return(eusfloat_to_big(f));}
1018  }
1019 
1020 pointer FLOOR(ctx,n,argv)
1021 register context *ctx;
1022 int n;
1023 pointer argv[];
1024 { register pointer a=argv[0];
1025  eusfloat_t f;
1026  register eusinteger_t x;
1027  numunion nu;
1028  ckarg(1);
1029  if (isint(a)) return(a);
1030  else if (isbignum(a)) return(a);
1031  else {
1032  f=floor(ckfltval(a)); return(eusfloat_to_big(f));} }
1033 
1034 pointer CEILING(ctx,n,argv)
1035 register context *ctx;
1036 int n;
1037 pointer argv[];
1038 { register pointer a=argv[0];
1039  eusfloat_t f;
1040  numunion nu;
1041  ckarg(1);
1042  if (isint(a)) return(a);
1043  else if (isbignum(a)) return(a);
1044  else { f=ckfltval(a); f=ceil(f); return(eusfloat_to_big(f));}
1045  }
1046 
1047 pointer TRUNCATE(ctx,n,argv)
1048 register context *ctx;
1049 int n;
1050 pointer argv[];
1051 { register pointer a=argv[0];
1052  eusfloat_t f;
1053  register eusinteger_t x;
1054  numunion nu;
1055  ckarg(1);
1056  if (isint(a)) return(a);
1057  else if (isbignum(a)) return(a);
1058  else { f=ckfltval(a); return(eusfloat_to_big(f));}
1059  }
1060 
1061 pointer FREXP(ctx,n,argv)
1062 context *ctx;
1063 int n;
1064 pointer argv[];
1065 { eusfloat_t f,z;
1066  int exp;
1067  pointer p;
1068  numunion nu;
1069  extern double frexp(double, int *);
1070  ckarg(1);
1071  f=ckfltval(argv[0]);
1072  z=frexp(f, &exp);
1073  p=cons(ctx, makeint(exp), NIL);
1074  return(cons(ctx,makeflt(z),p));
1075  }
1076 
1077 pointer EUSFLOAT(ctx,n,argv)
1078 register context *ctx;
1079 int n;
1080 pointer argv[];
1081 { pointer a;
1082  eusfloat_t f;
1083  numunion nu;
1084  ckarg(1);
1085  a=argv[0];
1086  if (isflt(a)) return(a);
1087  else if (isint(a)) { f=intval(a); return(makeflt(f));}
1088  else { f=ckfltval(a); return(makeflt(f));}
1089  }
1090 
1091 pointer DECFLOAT(ctx,n,argv) /*(decode-float FLOAT) -> int*/
1092 register context *ctx;
1093 int n;
1094 pointer argv[];
1095 { pointer x;
1096  eusinteger_t i;
1097  ckarg(1);
1098  x=argv[0];
1099  if (!isflt(x)) error(E_NONUMBER);
1100  i=intval(x);
1101  return(makeint(i));}
1102 
1103 pointer MAX(ctx,n,argv)
1104 register context *ctx;
1105 register int n;
1106 pointer argv[];
1107 { eusfloat_t fs,fm;
1108  register int i=1;
1109  register eusinteger_t is;
1110  register pointer a=argv[0];
1111  numunion nu;
1112  if (n<1) error(E_MISMATCHARG);
1113  if (n==1) return(a);
1114  if (isint(a)) is=(eusinteger_t)a;
1115  else { fs=ckfltval(a); goto fmax; }
1116  while (i<n) {
1117  a=argv[i];
1118  if (isint(a)) { if (is<(eusinteger_t)a) is=(eusinteger_t)a;}
1119  else { fs=intval((pointer)is); goto fmax; }
1120  i++;}
1121  return((pointer)is);
1122 fmax:
1123  while (i<n) {
1124  fm=ckfltval(argv[i]);
1125  if (fs<fm) fs=fm;
1126  i++;}
1127  return(makeflt(fs));}
1128 
1129 pointer MIN(ctx,n,argv)
1130 register context *ctx;
1131 register int n;
1132 register pointer argv[];
1133 { eusfloat_t fs,fm;
1134  register int i=1;
1135  register eusinteger_t is;
1136  register pointer a=argv[0];
1137  numunion nu;
1138  if (n<1) error(E_MISMATCHARG);
1139  if (n==1) return(a);
1140  if (isint(a)) is=(eusinteger_t)a;
1141  else { fs=ckfltval(a); goto fmin;}
1142  while (i<n) {
1143  a=argv[i];
1144  if (isint(a)) { if (is>(eusinteger_t)a) is=(eusinteger_t)a;}
1145  else { fs=intval((pointer)is); goto fmin;}
1146  i++;}
1147  return((pointer)is);
1148 fmin:
1149  while (i<n) {
1150  fm=ckfltval(argv[i]);
1151  if (fs>fm) fs=fm;
1152  i++;}
1153  return(makeflt(fs));}
1154 
1155 /****************************************************************/
1156 /* bit wise logical operations
1157 /****************************************************************/
1158 pointer LOGAND(context *ctx, int n, pointer argv[])
1159 { int i=1,j,k,rsize,psize;
1160  eusinteger_t *rbv, *bbv, *pbv;
1161  pointer b,p,r=argv[0];
1162 
1163  if (isbignum(r)) {
1164  r=copy_big(r); rsize=bigsize(r); rbv=bigvec(r);
1165  p=argv[i++];
1166  goto bigand;}
1167 
1168  k=intval(r);
1169  while (i<n) {
1170  p=argv[i++];
1171  if (isint(p)) k &=intval(p);
1172  else if (isbignum(p)) {
1173  b=copy_big(p);
1174  p=makeint((eusinteger_t)r);
1175  r=b; rsize=bigsize(r); rbv=bigvec(r);
1176  goto bigand;}
1177  else error(E_NOINT);}
1178  return(makeint(k));
1179 
1180  while (i<n) {
1181  p=argv[i++];
1182 bigand:
1183  /* r is bignum */
1184  if (isint(p)) {
1185  rbv[0] &= intval(p);
1186  if (intval(p)>=0) for (j=1; j<rsize; j++) rbv[j]=0; }
1187  else if (isbignum(p)) {
1188  psize=bigsize(p);
1189  if (rsize>=psize) {
1190  for (j=0; j<psize; j++) rbv[j] &= p->c.bgnm.bv->c.ivec.iv[j];
1191  if (rsize>psize) {
1192  if (big_sign(p)>0) for (j=psize; j<rsize; j++) rbv[j]=0;}
1193  }
1194  else if (big_sign(r)<0) {
1195  r=extend_big(r,psize);
1196  rsize=psize; rbv=bigvec(r);
1197  for (j=0; j<psize; j++) rbv[j] &= p->c.bgnm.bv->c.ivec.iv[j];
1198  }
1199  else
1200  for (j=0; j<rsize; j++) rbv[j] &= p->c.bgnm.bv->c.ivec.iv[j];
1201  }
1202  else error(E_NOINT);}
1203  return(normalize_bignum(r));}
1204 
1205 pointer LOGIOR(ctx,n,argv)
1206 register context *ctx;
1207 register int n;
1208 register pointer argv[];
1209 { register eusinteger_t result=0;
1210  register int i=0;
1211  pointer p;
1212  while (i<n) {
1213  p=argv[i];
1214  if (!isint(p)) {
1215  if (isbignum(p)) result |= bigintval(p);
1216  else error(E_NOINT);}
1217  else result |= intval(p);
1218  i++; }
1219  return(mkbigint(result));}
1220 
1221 pointer LOGXOR(ctx,n,argv)
1222 register context *ctx;
1223 register int n;
1224 register pointer argv[];
1225 { register eusinteger_t result=0;
1226  register int i=0;
1227  while (i<n)
1228  if (!isint(argv[i])) error(E_NOINT);
1229  else result ^= intval(argv[i++]);
1230  return(makeint(result));}
1231 
1232 pointer LOGEQV(ctx,n,argv)
1233 register context *ctx;
1234 register int n;
1235 register pointer argv[];
1236 { register eusinteger_t result=0;
1237  register int i=0;
1238  while (n>0) {
1239  if (!isint(argv[--n])) error(E_NOINT);
1240  result ^= intval(argv[n]); }
1241  return(makeint(~result));}
1242 
1243 pointer LOGNAND(ctx,n,argv)
1244 register context *ctx;
1245 register int n;
1246 register pointer argv[];
1247 { register eusinteger_t result= ~0;
1248  register int i=0;
1249  while (i<n)
1250  if (!isint(argv[i])) error(E_NOINT);
1251  else result &= intval(argv[i++]);
1252  return(makeint(~result));}
1253 
1254 pointer LOGNOR(ctx,n,argv)
1255 register context *ctx;
1256 register int n;
1257 register pointer argv[];
1258 { register eusinteger_t result=0;
1259  register int i=0;
1260  while (i<n)
1261  if (!isint(argv[i])) error(E_NOINT);
1262  else result |= intval(argv[i++]);
1263  return(makeint(~result));}
1264 
1265 pointer LOGNOT(ctx,n,argv)
1266 register context *ctx;
1267 int n;
1268 pointer argv[];
1269 { eusinteger_t i;
1270  ckarg(1);
1271  if (!isint(argv[0])) error(E_NOINT);
1272  else {
1273  i=intval(argv[0]);
1274  return(makeint(~i));}}
1275 
1276 pointer LOGTEST(ctx,n,argv)
1277 register context *ctx;
1278 int n;
1279 register pointer argv[];
1280 { ckarg(2);
1281  if (!isint(argv[0])) error(E_NOINT);
1282  if (!isint(argv[1])) error(E_NOINT);
1283  if ((eusinteger_t)argv[0] & (eusinteger_t)argv[1] & (eusinteger_t)~3) return(T);
1284  else return(NIL);}
1285 
1286 pointer LOGBITP(ctx,n,argv)
1287 register context *ctx;
1288 register int n;
1289 register pointer argv[];
1290 { register eusinteger_t index,val;
1291  ckarg(2);
1292  index=ckintval(argv[0]);
1293  val=ckintval(argv[1]);
1294  if (index<0) error(E_NOINT);
1295  if ((val>>index) & 1) return(T); else return(NIL);}
1296 
1297 pointer ASH(ctx,n,argv)
1298 register context *ctx;
1299 register int n;
1300 register pointer argv[];
1301 { register eusinteger_t count,val;
1302  register int firstone;
1303  register eusinteger_t sign;
1304  pointer a,b;
1305  ckarg(2);
1306  count=ckintval(argv[1]);
1307  if (isint(argv[0])) {
1308  val=intval(argv[0]);
1309  if (count<=0) return(makeint(val>>(-count)));
1310  if (val<=0) { return(makeint(val<<count));}
1311 #if (WORD_SIZE == 64)
1312  firstone=ffsl(val);
1313 #else
1314  firstone=ffs(val);
1315 #endif
1316  if ((firstone + count)<WORD_SIZE-2) {
1317  sign=(val>=0)?1:(-1);
1318  val=val<<count;
1319  if (sign>0) return(makeint(val));
1320  else return(makeint(~val)); }
1321  /*extend to big*/
1322  a=makebig1(val);}
1323  else if (isbignum(argv[0])) { a=argv[0]; sign=big_sign(a);}
1324  else error(E_NOINT);
1325 
1326  /*shift b by count bits*/
1327  { int size=bigsize(a);
1328  int i, j, k;
1329  eusinteger_t x, *av, *bv;
1330  pointer b=makebig(size+(count+(WORD_SIZE-1))/(WORD_SIZE-1));
1331  vpush(b);
1332  av=bigvec(a); bv=bigvec(b);
1333  if (count>=0) {
1334  j= count/(WORD_SIZE-1); k=count % (WORD_SIZE-1);
1335  for (i=0; i<size; i++) {
1336  x=av[i];
1337  bv[i+j] |= (x << k);
1338  bv[i+j+1] = (x>>((WORD_SIZE-1)-k)); } }
1339  else { /* count <0 ; shift right */
1340  count = -count;
1341  j=count/(WORD_SIZE-1); k=count % (WORD_SIZE-1);
1342  for (i=0; i<size-j-1; i++) {
1343  bv[i]=(av[j+i]>>k) | ((av[j+i+1]<<((WORD_SIZE-1)-k)) & MASK); }
1344  bv[size-j-1]=av[size-1]>>k;
1345  }
1346  b=normalize_bignum(b);
1347  vpop();
1348  return(b); }
1349  }
1350 
1351 pointer LDB(ctx,n,argv) /*(LDB 'val 'pos 'width)*/
1352 register context *ctx;
1353 register int n; /*no byte specifier in euslisp*/
1354 register pointer argv[];
1355 { register eusinteger_t pos,width=8;
1356 #if (WORD_SIZE == 64)
1357  register unsigned long val;
1358 #else
1359  register unsigned int val;
1360 #endif
1361  ckarg2(2,3);
1362  val=ckintval(argv[0]); pos=ckintval(argv[1]);
1363  if (n==3) width=ckintval(argv[2]);
1364  val=(val<<(WORD_SIZE-pos-width))>>(WORD_SIZE-width);
1365  return(makeint(val));}
1366 
1367 pointer DPB(ctx,n,argv)
1368 register context *ctx;
1369 int n;
1370 pointer argv[];
1371 { register eusinteger_t pos,width=8;
1372 #if (WORD_SIZE == 64)
1373  register unsigned long val,target,mask=~0L;
1374 #else
1375  register unsigned int val,target,mask=~0;
1376 #endif
1377  ckarg(4);
1378  val=ckintval(argv[0]);
1379  target=ckintval(argv[1]);
1380  pos=ckintval(argv[2]);
1381  width=ckintval(argv[3]);
1382  mask=mask<<(WORD_SIZE-(pos+width));
1383  mask=mask>>(WORD_SIZE-width);
1384  val &= mask;
1385  mask <<= pos;
1386  target=(target & ~mask) | (val<<pos);
1387  return(makeint(target));}
1388 
1390 register context *ctx;
1391 int n;
1392 register pointer argv[];
1393 { pointer state;
1394  pointer randvec;
1395  time_t tm;
1396 
1397  ckarg2(0,1);
1398  state=NIL;
1399  randvec=makevector(C_INTVECTOR, 2);
1400  if (n==1) {
1401  state=argv[0];
1402  if (state==NIL) { goto MAKERANDSTATENIL; }
1403  else if (state==T) {
1404  if (time(&tm)==-1){
1405  error(E_USER,(pointer)"failed to fetch time"); }
1406  srand((unsigned int)tm);
1407  randvec->c.ivec.iv[0] = rand();
1408  randvec->c.ivec.iv[1] = rand();
1409  return (randvec); }
1410  if (!isintvector(state) && !isstring(state)) error(E_NOVECTOR);
1411  if (vecsize(state)<2) error(E_VECSIZE); }
1412 MAKERANDSTATENIL:
1413  if (state==NIL) {
1414  state=Spevalof(RANDSTATE);
1415  if (state==UNBOUND) state=speval(RANDSTATE); }
1416  randvec->c.ivec.iv[0] = state->c.ivec.iv[0];
1417  randvec->c.ivec.iv[1] = state->c.ivec.iv[1];
1418  return (randvec);
1419  }
1420 
1421 pointer RANDOM(ctx,n,argv)
1422 register context *ctx;
1423 int n;
1424 register pointer argv[];
1425 { pointer a=argv[0],state;
1426  eusinteger_t imax,irandval;
1427  eusfloat_t fmax,frandval;
1428  double randval;
1429  double erand48();
1430 #if news || sanyo
1431  long random();
1432 #endif
1433  numunion nu;
1434 
1435  ckarg2(1,2);
1436  if (n==2) {
1437  state=argv[1];
1438  if (!isintvector(state) && !isstring(state)) error(E_NOVECTOR);
1439  if (vecsize(state)<2) error(E_VECSIZE);}
1440  else {
1441  state=Spevalof(RANDSTATE);
1442  if (state==UNBOUND) state=speval(RANDSTATE);}
1443 #if news || sanyo
1444  randval=random();
1445 #else
1446 #if alpha
1447  randval=erand48((unsigned short *)state->c.ivec.iv);
1448 #elif Win32 || Cygwin
1449  randval=((double)rand())/RAND_MAX;
1450 #else
1451  randval=erand48((unsigned short *)(state->c.ivec.iv));
1452 #endif
1453 #endif
1454  if (isint(a)) {
1455  imax=intval(a);
1456  irandval=randval*imax;
1457  return(makeint(irandval));}
1458  else if (isflt(a)) {
1459  fmax=fltval(a);
1460  frandval=randval*fmax;
1461  return(makeflt(frandval));}
1462  else error(E_NONUMBER);
1463  }
1464 
1465 
1466 void arith(ctx,mod)
1467 register context *ctx;
1468 pointer mod;
1469 {
1470  defun(ctx,"=",mod,NUMEQUAL,NULL);
1471  defun(ctx,"/=",mod,NUMNEQUAL,NULL);
1472  defun(ctx,">",mod,GREATERP,NULL);
1473  defun(ctx,"<",mod,LESSP,NULL);
1474  defun(ctx,">=",mod,GREQP,NULL);
1475  defun(ctx,"<=",mod,LSEQP,NULL);
1476  defun(ctx,"MOD",mod,MOD,NULL);
1477  defun(ctx,"1-",mod,SUB1,NULL);
1478  defun(ctx,"1+",mod,ADD1,NULL);
1479  defun(ctx,"+",mod,PLUS,NULL);
1480  defun(ctx,"-",mod,MINUS,NULL);
1481  defun(ctx,"*",mod,TIMES,NULL);
1482  defun(ctx,"/",mod,QUOTIENT,NULL);
1483  defun(ctx,"SIN",mod,SIN,NULL);
1484  defun(ctx,"COS",mod,COS,NULL);
1485  defun(ctx,"TAN",mod,TAN,NULL);
1486  defun(ctx,"ATAN",mod,ATAN,NULL);
1487  defun(ctx,"TANH",mod,TANH,NULL);
1488  defun(ctx,"ATANH",mod,ATANH,NULL);
1489  defun(ctx,"SINH",mod,SINH,NULL);
1490  defun(ctx,"ASINH",mod,ASINH,NULL);
1491  defun(ctx,"COSH",mod,COSH,NULL);
1492  defun(ctx,"ACOSH",mod,ACOSH,NULL);
1493  defun(ctx,"SQRT",mod,SQRT,NULL);
1494  defun(ctx,"LOG",mod,LOG,NULL);
1495  defun(ctx,"EXP",mod,EXP,NULL);
1496  defun(ctx,"ABS",mod,ABS,NULL);
1497  defun(ctx,"ROUND",mod,ROUND,NULL);
1498  defun(ctx,"FLOOR",mod,FLOOR,NULL);
1499  defun(ctx,"CEILING",mod,CEILING,NULL);
1500  defun(ctx,"TRUNCATE",mod,TRUNCATE,NULL);
1501  defun(ctx,"FLOAT",mod,EUSFLOAT,NULL);
1502  defun(ctx,"DECODE-FLOAT",mod,DECFLOAT,NULL);
1503  defun(ctx,"MAX",mod,MAX,NULL);
1504  defun(ctx,"MIN",mod,MIN,NULL);
1505  defun(ctx,"LOGAND",mod,LOGAND,NULL);
1506  defun(ctx,"LOGIOR",mod,LOGIOR,NULL);
1507  defun(ctx,"LOGXOR",mod,LOGXOR,NULL);
1508  defun(ctx,"LOGEQV",mod,LOGEQV,NULL);
1509  defun(ctx,"LOGNAND",mod,LOGNAND,NULL);
1510  defun(ctx,"LOGNOR",mod,LOGNOR,NULL);
1511  defun(ctx,"LOGNOT",mod,LOGNOT,NULL);
1512  defun(ctx,"LOGTEST",mod,LOGTEST,NULL);
1513  defun(ctx,"LOGBITP",mod,LOGBITP,NULL);
1514  defun(ctx,"ASH",mod,ASH,NULL);
1515  defun(ctx,"LDB",mod,LDB,NULL);
1516  defun(ctx,"DPB",mod,DPB,NULL);
1517  defun(ctx,"MAKE-RANDOM-STATE",mod,MAKERANDOMSTATE,NULL);
1518  defun(ctx,"RANDOM",mod,RANDOM,NULL);
1519  defun(ctx,"FREXP",mod,FREXP,NULL);
1520 }
LOG
pointer LOG(context *ctx, int n, argv)
Definition: arith.c:964
if
if(n==1)
Definition: unixcall.c:492
numunion
Definition: eus.h:428
complement_big
void complement_big(pointer x)
Definition: big.c:475
LOGIOR
pointer LOGIOR(context *ctx, int n, argv)
Definition: arith.c:1205
big_sign
eusinteger_t big_sign(pointer)
Definition: big.c:423
EUSFLOAT
pointer EUSFLOAT(context *ctx, int n, argv)
Definition: arith.c:1077
RANDOM
pointer RANDOM(context *ctx, int n, argv)
Definition: arith.c:1421
NIL
pointer NIL
Definition: eus.c:110
SINH
pointer SINH(context *ctx, int n, argv)
Definition: arith.c:924
defun
defun("ADR_TO_STRING", mod, ADR_TO_STRING)
add_big_big
pointer add_big_big()
ratio_minus
pointer ratio_minus(pointer x, pointer y)
Definition: arith.c:440
TIMES
pointer TIMES(context *ctx, int n, argv)
Definition: arith.c:690
TRUNCATE
pointer TRUNCATE(context *ctx, int n, argv)
Definition: arith.c:1047
gcd
int gcd()
return_ratio
pointer return_ratio(pointer r)
Definition: arith.c:522
FREXP
pointer FREXP(context *ctx, int n, argv)
Definition: arith.c:1061
makeint
#define makeint(v)
Definition: sfttest.c:2
context
Definition: eus.h:524
EXP
pointer EXP(context *ctx, int n, argv)
Definition: arith.c:975
s
short s
Definition: structsize.c:2
LOGAND
pointer LOGAND(context *ctx, int n, pointer argv[])
Definition: arith.c:1158
ratio_divide
pointer ratio_divide(pointer x, pointer y)
Definition: arith.c:480
makevector
pointer makevector(pointer, int)
Definition: makes.c:417
big_minus
pointer big_minus()
intval
#define intval(p)
Definition: sfttest.c:1
div_int_big
eusinteger_t div_int_big(eusinteger_t c, pointer x)
Definition: big.c:628
LSEQP
pointer LSEQP(context *ctx, int n, argv)
Definition: arith.c:296
ckfltval
float ckfltval()
T
pointer T
Definition: eus.c:110
abs
#define abs(x)
Definition: image_correlation.c:12
atan2
double atan2()
E_NONUMBER
@ E_NONUMBER
Definition: eus.h:960
MAKERANDOMSTATE
pointer MAKERANDOMSTATE(context *ctx, int n, argv)
Definition: arith.c:1389
E_MISMATCHARG
@ E_MISMATCHARG
Definition: eus.h:942
add_int_big
void add_int_big()
eus.h
sin
double sin()
LOGNOR
pointer LOGNOR(context *ctx, int n, argv)
Definition: arith.c:1254
GREATERP
pointer GREATERP(context *ctx, int n, argv)
Definition: arith.c:104
cell::cellunion::bgnm
struct bignum bgnm
Definition: eus.h:424
cell::cellunion::ivec
struct intvector ivec
Definition: eus.h:416
TANH
pointer TANH(context *ctx, int n, argv)
Definition: arith.c:908
COSH
pointer COSH(context *ctx, int n, argv)
Definition: arith.c:940
eusfloat_t
double eusfloat_t
Definition: eus.h:21
FLOOR
pointer FLOOR(context *ctx, int n, argv)
Definition: arith.c:1020
eusfloat_to_big
pointer eusfloat_to_big(float)
Definition: big.c:968
MIN
pointer MIN(context *ctx, int n, argv)
Definition: arith.c:1129
cell::c
union cell::cellunion c
MAX
pointer MAX(context *ctx, int n, argv)
Definition: arith.c:1103
RANDSTATE
pointer RANDSTATE
Definition: eus.c:172
arith
void arith(context *ctx, pointer mod)
Definition: arith.c:1466
ABS
pointer ABS(context *ctx, int n, argv)
Definition: arith.c:983
extend_big
pointer extend_big(pointer, int)
Definition: big.c:392
ASH
pointer ASH(context *ctx, int n, argv)
Definition: arith.c:1297
div_big_big
eusinteger_t div_big_big(pointer x, pointer y)
Definition: big.c:809
NULL
#define NULL
Definition: transargv.c:8
ACOSH
pointer ACOSH(context *ctx, int n, argv)
Definition: arith.c:948
mul_int_big
void mul_int_big(eusinteger_t c, pointer x)
Definition: big.c:607
fltval
float fltval()
rcsid
static char * rcsid
Definition: arith.c:8
big_to_float
eusfloat_t big_to_float(pointer)
Definition: big.c:954
cell::cellunion::ratio
struct ratio ratio
Definition: eus.h:422
SUB1
pointer SUB1(context *ctx, int n, argv)
Definition: arith.c:375
LOGEQV
pointer LOGEQV(context *ctx, int n, argv)
Definition: arith.c:1232
DECFLOAT
pointer DECFLOAT(context *ctx, int n, argv)
Definition: arith.c:1091
GREQP
pointer GREQP(context *ctx, int n, argv)
Definition: arith.c:232
LDB
pointer LDB(context *ctx, int n, argv)
Definition: arith.c:1351
LOGNAND
pointer LOGNAND(context *ctx, int n, argv)
Definition: arith.c:1243
LOGNOT
pointer LOGNOT(context *ctx, int n, argv)
Definition: arith.c:1265
ratio::denominator
pointer denominator
Definition: eus.h:370
NUMEQUAL
pointer NUMEQUAL(context *ctx, int n, argv)
Definition: arith.c:36
cons
pointer cons(context *, pointer, pointer)
Definition: makes.c:97
big_plus
pointer big_plus()
E_NOVECTOR
@ E_NOVECTOR
Definition: eus.h:963
ratio2flt
eusfloat_t ratio2flt(pointer r)
Definition: arith.c:506
E_NOINT
@ E_NOINT
Definition: eus.h:956
makeratio
pointer makeratio()
makeflt
pointer makeflt()
bignum::bv
pointer bv
Definition: eus.h:378
error
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
count
int count
Definition: thrtest.c:11
NUMNEQUAL
pointer NUMNEQUAL(context *ctx, int n, argv)
Definition: arith.c:86
f
f
ffsl
int ffsl(long int i)
ratio_times
pointer ratio_times(pointer x, pointer y)
Definition: arith.c:462
sqrt
double sqrt()
cell
Definition: eus.h:381
normalize_bignum
pointer normalize_bignum()
eusinteger_t
long eusinteger_t
Definition: eus.h:19
ATANH
pointer ATANH(context *ctx, int n, argv)
Definition: arith.c:916
extended_mul
void extended_mul(eusinteger_t d, eusinteger_t q, eusinteger_t r, eusinteger_t *hp, eusinteger_t *lp)
Definition: big.c:28
makebig
pointer makebig()
sub_int_big
void sub_int_big()
int2ratio
pointer int2ratio(eusinteger_t i)
Definition: arith.c:502
big_times
pointer big_times()
big_compare
int big_compare(pointer x, pointer y)
Definition: big.c:437
cos
double cos()
E_VECSIZE
@ E_VECSIZE
Definition: eus.h:964
index
char * index(char *sp, char c)
Definition: eustags.c:1669
ASINH
pointer ASINH(context *ctx, int n, argv)
Definition: arith.c:932
TAN
pointer TAN(context *ctx, int n, argv)
Definition: arith.c:891
COS
pointer COS(context *ctx, int n, argv)
Definition: arith.c:883
ratio::numerator
pointer numerator
Definition: eus.h:369
C_INTVECTOR
pointer C_INTVECTOR
Definition: eus.c:146
MINUS
pointer MINUS(context *ctx, int n, argv)
Definition: arith.c:591
ATAN
pointer ATAN(context *ctx, int n, argv)
Definition: arith.c:899
LESSP
pointer LESSP(context *ctx, int n, argv)
Definition: arith.c:168
DPB
pointer DPB(context *ctx, int n, argv)
Definition: arith.c:1367
E_USER
@ E_USER
Definition: eus.h:1006
LOGBITP
pointer LOGBITP(context *ctx, int n, argv)
Definition: arith.c:1286
copy_big
pointer copy_big()
LOGXOR
pointer LOGXOR(context *ctx, int n, argv)
Definition: arith.c:1221
SQRT
pointer SQRT(context *ctx, int n, argv)
Definition: arith.c:956
intvector::iv
eusinteger_t iv[1]
Definition: eus.h:305
makebig2
pointer makebig2()
CEILING
pointer CEILING(context *ctx, int n, argv)
Definition: arith.c:1034
a
char a[26]
Definition: freq.c:4
makebig1
pointer makebig1()
QUOTIENT
pointer QUOTIENT(context *ctx, int n, argv)
Definition: arith.c:800
ROUND
pointer ROUND(context *ctx, int n, argv)
Definition: arith.c:1003
LOGTEST
pointer LOGTEST(context *ctx, int n, argv)
Definition: arith.c:1276
n
GLfloat n[6][3]
Definition: cube.c:15
MOD
pointer MOD(context *ctx, int n, argv)
Definition: arith.c:360
PLUS
pointer PLUS(context *ctx, int n, argv)
Definition: arith.c:529
ratio_plus
pointer ratio_plus(pointer x, pointer y)
Definition: arith.c:416
SIN
pointer SIN(context *ctx, int n, argv)
Definition: arith.c:875
ckarg
ckarg(2)
ADD1
pointer ADD1(context *ctx, int n, argv)
Definition: arith.c:395


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 15 2023 02:06:42