Ticket #1773: numeric-type-hash-switches.patch
File numeric-type-hash-switches.patch, 40.1 KB (added by , 22 months ago) |
---|
-
runtime.c
diff --git a/runtime.c b/runtime.c index 93dd9d29..cf7351e7 100644
a b static C_TLS int timezone; 269 269 #define C_thread_id(x) C_block_item((x), 14) 270 270 271 271 272 /* A numeric type hash packs the type bits into the bottom 12 bits (regardless of immediate/block type). */ 273 /* NOTE: Only fixnum-immediates are currently distinguished - to make this more generic one would need to use one more test */ 274 #define C_type_hash(x) (((x) & C_IMMEDIATE_MARK_BITS) ? ((x) & C_FIXNUM_BIT) : C_header_bits(x)) 275 276 /* We only care about numeric type hashes currently */ 277 #define C_FIXNUM_TYPE_HASH C_FIXNUM_BIT 278 #define C_FLONUM_TYPE_HASH C_FLONUM_TYPE 279 #define C_BIGNUM_TYPE_HASH C_BIGNUM_TYPE 280 #define C_RATNUM_TYPE_HASH C_RATNUM_TYPE 281 #define C_CPLXNUM_TYPE_HASH C_CPLXNUM_TYPE 282 283 272 284 /* Type definitions: */ 273 285 274 286 typedef C_regparm C_word C_fcall (*integer_plusmin_op) (C_word **ptr, C_word n, C_word x, C_word y); … … C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x) 5287 5299 5288 5300 C_regparm C_word C_fcall C_i_nanp(C_word x) 5289 5301 { 5290 if (x & C_FIXNUM_BIT) { 5302 switch(C_type_hash(x)) { 5303 case C_FIXNUM_TYPE_HASH: 5304 case C_BIGNUM_TYPE_HASH: 5305 case C_RATNUM_TYPE_HASH: 5291 5306 return C_SCHEME_FALSE; 5292 } else if (C_immediatep(x)) { 5293 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x); 5294 } else if (C_block_header(x) == C_FLONUM_TAG) { 5307 5308 case C_FLONUM_TYPE_HASH: 5295 5309 return C_u_i_flonum_nanp(x); 5296 } else if (C_truep(C_bignump(x))) { 5297 return C_SCHEME_FALSE; 5298 } else if (C_block_header(x) == C_RATNUM_TAG) { 5299 return C_SCHEME_FALSE; 5300 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 5310 5311 case C_CPLXNUM_TYPE_HASH: 5301 5312 return C_mk_bool(C_truep(C_i_nanp(C_u_i_cplxnum_real(x))) || 5302 5313 C_truep(C_i_nanp(C_u_i_cplxnum_imag(x)))); 5303 } else { 5314 5315 default: 5304 5316 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x); 5305 5317 } 5306 5318 } 5307 5319 5308 5320 C_regparm C_word C_fcall C_i_finitep(C_word x) 5309 5321 { 5310 if (x & C_FIXNUM_BIT) { 5322 switch(C_type_hash(x)) { 5323 case C_FIXNUM_TYPE_HASH: 5324 case C_BIGNUM_TYPE_HASH: 5325 case C_RATNUM_TYPE_HASH: 5311 5326 return C_SCHEME_TRUE; 5312 } else if (C_immediatep(x)) { 5313 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x); 5314 } else if (C_block_header(x) == C_FLONUM_TAG) { 5327 5328 case C_FLONUM_TYPE_HASH: 5315 5329 return C_u_i_flonum_finitep(x); 5316 } else if (C_truep(C_bignump(x))) { 5317 return C_SCHEME_TRUE; 5318 } else if (C_block_header(x) == C_RATNUM_TAG) { 5319 return C_SCHEME_TRUE; 5320 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 5330 5331 case C_CPLXNUM_TYPE_HASH: 5321 5332 return C_and(C_i_finitep(C_u_i_cplxnum_real(x)), 5322 5333 C_i_finitep(C_u_i_cplxnum_imag(x))); 5323 } else { 5334 5335 default: 5324 5336 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x); 5325 5337 } 5326 5338 } 5327 5339 5328 5340 C_regparm C_word C_fcall C_i_infinitep(C_word x) 5329 5341 { 5330 if (x & C_FIXNUM_BIT) { 5342 switch(C_type_hash(x)) { 5343 case C_FIXNUM_TYPE_HASH: 5344 case C_BIGNUM_TYPE_HASH: 5345 case C_RATNUM_TYPE_HASH: 5331 5346 return C_SCHEME_FALSE; 5332 } else if (C_immediatep(x)) { 5333 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x); 5334 } else if (C_block_header(x) == C_FLONUM_TAG) { 5347 5348 case C_FLONUM_TYPE_HASH: 5335 5349 return C_u_i_flonum_infinitep(x); 5336 } else if (C_truep(C_bignump(x))) { 5337 return C_SCHEME_FALSE; 5338 } else if (C_block_header(x) == C_RATNUM_TAG) { 5339 return C_SCHEME_FALSE; 5340 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 5350 5351 case C_CPLXNUM_TYPE_HASH: 5341 5352 return C_mk_bool(C_truep(C_i_infinitep(C_u_i_cplxnum_real(x))) || 5342 5353 C_truep(C_i_infinitep(C_u_i_cplxnum_imag(x)))); 5343 } else { 5354 5355 default: 5344 5356 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x); 5345 5357 } 5346 5358 } 5347 5359 5348 5360 C_regparm C_word C_fcall C_i_exactp(C_word x) 5349 5361 { 5350 if (x & C_FIXNUM_BIT) { 5362 switch(C_type_hash(x)) { 5363 case C_FIXNUM_TYPE_HASH: 5364 case C_BIGNUM_TYPE_HASH: 5365 case C_RATNUM_TYPE_HASH: 5351 5366 return C_SCHEME_TRUE; 5352 } else if (C_immediatep(x)) { 5353 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x); 5354 } else if (C_block_header(x) == C_FLONUM_TAG) { 5367 5368 case C_FLONUM_TYPE_HASH: 5355 5369 return C_SCHEME_FALSE; 5356 } else if (C_truep(C_bignump(x))) { 5357 return C_SCHEME_TRUE; 5358 } else if (C_block_header(x) == C_RATNUM_TAG) { 5359 return C_SCHEME_TRUE; 5360 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 5370 5371 case C_CPLXNUM_TYPE_HASH: 5361 5372 return C_i_exactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */ 5362 } else { 5373 5374 default: 5363 5375 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x); 5364 5376 } 5365 5377 } … … C_regparm C_word C_fcall C_i_exactp(C_word x) 5367 5379 5368 5380 C_regparm C_word C_fcall C_i_inexactp(C_word x) 5369 5381 { 5370 if (x & C_FIXNUM_BIT) { 5382 switch(C_type_hash(x)) { 5383 case C_FIXNUM_TYPE_HASH: 5384 case C_BIGNUM_TYPE_HASH: 5385 case C_RATNUM_TYPE_HASH: 5371 5386 return C_SCHEME_FALSE; 5372 } else if (C_immediatep(x)) { 5373 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x); 5374 } else if (C_block_header(x) == C_FLONUM_TAG) { 5387 5388 case C_FLONUM_TYPE_HASH: 5375 5389 return C_SCHEME_TRUE; 5376 } else if (C_truep(C_bignump(x))) { 5377 return C_SCHEME_FALSE; 5378 } else if (C_block_header(x) == C_RATNUM_TAG) { 5379 return C_SCHEME_FALSE; 5380 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 5390 5391 case C_CPLXNUM_TYPE_HASH: 5381 5392 return C_i_inexactp(C_u_i_cplxnum_real(x)); /* Exactness of i and r matches */ 5382 } else { 5393 5394 default: 5383 5395 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x); 5384 5396 } 5385 5397 } … … C_regparm C_word C_fcall C_i_inexactp(C_word x) 5387 5399 5388 5400 C_regparm C_word C_fcall C_i_zerop(C_word x) 5389 5401 { 5390 if (x & C_FIXNUM_BIT) { 5402 switch(C_type_hash(x)) { 5403 case C_FIXNUM_TYPE_HASH: 5391 5404 return C_mk_bool(x == C_fix(0)); 5392 } else if (C_immediatep(x)) { 5393 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x); 5394 } else if (C_block_header(x) == C_FLONUM_TAG) { 5405 5406 case C_FLONUM_TYPE_HASH: 5395 5407 return C_mk_bool(C_flonum_magnitude(x) == 0.0); 5396 } else if (C_block_header(x) == C_BIGNUM_TAG || 5397 C_block_header(x) == C_RATNUM_TAG || 5398 C_block_header(x) == C_CPLXNUM_TAG) { 5408 5409 case C_BIGNUM_TYPE_HASH: 5410 case C_RATNUM_TYPE_HASH: 5411 case C_CPLXNUM_TYPE_HASH: 5399 5412 return C_SCHEME_FALSE; 5400 } else { 5413 5414 default: 5401 5415 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x); 5402 5416 } 5403 5417 } … … C_regparm C_word C_fcall C_u_i_zerop(C_word x) 5414 5428 5415 5429 C_regparm C_word C_fcall C_i_positivep(C_word x) 5416 5430 { 5417 if (x & C_FIXNUM_BIT) 5431 switch(C_type_hash(x)) { 5432 case C_FIXNUM_TYPE_HASH: 5418 5433 return C_i_fixnum_positivep(x); 5419 else if (C_immediatep(x)) 5420 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x); 5421 else if (C_block_header(x) == C_FLONUM_TAG) 5434 5435 case C_FLONUM_TYPE_HASH: 5422 5436 return C_mk_bool(C_flonum_magnitude(x) > 0.0); 5423 else if (C_truep(C_bignump(x))) 5437 5438 case C_BIGNUM_TYPE_HASH: 5424 5439 return C_mk_nbool(C_bignum_negativep(x)); 5425 else if (C_block_header(x) == C_RATNUM_TAG) 5440 5441 case C_RATNUM_TYPE_HASH: 5426 5442 return C_i_integer_positivep(C_u_i_ratnum_num(x)); 5427 else if (C_block_header(x) == C_CPLXNUM_TAG) 5443 5444 case C_CPLXNUM_TYPE_HASH: 5428 5445 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "positive?", x); 5429 else 5446 5447 default: 5430 5448 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x); 5449 } 5431 5450 } 5432 5451 5433 5452 C_regparm C_word C_fcall C_i_integer_positivep(C_word x) … … C_regparm C_word C_fcall C_i_integer_positivep(C_word x) 5438 5457 5439 5458 C_regparm C_word C_fcall C_i_negativep(C_word x) 5440 5459 { 5441 if (x & C_FIXNUM_BIT) 5460 switch(C_type_hash(x)) { 5461 case C_FIXNUM_TYPE_HASH: 5442 5462 return C_i_fixnum_negativep(x); 5443 else if (C_immediatep(x)) 5444 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x); 5445 else if (C_block_header(x) == C_FLONUM_TAG) 5463 5464 case C_FLONUM_TYPE_HASH: 5446 5465 return C_mk_bool(C_flonum_magnitude(x) < 0.0); 5447 else if (C_truep(C_bignump(x))) 5466 5467 case C_BIGNUM_TYPE_HASH: 5448 5468 return C_mk_bool(C_bignum_negativep(x)); 5449 else if (C_block_header(x) == C_RATNUM_TAG) 5469 5470 case C_RATNUM_TYPE_HASH: 5450 5471 return C_i_integer_negativep(C_u_i_ratnum_num(x)); 5451 else if (C_block_header(x) == C_CPLXNUM_TAG) 5472 5473 case C_CPLXNUM_TYPE_HASH: 5452 5474 barf(C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR, "negative?", x); 5453 else 5475 5476 default: 5454 5477 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x); 5478 } 5455 5479 } 5456 5480 5457 5481 … … C_regparm C_word C_fcall C_i_integer_negativep(C_word x) 5464 5488 5465 5489 C_regparm C_word C_fcall C_i_evenp(C_word x) 5466 5490 { 5467 if(x & C_FIXNUM_BIT) { 5491 switch(C_type_hash(x)) { 5492 case C_FIXNUM_TYPE_HASH: 5468 5493 return C_i_fixnumevenp(x); 5469 } else if(C_immediatep(x)) { 5470 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);5471 } else if (C_block_header(x) == C_FLONUM_TAG){5494 5495 case C_FLONUM_TYPE_HASH: 5496 { 5472 5497 double val, dummy; 5473 5498 val = C_flonum_magnitude(x); 5474 5499 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0) 5475 5500 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x); 5476 5501 else 5477 5502 return C_mk_bool(fmod(val, 2.0) == 0.0); 5478 } else if (C_truep(C_bignump(x))) { 5503 } 5504 5505 case C_BIGNUM_TYPE_HASH: 5479 5506 return C_mk_nbool(C_bignum_digits(x)[0] & 1); 5480 } else { /* No need to try extended number */ 5507 5508 default: 5481 5509 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x); 5482 5510 } 5483 5511 } … … C_regparm C_word C_fcall C_i_integer_evenp(C_word x) 5491 5519 5492 5520 C_regparm C_word C_fcall C_i_oddp(C_word x) 5493 5521 { 5494 if(x & C_FIXNUM_BIT) { 5522 switch(C_type_hash(x)) { 5523 case C_FIXNUM_TYPE_HASH: 5495 5524 return C_i_fixnumoddp(x); 5496 } else if(C_immediatep(x)) { 5497 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);5498 } else if(C_block_header(x) == C_FLONUM_TAG){5525 5526 case C_FLONUM_TYPE_HASH: 5527 { 5499 5528 double val, dummy; 5500 5529 val = C_flonum_magnitude(x); 5501 5530 if(C_isnan(val) || C_isinf(val) || C_modf(val, &dummy) != 0.0) 5502 5531 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x); 5503 5532 else 5504 5533 return C_mk_bool(fmod(val, 2.0) != 0.0); 5505 } else if (C_truep(C_bignump(x))) { 5534 } 5535 5536 case C_BIGNUM_TYPE_HASH: 5506 5537 return C_mk_bool(C_bignum_digits(x)[0] & 1); 5507 } else { 5538 5539 default: 5508 5540 barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x); 5509 5541 } 5510 5542 } … … C_regparm C_word C_fcall C_i_f64vector_set(C_word v, C_word i, C_word x) 6400 6432 C_regparm C_word C_fcall 6401 6433 C_s_a_i_abs(C_word **ptr, C_word n, C_word x) 6402 6434 { 6403 if (x & C_FIXNUM_BIT) { 6435 switch(C_type_hash(x)) { 6436 case C_FIXNUM_TYPE_HASH: 6404 6437 return C_a_i_fixnum_abs(ptr, 1, x); 6405 } else if (C_immediatep(x)) { 6406 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x); 6407 } else if (C_block_header(x) == C_FLONUM_TAG) { 6438 6439 case C_FLONUM_TYPE_HASH: 6408 6440 return C_a_i_flonum_abs(ptr, 1, x); 6409 } else if (C_truep(C_bignump(x))) { 6441 6442 case C_BIGNUM_TYPE_HASH: 6410 6443 return C_s_a_u_i_integer_abs(ptr, 1, x); 6411 } else if (C_block_header(x) == C_RATNUM_TAG) { 6444 6445 case C_RATNUM_TYPE_HASH: 6412 6446 return C_ratnum(ptr, C_s_a_u_i_integer_abs(ptr, 1, C_u_i_ratnum_num(x)), 6413 6447 C_u_i_ratnum_denom(x)); 6414 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 6448 6449 case C_CPLXNUM_TYPE_HASH: 6415 6450 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_ABS, "abs", x); 6416 } else { 6451 6452 default: 6417 6453 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "abs", x); 6418 6454 } 6419 6455 } … … void C_ccall C_signum(C_word c, C_word *av) 6427 6463 x = av[ 2 ]; 6428 6464 y = av[ 3 ]; 6429 6465 6430 if (x & C_FIXNUM_BIT) { 6466 switch(C_type_hash(x)) { 6467 case C_FIXNUM_TYPE_HASH: 6431 6468 C_kontinue(k, C_i_fixnum_signum(x)); 6432 } else if (C_immediatep(x)) { 6433 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "signum", x);6434 } else if (C_block_header(x) == C_FLONUM_TAG){6469 6470 case C_FLONUM_TYPE_HASH: 6471 { 6435 6472 C_word *a = C_alloc(C_SIZEOF_FLONUM); 6436 6473 C_kontinue(k, C_a_u_i_flonum_signum(&a, 1, x)); 6437 } else if (C_truep(C_bignump(x))) { 6474 } 6475 6476 case C_BIGNUM_TYPE_HASH: 6438 6477 C_kontinue(k, C_bignum_negativep(x) ? C_fix(-1) : C_fix(1)); 6439 } else { 6478 6479 case C_RATNUM_TYPE_HASH: 6480 case C_CPLXNUM_TYPE_HASH: 6440 6481 try_extended_number("##sys#extended-signum", 2, k, x); 6482 6483 default: 6484 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "signum", x); 6441 6485 } 6442 6486 } 6443 6487 … … void C_ccall C_signum(C_word c, C_word *av) 6449 6493 C_regparm C_word C_fcall 6450 6494 C_s_a_i_negate(C_word **ptr, C_word n, C_word x) 6451 6495 { 6452 if (x & C_FIXNUM_BIT) { 6496 switch(C_type_hash(x)) { 6497 case C_FIXNUM_TYPE_HASH: 6453 6498 return C_a_i_fixnum_negate(ptr, 1, x); 6454 } else if (C_immediatep(x)) { 6455 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x); 6456 } else if (C_block_header(x) == C_FLONUM_TAG) { 6499 6500 case C_FLONUM_TYPE_HASH: 6457 6501 return C_a_i_flonum_negate(ptr, 1, x); 6458 } else if (C_truep(C_bignump(x))) { 6502 6503 case C_BIGNUM_TYPE_HASH: 6459 6504 return C_s_a_u_i_integer_negate(ptr, 1, x); 6460 } else if (C_block_header(x) == C_RATNUM_TAG) { 6505 6506 case C_RATNUM_TYPE_HASH: 6461 6507 return C_ratnum(ptr, C_s_a_u_i_integer_negate(ptr, 1, C_u_i_ratnum_num(x)), 6462 6508 C_u_i_ratnum_denom(x)); 6463 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 6509 6510 case C_CPLXNUM_TYPE_HASH: 6464 6511 return C_cplxnum(ptr, C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_real(x)), 6465 6512 C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(x))); 6466 } else { 6513 6514 default: 6467 6515 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x); 6468 6516 } 6469 6517 } … … cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy) 7987 8035 C_regparm C_word C_fcall 7988 8036 C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y) 7989 8037 { 7990 if (x & C_FIXNUM_BIT) { 7991 if (y & C_FIXNUM_BIT) { 8038 switch(C_type_hash(x)) { /* TODO: Use dyadic_hash? */ 8039 case C_FIXNUM_TYPE_HASH: 8040 switch(C_type_hash(y)) { 8041 case C_FIXNUM_TYPE_HASH: 7992 8042 return C_a_i_fixnum_times(ptr, 2, x, y); 7993 } else if (C_immediatep(y)) { 7994 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 7995 } else if (C_block_header(y) == C_FLONUM_TAG) { 8043 8044 case C_FLONUM_TYPE_HASH: 7996 8045 return C_flonum(ptr, (double)C_unfix(x) * C_flonum_magnitude(y)); 7997 } else if (C_truep(C_bignump(y))) { 7998 return C_s_a_u_i_integer_times(ptr, 2, x, y); 7999 } else if (C_block_header(y) == C_RATNUM_TAG) { 8000 return rat_times_integer(ptr, y, x); 8001 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8002 return cplx_times(ptr, x, C_fix(0), 8003 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); 8004 } else { 8005 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 8006 } 8007 } else if (C_immediatep(x)) { 8008 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x); 8009 } else if (C_block_header(x) == C_FLONUM_TAG) { 8010 if (y & C_FIXNUM_BIT) { 8011 return C_flonum(ptr, C_flonum_magnitude(x) * (double)C_unfix(y)); 8012 } else if (C_immediatep(y)) { 8013 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 8014 } else if (C_block_header(y) == C_FLONUM_TAG) { 8015 return C_a_i_flonum_times(ptr, 2, x, y); 8016 } else if (C_truep(C_bignump(y))) { 8017 return C_flonum(ptr, C_flonum_magnitude(x) * C_bignum_to_double(y)); 8018 } else if (C_block_header(y) == C_RATNUM_TAG) { 8019 return C_s_a_i_times(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); 8020 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8021 C_word ab[C_SIZEOF_FLONUM], *a = ab; 8022 return cplx_times(ptr, x, C_flonum(&a, 0.0), 8023 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); 8024 } else { 8025 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 8026 } 8027 } else if (C_truep(C_bignump(x))) { 8028 if (y & C_FIXNUM_BIT) { 8029 return C_s_a_u_i_integer_times(ptr, 2, x, y); 8030 } else if (C_immediatep(y)) { 8031 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x); 8032 } else if (C_block_header(y) == C_FLONUM_TAG) { 8033 return C_flonum(ptr, C_bignum_to_double(x) * C_flonum_magnitude(y)); 8034 } else if (C_truep(C_bignump(y))) { 8046 8047 case C_BIGNUM_TYPE_HASH: 8035 8048 return C_s_a_u_i_integer_times(ptr, 2, x, y); 8036 } else if (C_block_header(y) == C_RATNUM_TAG) { 8049 8050 case C_RATNUM_TYPE_HASH: 8037 8051 return rat_times_integer(ptr, y, x); 8038 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8052 8053 case C_CPLXNUM_TYPE_HASH: 8039 8054 return cplx_times(ptr, x, C_fix(0), 8040 8055 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); 8041 } else { 8056 8057 default: 8042 8058 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 8043 8059 } 8044 } else if (C_block_header(x) == C_RATNUM_TAG) { 8045 if (y & C_FIXNUM_BIT) { 8046 return rat_times_integer(ptr, x, y); 8047 } else if (C_immediatep(y)) { 8048 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 8049 } else if (C_block_header(y) == C_FLONUM_TAG) { 8050 return C_s_a_i_times(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); 8051 } else if (C_truep(C_bignump(y))) { 8052 return rat_times_integer(ptr, x, y); 8053 } else if (C_block_header(y) == C_RATNUM_TAG) { 8060 8061 case C_FLONUM_TYPE_HASH: 8062 switch(C_type_hash(y)) { 8063 case C_FIXNUM_TYPE_HASH: 8064 return C_flonum(ptr, C_flonum_magnitude(x) * (double)C_unfix(y)); 8065 8066 case C_FLONUM_TYPE_HASH: 8067 return C_a_i_flonum_times(ptr, 2, x, y); 8068 8069 case C_BIGNUM_TYPE_HASH: 8070 return C_flonum(ptr, C_flonum_magnitude(x) * C_bignum_to_double(y)); 8071 8072 case C_RATNUM_TYPE_HASH: 8073 return C_s_a_i_times(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); 8074 8075 case C_CPLXNUM_TYPE_HASH: 8076 { 8077 C_word ab[C_SIZEOF_FLONUM], *a = ab; 8078 return cplx_times(ptr, x, C_flonum(&a, 0.0), 8079 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); 8080 } 8081 8082 default: 8083 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 8084 } 8085 8086 case C_BIGNUM_TYPE_HASH: 8087 switch(C_type_hash(y)) { 8088 case C_FIXNUM_TYPE_HASH: 8089 return C_s_a_u_i_integer_times(ptr, 2, x, y); 8090 8091 case C_FLONUM_TYPE_HASH: 8092 return C_flonum(ptr, C_bignum_to_double(x) * C_flonum_magnitude(y)); 8093 8094 case C_BIGNUM_TYPE_HASH: 8095 return C_s_a_u_i_integer_times(ptr, 2, x, y); 8096 8097 case C_RATNUM_TYPE_HASH: 8098 return rat_times_integer(ptr, y, x); 8099 8100 case C_CPLXNUM_TYPE_HASH: 8101 return cplx_times(ptr, x, C_fix(0), 8102 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); 8103 8104 default: 8105 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 8106 } 8107 8108 case C_RATNUM_TYPE_HASH: 8109 switch(C_type_hash(y)) { 8110 case C_FIXNUM_TYPE_HASH: 8111 return rat_times_integer(ptr, x, y); 8112 8113 case C_FLONUM_TYPE_HASH: 8114 return C_s_a_i_times(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); 8115 8116 case C_BIGNUM_TYPE_HASH: 8117 return rat_times_integer(ptr, x, y); 8118 8119 case C_RATNUM_TYPE_HASH: 8054 8120 return rat_times_rat(ptr, x, y); 8055 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8056 return cplx_times(ptr, x, C_fix(0), 8057 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); 8058 } else { 8059 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 8060 } 8061 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 8062 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) { 8063 return cplx_times(ptr, C_u_i_cplxnum_real(x), C_u_i_cplxnum_imag(x), 8064 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); 8065 } else { 8066 C_word ab[C_SIZEOF_FLONUM], *a = ab, yi; 8067 yi = C_truep(C_i_flonump(y)) ? C_flonum(&a,0) : C_fix(0); 8068 return cplx_times(ptr, C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), y, yi); 8069 } 8070 } else { 8121 8122 case C_CPLXNUM_TYPE_HASH: 8123 return cplx_times(ptr, x, C_fix(0), 8124 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); 8125 8126 default: 8127 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y); 8128 } 8129 8130 case C_CPLXNUM_TYPE_HASH: 8131 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) { 8132 return cplx_times(ptr, C_u_i_cplxnum_real(x), C_u_i_cplxnum_imag(x), 8133 C_u_i_cplxnum_real(y), C_u_i_cplxnum_imag(y)); 8134 } else { 8135 C_word ab[C_SIZEOF_FLONUM], *a = ab, yi; 8136 yi = C_truep(C_i_flonump(y)) ? C_flonum(&a,0) : C_fix(0); 8137 return cplx_times(ptr, C_u_i_ratnum_num(x), C_u_i_ratnum_denom(x), y, yi); 8138 } 8139 8140 default: 8071 8141 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", x); 8072 8142 } 8073 8143 } … … static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_ 8382 8452 C_regparm C_word C_fcall 8383 8453 C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y) 8384 8454 { 8385 if (x & C_FIXNUM_BIT) { 8386 if (y & C_FIXNUM_BIT) { 8455 switch(C_type_hash(x)) { /* TODO: Use dyadic_hash? */ 8456 case C_FIXNUM_TYPE_HASH: 8457 switch(C_type_hash(y)) { 8458 case C_FIXNUM_TYPE_HASH: 8387 8459 return C_a_i_fixnum_plus(ptr, 2, x, y); 8388 } else if (C_immediatep(y)) { 8389 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); 8390 } else if (C_block_header(y) == C_FLONUM_TAG) { 8460 8461 case C_FLONUM_TYPE_HASH: 8391 8462 return C_flonum(ptr, (double)C_unfix(x) + C_flonum_magnitude(y)); 8392 } else if (C_truep(C_bignump(y))) { 8463 8464 case C_BIGNUM_TYPE_HASH: 8393 8465 return C_s_a_u_i_integer_plus(ptr, 2, x, y); 8394 } else if (C_block_header(y) == C_RATNUM_TAG) { 8466 8467 case C_RATNUM_TYPE_HASH: 8395 8468 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus); 8396 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8469 8470 case C_CPLXNUM_TYPE_HASH: 8471 { 8397 8472 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)), 8398 8473 imag = C_u_i_cplxnum_imag(y); 8399 8474 if (C_truep(C_u_i_inexactp(real_sum))) 8400 8475 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8401 8476 return C_cplxnum(ptr, real_sum, imag); 8402 } else {8403 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);8404 8477 } 8405 } else if (C_immediatep(x)) { 8406 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x); 8407 } else if (C_block_header(x) == C_FLONUM_TAG) { 8408 if (y & C_FIXNUM_BIT) { 8409 return C_flonum(ptr, C_flonum_magnitude(x) + (double)C_unfix(y)); 8410 } else if (C_immediatep(y)) { 8411 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); 8412 } else if (C_block_header(y) == C_FLONUM_TAG) { 8413 return C_a_i_flonum_plus(ptr, 2, x, y); 8414 } else if (C_truep(C_bignump(y))) { 8415 return C_flonum(ptr, C_flonum_magnitude(x)+C_bignum_to_double(y)); 8416 } else if (C_block_header(y) == C_RATNUM_TAG) { 8417 return C_s_a_i_plus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); 8418 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8419 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)), 8420 imag = C_u_i_cplxnum_imag(y); 8421 if (C_truep(C_u_i_inexactp(real_sum))) 8422 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8423 return C_cplxnum(ptr, real_sum, imag); 8424 } else { 8478 8479 default: 8425 8480 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); 8426 8481 } 8427 } else if (C_truep(C_bignump(x))) { 8428 if (y & C_FIXNUM_BIT) { 8482 8483 case C_FLONUM_TYPE_HASH: 8484 switch(C_type_hash(y)) { 8485 case C_FIXNUM_TYPE_HASH: 8486 return C_flonum(ptr, C_flonum_magnitude(x) + (double)C_unfix(y)); 8487 8488 case C_FLONUM_TYPE_HASH: 8489 return C_a_i_flonum_plus(ptr, 2, x, y); 8490 8491 case C_BIGNUM_TYPE_HASH: 8492 return C_flonum(ptr, C_flonum_magnitude(x)+C_bignum_to_double(y)); 8493 8494 case C_RATNUM_TYPE_HASH: 8495 return C_s_a_i_plus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); 8496 8497 case C_CPLXNUM_TYPE_HASH: 8498 { 8499 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)), 8500 imag = C_u_i_cplxnum_imag(y); 8501 if (C_truep(C_u_i_inexactp(real_sum))) 8502 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8503 return C_cplxnum(ptr, real_sum, imag); 8504 } 8505 8506 default: 8507 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); 8508 } 8509 8510 case C_BIGNUM_TYPE_HASH: 8511 switch(C_type_hash(y)) { 8512 case C_FIXNUM_TYPE_HASH: 8429 8513 return C_s_a_u_i_integer_plus(ptr, 2, x, y); 8430 } else if (C_immediatep(y)) { 8431 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); 8432 } else if (C_block_header(y) == C_FLONUM_TAG) { 8514 case C_FLONUM_TYPE_HASH: 8433 8515 return C_flonum(ptr, C_bignum_to_double(x)+C_flonum_magnitude(y)); 8434 } else if (C_truep(C_bignump(y))) { 8516 8517 case C_BIGNUM_TYPE_HASH: 8435 8518 return C_s_a_u_i_integer_plus(ptr, 2, x, y); 8436 } else if (C_block_header(y) == C_RATNUM_TAG) { 8519 8520 case C_RATNUM_TYPE_HASH: 8437 8521 return rat_plusmin_integer(ptr, y, x, C_s_a_u_i_integer_plus); 8438 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8522 8523 case C_CPLXNUM_TYPE_HASH: 8524 { 8439 8525 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)), 8440 8526 imag = C_u_i_cplxnum_imag(y); 8441 8527 if (C_truep(C_u_i_inexactp(real_sum))) 8442 8528 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8443 8529 return C_cplxnum(ptr, real_sum, imag); 8444 } else { 8530 } 8531 8532 default: 8445 8533 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); 8446 8534 } 8447 } else if (C_block_header(x) == C_RATNUM_TAG) { 8448 if (y & C_FIXNUM_BIT) { 8535 8536 case C_RATNUM_TYPE_HASH: 8537 switch(C_type_hash(y)) { 8538 case C_FIXNUM_TYPE_HASH: 8539 case C_BIGNUM_TYPE_HASH: 8449 8540 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus); 8450 } else if (C_immediatep(y)) { 8451 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); 8452 } else if (C_block_header(y) == C_FLONUM_TAG) { 8541 8542 case C_FLONUM_TYPE_HASH: 8453 8543 return C_s_a_i_plus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); 8454 } else if (C_truep(C_bignump(y))) { 8455 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_plus); 8456 } else if (C_block_header(y) == C_RATNUM_TAG) { 8544 8545 case C_RATNUM_TYPE_HASH: 8457 8546 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_plus); 8458 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8547 8548 case C_CPLXNUM_TYPE_HASH: 8549 { 8459 8550 C_word real_sum = C_s_a_i_plus(ptr, 2, x, C_u_i_cplxnum_real(y)), 8460 8551 imag = C_u_i_cplxnum_imag(y); 8461 8552 if (C_truep(C_u_i_inexactp(real_sum))) 8462 8553 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8463 8554 return C_cplxnum(ptr, real_sum, imag); 8464 } else { 8555 } 8556 8557 default: 8465 8558 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y); 8466 8559 } 8467 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 8560 8561 case C_CPLXNUM_TYPE_HASH: 8468 8562 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) { 8469 8563 C_word real_sum, imag_sum; 8470 8564 real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y)); … … C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y) 8473 8567 else return C_cplxnum(ptr, real_sum, imag_sum); 8474 8568 } else { 8475 8569 C_word real_sum = C_s_a_i_plus(ptr, 2, C_u_i_cplxnum_real(x), y), 8476 8570 imag = C_u_i_cplxnum_imag(x); 8477 8571 if (C_truep(C_u_i_inexactp(real_sum))) 8478 8572 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8479 8573 return C_cplxnum(ptr, real_sum, imag); 8480 8574 } 8481 } else { 8575 8576 default: 8482 8577 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", x); 8483 8578 } 8484 8579 } … … static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y) 8593 8688 C_regparm C_word C_fcall 8594 8689 C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y) 8595 8690 { 8596 if (x & C_FIXNUM_BIT) { 8597 if (y & C_FIXNUM_BIT) { 8691 switch(C_type_hash(x)) { /* TODO: Use dyadic_hash? */ 8692 case C_FIXNUM_TYPE_HASH: 8693 switch(C_type_hash(y)) { 8694 case C_FIXNUM_TYPE_HASH: 8598 8695 return C_a_i_fixnum_difference(ptr, 2, x, y); 8599 } else if (C_immediatep(y)) { 8600 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); 8601 } else if (C_block_header(y) == C_FLONUM_TAG) { 8696 8697 case C_FLONUM_TYPE_HASH: 8602 8698 return C_flonum(ptr, (double)C_unfix(x) - C_flonum_magnitude(y)); 8603 } else if (C_truep(C_bignump(y))) { 8699 8700 case C_BIGNUM_TYPE_HASH: 8604 8701 return C_s_a_u_i_integer_minus(ptr, 2, x, y); 8605 } else if (C_block_header(y) == C_RATNUM_TAG) { 8702 8703 case C_RATNUM_TYPE_HASH: 8606 8704 return integer_minus_rat(ptr, x, y); 8607 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8705 8706 case C_CPLXNUM_TYPE_HASH: 8707 { 8608 8708 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)), 8609 8709 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y)); 8610 8710 if (C_truep(C_u_i_inexactp(real_diff))) 8611 8711 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8612 8712 return C_cplxnum(ptr, real_diff, imag); 8613 } else { 8713 } 8714 8715 default: 8614 8716 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); 8615 8717 } 8616 } else if (C_immediatep(x)) { 8617 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x);8618 } else if (C_block_header(x) == C_FLONUM_TAG) {8619 if (y & C_FIXNUM_BIT) {8718 8719 case C_FLONUM_TYPE_HASH: 8720 switch(C_type_hash(y)) { 8721 case C_FIXNUM_TYPE_HASH: 8620 8722 return C_flonum(ptr, C_flonum_magnitude(x) - (double)C_unfix(y)); 8621 } else if (C_immediatep(y)) { 8622 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); 8623 } else if (C_block_header(y) == C_FLONUM_TAG) { 8723 8724 case C_FLONUM_TYPE_HASH: 8624 8725 return C_a_i_flonum_difference(ptr, 2, x, y); 8625 } else if (C_truep(C_bignump(y))) { 8726 8727 case C_BIGNUM_TYPE_HASH: 8626 8728 return C_flonum(ptr, C_flonum_magnitude(x)-C_bignum_to_double(y)); 8627 } else if (C_block_header(y) == C_RATNUM_TAG) { 8729 8730 case C_RATNUM_TYPE_HASH: 8628 8731 return C_s_a_i_minus(ptr, 2, x, C_a_i_exact_to_inexact(ptr, 1, y)); 8629 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8732 8733 case C_CPLXNUM_TYPE_HASH: 8734 { 8630 8735 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)), 8631 8736 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y)); 8632 8737 if (C_truep(C_u_i_inexactp(real_diff))) 8633 8738 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8634 8739 return C_cplxnum(ptr, real_diff, imag); 8635 } else { 8740 } 8741 8742 default: 8636 8743 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); 8637 8744 } 8638 } else if (C_truep(C_bignump(x))) { 8639 if (y & C_FIXNUM_BIT) { 8745 8746 case C_BIGNUM_TYPE_HASH: 8747 switch(C_type_hash(y)) { 8748 case C_FIXNUM_TYPE_HASH: 8640 8749 return C_s_a_u_i_integer_minus(ptr, 2, x, y); 8641 } else if (C_immediatep(y)) { 8642 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); 8643 } else if (C_block_header(y) == C_FLONUM_TAG) { 8750 8751 case C_FLONUM_TYPE_HASH: 8644 8752 return C_flonum(ptr, C_bignum_to_double(x)-C_flonum_magnitude(y)); 8645 } else if (C_truep(C_bignump(y))) { 8753 8754 case C_BIGNUM_TYPE_HASH: 8646 8755 return C_s_a_u_i_integer_minus(ptr, 2, x, y); 8647 } else if (C_block_header(y) == C_RATNUM_TAG) { 8756 8757 case C_RATNUM_TYPE_HASH: 8648 8758 return integer_minus_rat(ptr, x, y); 8649 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8759 8760 case C_CPLXNUM_TYPE_HASH: 8761 { 8650 8762 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)), 8651 8763 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y)); 8652 8764 if (C_truep(C_u_i_inexactp(real_diff))) 8653 8765 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8654 8766 return C_cplxnum(ptr, real_diff, imag); 8655 } else { 8767 } 8768 8769 default: 8656 8770 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); 8657 8771 } 8658 } else if (C_block_header(x) == C_RATNUM_TAG) { 8659 if (y & C_FIXNUM_BIT) { 8772 8773 case C_RATNUM_TYPE_HASH: 8774 switch(C_type_hash(y)) { 8775 case C_FIXNUM_TYPE_HASH: 8660 8776 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus); 8661 } else if (C_immediatep(y)) { 8662 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); 8663 } else if (C_block_header(y) == C_FLONUM_TAG) { 8777 8778 case C_FLONUM_TYPE_HASH: 8664 8779 return C_s_a_i_minus(ptr, 2, C_a_i_exact_to_inexact(ptr, 1, x), y); 8665 } else if (C_truep(C_bignump(y))) { 8780 8781 case C_BIGNUM_TYPE_HASH: 8666 8782 return rat_plusmin_integer(ptr, x, y, C_s_a_u_i_integer_minus); 8667 } else if (C_block_header(y) == C_RATNUM_TAG) { 8783 8784 case C_RATNUM_TYPE_HASH: 8668 8785 return rat_plusmin_rat(ptr, x, y, C_s_a_u_i_integer_minus); 8669 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 8786 8787 case C_CPLXNUM_TYPE_HASH: 8788 { 8670 8789 C_word real_diff = C_s_a_i_minus(ptr, 2, x, C_u_i_cplxnum_real(y)), 8671 8790 imag = C_s_a_i_negate(ptr, 1, C_u_i_cplxnum_imag(y)); 8672 8791 if (C_truep(C_u_i_inexactp(real_diff))) 8673 8792 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8674 8793 return C_cplxnum(ptr, real_diff, imag); 8675 } else { 8794 } 8795 8796 default: 8676 8797 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y); 8677 8798 } 8678 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 8799 8800 case C_CPLXNUM_TYPE_HASH: 8679 8801 if (!C_immediatep(y) && C_block_header(y) == C_CPLXNUM_TAG) { 8680 8802 C_word real_diff, imag_diff; 8681 8803 real_diff = C_s_a_i_minus(ptr,2,C_u_i_cplxnum_real(x),C_u_i_cplxnum_real(y)); … … C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y) 8689 8811 imag = C_a_i_exact_to_inexact(ptr, 1, imag); 8690 8812 return C_cplxnum(ptr, real_diff, imag); 8691 8813 } 8692 } else { 8814 8815 default: 8693 8816 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", x); 8694 8817 } 8695 8818 } … … static C_word flo_rat_cmp(C_word flonum, C_word ratnum) 9599 9722 */ 9600 9723 static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp) 9601 9724 { 9602 if (x & C_FIXNUM_BIT) { 9603 if (y & C_FIXNUM_BIT) { 9725 switch(C_type_hash(x)) { /* TODO: Use dyadic_hash? */ 9726 case C_FIXNUM_TYPE_HASH: 9727 switch(C_type_hash(y)) { 9728 case C_FIXNUM_TYPE_HASH: 9604 9729 return C_fix((x < y) ? -1 : ((x > y) ? 1 : 0)); 9605 } else if (C_immediatep(y)) { 9606 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); 9607 } else if (C_block_header(y) == C_FLONUM_TAG) { 9730 9731 case C_FLONUM_TYPE_HASH: 9608 9732 return int_flo_cmp(x, y); 9609 } else if (C_truep(C_bignump(y))) { 9733 9734 case C_BIGNUM_TYPE_HASH: 9735 { 9610 9736 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab; 9611 9737 return C_i_bignum_cmp(C_a_u_i_fix_to_big(&a, x), y); 9612 } else if (C_block_header(y) == C_RATNUM_TAG) { 9738 } 9739 9740 case C_RATNUM_TYPE_HASH: 9613 9741 if (eqp) return C_SCHEME_FALSE; 9614 9742 else return rat_cmp(x, y); 9615 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 9743 9744 case C_CPLXNUM_TYPE_HASH: 9616 9745 if (eqp) return C_SCHEME_FALSE; 9617 9746 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); 9618 } else { 9747 9748 default: 9619 9749 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); 9620 9750 } 9621 } else if (C_immediatep(x)) { 9622 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);9623 } else if (C_block_header(x) == C_FLONUM_TAG) {9624 if (y & C_FIXNUM_BIT) {9751 9752 case C_FLONUM_TYPE_HASH: 9753 switch(C_type_hash(y)) { 9754 case C_FIXNUM_TYPE_HASH: 9625 9755 return flo_int_cmp(x, y); 9626 } else if (C_immediatep(y)) { 9627 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);9628 } else if (C_block_header(y) == C_FLONUM_TAG){9756 9757 case C_FLONUM_TYPE_HASH: 9758 { 9629 9759 double a = C_flonum_magnitude(x), b = C_flonum_magnitude(y); 9630 9760 if (C_isnan(a) || C_isnan(b)) return C_SCHEME_FALSE; /* "mu" */ 9631 9761 else return C_fix((a < b) ? -1 : ((a > b) ? 1 : 0)); 9632 } else if (C_truep(C_bignump(y))) { 9762 } 9763 9764 case C_BIGNUM_TYPE_HASH: 9633 9765 return flo_int_cmp(x, y); 9634 } else if (C_block_header(y) == C_RATNUM_TAG) { 9766 9767 case C_RATNUM_TYPE_HASH: 9635 9768 return flo_rat_cmp(x, y); 9636 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 9769 9770 case C_CPLXNUM_TYPE_HASH: 9637 9771 if (eqp) return C_SCHEME_FALSE; 9638 9772 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); 9639 } else { 9773 9774 default: 9640 9775 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); 9641 9776 } 9642 } else if (C_truep(C_bignump(x))) { 9643 if (y & C_FIXNUM_BIT) { 9777 9778 case C_BIGNUM_TYPE_HASH: 9779 switch(C_type_hash(y)) { 9780 case C_FIXNUM_TYPE_HASH: 9781 { 9644 9782 C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab; 9645 9783 return C_i_bignum_cmp(x, C_a_u_i_fix_to_big(&a, y)); 9646 } else if (C_immediatep(y)) {9647 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); 9648 } else if (C_block_header(y) == C_FLONUM_TAG) {9784 } 9785 9786 case C_FLONUM_TYPE_HASH: 9649 9787 return int_flo_cmp(x, y); 9650 } else if (C_truep(C_bignump(y))) { 9788 9789 case C_BIGNUM_TYPE_HASH: 9651 9790 return C_i_bignum_cmp(x, y); 9652 } else if (C_block_header(y) == C_RATNUM_TAG) { 9791 9792 case C_RATNUM_TYPE_HASH: 9653 9793 if (eqp) return C_SCHEME_FALSE; 9654 9794 else return rat_cmp(x, y); 9655 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 9795 9796 case C_CPLXNUM_TYPE_HASH: 9656 9797 if (eqp) return C_SCHEME_FALSE; 9657 9798 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); 9658 } else { 9799 9800 default: 9659 9801 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); 9660 9802 } 9661 } else if (C_block_header(x) == C_RATNUM_TAG) { 9662 if (y & C_FIXNUM_BIT) { 9803 9804 case C_RATNUM_TYPE_HASH: 9805 switch(C_type_hash(y)) { 9806 case C_FIXNUM_TYPE_HASH: 9663 9807 if (eqp) return C_SCHEME_FALSE; 9664 9808 else return rat_cmp(x, y); 9665 } else if (C_immediatep(y)) { 9666 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); 9667 } else if (C_block_header(y) == C_FLONUM_TAG) { 9809 9810 case C_FLONUM_TYPE_HASH: 9668 9811 return rat_flo_cmp(x, y); 9669 } else if (C_truep(C_bignump(y))) { 9812 9813 case C_BIGNUM_TYPE_HASH: 9670 9814 if (eqp) return C_SCHEME_FALSE; 9671 9815 else return rat_cmp(x, y); 9672 } else if (C_block_header(y) == C_RATNUM_TAG) { 9816 9817 case C_RATNUM_TYPE_HASH: 9673 9818 if (eqp) { 9674 9819 return C_and(C_and(C_i_integer_equalp(C_u_i_ratnum_num(x), 9675 9820 C_u_i_ratnum_num(y)), … … static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp) 9679 9824 } else { 9680 9825 return rat_cmp(x, y); 9681 9826 } 9682 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 9827 9828 case C_CPLXNUM_TYPE_HASH: 9683 9829 if (eqp) return C_SCHEME_FALSE; 9684 9830 else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y); 9685 } else { 9831 9832 default: 9686 9833 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); 9687 9834 } 9688 } else if (C_block_header(x) == C_CPLXNUM_TAG) { 9689 if (!eqp) { 9835 9836 case C_CPLXNUM_TYPE_HASH: 9837 if (!eqp) 9690 9838 barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, x); 9691 } else if (y & C_FIXNUM_BIT) { 9692 return C_SCHEME_FALSE; 9693 } else if (C_immediatep(y)) { 9694 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); 9695 } else if (C_block_header(y) == C_FLONUM_TAG || 9696 C_truep(C_bignump(x)) || 9697 C_block_header(y) == C_RATNUM_TAG) { 9839 9840 switch(C_type_hash(y)) { 9841 case C_FIXNUM_TYPE_HASH: 9842 case C_FLONUM_TYPE_HASH: 9843 case C_BIGNUM_TYPE_HASH: 9844 case C_RATNUM_TYPE_HASH: 9698 9845 return C_SCHEME_FALSE; 9699 } else if (C_block_header(y) == C_CPLXNUM_TAG) { 9846 9847 case C_CPLXNUM_TYPE_HASH: 9700 9848 return C_and(C_and(C_i_nequalp(C_u_i_cplxnum_real(x), C_u_i_cplxnum_real(y)), 9701 9849 C_i_nequalp(C_u_i_cplxnum_imag(x), C_u_i_cplxnum_imag(y))), 9702 9850 C_fix(0)); 9703 } else { 9851 9852 default: 9704 9853 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y); 9705 9854 } 9706 } else { 9855 9856 default: 9707 9857 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x); 9708 9858 } 9709 9859 } … … void C_ccall C_string_to_keyword(C_word c, C_word *av) 10582 10732 C_regparm C_word C_fcall 10583 10733 C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n) 10584 10734 { 10585 if (n & C_FIXNUM_BIT) { 10735 switch(C_type_hash(n)) { 10736 case C_FIXNUM_TYPE_HASH: 10586 10737 return C_flonum(ptr, (double)C_unfix(n)); 10587 } else if (C_immediatep(n)) { 10588 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n); 10589 } else if (C_block_header(n) == C_FLONUM_TAG) { 10738 10739 case C_FLONUM_TYPE_HASH: 10590 10740 return n; 10591 } else if (C_truep(C_bignump(n))) { 10741 10742 case C_BIGNUM_TYPE_HASH: 10592 10743 return C_a_u_i_big_to_flo(ptr, c, n); 10593 } else if (C_block_header(n) == C_CPLXNUM_TAG) { 10744 10745 case C_CPLXNUM_TYPE_HASH: 10594 10746 return C_cplxnum(ptr, C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_real(n)), 10595 10747 C_a_i_exact_to_inexact(ptr, 1, C_u_i_cplxnum_imag(n))); 10748 10596 10749 /* The horribly painful case: ratnums */ 10597 } else if (C_block_header(n) == C_RATNUM_TAG) { 10750 case C_RATNUM_TYPE_HASH: 10751 { 10598 10752 /* This tries to keep the numbers within representable ranges and 10599 10753 * tries to drop as few significant digits as possible by bringing 10600 10754 * the two numbers to within the same powers of two. See … … C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n) 10666 10820 shift_amount = nmin(DBL_MANT_DIG-1, e - (DBL_MIN_EXP - DBL_MANT_DIG)); 10667 10821 res = ldexp(fraction, e - shift_amount); 10668 10822 return C_flonum(ptr, C_truep(negp) ? -res : res); 10669 } else { 10823 } 10824 10825 default: 10670 10826 barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact->inexact", n); 10671 10827 } 10672 10828 } … … static char *to_n_nary(C_uword num, C_uword base, int negp, int as_flonum) 11009 11165 void C_ccall C_number_to_string(C_word c, C_word *av) 11010 11166 { 11011 11167 C_word radix, num; 11168 C_word k = av[ 1 ]; 11012 11169 11013 11170 if(c == 3) { 11014 11171 radix = C_fix(10); … … void C_ccall C_number_to_string(C_word c, C_word *av) 11022 11179 11023 11180 num = av[ 2 ]; 11024 11181 11025 if(num & C_FIXNUM_BIT) { 11182 switch(C_type_hash(num)) { 11183 case C_FIXNUM_TYPE_HASH: 11026 11184 C_fixnum_to_string(c, av); /* reuse av */ 11027 } else if (C_immediatep(num)) { 11028 barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num); 11029 } else if(C_block_header(num) == C_FLONUM_TAG) { 11185 11186 case C_FLONUM_TYPE_HASH: 11030 11187 C_flonum_to_string(c, av); /* reuse av */ 11031 } else if (C_truep(C_bignump(num))) { 11188 11189 case C_BIGNUM_TYPE_HASH: 11032 11190 C_integer_to_string(c, av); /* reuse av */ 11033 } else { 11034 C_word k = av[ 1 ]; 11191 11192 case C_RATNUM_TYPE_HASH: 11193 case C_CPLXNUM_TYPE_HASH: 11035 11194 try_extended_number("##sys#extended-number->string", 3, k, num, radix); 11195 11196 default: 11197 barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num); 11036 11198 } 11037 11199 } 11038 11200