Mercurial > hg > xemacs-beta

comparison src/bytecode.c @ 1983:9c872f33ecbe

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2004-04-05 22:49:31 by james] Add bignum, ratio, and bigfloat support.
author james
date Mon, 05 Apr 2004 22:50:11 +0000
parents c66036f59678
children 4e6a63799f08
comparison
equal deleted inserted replaced
1982:a748951fd4fb 1983:9c872f33ecbe
244 static Lisp_Object 244 static Lisp_Object
245 bytecode_negate (Lisp_Object obj) 245 bytecode_negate (Lisp_Object obj)
246 { 246 {
247 retry: 247 retry:
248 248
249 if (INTP (obj)) return make_int (- XINT (obj)); 249 if (INTP (obj)) return make_integer (- XINT (obj));
250 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj)); 250 if (FLOATP (obj)) return make_float (- XFLOAT_DATA (obj));
251 if (CHARP (obj)) return make_int (- ((int) XCHAR (obj))); 251 if (CHARP (obj)) return make_integer (- ((int) XCHAR (obj)));
252 if (MARKERP (obj)) return make_int (- ((int) marker_position (obj))); 252 if (MARKERP (obj)) return make_integer (- ((int) marker_position (obj)));
253 #ifdef HAVE_BIGNUM
254 if (BIGNUMP (obj)) BIGNUM_ARITH_RETURN (obj, neg);
255 #endif
256 #ifdef HAVE_RATIO
257 if (RATIOP (obj)) RATIO_ARITH_RETURN (obj, neg);
258 #endif
259 #ifdef HAVE_BIG_FLOAT
260 if (BIGFLOAT_P (obj)) BIGFLOAT_ARITH_RETURN (obj, neg);
261 #endif
253 262
254 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj); 263 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
255 goto retry; 264 goto retry;
256 } 265 }
257 266
277 /* We have our own two-argument versions of various arithmetic ops. 286 /* We have our own two-argument versions of various arithmetic ops.
278 Only two-argument arithmetic operations have their own byte codes. */ 287 Only two-argument arithmetic operations have their own byte codes. */
279 static int 288 static int
280 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2) 289 bytecode_arithcompare (Lisp_Object obj1, Lisp_Object obj2)
281 { 290 {
291 #ifdef WITH_NUMBER_TYPES
292 switch (promote_args (&obj1, &obj2))
293 {
294 case FIXNUM_T:
295 {
296 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2);
297 return ival1 < ival2 ? -1 : ival1 > ival2 ? 1 : 0;
298 }
299 #ifdef HAVE_BIGNUM
300 case BIGNUM_T:
301 return bignum_cmp (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2));
302 #endif
303 #ifdef HAVE_RATIO
304 case RATIO_T:
305 return ratio_cmp (XRATIO_DATA (obj1), XRATIO_DATA (obj2));
306 #endif
307 case FLOAT_T:
308 {
309 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2);
310 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
311 }
312 #ifdef HAVE_BIGFLOAT
313 case BIGFLOAT_T:
314 return bigfloat_cmp (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2));
315 #endif
316 }
317 #else /* !WITH_NUMBER_TYPES */
282 retry: 318 retry:
283 319
284 { 320 {
285 EMACS_INT ival1, ival2; 321 EMACS_INT ival1, ival2;
286 322
322 goto retry; 358 goto retry;
323 } 359 }
324 360
325 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0; 361 return dval1 < dval2 ? -1 : dval1 > dval2 ? 1 : 0;
326 } 362 }
363 #endif /* WITH_NUMBER_TYPES */
327 } 364 }
328 365
329 static Lisp_Object 366 static Lisp_Object
330 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode) 367 bytecode_arithop (Lisp_Object obj1, Lisp_Object obj2, Opcode opcode)
331 { 368 {
369 #ifdef WITH_NUMBER_TYPES
370 switch (promote_args (&obj1, &obj2))
371 {
372 case FIXNUM_T:
373 {
374 EMACS_INT ival1 = XREALINT (obj1), ival2 = XREALINT (obj2);
375 switch (opcode)
376 {
377 case Bplus: ival1 += ival2; break;
378 case Bdiff: ival1 -= ival2; break;
379 case Bmult:
380 #ifdef HAVE_BIGNUM
381 /* Due to potential overflow, we compute using bignums */
382 bignum_set_long (scratch_bignum, ival1);
383 bignum_set_long (scratch_bignum2, ival2);
384 bignum_mul (scratch_bignum, scratch_bignum, scratch_bignum2);
385 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
386 #else
387 ival1 *= ival2; break;
388 #endif
389 case Bquo:
390 if (ival2 == 0) Fsignal (Qarith_error, Qnil);
391 ival1 /= ival2;
392 break;
393 case Bmax: if (ival1 < ival2) ival1 = ival2; break;
394 case Bmin: if (ival1 > ival2) ival1 = ival2; break;
395 }
396 return make_integer (ival1);
397 }
398 #ifdef HAVE_BIGNUM
399 case BIGNUM_T:
400 switch (opcode)
401 {
402 case Bplus:
403 bignum_add (scratch_bignum, XBIGNUM_DATA (obj1),
404 XBIGNUM_DATA (obj2));
405 break;
406 case Bdiff:
407 bignum_sub (scratch_bignum, XBIGNUM_DATA (obj1),
408 XBIGNUM_DATA (obj2));
409 break;
410 case Bmult:
411 bignum_mul (scratch_bignum, XBIGNUM_DATA (obj1),
412 XBIGNUM_DATA (obj2));
413 break;
414 case Bquo:
415 if (bignum_sign (XBIGNUM_DATA (obj2)) == 0)
416 Fsignal (Qarith_error, Qnil);
417 bignum_div (scratch_bignum, XBIGNUM_DATA (obj1),
418 XBIGNUM_DATA (obj2));
419 break;
420 case Bmax:
421 return bignum_gt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))
422 ? obj1 : obj2;
423 case Bmin:
424 return bignum_lt (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))
425 ? obj1 : obj2;
426 }
427 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
428 #endif
429 #ifdef HAVE_RATIO
430 case RATIO_T:
431 switch (opcode)
432 {
433 case Bplus:
434 ratio_add (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
435 break;
436 case Bdiff:
437 ratio_sub (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
438 break;
439 case Bmult:
440 ratio_mul (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
441 break;
442 case Bquo:
443 if (ratio_sign (XRATIO_DATA (obj2)) == 0)
444 Fsignal (Qarith_error, Qnil);
445 ratio_div (scratch_ratio, XRATIO_DATA (obj1), XRATIO_DATA (obj2));
446 break;
447 case Bmax:
448 return ratio_gt (XRATIO_DATA (obj1), XRATIO_DATA (obj2))
449 ? obj1 : obj2;
450 case Bmin:
451 return ratio_lt (XRATIO_DATA (obj1), XRATIO_DATA (obj2))
452 ? obj1 : obj2;
453 }
454 return make_ratio_rt (scratch_ratio);
455 #endif
456 case FLOAT_T:
457 {
458 double dval1 = XFLOAT_DATA (obj1), dval2 = XFLOAT_DATA (obj2);
459 switch (opcode)
460 {
461 case Bplus: dval1 += dval2; break;
462 case Bdiff: dval1 -= dval2; break;
463 case Bmult: dval1 *= dval2; break;
464 case Bquo:
465 if (dval2 == 0.0) Fsignal (Qarith_error, Qnil);
466 dval1 /= dval2;
467 break;
468 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
469 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
470 }
471 return make_float (dval1);
472 }
473 #ifdef HAVE_BIGFLOAT
474 case BIGFLOAT_T:
475 bigfloat_set_prec (scratch_bigfloat, max (XBIGFLOAT_GET_PREC (obj1),
476 XBIGFLOAT_GET_PREC (obj2)));
477 switch (opcode)
478 {
479 case Bplus:
480 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
481 XBIGFLOAT_DATA (obj2));
482 break;
483 case Bdiff:
484 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
485 XBIGFLOAT_DATA (obj2));
486 break;
487 case Bmult:
488 bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
489 XBIGFLOAT_DATA (obj2));
490 break;
491 case Bquo:
492 if (bigfloat_sign (XBIGFLOAT_DATA (obj2)) == 0)
493 Fsignal (Qarith_error, Qnil);
494 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (obj1),
495 XBIGFLOAT_DATA (obj2));
496 break;
497 case Bmax:
498 return bigfloat_gt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))
499 ? obj1 : obj2;
500 case Bmin:
501 return bigfloat_lt (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))
502 ? obj1 : obj2;
503 }
504 return make_bigfloat_bf (scratch_bigfloat);
505 #endif
506 }
507 #else /* !WITH_NUMBER_TYPES */
332 EMACS_INT ival1, ival2; 508 EMACS_INT ival1, ival2;
333 int float_p; 509 int float_p;
334 510
335 retry: 511 retry:
336 512
388 case Bmax: if (dval1 < dval2) dval1 = dval2; break; 564 case Bmax: if (dval1 < dval2) dval1 = dval2; break;
389 case Bmin: if (dval1 > dval2) dval1 = dval2; break; 565 case Bmin: if (dval1 > dval2) dval1 = dval2; break;
390 } 566 }
391 return make_float (dval1); 567 return make_float (dval1);
392 } 568 }
569 #endif /* WITH_NUMBER_TYPES */
393 } 570 }
394 571
395 572
396 /* Read next uint8 from the instruction stream. */ 573 /* Read next uint8 from the instruction stream. */
397 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++) 574 #define READ_UINT_1 ((unsigned int) (unsigned char) *program_ptr++)
804 case Blistp: 981 case Blistp:
805 TOP = LISTP (TOP) ? Qt : Qnil; 982 TOP = LISTP (TOP) ? Qt : Qnil;
806 break; 983 break;
807 984
808 case Bnumberp: 985 case Bnumberp:
986 #ifdef WITH_NUMBER_TYPES
987 TOP = NUMBERP (TOP) ? Qt : Qnil;
988 #else
809 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil; 989 TOP = INT_OR_FLOATP (TOP) ? Qt : Qnil;
990 #endif
810 break; 991 break;
811 992
812 case Bintegerp: 993 case Bintegerp:
994 #ifdef HAVE_BIGNUM
995 TOP = INTEGERP (TOP) ? Qt : Qnil;
996 #else
813 TOP = INTP (TOP) ? Qt : Qnil; 997 TOP = INTP (TOP) ? Qt : Qnil;
998 #endif
814 break; 999 break;
815 1000
816 case Beq: 1001 case Beq:
817 { 1002 {
818 Lisp_Object arg = POP; 1003 Lisp_Object arg = POP;
905 TOP = Fget (TOP, arg, Qnil); 1090 TOP = Fget (TOP, arg, Qnil);
906 break; 1091 break;
907 } 1092 }
908 1093
909 case Bsub1: 1094 case Bsub1:
1095 #ifdef HAVE_BIGNUM
1096 TOP = Fsub1 (TOP);
1097 #else
910 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP); 1098 TOP = INTP (TOP) ? INT_MINUS1 (TOP) : Fsub1 (TOP);
1099 #endif
911 break; 1100 break;
912 1101
913 case Badd1: 1102 case Badd1:
1103 #ifdef HAVE_BIGNUM
1104 TOP = Fadd1 (TOP);
1105 #else
914 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP); 1106 TOP = INTP (TOP) ? INT_PLUS1 (TOP) : Fadd1 (TOP);
1107 #endif
915 break; 1108 break;
916 1109
917 1110
918 case Beqlsign: 1111 case Beqlsign:
919 { 1112 {
964 1157
965 case Bplus: 1158 case Bplus:
966 { 1159 {
967 Lisp_Object arg2 = POP; 1160 Lisp_Object arg2 = POP;
968 Lisp_Object arg1 = TOP; 1161 Lisp_Object arg1 = TOP;
1162 #ifdef HAVE_BIGNUM
1163 TOP = bytecode_arithop (arg1, arg2, opcode);
1164 #else
969 TOP = INTP (arg1) && INTP (arg2) ? 1165 TOP = INTP (arg1) && INTP (arg2) ?
970 INT_PLUS (arg1, arg2) : 1166 INT_PLUS (arg1, arg2) :
971 bytecode_arithop (arg1, arg2, opcode); 1167 bytecode_arithop (arg1, arg2, opcode);
1168 #endif
972 break; 1169 break;
973 } 1170 }
974 1171
975 case Bdiff: 1172 case Bdiff:
976 { 1173 {
977 Lisp_Object arg2 = POP; 1174 Lisp_Object arg2 = POP;
978 Lisp_Object arg1 = TOP; 1175 Lisp_Object arg1 = TOP;
1176 #ifdef HAVE_BIGNUM
1177 TOP = bytecode_arithop (arg1, arg2, opcode);
1178 #else
979 TOP = INTP (arg1) && INTP (arg2) ? 1179 TOP = INTP (arg1) && INTP (arg2) ?
980 INT_MINUS (arg1, arg2) : 1180 INT_MINUS (arg1, arg2) :
981 bytecode_arithop (arg1, arg2, opcode); 1181 bytecode_arithop (arg1, arg2, opcode);
1182 #endif
982 break; 1183 break;
983 } 1184 }
984 1185
985 case Bmult: 1186 case Bmult:
986 case Bquo: 1187 case Bquo: