Changeset 32040 in project


Ignore:
Timestamp:
12/18/14 22:20:11 (6 years ago)
Author:
sjamaan
Message:

numbers: Create a hairy "compare" primitive, so we can simplify everything else and make comparisons inlinable!

Location:
release/4/numbers/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/numbers/trunk/numbers-c.c

    r32002 r32040  
    6262static C_word init_tags(___scheme_value tagvec);
    6363static void bignum_negate_2(C_word c, C_word self, C_word new_big) C_noret;
     64static C_word rat_cmp(C_word x, C_word y);
     65static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp);
    6466static void allocate_bignum_2(C_word c, C_word self, C_word bigvec) C_noret;
    6567static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp);
     
    110112static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...) C_noret;
    111113
    112 #define C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR                48
     114/* Use high numbers for when CHICKEN 4 grows more error codes! */
     115#define C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR                99948
     116#define C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR    99949
    113117
    114118/* XXX THIS IS DUPLICATED HERE FROM runtime.c, but should be ripped out */
     
    121125  C_word err, ab[C_SIZEOF_STRING(64)], *a = ab;
    122126
    123   err = C_lookup_symbol(C_intern2(&a, C_text("\003syserror-hook")));
     127  err = C_lookup_symbol(C_intern2(&a, C_text("numbers#@error-hook")));
    124128
    125129  switch(code) {
     
    186190  case C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR:
    187191    msg = C_text("bad argument type - not a real");
     192    c = 1;
     193    break;
     194
     195  case C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR:
     196    msg = C_text("bad argument type - complex number has no ordering");
    188197    c = 1;
    189198    break;
     
    10671076}
    10681077
    1069 /* TODO: Once these are inlineable, rewrite them in terms of a
    1070  * common C_2_basic_cmp which returns -1, 0, or 1.  This should
    1071  * reduce the amount of needed code quite a bit, and would allow
    1072  * easier implementation of lessp, greaterp, and also the set
    1073  * {greater_or_|less_or_}?equalp, as inline loops without any
    1074  * conversion to a vararg list in Scheme!
     1078/* Compare two numbers as ratnums.  Either may be rat-, fix- or bignums */
     1079static C_word rat_cmp(C_word x, C_word y)
     1080{
     1081  C_word ab[C_SIZEOF_FIX_BIGNUM*4], *a = ab, x1, x2, y1, y2,
     1082         s, t, ssize, tsize, result, negp;
     1083  C_uword *scan;
     1084
     1085  /* Check for 1 or 0; if x or y is this, the other must be the ratnum */
     1086  if (x == C_fix(0)) {        /* Only the sign of y1 matters */
     1087    return basic_cmp(x, C_block_item(y, 1), "ratcmp", 0);
     1088  } else if (x == C_fix(1)) { /* x1*y1 <> x2*y2 --> y2 <> y1 | x1/x2 = 1/1 */
     1089    return basic_cmp(C_block_item(y, 2), C_block_item(y, 1), "ratcmp", 0);
     1090  } else if (y == C_fix(0)) { /* Only the sign of x1 matters */
     1091    return basic_cmp(C_block_item(x, 1), y, "ratcmp", 0);
     1092  } else if (y == C_fix(1)) { /* x1*y1 <> x2*y2 --> x1 <> x2 | y1/y2 = 1/1 */
     1093    return basic_cmp(C_block_item(x, 1), C_block_item(x, 2), "ratcmp", 0);
     1094  }
     1095
     1096  /* Extract components x=x1/x2 and y=y1/y2 */
     1097  if (x & C_FIXNUM_BIT || C_IS_BIGNUM_TYPE(x)) x1 = x, x2 = C_fix(1);
     1098  else x1 = C_block_item(x, 1), x2 = C_block_item(x, 2);
     1099
     1100  if (y & C_FIXNUM_BIT || C_IS_BIGNUM_TYPE(y)) y1 = y, y2 = C_fix(1);
     1101  else y1 = C_block_item(y, 1), y2 = C_block_item(y, 2);
     1102
     1103  /* We only want to deal with bignums (this is tricky enough) */
     1104  if (x1 & C_FIXNUM_BIT) x1 = C_a_u_i_fix_to_big(&a, x1);
     1105  if (x2 & C_FIXNUM_BIT) x2 = C_a_u_i_fix_to_big(&a, x2);
     1106  if (y1 & C_FIXNUM_BIT) y1 = C_a_u_i_fix_to_big(&a, y1);
     1107  if (y2 & C_FIXNUM_BIT) y2 = C_a_u_i_fix_to_big(&a, y2);
     1108
     1109  /* We multiply using schoolbook method, so this will be very slow in
     1110   * extreme cases.  This is a tradeoff we make so that comparisons
     1111   * are inlineable, which makes a big difference for the common case.
     1112   */
     1113  ssize = C_fix(C_bignum_size(x1) + C_bignum_size(y2));
     1114  negp = C_u_i_bignum_negativep(x1);
     1115  s = allocate_tmp_bignum(C_fix(ssize), negp, C_SCHEME_TRUE);
     1116  bignum_digits_multiply(x1, y2, s); /* Swap args if x1 < y2? */
     1117
     1118  tsize = C_fix(C_bignum_size(y1) + C_bignum_size(x2));
     1119  negp = C_u_i_bignum_negativep(y1);
     1120  t = allocate_tmp_bignum(C_fix(tsize), negp, C_SCHEME_TRUE);
     1121  bignum_digits_multiply(y1, x2, t); /* Swap args if y1 < x2? */
     1122
     1123  /* Shorten the numbers if needed */
     1124  for (scan = C_bignum_digits(s)+ssize-1; *scan == 0; scan--) ssize--;
     1125  C_bignum_mutate_size(s, ssize);
     1126  for (scan = C_bignum_digits(t)+tsize-1; *scan == 0; scan--) tsize--;
     1127  C_bignum_mutate_size(t, tsize);
     1128
     1129  result = C_u_i_bignum_cmp(s, t);
     1130
     1131  free_tmp_bignum(t);
     1132  free_tmp_bignum(s);
     1133  return result;
     1134}
     1135
     1136/* The primitive comparison operator.  eqp should be 1 if we're only
     1137 * interested in equality testing (can speed things up and in case of
     1138 * compnums, equality checking is the only available operation).
    10751139 */
    1076 C_regparm C_word C_fcall
    1077 C_i_2_basic_equalp(C_word x, C_word y)
     1140static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)
    10781141{
    10791142  if (x & C_FIXNUM_BIT) {
    10801143    if (y & C_FIXNUM_BIT) {
    1081       return C_mk_bool(x == y);
     1144      return C_fix((x < y) ? -1 : ((x > y) ? 1 : 0));
    10821145    } else if (C_immediatep(y)) {
    1083       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
     1146      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
    10841147    } else if (C_block_header(y) == C_FLONUM_TAG) {
    1085       return C_mk_bool(int_flo_cmp(x, y) == C_fix(0));
    1086     } else if (C_IS_BIGNUM_TYPE(y) ||
    1087                (C_header_bits(y) == C_STRUCTURE_TYPE &&
    1088                 (C_block_item(y, 0) == ratnum_type_tag ||
    1089                  C_block_item(y, 0) == compnum_type_tag))) {
    1090       return C_SCHEME_FALSE;
    1091     } else {
    1092       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
     1148      return int_flo_cmp(x, y);
     1149    } else if (C_IS_BIGNUM_TYPE(y)) {
     1150      C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
     1151      return C_u_i_bignum_cmp(C_a_u_i_fix_to_big(&a, x), y);
     1152    } else if (C_header_bits(y) == C_STRUCTURE_TYPE &&
     1153               C_block_item(y, 0) == ratnum_type_tag) {
     1154      if (eqp) return C_SCHEME_FALSE;
     1155      else return rat_cmp(x, y);
     1156    } else if (C_block_item(y, 0) == compnum_type_tag) {
     1157      if (eqp) return C_SCHEME_FALSE;
     1158      else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);
     1159    } else {
     1160      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
    10931161    }
    10941162  } else if (C_immediatep(x)) {
    1095     barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", x);
     1163    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);
    10961164  } else if (C_block_header(x) == C_FLONUM_TAG) {
    10971165    if (y & C_FIXNUM_BIT) {
    1098       return C_mk_bool(flo_int_cmp(x, y) == C_fix(0));
     1166      return flo_int_cmp(x, y);
    10991167    } else if (C_immediatep(y)) {
    1100       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
     1168      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
    11011169    } else if (C_block_header(y) == C_FLONUM_TAG) {
    1102       return C_flonum_equalp(x, y);
     1170      double a = C_flonum_magnitude(x), b = C_flonum_magnitude(y);
     1171      if (C_isnan(a) || C_isnan(b)) return C_SCHEME_FALSE;
     1172      else return C_fix((a < b) ? -1 : ((a > b) ? 1 : 0));
    11031173    } else if (C_IS_BIGNUM_TYPE(y)) {
    1104       return C_mk_bool(flo_int_cmp(x, y) == C_fix(0));
     1174      return flo_int_cmp(x, y);
    11051175    } else if (C_header_bits(y) == C_STRUCTURE_TYPE) {
    11061176      if (C_block_item(y, 0) == ratnum_type_tag) {
    1107         return C_mk_bool(flo_rat_cmp(x, y) == C_fix(0));
     1177        return flo_rat_cmp(x, y);
    11081178      } else if (C_block_item(y, 0) == compnum_type_tag) {
    1109         return C_SCHEME_FALSE;
     1179        if (eqp) return C_SCHEME_FALSE;
     1180        else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);
    11101181      } else {
    1111         barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
     1182        barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
    11121183      }
    11131184    } else {
    1114       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
     1185      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
    11151186    }
    11161187  } else if (C_IS_BIGNUM_TYPE(x)) {
    11171188    if (y & C_FIXNUM_BIT) {
    1118       return C_SCHEME_FALSE;
     1189      C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
     1190      return C_u_i_bignum_cmp(x, C_a_u_i_fix_to_big(&a, y));
    11191191    } else if (C_immediatep(y)) {
    1120       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
     1192      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
    11211193    } else if (C_block_header(y) == C_FLONUM_TAG) {
    1122       return C_mk_bool(int_flo_cmp(x, y) == C_fix(0));
     1194      return int_flo_cmp(x, y);
    11231195    } else if (C_IS_BIGNUM_TYPE(y)) {
    1124       return C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(0));
     1196      return C_u_i_bignum_cmp(x, y);
    11251197    } else if (C_header_bits(y) == C_STRUCTURE_TYPE &&
    1126                (C_block_item(y, 0) == ratnum_type_tag ||
    1127                 C_block_item(y, 0) == compnum_type_tag)) {
    1128       return C_SCHEME_FALSE;
    1129     } else {
    1130       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
     1198               C_block_item(y, 0) == ratnum_type_tag) {
     1199      if (eqp) return C_SCHEME_FALSE;
     1200      else return rat_cmp(x, y);
     1201    } else if (C_block_item(y, 0) == compnum_type_tag) {
     1202      if (eqp) return C_SCHEME_FALSE;
     1203      else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);
     1204    } else {
     1205      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
    11311206    }
    11321207  } else if (C_header_bits(x) == C_STRUCTURE_TYPE &&
    11331208             (C_block_item(x, 0) == ratnum_type_tag)) {
    11341209    if (y & C_FIXNUM_BIT) {
     1210      if (eqp) return C_SCHEME_FALSE;
     1211      else return rat_cmp(x, y);
     1212    } else if (C_immediatep(y)) {
     1213      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
     1214    } else if (C_block_header(y) == C_FLONUM_TAG) {
     1215      return rat_flo_cmp(x, y);
     1216    } else if (C_IS_BIGNUM_TYPE(y)) {
     1217      if (eqp) return C_SCHEME_FALSE;
     1218      else return rat_cmp(x, y);
     1219    } else if (C_header_bits(y) == C_STRUCTURE_TYPE &&
     1220               (C_block_item(y, 0) == ratnum_type_tag)) {
     1221      if (eqp) {
     1222        return C_and(C_and(C_u_i_2_integer_equalp(C_block_item(x, 1),
     1223                                                  C_block_item(y, 1)),
     1224                           C_u_i_2_integer_equalp(C_block_item(x, 2),
     1225                                                  C_block_item(y, 2))),
     1226                     C_fix(0));
     1227      } else {
     1228        return rat_cmp(x, y);
     1229      }
     1230    } else if (C_header_bits(y) == C_STRUCTURE_TYPE &&
     1231               (C_block_item(y, 0) == compnum_type_tag)) {
     1232      if (eqp) return C_SCHEME_FALSE;
     1233      else barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, y);
     1234    } else {
     1235      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
     1236    }
     1237  } else if (C_header_bits(x) == C_STRUCTURE_TYPE &&
     1238             (C_block_item(x, 0) == compnum_type_tag)) {
     1239    if (!eqp) {
     1240      barf(C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR, loc, x);
     1241    } else if (y & C_FIXNUM_BIT) {
    11351242      return C_SCHEME_FALSE;
    11361243    } else if (C_immediatep(y)) {
    1137       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
    1138     } else if (C_block_header(y) == C_FLONUM_TAG) {
    1139       return C_mk_bool(rat_flo_cmp(x, y) == C_fix(0));
    1140     } else if (C_IS_BIGNUM_TYPE(y)) {
    1141       return C_SCHEME_FALSE;
    1142     } else if (C_header_bits(y) == C_STRUCTURE_TYPE &&
    1143                (C_block_item(y, 0) == ratnum_type_tag)) {
    1144       return C_and(C_u_i_2_integer_equalp(C_block_item(x, 1),
    1145                                           C_block_item(y, 1)),
    1146                    C_u_i_2_integer_equalp(C_block_item(x, 2),
    1147                                           C_block_item(y, 2)));
    1148     } else if (C_header_bits(y) == C_STRUCTURE_TYPE &&
    1149                (C_block_item(y, 0) == compnum_type_tag)) {
    1150       return C_SCHEME_FALSE;
    1151     } else {
    1152       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
    1153     }
    1154   } else if (C_header_bits(x) == C_STRUCTURE_TYPE &&
    1155              (C_block_item(x, 0) == compnum_type_tag)) {
    1156     if (y & C_FIXNUM_BIT) {
    1157       return C_SCHEME_FALSE;
    1158     } else if (C_immediatep(y)) {
    1159       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
     1244      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
    11601245    } else if (C_block_header(y) == C_FLONUM_TAG ||
    11611246               C_IS_BIGNUM_TYPE(y) ||
     
    11651250    } else if (C_header_bits(y) == C_STRUCTURE_TYPE &&
    11661251               (C_block_item(y, 0) == compnum_type_tag)) {
    1167       return C_and(C_i_2_basic_equalp(C_block_item(x, 1),
    1168                                       C_block_item(y, 1)),
    1169                    C_i_2_basic_equalp(C_block_item(x, 2),
    1170                                       C_block_item(y, 2)));
    1171     } else {
    1172       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", y);
    1173     }
    1174   } else {
    1175     barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "=", x);
    1176   }
    1177 }
    1178 
    1179 C_word C_ccall
    1180 C_u_i_2_integer_equalp(C_word x, C_word y)
     1252      return C_and(C_and(C_i_2_basic_equalp(C_block_item(x, 1),
     1253                                            C_block_item(y, 1)),
     1254                         C_i_2_basic_equalp(C_block_item(x, 2),
     1255                                            C_block_item(y, 2))),
     1256                   C_fix(0));
     1257    } else {
     1258      barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
     1259    }
     1260  } else {
     1261    barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, x);
     1262  }
     1263}
     1264
     1265/* TODO: Implement vararg versions of these */
     1266C_regparm C_word C_fcall
     1267C_i_2_basic_equalp(C_word x, C_word y)
     1268{
     1269   return C_mk_bool(basic_cmp(x, y, "=", 1) == C_fix(0));
     1270}
     1271
     1272C_word C_ccall C_u_i_2_integer_equalp(C_word x, C_word y)
    11811273{
    11821274  if (x & C_FIXNUM_BIT)
     
    11881280}
    11891281
    1190 void C_ccall
    1191 C_2_basic_lessp(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
    1192 {
    1193   C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
    1194 
    1195   if (x & C_FIXNUM_BIT) {
    1196     if (y & C_FIXNUM_BIT) {
    1197       C_kontinue(k, C_mk_bool(C_unfix(x) < C_unfix(y)));
    1198     } else if (C_immediatep(y)) {
    1199       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
    1200     } else if (C_block_header(y) == C_FLONUM_TAG) {
    1201       C_kontinue(k, C_mk_bool(int_flo_cmp(x, y) == C_fix(-1)));
    1202     } else if (C_IS_BIGNUM_TYPE(y)) {
    1203       /* A fixnum can only be smaller than a positive bignum */
    1204       C_kontinue(k, C_mk_nbool(C_bignum_negativep(y)));
    1205     } else {
    1206       try_extended_number("numbers#@extended-2-<", 4, k, loc, x, y);
    1207     }
    1208   } else if (C_immediatep(x)) {
    1209     barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), x);
    1210   } else if (C_block_header(x) == C_FLONUM_TAG) {
    1211     if (y & C_FIXNUM_BIT) {
    1212       C_kontinue(k, C_mk_bool(flo_int_cmp(x, y) == C_fix(-1)));
    1213     } else if (C_immediatep(y)) {
    1214        barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
    1215     } else if (C_block_header(y) == C_FLONUM_TAG) {
    1216       C_kontinue(k, C_flonum_lessp(x, y));
    1217     } else if (C_IS_BIGNUM_TYPE(y)) {
    1218       C_kontinue(k, C_mk_bool(flo_int_cmp(x, y) == C_fix(-1)));
    1219     } else {
    1220       try_extended_number("numbers#@extended-2-<", 4, k, loc, x, y);
    1221     }
    1222   } else if (C_IS_BIGNUM_TYPE(x)) {
    1223     if (y & C_FIXNUM_BIT) {
    1224       /* Only a negative bignum is smaller than any fixnum */
    1225       C_kontinue(k, C_mk_bool(C_bignum_negativep(x)));
    1226     } else if (C_immediatep(y)) {
    1227        barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
    1228     } else if (C_block_header(y) == C_FLONUM_TAG) {
    1229       C_kontinue(k, C_mk_bool(int_flo_cmp(x, y) == C_fix(-1)));
    1230     } else if (C_IS_BIGNUM_TYPE(y)) {
    1231       C_kontinue(k, C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(-1)));
    1232     } else {
    1233       try_extended_number("numbers#@extended-2-<", 4, k, loc, x, y);
    1234     }
    1235   } else {
    1236     try_extended_number("numbers#@extended-2-<", 4, k, loc, x, y);
    1237   }
     1282C_regparm C_word C_fcall C_i_2_basic_lessp(C_word x, C_word y)
     1283{
     1284   return C_mk_bool(basic_cmp(x, y, "<", 0) == C_fix(-1));
    12381285}
    12391286
     
    12541301}
    12551302
    1256 void C_ccall
    1257 C_2_basic_greaterp(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
    1258 {
    1259   C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
    1260 
    1261   if (x & C_FIXNUM_BIT) {
    1262     if (y & C_FIXNUM_BIT) {
    1263       C_kontinue(k, C_mk_bool(C_unfix(x) > C_unfix(y)));
    1264     } else if (C_immediatep(y)) {
    1265       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
    1266     } else if (C_block_header(y) == C_FLONUM_TAG) {
    1267       C_kontinue(k, C_mk_bool(int_flo_cmp(x, y) == C_fix(1)));
    1268     } else if (C_IS_BIGNUM_TYPE(y)) {
    1269       /* A fixnum can only be larger than a negative bignum */
    1270       C_kontinue(k, C_mk_bool(C_bignum_negativep(y)));
    1271     } else {
    1272       try_extended_number("numbers#@extended-2->", 4, k, loc, x, y);
    1273     }
    1274   } else if (C_immediatep(x)) {
    1275     barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), x);
    1276   } else if (C_block_header(x) == C_FLONUM_TAG) {
    1277     if (y & C_FIXNUM_BIT) {
    1278       C_kontinue(k, C_mk_bool(flo_int_cmp(x, y) == C_fix(1)));
    1279     } else if (C_immediatep(y)) {
    1280       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
    1281     } else if (C_block_header(y) == C_FLONUM_TAG) {
    1282       C_kontinue(k, C_flonum_greaterp(x, y));
    1283     } else if (C_IS_BIGNUM_TYPE(y)) {
    1284       C_kontinue(k, C_mk_bool(flo_int_cmp(x, y) == C_fix(1)));
    1285     } else {
    1286       try_extended_number("numbers#@extended-2->", 4, k, loc, x, y);
    1287     }
    1288   } else if (C_IS_BIGNUM_TYPE(x)) {
    1289     if (y & C_FIXNUM_BIT) {
    1290       /* Only a positive bignum is greater than any fixnum */
    1291       C_kontinue(k, C_mk_nbool(C_bignum_negativep(x)));
    1292     } else if (C_immediatep(y)) {
    1293       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, C_strloc(loc), y);
    1294     } else if (C_block_header(y) == C_FLONUM_TAG) {
    1295       C_kontinue(k, C_mk_bool(int_flo_cmp(x, y) == C_fix(1)));
    1296     } else if (C_IS_BIGNUM_TYPE(y)) {
    1297       C_kontinue(k, C_mk_bool(C_u_i_bignum_cmp(x, y) == C_fix(1)));
    1298     } else {
    1299       try_extended_number("numbers#@extended-2->", 4, k, loc, x, y);
    1300     }
    1301   } else {
    1302       try_extended_number("numbers#@extended-2->", 4, k, loc, x, y);
    1303   }
     1303C_regparm C_word C_fcall C_i_2_basic_greaterp(C_word x, C_word y)
     1304{
     1305   return C_mk_bool(basic_cmp(x, y, ">", 0) == C_fix(1));
    13041306}
    13051307
     
    29392941      if (!C_truep(C_u_i_fpintegerp(y))) {
    29402942        barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, C_strloc(loc), y);
     2943      } else if (C_flonum_magnitude(y) == 0.0) {
     2944        C_div_by_zero_error(C_strloc(loc));
    29412945      } else {
    29422946        y = flo_to_tmp_bignum(y);
  • release/4/numbers/trunk/numbers-c.h

    r31987 r32040  
    159159C_regparm C_word C_fcall C_i_2_basic_equalp(C_word x, C_word y);
    160160C_word C_ccall C_u_i_2_integer_equalp(C_word x, C_word y);
    161 void C_ccall C_2_basic_lessp(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y);
     161C_regparm C_word C_fcall C_i_2_basic_lessp(C_word x, C_word y);
    162162C_word C_ccall C_u_i_2_integer_lessp(C_word x, C_word y);
    163 void C_ccall C_2_basic_greaterp(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y);
     163C_regparm C_word C_fcall C_i_2_basic_greaterp(C_word x, C_word y);
    164164C_word C_ccall C_u_i_2_integer_greaterp(C_word x, C_word y);
    165165
  • release/4/numbers/trunk/numbers.scm

    r32001 r32040  
    8787       ;; These must stay exported because they're called as hooks from C.
    8888       ;; We might later use them in the types db, but it won't help much?
    89        @extended-2-> @extended-2-<
    9089       @extended-2-plus @extended-2-minus @extended-2-times
    9190       @bignum-2-times-karatsuba @bignum-2-divrem-burnikel-ziegler
    9291       @extended-abs @extended-signum @extended-negate
    93        @integer->string/recursive @extended-number->string)
     92       @integer->string/recursive @extended-number->string
     93       @error-hook)
    9494
    9595  (import (except scheme
     
    178178(define (@bignum-2-= a b) (##core#inline "C_u_i_2_bignum_equalp" a b))
    179179
    180 (define @basic-2-< (##core#primitive "C_2_basic_lessp"))
     180(define (@basic-2-< a b) (##core#inline "C_i_2_basic_lessp" a b))
    181181(define (@integer-2-< a b) (##core#inline "C_u_i_2_integer_lessp" a b))
    182182(define (@bignum-2-< a b) (##core#inline "C_u_i_2_bignum_lessp" a b))
    183183
    184 (define @basic-2-> (##core#primitive "C_2_basic_greaterp"))
     184(define (@basic-2-> a b) (##core#inline "C_i_2_basic_greaterp" a b))
    185185(define (@integer-2-> a b) (##core#inline "C_u_i_2_integer_greaterp" a b))
    186186(define (@bignum-2-> a b) (##core#inline "C_u_i_2_bignum_greaterp" a b))
     
    245245(define (div/0 loc x y) (##sys#signal-hook #:arithmetic-error loc "division by zero" x y))
    246246
     247;; Ugly override because we add our own codes
     248(define (@error-hook code loc . args)
     249  (case code
     250    ((99948) (bad-real loc (car args)))
     251    ((99949) (bad-complex/o loc (car args)))
     252    (else (apply ##sys#error-hook code loc args))))
     253
    247254(define-inline (%init-tags tagvec) (##core#inline "init_tags" tagvec))
    248255
     
    269276
    270277(##sys#gc #f)                           ; move tag-vector into 2nd generation
     278
     279
     280;;; Comparisons:
     281
     282(define-inline (%= a b) (##core#inline "C_i_2_basic_equalp" a b))
     283(define-inline (%> a b) (##core#inline "C_i_2_basic_greaterp" a b))
     284(define-inline (%< a b) (##core#inline "C_i_2_basic_lessp" a b))
     285
     286(define = (##core#primitive "C_numbers_nequalp"))
     287(define (eqv? a b) (##core#inline "C_i_numbers_eqvp" a b))
     288
     289;; TODO: Convert to primitive C loop, to avoid allocating rest lists
     290(define (> x1 x2 . xs)
     291  (and (%> x1 x2)
     292       (let loop ((x x2) (xs xs))
     293         (or (null? xs)
     294             (let ((h (##sys#slot xs 0)))
     295               (and (%> x h)
     296                    (loop h (##sys#slot xs 1)) ) ) ) ) ) )
     297
     298(define (< x1 x2 . xs)
     299  (and (%< x1 x2)
     300       (let loop ((x x2) (xs xs))
     301         (or (null? xs)
     302             (let ((h (##sys#slot xs 0)))
     303               (and (%< x h)
     304                    (loop h (##sys#slot xs 1)) ) ) ) ) ) )
     305
     306(define (>= x1 x2 . xs)
     307  ;; Could use nan? here, but that would give an error message with bad loc :(
     308  (and (or (not (##core#inline "C_i_flonump" x1))
     309           (not (##core#inline "C_u_i_flonum_nanp" x1)))
     310       (or (not (##core#inline "C_i_flonump" x2))
     311           (not (##core#inline "C_u_i_flonum_nanp" x2)))
     312       (not (%< x1 x2))
     313       (let loop ((x x2) (xs xs))
     314         (or (null? xs)
     315             (let ((h (##sys#slot xs 0)))
     316               (and (or (not (##core#inline "C_i_flonump" h))
     317                        (not (##core#inline "C_u_i_flonum_nanp" h)))
     318                    (not (%< x h))
     319                    (loop h (##sys#slot xs 1)) ) ) ) ) ) )
     320
     321(define (<= x1 x2 . xs)
     322  ;; Could use nan? here, but that would give an error message with bad loc :(
     323  (and (or (not (##core#inline "C_i_flonump" x1))
     324           (not (##core#inline "C_u_i_flonum_nanp" x1)))
     325       (or (not (##core#inline "C_i_flonump" x2))
     326           (not (##core#inline "C_u_i_flonum_nanp" x2)))
     327       (not (%> x1 x2))
     328       (let loop ((x x2) (xs xs))
     329         (or (null? xs)
     330             (let ((h (##sys#slot xs 0)))
     331               (and (or (not (##core#inline "C_i_flonump" h))
     332                        (not (##core#inline "C_u_i_flonum_nanp" h)))
     333                    (not (%> x h))
     334                    (loop h (##sys#slot xs 1)) ) ) ) ) ) )
    271335
    272336
     
    523587  (define (burnikel-ziegler-3n/2n a12 a3 b b1 b2 n)
    524588    (receive (q^ r1)
    525         (if (%< 'bz-3n/2n (arithmetic-shift a12 (fxneg (digit-bits n))) b1)
     589        (if (%< (arithmetic-shift a12 (fxneg (digit-bits n))) b1)
    526590            (let* ((n/2 (fxshr n 1))
    527591                   (b11 (%extract-digits b1 n/2 #f))
     
    594658
    595659
    596 ;;; Comparisons:
    597 
    598 (define (%= a b) (##core#inline "C_i_2_basic_equalp" a b))
    599 (define = (##core#primitive "C_numbers_nequalp"))
    600 (define (eqv? a b) (##core#inline "C_i_numbers_eqvp" a b))
    601 
    602 (define (@extended-2-> loc x y)
    603   (cond ((cplxnum? x) (bad-complex/o loc x))
    604         ((cplxnum? y) (bad-complex/o loc y))
    605         ((##core#inline "C_i_flonump" x)
    606          (or (fp= x +inf.0)
    607              (and (##core#inline "C_u_i_flonum_finitep" x)
    608                   (%> loc (%flo->rat loc x) y))))
    609         ((##core#inline "C_i_flonump" y)
    610          (or (fp= y -inf.0)
    611              (and (##core#inline "C_u_i_flonum_finitep" y)
    612                   (%> loc x (%flo->rat loc y)))))
    613         ((and (number? x) (number? y))  ; Compare as two ratnums
    614          ;; a/b > c/d  when  a*d > b*c  [generic]
    615          (%> loc
    616              (%* (numerator x) (denominator y))
    617              (%* (denominator x) (numerator y))))
    618         (else (bad-number loc x))))
    619 
    620 (define %> (##core#primitive "C_2_basic_greaterp"))
    621 
    622 (define (> x1 x2 . xs)
    623   (and (%> '> x1 x2)
    624        (let loop ((x x2) (xs xs))
    625          (or (null? xs)
    626              (let ((h (##sys#slot xs 0)))
    627                (and (%> '> x h)
    628                     (loop h (##sys#slot xs 1)) ) ) ) ) ) )
    629 
    630 
    631 (define (@extended-2-< loc x y)
    632   (cond ((cplxnum? x) (bad-complex/o loc x))
    633         ((cplxnum? y) (bad-complex/o loc y))
    634         ((##core#inline "C_i_flonump" x)
    635          (or (fp= x -inf.0)
    636              (and (##core#inline "C_u_i_flonum_finitep" x)
    637                   (%< loc (%flo->rat loc x) y))))
    638         ((##core#inline "C_i_flonump" y)
    639          (or (fp= y +inf.0)
    640              (and (##core#inline "C_u_i_flonum_finitep" y)
    641                   (%< loc x (%flo->rat loc y)))))
    642         ((and (number? x) (number? y))  ; Compare as two ratnums
    643          ;; a/b < c/d  when  a*d < b*c  [generic]
    644          (%< loc
    645              (%* (numerator x) (denominator y))
    646              (%* (denominator x) (numerator y))))
    647         (else (bad-number loc x))))
    648 
    649 (define %< (##core#primitive "C_2_basic_lessp"))
    650 
    651 (define (< x1 x2 . xs)
    652   (and (%< '< x1 x2)
    653        (let loop ((x x2) (xs xs))
    654          (or (null? xs)
    655              (let ((h (##sys#slot xs 0)))
    656                (and (%< '< x h)
    657                     (loop h (##sys#slot xs 1)) ) ) ) ) ) )
    658 
    659 (define (>= x1 x2 . xs)
    660   ;; Could use nan? here, but that would give an error message with bad loc :(
    661   (and (or (not (##core#inline "C_i_flonump" x1))
    662            (not (##core#inline "C_u_i_flonum_nanp" x1)))
    663        (or (not (##core#inline "C_i_flonump" x2))
    664            (not (##core#inline "C_u_i_flonum_nanp" x2)))
    665        (not (%< '>= x1 x2))
    666        (let loop ((x x2) (xs xs))
    667          (or (null? xs)
    668              (let ((h (##sys#slot xs 0)))
    669                (and (or (not (##core#inline "C_i_flonump" h))
    670                         (not (##core#inline "C_u_i_flonum_nanp" h)))
    671                     (not (%< '>= x h))
    672                     (loop h (##sys#slot xs 1)) ) ) ) ) ) )
    673 
    674 (define (<= x1 x2 . xs)
    675   ;; Could use nan? here, but that would give an error message with bad loc :(
    676   (and (or (not (##core#inline "C_i_flonump" x1))
    677            (not (##core#inline "C_u_i_flonum_nanp" x1)))
    678        (or (not (##core#inline "C_i_flonump" x2))
    679            (not (##core#inline "C_u_i_flonum_nanp" x2)))
    680        (not (%> '<= x1 x2))
    681        (let loop ((x x2) (xs xs))
    682          (or (null? xs)
    683              (let ((h (##sys#slot xs 0)))
    684                (and (or (not (##core#inline "C_i_flonump" h))
    685                         (not (##core#inline "C_u_i_flonum_nanp" h)))
    686                     (not (%> '<= x h))
    687                     (loop h (##sys#slot xs 1)) ) ) ) ) ) )
    688 
    689 
    690660;;; Complex numbers
    691661
     
    864834        (let ((h (##sys#slot xs 0)))
    865835          (loop (or i (##core#inline "C_i_flonump" h))
    866                 (if (%> 'max h m) h m)
     836                (if (%> h m) h m)
    867837                (##sys#slot xs 1)) ) ) )  )
    868838
     
    874844        (let ((h (##sys#slot xs 0)))
    875845          (loop (or i (##core#inline "C_i_flonump" h))
    876                 (if (%< 'min h m) h m)
     846                (if (%< h m) h m)
    877847                (##sys#slot xs 1)) ) ) )  )
    878848
     
    958928          (bad-inexact loc x))))
    959929
    960   (if (and (%< loc x 1.0)         ; watch out for denormalized numbers
    961            (%> loc x -1.0))
     930  (if (and (%< x 1.0)         ; watch out for denormalized numbers
     931           (%> x -1.0))
    962932      (deliver (%* x (expt 2.0 flonum-precision))
    963933               ;; Can be bignum (is on 32-bit), so must wait until after init.
     
    1021991                           (if (negative? n1) (%- 0 res) res)))))
    1022992                (scale (lambda (n d)  ; Here, 1/2 <= n/d < 2   [N3]
    1023                          (if (%< 'exact->inexact n d) ; n/d < 1?
     993                         (if (%< n d) ; n/d < 1?
    1024994                             ;; Scale left [N3]; only needed once (see note in M3)
    1025995                             (rnd (arithmetic-shift n 1) d (fx- e 1))
     
    10891059  ;; The complexity of the whole thing is supposedly O(n^2/log n)
    10901060  ;; where n is the number of bits in a and b.
    1091   (let* ((a (abs a)) (b (abs b))        ; Enforce loop invariant on input:
    1092          (swap? (%< 'gcd a b)))         ; both must be positive, and a >= b
     1061  (let* ((a (abs a)) (b (abs b))   ; Enforce loop invariant on input:
     1062         (swap? (%< a b)))         ; both must be positive, and a >= b
    10931063    (let lp ((a (if swap? b a))
    10941064             (b (if swap? a b)))
     
    11881158    (let ((fx (inexact->exact (floor x)))
    11891159          (fy (inexact->exact (floor y))))
    1190       (cond ((not (%< 'rationalize fx x)) (list fx 1))
     1160      (cond ((not (%< fx x)) (list fx 1))
    11911161            ((%= fx fy)
    11921162             (let ((rat (sr (%/ 1 (%- y fy)) (%/ 1 (%- x fx)))))
    11931163               (list (%+ (cadr rat) (%* fx (car rat))) (car rat))))
    11941164            (else (list (%+ 1 fx) 1)))))
    1195   (cond ((%< 'rationalize y x) (find-ratio-between y x))
    1196         ((not (%< 'rationalize x y)) (list x 1))
     1165  (cond ((%< y x) (find-ratio-between y x))
     1166        ((not (%< x y)) (list x 1))
    11971167        ((positive? x) (sr x y))
    11981168        ((negative? y) (let ((rat (sr (%- 0 y) (%- 0 x))))
     
    12231193    (log0 'log x))
    12241194   ;; avoid calling inexact->exact on X here (to avoid overflow?)
    1225    ((or (cplxnum? x) (%< 'log x 0.0)) ; General case
     1195   ((or (cplxnum? x) (negative? x)) ; General case
    12261196    (%+ (%log (magnitude x)) (* (make-complex 0 1) (angle x))))
    12271197   (else ; Real number case (< already ensured the argument type is a number)
     
    13721342   (else
    13731343    (let ((len (integer-length k)))
    1374       (if (%< loc len n)      ; Idea from Gambit: 2^{len-1} <= k < 2^{len}
     1344      (if (%< len n)          ; Idea from Gambit: 2^{len-1} <= k < 2^{len}
    13751345          (values 1 (%- k 1)) ; Since we know x >= 2, we know x^{n} can't exist
    13761346          ;; Set initial guess to (at least) 2^ceil(ceil(log2(k))/n)
     
    13801350            (let lp ((g0 g0)
    13811351                     (g1 (%quotient loc (%+ (%* n-1 g0) (%quotient loc k (%integer-power g0 n-1))) n)))
    1382               (if (%< loc g1 g0)
     1352              (if (%< g1 g0)
    13831353                  (lp g1 (%quotient loc (%+ (%* n-1 g1) (%quotient loc k (%integer-power g1 n-1))) n))
    13841354                  (values g0 (%- k (%integer-power g0 n)))))))))))
     
    15551525                        (number->string r base)
    15561526                        ;; The infinities and NaN always print their sign
    1557                         (if (and (finite? i) (%> 'number->string i 0)) "+" "")
     1527                        (if (and (finite? i) (positive? i)) "+" "")
    15581528                        (number->string i base) "i") ))
    15591529       (else (bad-number 'number->string n)))  ) ) )
     
    15761546               0
    15771547               (cond
    1578                 ((%> 'string->number e +maximum-allowed-exponent+)
     1548                ((%> e +maximum-allowed-exponent+)
    15791549                 (and (eq? exactness 'i)
    15801550                      (cond ((zero? value) 0.0)
    1581                             ((%> 'string->number value 0.0) +inf.0)
     1551                            ((%> value 0.0) +inf.0)
    15821552                            (else -inf.0))))
    1583                 ((%< 'string->number e ((##core#primitive "C_u_integer_negate")
    1584                                         +maximum-allowed-exponent+))
     1553                ((%< e ((##core#primitive "C_u_integer_negate")
     1554                        +maximum-allowed-exponent+))
    15851555                 (and (eq? exactness 'i) +0.0))
    15861556                (else (%* value (%integer-power 10 e)))))))
  • release/4/numbers/trunk/numbers.types

    r31986 r32040  
    290290(numbers#> (#(procedure #:clean #:enforce) numbers#> (#!rest (or fixnum float (struct bignum) (struct ratnum))) boolean)
    291291           ((fixnum fixnum) (fx> #(1) #(2)))
    292            ((float fixnum) (numbers#@basic-2-> '> #(1) #(2)))
    293            ((fixnum float) (numbers#@basic-2-> '> #(1) #(2)))
     292           ((float fixnum) (numbers#@basic-2-> #(1) #(2)))
     293           ((fixnum float) (numbers#@basic-2-> #(1) #(2)))
    294294           ((float float) (##core#inline "C_flonum_greaterp" #(1) #(2)))
    295295           (((struct bignum) (struct bignum)) (numbers#@bignum-2-> #(1) #(2)))
    296296           (((or fixnum (struct bignum)) (or fixnum (struct bignum)))
    297297            (numbers#@integer-2-> #(1) #(2)))
    298            ((* *) (numbers#@basic-2-> '> #(1) #(2))))
     298           ((* *) (numbers#@basic-2-> #(1) #(2))))
    299299
    300300(numbers#< (#(procedure #:clean #:enforce) numbers#< (#!rest (or fixnum float (struct bignum) (struct ratnum))) boolean)
    301301           ((fixnum fixnum) (fx< #(1) #(2)))
    302            ((float fixnum) (numbers#@basic-2-< '< #(1) #(2)))
    303            ((fixnum float) (numbers#@basic-2-< '< #(1) #(2)))
     302           ((float fixnum) (numbers#@basic-2-< #(1) #(2)))
     303           ((fixnum float) (numbers#@basic-2-< #(1) #(2)))
    304304           ((float float) (##core#inline "C_flonum_lessp" #(1) #(2)))
    305305           (((struct bignum) (struct bignum)) (numbers#@bignum-2-< #(1) #(2)))
    306306           (((or fixnum (struct bignum)) (or fixnum (struct bignum)))
    307307            (numbers#@integer-2-< #(1) #(2)))
    308            ((* *) (numbers#@basic-2-< '< #(1) #(2))))
     308           ((* *) (numbers#@basic-2-< #(1) #(2))))
    309309
    310310(numbers#>= (#(procedure #:clean #:enforce) numbers#>= (#!rest (or fixnum float (struct bignum) (struct ratnum))) boolean)
Note: See TracChangeset for help on using the changeset viewer.